diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index a52be9a30e..23d851ea92 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -19,11 +19,13 @@ module EDCanopyStructureMod use EDCohortDynamicsMod , only : InitPRTObject use FatesAllometryMod , only : tree_lai use FatesAllometryMod , only : tree_sai - use EDtypesMod , only : ed_site_type + use EDTypesMod , only : ed_site_type + use FatesAllometryMod , only : VegAreaLayer use FatesPatchMod, only : fates_patch_type use FatesCohortMod, only : fates_cohort_type use EDParamsMod , only : nclmax use EDParamsMod , only : nlevleaf + use EDParamsMod , only : radiation_model use EDtypesMod , only : AREA use EDLoggingMortalityMod , only : UpdateHarvestC use FatesGlobals , only : endrun => fates_endrun @@ -43,7 +45,9 @@ module EDCanopyStructureMod use PRTGenericMod, only : struct_organ use PRTGenericMod, only : SetState use PRTGenericMod, only : carbon12_element - + use FatesTwoStreamUtilsMod, only : FatesConstructRadElements + use FatesRadiationMemMod , only : twostr_solver + ! CIME Globals use shr_log_mod , only : errMsg => shr_log_errMsg @@ -79,6 +83,7 @@ module EDCanopyStructureMod real(r8), parameter :: similar_height_tol = 1.0E-3_r8 ! I think trees that differ by 1mm ! can be roughly considered the same right? + logical, parameter :: preserve_b4b = .true. ! 10/30/09: Created by Rosie Fisher ! 2017/2018: Modifications and updates by Ryan Knox @@ -1432,10 +1437,12 @@ subroutine canopy_summarization( nsites, sites, bc_in ) currentPatch => currentPatch%younger end do !patch loop - - call leaf_area_profile(sites(s)) - + + if(radiation_model.eq.twostr_solver) then + call FatesConstructRadElements(sites(s),bc_in(s)%fcansno_pa,bc_in(s)%coszen_pa) + end if + end do ! site loop return @@ -1493,8 +1500,6 @@ subroutine leaf_area_profile( currentSite ) ! currentPatch%esai_profile(cl,ft,iv) ! non-snow covered m2 of stems per m2 of PFT footprint ! currentPatch%canopy_area_profile(cl,ft,iv) ! Fractional area of leaf layer ! ! relative to vegetated area - ! currentPatch%layer_height_profile(cl,ft,iv) ! Elevation of layer in m - ! ! ----------------------------------------------------------------------------------- ! !USES: @@ -1517,17 +1522,17 @@ subroutine leaf_area_profile( currentSite ) integer :: iv ! Vertical leaf layer index integer :: cl ! Canopy layer index real(r8) :: fraction_exposed ! how much of this layer is not covered by snow? - real(r8) :: layer_top_height ! notional top height of this canopy layer (m) - real(r8) :: layer_bottom_height ! notional bottom height of this canopy layer (m) real(r8) :: frac_canopy(N_HEIGHT_BINS) ! amount of canopy in each height class real(r8) :: minh(N_HEIGHT_BINS) ! minimum height in height class (m) real(r8) :: maxh(N_HEIGHT_BINS) ! maximum height in height class (m) real(r8) :: dh ! vertical detph of height class (m) real(r8) :: min_cheight ! bottom of cohort canopy (m) real(r8) :: max_cheight ! top of cohort canopy (m) - real(r8) :: lai ! leaf area per canopy area - real(r8) :: sai ! stem area per canopy area + real(r8) :: elai_layer,tlai_layer ! leaf area per canopy area + real(r8) :: esai_layer,tsai_layer ! stem area per canopy area + real(r8) :: vai_top,vai_bot ! integrated top down veg area index at boundary of layer + real(r8) :: layer_bottom_height,layer_top_height,lai,sai ! Can be removed later !---------------------------------------------------------------------- @@ -1551,7 +1556,6 @@ subroutine leaf_area_profile( currentSite ) currentPatch%tsai_profile(:,:,:) = 0._r8 currentPatch%elai_profile(:,:,:) = 0._r8 currentPatch%esai_profile(:,:,:) = 0._r8 - currentPatch%layer_height_profile(:,:,:) = 0._r8 currentPatch%canopy_area_profile(:,:,:) = 0._r8 currentPatch%canopy_mask(:,:) = 0 @@ -1560,10 +1564,12 @@ subroutine leaf_area_profile( currentSite ) ! area, ie not plants at all... ! ------------------------------------------------------------------------------ - if (currentPatch%total_canopy_area > nearzero ) then + if_any_canopy_area: if (currentPatch%total_canopy_area > nearzero ) then call UpdatePatchLAI(currentPatch) + currentPatch%nrad(:,:) = currentPatch%ncan(:,:) + ! ----------------------------------------------------------------------------- ! Standard canopy layering model. ! Go through all cohorts and add their leaf area @@ -1579,100 +1585,131 @@ subroutine leaf_area_profile( currentSite ) ! How much of each tree is stem area index? Assuming that there is ! This may indeed be zero if there is a sensecent grass ! ---------------------------------------------------------------- - lai = currentCohort%treelai * currentCohort%c_area/currentPatch%total_canopy_area - sai = currentCohort%treesai * currentCohort%c_area/currentPatch%total_canopy_area - if( (currentCohort%treelai+currentCohort%treesai) > nearzero)then - - ! See issue: https://github.com/NGEET/fates/issues/899 - ! fleaf = currentCohort%treelai / (currentCohort%treelai + currentCohort%treesai) - fleaf = lai / (lai+sai) - else - fleaf = 0._r8 - endif - - currentPatch%nrad(cl,ft) = currentPatch%ncan(cl,ft) - - if (currentPatch%nrad(cl,ft) > nlevleaf ) then - write(fates_log(), *) 'Number of radiative leaf layers is larger' - write(fates_log(), *) ' than the maximum allowed.' - write(fates_log(), *) ' cl: ',cl - write(fates_log(), *) ' ft: ',ft - write(fates_log(), *) ' nlevleaf: ',nlevleaf - write(fates_log(), *) ' currentPatch%nrad(cl,ft): ', currentPatch%nrad(cl,ft) - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - - ! -------------------------------------------------------------------------- - ! Whole layers. Make a weighted average of the leaf area in each layer - ! before dividing it by the total area. Fill up layer for whole layers. - ! -------------------------------------------------------------------------- - - do iv = 1,currentCohort%NV - - ! This loop builds the arrays that define the effective (not snow covered) - ! and total (includes snow covered) area indices for leaves and stems - ! We calculate the absolute elevation of each layer to help determine if the layer - ! is obscured by snow. - - layer_top_height = currentCohort%height - & - ( real(iv-1,r8)/currentCohort%NV * currentCohort%height * & - prt_params%crown_depth_frac(currentCohort%pft) ) - - layer_bottom_height = currentCohort%height - & - ( real(iv,r8)/currentCohort%NV * currentCohort%height * & - prt_params%crown_depth_frac(currentCohort%pft) ) - - fraction_exposed = 1.0_r8 - if(currentSite%snow_depth > layer_top_height)then - fraction_exposed = 0._r8 - endif - if(currentSite%snow_depth < layer_bottom_height)then - fraction_exposed = 1._r8 - endif - if(currentSite%snow_depth >= layer_bottom_height .and. & - currentSite%snow_depth <= layer_top_height) then !only partly hidden... - fraction_exposed = 1._r8 - max(0._r8,(min(1.0_r8,(currentSite%snow_depth -layer_bottom_height)/ & - (layer_top_height-layer_bottom_height )))) - endif - - if(iv==currentCohort%NV) then - remainder = (currentCohort%treelai + currentCohort%treesai) - & - (dlower_vai(iv) - dinc_vai(iv)) - if(remainder > dinc_vai(iv) )then - write(fates_log(), *)'ED: issue with remainder', & - currentCohort%treelai,currentCohort%treesai,dinc_vai(iv), & - currentCohort%NV,remainder - - call endrun(msg=errMsg(sourcefile, __LINE__)) - endif + ! preserve_b4b will be removed soon. This is kept here to prevent + ! round off errors in the baseline tests for the two-stream code (RGK 12-27-23) + if_preserve_b4b: if(preserve_b4b) then + lai = currentCohort%treelai * currentCohort%c_area/currentPatch%total_canopy_area + sai = currentCohort%treesai * currentCohort%c_area/currentPatch%total_canopy_area + if( (currentCohort%treelai+currentCohort%treesai) > nearzero)then + + ! See issue: https://github.com/NGEET/fates/issues/899 + ! fleaf = currentCohort%treelai / (currentCohort%treelai + currentCohort%treesai) + fleaf = lai / (lai+sai) else - remainder = dinc_vai(iv) + fleaf = 0._r8 + endif + + currentPatch%nrad(cl,ft) = currentPatch%ncan(cl,ft) + + if (currentPatch%nrad(cl,ft) > nlevleaf ) then + write(fates_log(), *) 'Number of radiative leaf layers is larger' + write(fates_log(), *) ' than the maximum allowed.' + write(fates_log(), *) ' cl: ',cl + write(fates_log(), *) ' ft: ',ft + write(fates_log(), *) ' nlevleaf: ',nlevleaf + write(fates_log(), *) ' currentPatch%nrad(cl,ft): ', currentPatch%nrad(cl,ft) + call endrun(msg=errMsg(sourcefile, __LINE__)) end if - - currentPatch%tlai_profile(cl,ft,iv) = currentPatch%tlai_profile(cl,ft,iv) + & - remainder * fleaf * currentCohort%c_area/currentPatch%total_canopy_area - - currentPatch%elai_profile(cl,ft,iv) = currentPatch%elai_profile(cl,ft,iv) + & - remainder * fleaf * currentCohort%c_area/currentPatch%total_canopy_area * & - fraction_exposed - - currentPatch%tsai_profile(cl,ft,iv) = currentPatch%tsai_profile(cl,ft,iv) + & - remainder * (1._r8 - fleaf) * currentCohort%c_area/currentPatch%total_canopy_area - - currentPatch%esai_profile(cl,ft,iv) = currentPatch%esai_profile(cl,ft,iv) + & - remainder * (1._r8 - fleaf) * currentCohort%c_area/currentPatch%total_canopy_area * & - fraction_exposed - - currentPatch%canopy_area_profile(cl,ft,iv) = currentPatch%canopy_area_profile(cl,ft,iv) + & - currentCohort%c_area/currentPatch%total_canopy_area - - currentPatch%layer_height_profile(cl,ft,iv) = currentPatch%layer_height_profile(cl,ft,iv) + & - (remainder * fleaf * currentCohort%c_area/currentPatch%total_canopy_area * & - (layer_top_height+layer_bottom_height)/2.0_r8) !average height of layer. - - end do - + + ! -------------------------------------------------------------------------- + ! Whole layers. Make a weighted average of the leaf area in each layer + ! before dividing it by the total area. Fill up layer for whole layers. + ! -------------------------------------------------------------------------- + + do iv = 1,currentCohort%NV + + ! This loop builds the arrays that define the effective (not snow covered) + ! and total (includes snow covered) area indices for leaves and stems + ! We calculate the absolute elevation of each layer to help determine if the layer + ! is obscured by snow. + + layer_top_height = currentCohort%height - & + ( real(iv-1,r8)/currentCohort%NV * currentCohort%height * & + prt_params%crown_depth_frac(currentCohort%pft) ) + + layer_bottom_height = currentCohort%height - & + ( real(iv,r8)/currentCohort%NV * currentCohort%height * & + prt_params%crown_depth_frac(currentCohort%pft) ) + + fraction_exposed = 1.0_r8 + if(currentSite%snow_depth > layer_top_height)then + fraction_exposed = 0._r8 + endif + if(currentSite%snow_depth < layer_bottom_height)then + fraction_exposed = 1._r8 + endif + if(currentSite%snow_depth >= layer_bottom_height .and. & + currentSite%snow_depth <= layer_top_height) then !only partly hidden... + fraction_exposed = 1._r8 - max(0._r8,(min(1.0_r8,(currentSite%snow_depth -layer_bottom_height)/ & + (layer_top_height-layer_bottom_height )))) + endif + + if(iv==currentCohort%NV) then + remainder = (currentCohort%treelai + currentCohort%treesai) - & + (dlower_vai(iv) - dinc_vai(iv)) + if(remainder > dinc_vai(iv) )then + write(fates_log(), *)'ED: issue with remainder', & + currentCohort%treelai,currentCohort%treesai,dinc_vai(iv), & + currentCohort%NV,remainder + + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + else + remainder = dinc_vai(iv) + end if + + currentPatch%tlai_profile(cl,ft,iv) = currentPatch%tlai_profile(cl,ft,iv) + & + remainder * fleaf * currentCohort%c_area/currentPatch%total_canopy_area + + currentPatch%elai_profile(cl,ft,iv) = currentPatch%elai_profile(cl,ft,iv) + & + remainder * fleaf * currentCohort%c_area/currentPatch%total_canopy_area * & + fraction_exposed + + currentPatch%tsai_profile(cl,ft,iv) = currentPatch%tsai_profile(cl,ft,iv) + & + remainder * (1._r8 - fleaf) * currentCohort%c_area/currentPatch%total_canopy_area + + currentPatch%esai_profile(cl,ft,iv) = currentPatch%esai_profile(cl,ft,iv) + & + remainder * (1._r8 - fleaf) * currentCohort%c_area/currentPatch%total_canopy_area * & + fraction_exposed + + currentPatch%canopy_area_profile(cl,ft,iv) = currentPatch%canopy_area_profile(cl,ft,iv) + & + currentCohort%c_area/currentPatch%total_canopy_area + + + end do + + else !if_preserve_b4b + + do iv = 1,currentCohort%NV + + call VegAreaLayer(currentCohort%treelai, & + currentCohort%treesai, & + currentCohort%height, & + iv,currentCohort%nv,currentCohort%pft, & + currentSite%snow_depth, & + vai_top,vai_bot, & + elai_layer,esai_layer,tlai_layer,tsai_layer) + + + currentPatch%tlai_profile(cl,ft,iv) = currentPatch%tlai_profile(cl,ft,iv) + & + tlai_layer * currentCohort%c_area/currentPatch%total_canopy_area + + currentPatch%elai_profile(cl,ft,iv) = currentPatch%elai_profile(cl,ft,iv) + & + elai_layer * currentCohort%c_area/currentPatch%total_canopy_area + + currentPatch%tsai_profile(cl,ft,iv) = currentPatch%tsai_profile(cl,ft,iv) + & + tsai_layer * currentCohort%c_area/currentPatch%total_canopy_area + + currentPatch%esai_profile(cl,ft,iv) = currentPatch%esai_profile(cl,ft,iv) + & + esai_layer * currentCohort%c_area/currentPatch%total_canopy_area + + currentPatch%canopy_area_profile(cl,ft,iv) = currentPatch%canopy_area_profile(cl,ft,iv) + & + currentCohort%c_area/currentPatch%total_canopy_area + + end do + + end if if_preserve_b4b + currentCohort => currentCohort%taller enddo !cohort @@ -1759,11 +1796,6 @@ subroutine leaf_area_profile( currentSite ) currentPatch%canopy_area_profile(cl,ft,iv) end if - if(currentPatch%tlai_profile(cl,ft,iv)>nearzero )then - currentPatch%layer_height_profile(cl,ft,iv) = currentPatch%layer_height_profile(cl,ft,iv) & - /currentPatch%tlai_profile(cl,ft,iv) - end if - enddo enddo @@ -1771,20 +1803,35 @@ subroutine leaf_area_profile( currentSite ) ! -------------------------------------------------------------------------- ! Set the mask that identifies which PFT x can-layer combinations have - ! scattering elements in them. + ! scattering elements in them for radiation. + ! RGK: I'm not sure we need nrad ... I can't see a scenario where + ! canopy_area_profile for these layers is not >0 for layers in ncan ... + ! Leaving this for the time being. ! -------------------------------------------------------------------------- + + currentPatch%canopy_mask(:,:) = 0 + ! preserve_b4b will be removed soon. This is kept here to prevent + ! round off errors in the baseline tests for the two-stream code (RGK 12-27-23) + if(preserve_b4b) then + do cl = 1,currentPatch%NCL_p + do ft = 1,numpft + do iv = 1, currentPatch%nrad(cl,ft) + if(currentPatch%canopy_area_profile(cl,ft,iv) > 0._r8)then + currentPatch%canopy_mask(cl,ft) = 1 + endif + end do !iv + end do + end do + else + do cl = 1,currentPatch%NCL_p + do ft = 1,numpft + if(currentPatch%canopy_area_profile(cl,ft,1) > 0._r8 ) currentPatch%canopy_mask(cl,ft) = 1 + end do + end do + end if - do cl = 1,currentPatch%NCL_p - do ft = 1,numpft - do iv = 1, currentPatch%nrad(cl,ft) - if(currentPatch%canopy_area_profile(cl,ft,iv) > 0._r8)then - currentPatch%canopy_mask(cl,ft) = 1 - endif - end do !iv - enddo !ft - enddo ! loop over cl - - end if + + end if if_any_canopy_area currentPatch => currentPatch%younger diff --git a/biogeochem/EDLoggingMortalityMod.F90 b/biogeochem/EDLoggingMortalityMod.F90 index a4703ae840..bf6ab7443c 100644 --- a/biogeochem/EDLoggingMortalityMod.F90 +++ b/biogeochem/EDLoggingMortalityMod.F90 @@ -63,7 +63,7 @@ module EDLoggingMortalityMod use PRTGenericMod , only : sapw_organ, struct_organ, leaf_organ use PRTGenericMod , only : fnrt_organ, store_organ, repro_organ use FatesAllometryMod , only : set_root_fraction - use FatesConstantsMod , only : primaryforest, secondaryforest, secondary_age_threshold + use FatesConstantsMod , only : primaryland, secondaryland, secondary_age_threshold use FatesConstantsMod , only : fates_tiny use FatesConstantsMod , only : months_per_year, days_per_sec, years_per_day, g_per_kg use FatesConstantsMod , only : hlm_harvest_area_fraction @@ -199,7 +199,7 @@ subroutine LoggingMortality_frac( pft_i, dbh, canopy_layer, lmort_direct, & lmort_collateral,lmort_infra, l_degrad, & hlm_harvest_rates, hlm_harvest_catnames, & hlm_harvest_units, & - patch_anthro_disturbance_label, secondary_age, & + patch_land_use_label, secondary_age, & frac_site_primary, harvestable_forest_c, & harvest_tag) @@ -210,7 +210,7 @@ subroutine LoggingMortality_frac( pft_i, dbh, canopy_layer, lmort_direct, & real(r8), intent(in) :: hlm_harvest_rates(:) ! annual harvest rate per hlm category character(len=64), intent(in) :: hlm_harvest_catnames(:) ! names of hlm harvest categories integer, intent(in) :: hlm_harvest_units ! unit type of hlm harvest rates: [area vs. mass] - integer, intent(in) :: patch_anthro_disturbance_label ! patch level anthro_disturbance_label + integer, intent(in) :: patch_land_use_label ! patch level land_use_label real(r8), intent(in) :: secondary_age ! patch level age_since_anthro_disturbance real(r8), intent(in) :: harvestable_forest_c(:) ! total harvestable forest carbon ! of all hlm harvest categories @@ -265,7 +265,7 @@ subroutine LoggingMortality_frac( pft_i, dbh, canopy_layer, lmort_direct, & ! HARVEST_SH3 = harvest from secondary non-forest (assume this is young for biomass) ! Get the area-based harvest rates based on info passed to FATES from the boundary condition - call get_harvest_rate_area (patch_anthro_disturbance_label, hlm_harvest_catnames, & + call get_harvest_rate_area (patch_land_use_label, hlm_harvest_catnames, & hlm_harvest_rates, frac_site_primary, secondary_age, harvest_rate) ! For area-based harvest, harvest_tag shall always be 2 (not applicable). @@ -280,7 +280,7 @@ subroutine LoggingMortality_frac( pft_i, dbh, canopy_layer, lmort_direct, & ! 2=use carbon from hlm ! shall call another subroutine, which transfers biomass/carbon into fraction - call get_harvest_rate_carbon (patch_anthro_disturbance_label, hlm_harvest_catnames, & + call get_harvest_rate_carbon (patch_land_use_label, hlm_harvest_catnames, & hlm_harvest_rates, secondary_age, harvestable_forest_c, & harvest_rate, harvest_tag, cur_harvest_tag) @@ -348,7 +348,7 @@ end subroutine LoggingMortality_frac ! ============================================================================ - subroutine get_harvest_rate_area (patch_anthro_disturbance_label, hlm_harvest_catnames, hlm_harvest_rates, & + subroutine get_harvest_rate_area (patch_land_use_label, hlm_harvest_catnames, hlm_harvest_rates, & frac_site_primary, secondary_age, harvest_rate) @@ -361,7 +361,7 @@ subroutine get_harvest_rate_area (patch_anthro_disturbance_label, hlm_harvest_ca ! Arguments real(r8), intent(in) :: hlm_harvest_rates(:) ! annual harvest rate per hlm category character(len=64), intent(in) :: hlm_harvest_catnames(:) ! names of hlm harvest categories - integer, intent(in) :: patch_anthro_disturbance_label ! patch level anthro_disturbance_label + integer, intent(in) :: patch_land_use_label ! patch level land_use_label real(r8), intent(in) :: secondary_age ! patch level age_since_anthro_disturbance real(r8), intent(in) :: frac_site_primary real(r8), intent(out) :: harvest_rate @@ -374,17 +374,17 @@ subroutine get_harvest_rate_area (patch_anthro_disturbance_label, hlm_harvest_ca ! We do account forest only since non-forest harvest has geographical mismatch to LUH2 dataset harvest_rate = 0._r8 do h_index = 1,hlm_num_lu_harvest_cats - if (patch_anthro_disturbance_label .eq. primaryforest) then + if (patch_land_use_label .eq. primaryland) then if(hlm_harvest_catnames(h_index) .eq. "HARVEST_VH1" .or. & hlm_harvest_catnames(h_index) .eq. "HARVEST_VH2") then harvest_rate = harvest_rate + hlm_harvest_rates(h_index) endif - else if (patch_anthro_disturbance_label .eq. secondaryforest .and. & + else if (patch_land_use_label .eq. secondaryland .and. & secondary_age >= secondary_age_threshold) then if(hlm_harvest_catnames(h_index) .eq. "HARVEST_SH1") then harvest_rate = harvest_rate + hlm_harvest_rates(h_index) endif - else if (patch_anthro_disturbance_label .eq. secondaryforest .and. & + else if (patch_land_use_label .eq. secondaryland .and. & secondary_age < secondary_age_threshold) then if(hlm_harvest_catnames(h_index) .eq. "HARVEST_SH2" .or. & hlm_harvest_catnames(h_index) .eq. "HARVEST_SH3") then @@ -396,7 +396,7 @@ subroutine get_harvest_rate_area (patch_anthro_disturbance_label, hlm_harvest_ca ! Normalize by site-level primary or secondary forest fraction ! since harvest_rate is specified as a fraction of the gridcell ! also need to put a cap so as not to harvest more primary or secondary area than there is in a gridcell - if (patch_anthro_disturbance_label .eq. primaryforest) then + if (patch_land_use_label .eq. primaryland) then if (frac_site_primary .gt. fates_tiny) then harvest_rate = min((harvest_rate / frac_site_primary),frac_site_primary) else @@ -511,18 +511,18 @@ subroutine get_harvestable_carbon (csite, site_area, hlm_harvest_catnames, harve ! since we have not separated forest vs. non-forest ! all carbon belongs to the forest categories do h_index = 1,hlm_num_lu_harvest_cats - if (currentPatch%anthro_disturbance_label .eq. primaryforest) then + if (currentPatch%land_use_label .eq. primaryland) then ! Primary if(hlm_harvest_catnames(h_index) .eq. "HARVEST_VH1") then harvestable_forest_c(h_index) = harvestable_forest_c(h_index) + harvestable_patch_c end if - else if (currentPatch%anthro_disturbance_label .eq. secondaryforest .and. & + else if (currentPatch%land_use_label .eq. secondaryland .and. & currentPatch%age_since_anthro_disturbance >= secondary_age_threshold) then ! Secondary mature if(hlm_harvest_catnames(h_index) .eq. "HARVEST_SH1") then harvestable_forest_c(h_index) = harvestable_forest_c(h_index) + harvestable_patch_c end if - else if (currentPatch%anthro_disturbance_label .eq. secondaryforest .and. & + else if (currentPatch%land_use_label .eq. secondaryland .and. & currentPatch%age_since_anthro_disturbance < secondary_age_threshold) then ! Secondary young if(hlm_harvest_catnames(h_index) .eq. "HARVEST_SH2") then @@ -537,7 +537,7 @@ end subroutine get_harvestable_carbon ! ============================================================================ - subroutine get_harvest_rate_carbon (patch_anthro_disturbance_label, hlm_harvest_catnames, & + subroutine get_harvest_rate_carbon (patch_land_use_label, hlm_harvest_catnames, & hlm_harvest_rates, secondary_age, harvestable_forest_c, & harvest_rate, harvest_tag, cur_harvest_tag) @@ -550,7 +550,7 @@ subroutine get_harvest_rate_carbon (patch_anthro_disturbance_label, hlm_harvest_ ! Arguments real(r8), intent(in) :: hlm_harvest_rates(:) ! annual harvest rate per hlm category character(len=64), intent(in) :: hlm_harvest_catnames(:) ! names of hlm harvest categories - integer, intent(in) :: patch_anthro_disturbance_label ! patch level anthro_disturbance_label + integer, intent(in) :: patch_land_use_label ! patch level land_use_label real(r8), intent(in) :: secondary_age ! patch level age_since_anthro_disturbance real(r8), intent(in) :: harvestable_forest_c(:) ! site level forest c matching criteria available for harvest, kgC site-1 real(r8), intent(out) :: harvest_rate ! area fraction @@ -584,17 +584,17 @@ subroutine get_harvest_rate_carbon (patch_anthro_disturbance_label, hlm_harvest_ ! mature and secondary young). ! Get the harvest rate from HLM do h_index = 1,hlm_num_lu_harvest_cats - if (patch_anthro_disturbance_label .eq. primaryforest) then + if (patch_land_use_label .eq. primaryland) then if(hlm_harvest_catnames(h_index) .eq. "HARVEST_VH1" .or. & hlm_harvest_catnames(h_index) .eq. "HARVEST_VH2") then harvest_rate_c = harvest_rate_c + hlm_harvest_rates(h_index) endif - else if (patch_anthro_disturbance_label .eq. secondaryforest .and. & + else if (patch_land_use_label .eq. secondaryland .and. & secondary_age >= secondary_age_threshold) then if(hlm_harvest_catnames(h_index) .eq. "HARVEST_SH1") then harvest_rate_c = harvest_rate_c + hlm_harvest_rates(h_index) endif - else if (patch_anthro_disturbance_label .eq. secondaryforest .and. & + else if (patch_land_use_label .eq. secondaryland .and. & secondary_age < secondary_age_threshold) then if(hlm_harvest_catnames(h_index) .eq. "HARVEST_SH2" .or. & hlm_harvest_catnames(h_index) .eq. "HARVEST_SH3") then @@ -606,7 +606,7 @@ subroutine get_harvest_rate_carbon (patch_anthro_disturbance_label, hlm_harvest_ ! Determine harvest status (succesful or not) ! Here only three categories are used do h_index = 1,hlm_num_lu_harvest_cats - if (patch_anthro_disturbance_label .eq. primaryforest) then + if (patch_land_use_label .eq. primaryland) then if(hlm_harvest_catnames(h_index) .eq. "HARVEST_VH1" ) then if(harvestable_forest_c(h_index) >= harvest_rate_c) then harvest_rate_supply = harvest_rate_supply + harvestable_forest_c(h_index) @@ -615,7 +615,7 @@ subroutine get_harvest_rate_carbon (patch_anthro_disturbance_label, hlm_harvest_ harvest_tag(h_index) = 1 end if end if - else if (patch_anthro_disturbance_label .eq. secondaryforest .and. & + else if (patch_land_use_label .eq. secondaryland .and. & secondary_age >= secondary_age_threshold) then if(hlm_harvest_catnames(h_index) .eq. "HARVEST_SH1" ) then if(harvestable_forest_c(h_index) >= harvest_rate_c) then @@ -625,7 +625,7 @@ subroutine get_harvest_rate_carbon (patch_anthro_disturbance_label, hlm_harvest_ harvest_tag(h_index) = 1 end if end if - else if (patch_anthro_disturbance_label .eq. secondaryforest .and. & + else if (patch_land_use_label .eq. secondaryland .and. & secondary_age < secondary_age_threshold) then if(hlm_harvest_catnames(h_index) .eq. "HARVEST_SH2" ) then if(harvestable_forest_c(h_index) >= harvest_rate_c) then diff --git a/biogeochem/EDMortalityFunctionsMod.F90 b/biogeochem/EDMortalityFunctionsMod.F90 index bf47a5cce3..fc941d0371 100644 --- a/biogeochem/EDMortalityFunctionsMod.F90 +++ b/biogeochem/EDMortalityFunctionsMod.F90 @@ -48,7 +48,7 @@ module EDMortalityFunctionsMod contains - subroutine mortality_rates( cohort_in,bc_in,btran_ft, mean_temp, & + subroutine mortality_rates( cohort_in,bc_in, btran_ft, mean_temp, & cmort,hmort,bmort, frmort,smort,asmort,dgmort ) ! ============================================================================ @@ -56,9 +56,10 @@ subroutine mortality_rates( cohort_in,bc_in,btran_ft, mean_temp, & ! background and freezing and size and age dependent senescence ! ============================================================================ - use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm - use FatesConstantsMod, only : fates_check_param_set - use DamageMainMod, only : GetDamageMortality + use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm + use FatesConstantsMod, only : fates_check_param_set + use DamageMainMod, only : GetDamageMortality + use EDParamsmod, only : soil_tfrz_thresh type (fates_cohort_type), intent(in) :: cohort_in type (bc_in_type), intent(in) :: bc_in @@ -156,7 +157,8 @@ subroutine mortality_rates( cohort_in,bc_in,btran_ft, mean_temp, & hmort = 0.0_r8 endif else - if(btran_ft(cohort_in%pft) <= hf_sm_threshold)then + if( ( btran_ft(cohort_in%pft) <= hf_sm_threshold ) .and. & + ( ( minval(bc_in%t_soisno_sl) - tfrz ) > soil_tfrz_thresh ) ) then hmort = EDPftvarcon_inst%mort_scalar_hydrfailure(cohort_in%pft) else hmort = 0.0_r8 @@ -232,7 +234,7 @@ end subroutine mortality_rates ! ============================================================================ subroutine Mortality_Derivative( currentSite, currentCohort, bc_in, btran_ft, & - mean_temp, anthro_disturbance_label, age_since_anthro_disturbance, & + mean_temp, land_use_label, age_since_anthro_disturbance, & frac_site_primary, harvestable_forest_c, harvest_tag) ! @@ -250,7 +252,7 @@ subroutine Mortality_Derivative( currentSite, currentCohort, bc_in, btran_ft, & type(bc_in_type), intent(in) :: bc_in real(r8), intent(in) :: btran_ft(maxpft) real(r8), intent(in) :: mean_temp - integer, intent(in) :: anthro_disturbance_label + integer, intent(in) :: land_use_label real(r8), intent(in) :: age_since_anthro_disturbance real(r8), intent(in) :: frac_site_primary @@ -289,7 +291,7 @@ subroutine Mortality_Derivative( currentSite, currentCohort, bc_in, btran_ft, & bc_in%hlm_harvest_rates, & bc_in%hlm_harvest_catnames, & bc_in%hlm_harvest_units, & - anthro_disturbance_label, & + land_use_label, & age_since_anthro_disturbance, & frac_site_primary, harvestable_forest_c, harvest_tag) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 6f022ccfbd..140c108d66 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -1,5 +1,5 @@ -module EDPatchDynamicsMod +module EDPatchDynamicsMod ! ============================================================================ ! Controls formation, creation, fusing and termination of patch level processes. ! ============================================================================ @@ -35,6 +35,7 @@ module EDPatchDynamicsMod use FatesConstantsMod , only : dtype_ifall use FatesConstantsMod , only : dtype_ilog use FatesConstantsMod , only : dtype_ifire + use FatesConstantsMod , only : dtype_ilandusechange use FatesConstantsMod , only : ican_upper use PRTGenericMod , only : num_elements use PRTGenericMod , only : element_list @@ -46,7 +47,6 @@ module EDPatchDynamicsMod use FatesConstantsMod , only : fates_tiny use FatesConstantsMod , only : nocomp_bareground use FatesInterfaceTypesMod , only : hlm_use_planthydro - use FatesInterfaceTypesMod , only : hlm_numSWb use FatesInterfaceTypesMod , only : bc_in_type use FatesInterfaceTypesMod , only : numpft use FatesInterfaceTypesMod , only : hlm_stepsize @@ -54,6 +54,9 @@ module EDPatchDynamicsMod use FatesInterfaceTypesMod , only : hlm_use_nocomp use FatesInterfaceTypesMod , only : hlm_use_fixed_biogeog use FatesInterfaceTypesMod , only : hlm_num_lu_harvest_cats + use FatesInterfaceTypesMod , only : hlm_use_luh + use FatesInterfaceTypesMod , only : hlm_num_luh2_states + use FatesInterfaceTypesMod , only : hlm_num_luh2_transitions use FatesGlobals , only : endrun => fates_endrun use FatesConstantsMod , only : r8 => fates_r8 use FatesConstantsMod , only : itrue, ifalse @@ -69,7 +72,6 @@ module EDPatchDynamicsMod use EDLoggingMortalityMod, only : get_harvestable_carbon use EDLoggingMortalityMod, only : get_harvest_debt use EDParamsMod , only : fates_mortality_disturbance_fraction - use EDParamsMod , only : regeneration_model use FatesAllometryMod , only : carea_allom use FatesAllometryMod , only : set_root_fraction use FatesConstantsMod , only : g_per_kg @@ -77,8 +79,9 @@ module EDPatchDynamicsMod use FatesConstantsMod , only : days_per_sec use FatesConstantsMod , only : years_per_day use FatesConstantsMod , only : nearzero - use FatesConstantsMod , only : primaryforest, secondaryforest - use FatesConstantsMod , only : n_anthro_disturbance_categories + use FatesConstantsMod , only : primaryland, secondaryland, pastureland, rangeland, cropland + use FatesConstantsMod , only : n_landuse_cats + use FatesLandUseChangeMod, only : get_landuse_transition_rates use FatesConstantsMod , only : fates_unset_r8 use FatesConstantsMod , only : fates_unset_int use FatesConstantsMod , only : hlm_harvest_carbon @@ -98,12 +101,11 @@ module EDPatchDynamicsMod use SFParamsMod, only : SF_VAL_CWD_FRAC use EDParamsMod, only : logging_event_code use EDParamsMod, only : logging_export_frac + use EDParamsMod, only : maxpatches_by_landuse use FatesRunningMeanMod, only : ema_sdlng_mdd use FatesRunningMeanMod, only : ema_sdlng_emerg_h2o, ema_sdlng_mort_par, ema_sdlng2sap_par - use EDParamsMod, only : maxpatch_primary - use EDParamsMod, only : maxpatch_secondary - use EDParamsMod, only : maxpatch_total use FatesRunningMeanMod, only : ema_24hr, fixed_24hr, ema_lpa, ema_longterm + use FatesRadiationMemMod, only : num_swb ! CIME globals use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) @@ -146,6 +148,7 @@ module EDPatchDynamicsMod real(r8), parameter :: existing_litt_localization = 1.0_r8 real(r8), parameter :: treefall_localization = 0.0_r8 real(r8), parameter :: burn_localization = 0.0_r8 + real(r8), parameter :: landusechange_localization = 1.0_r8 integer :: istat ! return status code character(len=255) :: smsg ! Message string for deallocation errors @@ -207,13 +210,14 @@ subroutine disturbance_rates( site_in, bc_in) real(r8) :: mean_temp real(r8) :: harvestable_forest_c(hlm_num_lu_harvest_cats) integer :: harvest_tag(hlm_num_lu_harvest_cats) - + real(r8) :: landuse_transition_matrix(n_landuse_cats, n_landuse_cats) ! [m2/m2/day] + real(r8) :: current_fates_landuse_state_vector(n_landuse_cats) ! [m2/m2] !---------------------------------------------------------------------------------------------- ! Calculate Mortality Rates (these were previously calculated during growth derivatives) ! And the same rates in understory plants have already been applied to %dndt !---------------------------------------------------------------------------------------------- - ! first calculate the fractino of the site that is primary land + ! first calculate the fraction of the site that is primary land call get_frac_site_primary(site_in, frac_site_primary) ! get available biomass for harvest for all patches @@ -247,7 +251,7 @@ subroutine disturbance_rates( site_in, bc_in) bc_in%hlm_harvest_rates, & bc_in%hlm_harvest_catnames, & bc_in%hlm_harvest_units, & - currentPatch%anthro_disturbance_label, & + currentPatch%land_use_label, & currentPatch%age_since_anthro_disturbance, & frac_site_primary, & harvestable_forest_c, & @@ -266,13 +270,26 @@ subroutine disturbance_rates( site_in, bc_in) call get_harvest_debt(site_in, bc_in, harvest_tag) + if ( hlm_use_luh .eq. itrue ) then + call get_landuse_transition_rates(bc_in, landuse_transition_matrix) + else + landuse_transition_matrix(:,:) = 0._r8 + endif + + ! calculate total area in each landuse category + current_fates_landuse_state_vector(:) = 0._r8 + currentPatch => site_in%oldest_patch + do while (associated(currentPatch)) + current_fates_landuse_state_vector(currentPatch%land_use_label) = & + current_fates_landuse_state_vector(currentPatch%land_use_label) + & + currentPatch%area/AREA + currentPatch => currentPatch%younger + end do + ! --------------------------------------------------------------------------------------------- ! Calculate Disturbance Rates based on the mortality rates just calculated ! --------------------------------------------------------------------------------------------- - ! zero the diagnostic disturbance rate fields - site_in%potential_disturbance_rates(1:N_DIST_TYPES) = 0._r8 - ! Recalculate total canopy area prior to resolving the disturbance currentPatch => site_in%oldest_patch do while (associated(currentPatch)) @@ -295,6 +312,15 @@ subroutine disturbance_rates( site_in, bc_in) currentPatch%disturbance_rates(dtype_ifire) = 0.0_r8 dist_rate_ldist_notharvested = 0.0_r8 + + ! Avoid this calculation to avoid NaN due to division by zero result if luh is not used + if (hlm_use_luh .eq. itrue) then + currentPatch%landuse_transition_rates(1:n_landuse_cats) = min(1._r8, & + landuse_transition_matrix(currentPatch%land_use_label,1:n_landuse_cats) / & + current_fates_landuse_state_vector(currentPatch%land_use_label)) + else + currentPatch%landuse_transition_rates = 0.0_r8 + end if currentCohort => currentPatch%shortest do while(associated(currentCohort)) @@ -336,11 +362,11 @@ subroutine disturbance_rates( site_in, bc_in) ! The canopy is NOT closed. if(bc_in%hlm_harvest_units == hlm_harvest_carbon) then - call get_harvest_rate_carbon (currentPatch%anthro_disturbance_label, bc_in%hlm_harvest_catnames, & + call get_harvest_rate_carbon (currentPatch%land_use_label, bc_in%hlm_harvest_catnames, & bc_in%hlm_harvest_rates, currentPatch%age_since_anthro_disturbance, harvestable_forest_c, & harvest_rate, harvest_tag) else - call get_harvest_rate_area (currentPatch%anthro_disturbance_label, bc_in%hlm_harvest_catnames, & + call get_harvest_rate_area (currentPatch%land_use_label, bc_in%hlm_harvest_catnames, & bc_in%hlm_harvest_rates, frac_site_primary, currentPatch%age_since_anthro_disturbance, harvest_rate) end if @@ -367,12 +393,6 @@ subroutine disturbance_rates( site_in, bc_in) ! Fire Disturbance Rate currentPatch%disturbance_rates(dtype_ifire) = currentPatch%frac_burnt - ! calculate a disgnostic sum of disturbance rates for different classes of disturbance across all patches in this site. - do i_dist = 1,N_DIST_TYPES - site_in%potential_disturbance_rates(i_dist) = site_in%potential_disturbance_rates(i_dist) + & - currentPatch%disturbance_rates(i_dist) * currentPatch%area * AREA_INV - end do - ! Fires can't burn the whole patch, as this causes /0 errors. if (currentPatch%disturbance_rates(dtype_ifire) > 0.98_r8)then msg = 'very high fire areas'//trim(A2S(currentPatch%disturbance_rates(:)))//trim(N2S(currentPatch%frac_burnt)) @@ -380,11 +400,14 @@ subroutine disturbance_rates( site_in, bc_in) endif ! if the sum of all disturbance rates is such that they will exceed total patch area on this day, then reduce them all proportionally. - if ( sum(currentPatch%disturbance_rates(:)) .gt. 1.0_r8 ) then - tempsum = sum(currentPatch%disturbance_rates(:)) + if ( (sum(currentPatch%disturbance_rates(:)) + sum(currentPatch%landuse_transition_rates(1:n_landuse_cats))) .gt. 1.0_r8 ) then + tempsum = sum(currentPatch%disturbance_rates(:)) + sum(currentPatch%landuse_transition_rates(1:n_landuse_cats)) do i_dist = 1,N_DIST_TYPES currentPatch%disturbance_rates(i_dist) = currentPatch%disturbance_rates(i_dist) / tempsum end do + do i_dist = 1,n_landuse_cats + currentPatch%landuse_transition_rates(i_dist) = currentPatch%landuse_transition_rates(i_dist) / tempsum + end do endif currentPatch => currentPatch%younger @@ -398,7 +421,9 @@ end subroutine disturbance_rates subroutine spawn_patches( currentSite, bc_in) ! ! !DESCRIPTION: - ! In this subroutine, the following happens + ! In this subroutine, the following happens, + ! all of which within a complex loop structure of (from outermost to innermost loop), + ! nocomp-PFT, disturbance type, donor patch land use label, and receiver patch land use label: ! 1) the total area disturbed is calculated ! 2) a new patch is created ! 3) properties are averaged @@ -411,28 +436,28 @@ subroutine spawn_patches( currentSite, bc_in) ! 10) Area checked, and patchno recalculated. ! ! !USES: - - use EDParamsMod , only : ED_val_understorey_death, logging_coll_under_frac - use EDCohortDynamicsMod , only : terminate_cohorts - use FatesConstantsMod , only : rsnbl_math_prec + use EDParamsMod , only : ED_val_understorey_death, logging_coll_under_frac + use EDCohortDynamicsMod , only : terminate_cohorts + use FatesConstantsMod , only : rsnbl_math_prec + use FatesLandUseChangeMod, only : get_landuse_transition_rates + use FatesLandUseChangeMod, only : get_landusechange_rules ! ! !ARGUMENTS: type (ed_site_type), intent(inout) :: currentSite type (bc_in_type), intent(in) :: bc_in ! ! !LOCAL VARIABLES: - type (fates_patch_type) , pointer :: new_patch - type (fates_patch_type) , pointer :: new_patch_primary - type (fates_patch_type) , pointer :: new_patch_secondary + type (fates_patch_type) , pointer :: newPatch type (fates_patch_type) , pointer :: currentPatch type (fates_cohort_type), pointer :: currentCohort type (fates_cohort_type), pointer :: nc type (fates_cohort_type), pointer :: storesmallcohort type (fates_cohort_type), pointer :: storebigcohort real(r8) :: site_areadis_primary ! total area disturbed (to primary forest) in m2 per site per day - real(r8) :: site_areadis_secondary ! total area disturbed (to secondary forest) in m2 per site per day + real(r8) :: site_areadis_secondary ! total area disturbed (to secondary forest) in m2 per site per day real(r8) :: patch_site_areadis ! total area disturbed in m2 per patch per day + real(r8) :: site_areadis ! total site area disturbed in m2 per day real(r8) :: age ! notional age of this patch in years integer :: el ! element loop index integer :: pft ! pft loop index @@ -446,13 +471,18 @@ subroutine spawn_patches( currentSite, bc_in) real(r8) :: struct_c ! structure carbon [kg] real(r8) :: total_c ! total carbon of plant [kg] real(r8) :: leaf_burn_frac ! fraction of leaves burned in fire - ! for both woody and grass species + ! for both woody and grass species real(r8) :: leaf_m ! leaf mass during partial burn calculations - logical :: found_youngest_primary ! logical for finding the first primary forest patch integer :: min_nocomp_pft, max_nocomp_pft, i_nocomp_pft integer :: i_disturbance_type, i_dist2 ! iterators for looping over disturbance types + integer :: i_landusechange_receiverpatchlabel ! iterator for the land use change types + integer :: i_donorpatch_landuse_type ! iterator for the land use change types donor patch + integer :: start_receiver_lulabel ! starting bound for receiver landuse label type loop + integer :: end_receiver_lulabel ! ending bound for receiver landuse label type loop real(r8) :: disturbance_rate ! rate of disturbance being resolved [fraction of patch area / day] real(r8) :: oldarea ! old patch area prior to disturbance + logical :: clearing_matrix(n_landuse_cats,n_landuse_cats) ! do we clear vegetation when transferring from one LU type to another? + !--------------------------------------------------------------------- storesmallcohort => null() ! storage of the smallest cohort for insertion routine @@ -467,9 +497,10 @@ subroutine spawn_patches( currentSite, bc_in) endif ! zero the diagnostic disturbance rate fields - currentSite%disturbance_rates_primary_to_primary(1:N_DIST_TYPES) = 0._r8 - currentSite%disturbance_rates_primary_to_secondary(1:N_DIST_TYPES) = 0._r8 - currentSite%disturbance_rates_secondary_to_secondary(1:N_DIST_TYPES) = 0._r8 + currentSite%disturbance_rates(:,:,:) = 0._r8 + + ! get rules for vegetation clearing during land use change + call get_landusechange_rules(clearing_matrix) ! in the nocomp cases, since every patch has a PFT identity, it can only receive patch area from patches ! that have the same identity. In order to allow this, we have this very high level loop over nocomp PFTs @@ -477,330 +508,443 @@ subroutine spawn_patches( currentSite, bc_in) ! If nocomp is not enabled, then this is not much of a loop, it only passes through once. nocomp_pft_loop: do i_nocomp_pft = min_nocomp_pft,max_nocomp_pft + ! we want at the second-outermost loop to go through all disturbance types, because we resolve each of these separately disturbance_type_loop: do i_disturbance_type = 1,N_DIST_TYPES - ! calculate area of disturbed land, in this timestep, by summing contributions from each existing patch. - currentPatch => currentSite%youngest_patch - - site_areadis_primary = 0.0_r8 - site_areadis_secondary = 0.0_r8 + ! the next loop level is to go through patches that have a specific land-use type. the reason to do this is because the combination of + ! disturbance type and donor land-use type uniquly define the land-use type of the receiver patch. + landuse_donortype_loop: do i_donorpatch_landuse_type = 1, n_landuse_cats + + ! figure out what land use label(s) the receiver patch for disturbance from patches with + ! this disturbance label and disturbance of this type will have, and set receiver label loop bounds accordingly. + + ! for fire and treefall disturbance, receiver land-use type is whatever the donor land-use type is. + ! for logging disturbance, receiver land-use type is always secondary lands + ! for land-use-change disturbance, we need to loop over all possible transition types for land-use-change from the current land-use type. + + select case(i_disturbance_type) + case(dtype_ifire) + start_receiver_lulabel = i_donorpatch_landuse_type + end_receiver_lulabel = i_donorpatch_landuse_type + case(dtype_ifall) + start_receiver_lulabel = i_donorpatch_landuse_type + end_receiver_lulabel = i_donorpatch_landuse_type + case(dtype_ilog) + start_receiver_lulabel = secondaryland + end_receiver_lulabel = secondaryland + case(dtype_ilandusechange) + start_receiver_lulabel = 1 ! this could actually maybe be 2, as primaryland column of matrix should all be zeros, but leave as 1 for now + end_receiver_lulabel = n_landuse_cats + case default + write(fates_log(),*) 'unknown disturbance mode?' + write(fates_log(),*) 'i_disturbance_type: ',i_disturbance_type + call endrun(msg=errMsg(sourcefile, __LINE__)) + end select + + ! next loop level is the set of possible receiver patch land use types. + ! for disturbance types other than land use change, this is sort of a dummy loop, per the above logic. + landusechange_receiverpatchlabel_loop: do i_landusechange_receiverpatchlabel = start_receiver_lulabel, end_receiver_lulabel + + ! now we want to begin resolving all of the disturbance given the above categorical criteria of: + ! nocomp-PFT, disturbance type, donor patch land use label, and receiver patch land use label. All of the disturbed area that meets these + ! criteria (if any) will be put into a new patch whose area and properties are taken from one or more donor patches. + + ! calculate area of disturbed land that meets the above criteria, in this timestep, by summing contributions from each existing patch. + currentPatch => currentSite%youngest_patch + + ! this variable site_areadis holds all the newly disturbed area from all patches for all disturbance being resolved now. + site_areadis = 0.0_r8 + + ! loop over all patches to figure out the total patch area generated as a result of all disturbance being resolved now. + patchloop_areadis: do while(associated(currentPatch)) + + cp_nocomp_matches_1_if: if ( hlm_use_nocomp .eq. ifalse .or. & + currentPatch%nocomp_pft_label .eq. i_nocomp_pft ) then + + patchlabel_matches_lutype_if_areadis: if (currentPatch%land_use_label .eq. i_donorpatch_landuse_type) then + + disturbance_rate = 0.0_r8 + if ( i_disturbance_type .ne. dtype_ilandusechange) then + disturbance_rate = currentPatch%disturbance_rates(i_disturbance_type) + else + disturbance_rate = currentPatch%landuse_transition_rates(i_landusechange_receiverpatchlabel) + endif + + if(disturbance_rate > (1.0_r8 + rsnbl_math_prec)) then + write(fates_log(),*) 'patch disturbance rate > 1 ?',disturbance_rate + call currentPatch%Dump() + call endrun(msg=errMsg(sourcefile, __LINE__)) + else if (disturbance_rate > 1.0_r8) then + disturbance_rate = 1.0_r8 + end if + + ! Only create new patches that have non-negligible amount of land + if((currentPatch%area*disturbance_rate) > nearzero ) then + + site_areadis = site_areadis + currentPatch%area * disturbance_rate + + ! track disturbance rates to output to history + currentSite%disturbance_rates(i_disturbance_type,i_donorpatch_landuse_type,i_landusechange_receiverpatchlabel) = & + currentSite%disturbance_rates(i_disturbance_type,i_donorpatch_landuse_type,i_landusechange_receiverpatchlabel) + & + currentPatch%area * disturbance_rate * AREA_INV + end if + + end if patchlabel_matches_lutype_if_areadis + end if cp_nocomp_matches_1_if + currentPatch => currentPatch%older + enddo patchloop_areadis! end loop over patches. sum area disturbed for all patches. + + ! It is possible that no disturbance area was generated + if ( site_areadis > nearzero) then + + age = 0.0_r8 + + ! create an empty patch, to absorb newly disturbed area + allocate(newPatch) + + call newPatch%Create(age, site_areadis, i_landusechange_receiverpatchlabel, i_nocomp_pft, & + num_swb, numpft, currentSite%nlevsoil, hlm_current_tod, & + regeneration_model) + + ! Initialize the litter pools to zero, these + ! pools will be populated by looping over the existing patches + ! and transfering in mass + do el=1,num_elements + call newPatch%litter(el)%InitConditions(init_leaf_fines=0._r8, & + init_root_fines=0._r8, & + init_ag_cwd=0._r8, & + init_bg_cwd=0._r8, & + init_seed=0._r8, & + init_seed_germ=0._r8) + end do + newPatch%tallest => null() + newPatch%shortest => null() - do while(associated(currentPatch)) + endif - cp_nocomp_matches_1_if: if ( hlm_use_nocomp .eq. ifalse .or. & - currentPatch%nocomp_pft_label .eq. i_nocomp_pft ) then + ! we now have a new patch and know its area, but it is otherwise empty. Next, we + ! loop round all the patches that contribute surviving individuals and litter + ! pools to the new patch. We only loop the pre-existing patches, so + ! quit the loop if the current patch is null, and ignore the patch if the patch's categorical variables do not + ! match those of the outermost set of loops (i.e. the patch's land-use label or nocomp-PFT label + ! are not what we are resolving right now). - disturbance_rate = currentPatch%disturbance_rates(i_disturbance_type) + currentPatch => currentSite%oldest_patch + patchloop: do while(associated(currentPatch)) - if(disturbance_rate > (1.0_r8 + rsnbl_math_prec)) then - write(fates_log(),*) 'patch disturbance rate > 1 ?',disturbance_rate - call currentPatch%Dump() - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if + cp_nocomp_matches_2_if: if ( hlm_use_nocomp .eq. ifalse .or. & + currentPatch%nocomp_pft_label .eq. i_nocomp_pft ) then - ! Only create new patches that have non-negligible amount of land - if((currentPatch%area*disturbance_rate) > nearzero ) then + patchlabel_matches_lutype_if: if (currentPatch%land_use_label .eq. i_donorpatch_landuse_type) then - ! figure out whether the receiver patch for disturbance from this patch will be - ! primary or secondary land receiver patch is primary forest only if both the - ! donor patch is primary forest and the current disturbance type is not logging - if ( currentPatch%anthro_disturbance_label .eq. primaryforest .and. & - (i_disturbance_type .ne. dtype_ilog) ) then - site_areadis_primary = site_areadis_primary + currentPatch%area * disturbance_rate + ! disturbance_rate is the fraction of the patch's area that is disturbed and donated + disturbance_rate = 0.0_r8 + if ( i_disturbance_type .ne. dtype_ilandusechange) then + disturbance_rate = currentPatch%disturbance_rates(i_disturbance_type) + else + disturbance_rate = currentPatch%landuse_transition_rates(i_landusechange_receiverpatchlabel) + endif - ! track disturbance rates to output to history - currentSite%disturbance_rates_primary_to_primary(i_disturbance_type) = & - currentSite%disturbance_rates_primary_to_primary(i_disturbance_type) + & - currentPatch%area * disturbance_rate * AREA_INV + ! patch_site_areadis is the absolute amount of the patch's area that is disturbed and donated + patch_site_areadis = currentPatch%area * disturbance_rate + + areadis_gt_zero_if: if ( patch_site_areadis > nearzero ) then - else - site_areadis_secondary = site_areadis_secondary + currentPatch%area * disturbance_rate + if(.not.associated(newPatch))then + write(fates_log(),*) 'Patch spawning has attempted to point to' + write(fates_log(),*) 'an un-allocated patch' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if - ! track disturbance rates to output to history - if (currentPatch%anthro_disturbance_label .eq. secondaryforest) then - currentSite%disturbance_rates_secondary_to_secondary(i_disturbance_type) = & - currentSite%disturbance_rates_secondary_to_secondary(i_disturbance_type) + & - currentPatch%area * disturbance_rate * AREA_INV + ! for the case where the donating patch is not primary, and + ! the current disturbance from this patch is non-anthropogenic, + ! then we need to average in the time-since-anthropogenic-disturbance + ! from the donor patch into that of the receiver patch + if ( currentPatch%land_use_label .gt. primaryland .and. & + (i_disturbance_type .lt. dtype_ilog) ) then - else - currentSite%disturbance_rates_primary_to_secondary(i_disturbance_type) = & - currentSite%disturbance_rates_primary_to_secondary(i_disturbance_type) + & - currentPatch%area * disturbance_rate * AREA_INV - endif + newPatch%age_since_anthro_disturbance = newPatch%age_since_anthro_disturbance + & + currentPatch%age_since_anthro_disturbance * (patch_site_areadis / site_areadis) + + endif - endif + ! Transfer the litter existing already in the donor patch to the new patch + ! This call will only transfer non-burned litter to new patch + ! and burned litter to atmosphere. Thus it is important to zero burnt_frac_litter when + ! fire is not the current disturbance regime. - end if + if(i_disturbance_type .ne. dtype_ifire) then + currentPatch%burnt_frac_litter(:) = 0._r8 + end if - end if cp_nocomp_matches_1_if - currentPatch => currentPatch%older - enddo ! end loop over patches. sum area disturbed for all patches. - - ! It is possible that no disturbance area was generated - if ( (site_areadis_primary + site_areadis_secondary) > nearzero) then - - age = 0.0_r8 - - ! create two empty patches, to absorb newly disturbed primary and secondary forest area - ! first create patch to receive primary forest area - if ( site_areadis_primary .gt. nearzero ) then - allocate(new_patch_primary) - call new_patch_primary%Create(age, site_areadis_primary, & - primaryforest, i_nocomp_pft, hlm_numSWb, numpft, & - currentSite%nlevsoil, hlm_current_tod, regeneration_model) - - ! Initialize the litter pools to zero, these - ! pools will be populated by looping over the existing patches - ! and transfering in mass - do el=1,num_elements - call new_patch_primary%litter(el)%InitConditions(init_leaf_fines=0._r8, & - init_root_fines=0._r8, & - init_ag_cwd=0._r8, & - init_bg_cwd=0._r8, & - init_seed=0._r8, & - init_seed_germ=0._r8) - end do - new_patch_primary%tallest => null() - new_patch_primary%shortest => null() + call TransLitterNewPatch( currentSite, currentPatch, newPatch, patch_site_areadis) + + ! Transfer in litter fluxes from plants in various contexts of death and destruction + + select case(i_disturbance_type) + case (dtype_ilog) + call logging_litter_fluxes(currentSite, currentPatch, & + newPatch, patch_site_areadis,bc_in) + case (dtype_ifire) + call fire_litter_fluxes(currentSite, currentPatch, & + newPatch, patch_site_areadis,bc_in) + case (dtype_ifall) + call mortality_litter_fluxes(currentSite, currentPatch, & + newPatch, patch_site_areadis,bc_in) + case (dtype_ilandusechange) + call landusechange_litter_fluxes(currentSite, currentPatch, & + newPatch, patch_site_areadis,bc_in, & + clearing_matrix(i_donorpatch_landuse_type,i_landusechange_receiverpatchlabel)) + case default + write(fates_log(),*) 'unknown disturbance mode?' + write(fates_log(),*) 'i_disturbance_type: ',i_disturbance_type + call endrun(msg=errMsg(sourcefile, __LINE__)) + end select - endif - ! next create patch to receive secondary forest area - if (site_areadis_secondary .gt. nearzero) then - allocate(new_patch_secondary) - call new_patch_secondary%Create(age, site_areadis_secondary, & - secondaryforest, i_nocomp_pft, hlm_numSWb, numpft, & - currentSite%nlevsoil, hlm_current_tod, regeneration_model) - - ! Initialize the litter pools to zero, these - ! pools will be populated by looping over the existing patches - ! and transfering in mass - do el=1,num_elements - call new_patch_secondary%litter(el)%InitConditions(init_leaf_fines=0._r8, & - init_root_fines=0._r8, & - init_ag_cwd=0._r8, & - init_bg_cwd=0._r8, & - init_seed=0._r8, & - init_seed_germ=0._r8) - end do - new_patch_secondary%tallest => null() - new_patch_secondary%shortest => null() + ! Copy any means or timers from the original patch to the new patch + ! These values will inherit all info from the original patch + ! -------------------------------------------------------------------------- + call newPatch%tveg24%CopyFromDonor(currentPatch%tveg24) + call newPatch%tveg_lpa%CopyFromDonor(currentPatch%tveg_lpa) + call newPatch%tveg_longterm%CopyFromDonor(currentPatch%tveg_longterm) - endif - ! loop round all the patches that contribute surviving indivduals and litter - ! pools to the new patch. We only loop the pre-existing patches, so - ! quit the loop if the current patch is either null, or matches the - ! two new pointers. - - currentPatch => currentSite%oldest_patch - do while(associated(currentPatch)) - - cp_nocomp_matches_2_if: if ( hlm_use_nocomp .eq. ifalse .or. & - currentPatch%nocomp_pft_label .eq. i_nocomp_pft ) then - - ! This is the amount of patch area that is disturbed, and donated by the donor - disturbance_rate = currentPatch%disturbance_rates(i_disturbance_type) - patch_site_areadis = currentPatch%area * disturbance_rate - - - if ( patch_site_areadis > nearzero ) then - - ! figure out whether the receiver patch for disturbance from this patch - ! will be primary or secondary land receiver patch is primary forest - ! only if both the donor patch is primary forest and the current - ! disturbance type is not logging - if (currentPatch%anthro_disturbance_label .eq. primaryforest .and. & - (i_disturbance_type .ne. dtype_ilog)) then - new_patch => new_patch_primary - else - new_patch => new_patch_secondary - endif - - if(.not.associated(new_patch))then - write(fates_log(),*) 'Patch spawning has attempted to point to' - write(fates_log(),*) 'an un-allocated patch' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - ! for the case where the donating patch is secondary forest, if - ! the current disturbance from this patch is non-anthropogenic, - ! we need to average in the time-since-anthropogenic-disturbance - ! from the donor patch into that of the receiver patch - if ( currentPatch%anthro_disturbance_label .eq. secondaryforest .and. & - (i_disturbance_type .ne. dtype_ilog) ) then - - new_patch%age_since_anthro_disturbance = new_patch%age_since_anthro_disturbance + & - currentPatch%age_since_anthro_disturbance * (patch_site_areadis / site_areadis_secondary) - - endif - - - ! Transfer the litter existing already in the donor patch to the new patch - ! This call will only transfer non-burned litter to new patch - ! and burned litter to atmosphere. Thus it is important to zero burnt_frac_litter when - ! fire is not the current disturbance regime. - - if(i_disturbance_type .ne. dtype_ifire) then - currentPatch%burnt_frac_litter(:) = 0._r8 - end if - - call TransLitterNewPatch( currentSite, currentPatch, new_patch, patch_site_areadis) - - ! Transfer in litter fluxes from plants in various contexts of death and destruction - - if(i_disturbance_type .eq. dtype_ilog) then - call logging_litter_fluxes(currentSite, currentPatch, & - new_patch, patch_site_areadis,bc_in) - elseif(i_disturbance_type .eq. dtype_ifire) then - call fire_litter_fluxes(currentSite, currentPatch, & - new_patch, patch_site_areadis,bc_in) - else - call mortality_litter_fluxes(currentSite, currentPatch, & - new_patch, patch_site_areadis,bc_in) - endif - - - ! Copy any means or timers from the original patch to the new patch - ! These values will inherit all info from the original patch - ! -------------------------------------------------------------------------- - call new_patch%tveg24%CopyFromDonor(currentPatch%tveg24) - call new_patch%tveg_lpa%CopyFromDonor(currentPatch%tveg_lpa) - - if ( regeneration_model == TRS_regeneration ) then - call new_patch%seedling_layer_par24%CopyFromDonor(currentPatch%seedling_layer_par24) - call new_patch%sdlng_mort_par%CopyFromDonor(currentPatch%sdlng_mort_par) - call new_patch%sdlng2sap_par%CopyFromDonor(currentPatch%sdlng2sap_par) - do pft = 1,numpft - call new_patch%sdlng_emerg_smp(pft)%p%CopyFromDonor(currentPatch%sdlng_emerg_smp(pft)%p) - call new_patch%sdlng_mdd(pft)%p%CopyFromDonor(currentPatch%sdlng_mdd(pft)%p) - enddo - end if - - call new_patch%tveg_longterm%CopyFromDonor(currentPatch%tveg_longterm) - - ! -------------------------------------------------------------------------- - ! The newly formed patch from disturbance (new_patch), has now been given - ! some litter from dead plants and pre-existing litter from the donor patches. - ! - ! Next, we loop through the cohorts in the donor patch, copy them with - ! area modified number density into the new-patch, and apply survivorship. - ! ------------------------------------------------------------------------- - - currentCohort => currentPatch%shortest - do while(associated(currentCohort)) - - allocate(nc) - if(hlm_use_planthydro.eq.itrue) call InitHydrCohort(CurrentSite,nc) - - ! Initialize the PARTEH object and point to the - ! correct boundary condition fields - nc%prt => null() - call InitPRTObject(nc%prt) - call nc%InitPRTBoundaryConditions() - - ! (Keeping as an example) - ! Allocate running mean functions - !allocate(nc%tveg_lpa) - !call nc%tveg_lpa%InitRMean(ema_lpa,init_value=new_patch%tveg_lpa%GetMean()) - - call nc%ZeroValues() - - ! nc is the new cohort that goes in the disturbed patch (new_patch)... currentCohort - ! is the curent cohort that stays in the donor patch (currentPatch) - call currentCohort%Copy(nc) - - !this is the case as the new patch probably doesn't have a closed canopy, and - ! even if it does, that will be sorted out in canopy_structure. - nc%canopy_layer = 1 - nc%canopy_layer_yesterday = 1._r8 - - sapw_c = currentCohort%prt%GetState(sapw_organ, carbon12_element) - struct_c = currentCohort%prt%GetState(struct_organ, carbon12_element) - leaf_c = currentCohort%prt%GetState(leaf_organ, carbon12_element) - fnrt_c = currentCohort%prt%GetState(fnrt_organ, carbon12_element) - store_c = currentCohort%prt%GetState(store_organ, carbon12_element) - total_c = sapw_c + struct_c + leaf_c + fnrt_c + store_c - - ! treefall mortality is the current disturbance - if(i_disturbance_type .eq. dtype_ifall) then - - if(currentCohort%canopy_layer == 1)then - - ! In the donor patch we are left with fewer trees because the area has decreased - ! the plant density for large trees does not actually decrease in the donor patch - ! because this is the part of the original patch where no trees have actually fallen - ! The diagnostic cmort,bmort,hmort, and frmort rates have already been saved - - currentCohort%n = currentCohort%n * (1.0_r8 - fates_mortality_disturbance_fraction * & - min(1.0_r8,currentCohort%dmort * hlm_freq_day)) - - nc%n = 0.0_r8 ! kill all of the trees who caused the disturbance. - - nc%cmort = nan ! The mortality diagnostics are set to nan - ! because the cohort should dissappear - nc%hmort = nan - nc%bmort = nan - nc%frmort = nan - nc%smort = nan - nc%asmort = nan - nc%dgmort = nan - nc%lmort_direct = nan - nc%lmort_collateral = nan - nc%lmort_infra = nan - nc%l_degrad = nan + if ( regeneration_model == TRS_regeneration ) then + call newPatch%seedling_layer_par24%CopyFromDonor(currentPatch%seedling_layer_par24) + call newPatch%sdlng_mort_par%CopyFromDonor(currentPatch%sdlng_mort_par) + call newPatch%sdlng2sap_par%CopyFromDonor(currentPatch%sdlng2sap_par) + do pft = 1,numpft + call newPatch%sdlng_emerg_smp(pft)%p%CopyFromDonor(currentPatch%sdlng_emerg_smp(pft)%p) + call newPatch%sdlng_mdd(pft)%p%CopyFromDonor(currentPatch%sdlng_mdd(pft)%p) + enddo + end if - else - ! small trees - if( prt_params%woody(currentCohort%pft) == itrue)then + call newPatch%tveg_longterm%CopyFromDonor(currentPatch%tveg_longterm) + + ! -------------------------------------------------------------------------- + ! The newly formed patch from disturbance (newPatch), has now been given + ! some litter from dead plants and pre-existing litter from the donor patches. + ! + ! Next, we loop through the cohorts in the donor patch, copy them with + ! area modified number density into the new patch, and apply survivorship. + ! ------------------------------------------------------------------------- + + currentCohort => currentPatch%shortest + cohortloop: do while(associated(currentCohort)) + + allocate(nc) + if(hlm_use_planthydro.eq.itrue) call InitHydrCohort(CurrentSite,nc) + + ! Initialize the PARTEH object and point to the + ! correct boundary condition fields + nc%prt => null() + call InitPRTObject(nc%prt) + call nc%InitPRTBoundaryConditions() + + ! (Keeping as an example) + ! Allocate running mean functions + !allocate(nc%tveg_lpa) + !call nc%tveg_lpa%InitRMean(ema_lpa,init_value=newPatch%tveg_lpa%GetMean()) + + call nc%ZeroValues() + + ! nc is the new cohort that goes in the disturbed patch (newPatch)... currentCohort + ! is the curent cohort that stays in the donor patch (currentPatch) + call currentCohort%Copy(nc) + + !this is the case as the new patch probably doesn't have a closed canopy, and + ! even if it does, that will be sorted out in canopy_structure. + nc%canopy_layer = 1 + nc%canopy_layer_yesterday = 1._r8 + + sapw_c = currentCohort%prt%GetState(sapw_organ, carbon12_element) + struct_c = currentCohort%prt%GetState(struct_organ, carbon12_element) + leaf_c = currentCohort%prt%GetState(leaf_organ, carbon12_element) + fnrt_c = currentCohort%prt%GetState(fnrt_organ, carbon12_element) + store_c = currentCohort%prt%GetState(store_organ, carbon12_element) + total_c = sapw_c + struct_c + leaf_c + fnrt_c + store_c + + ! survivorship of plants in both the disturbed and undisturbed cohorts depends on what type of disturbance is happening. + + disttype_case: select case(i_disturbance_type) + + ! treefall mortality is the current disturbance + case (dtype_ifall) + + in_canopy_if_falldtype: if(currentCohort%canopy_layer == 1)then + + ! In the donor patch we are left with fewer trees because the area has decreased + ! the plant density for large trees does not actually decrease in the donor patch + ! because this is the part of the original patch where no trees have actually fallen + ! The diagnostic cmort,bmort,hmort, and frmort rates have already been saved + + currentCohort%n = currentCohort%n * (1.0_r8 - fates_mortality_disturbance_fraction * & + min(1.0_r8,currentCohort%dmort * hlm_freq_day)) + + nc%n = 0.0_r8 ! kill all of the trees who caused the disturbance. + + nc%cmort = nan ! The mortality diagnostics are set to nan + ! because the cohort should dissappear + nc%hmort = nan + nc%bmort = nan + nc%frmort = nan + nc%smort = nan + nc%asmort = nan + nc%dgmort = nan + nc%lmort_direct = nan + nc%lmort_collateral = nan + nc%lmort_infra = nan + nc%l_degrad = nan + + else + ! understory trees + woody_if_falldtype: if( prt_params%woody(currentCohort%pft) == itrue)then + + + ! Survivorship of undestory woody plants. Two step process. + ! Step 1: Reduce current number of plants to reflect the + ! change in area. + ! The number density per square are doesn't change, + ! but since the patch is smaller and cohort counts + ! are absolute, reduce this number. + + nc%n = currentCohort%n * patch_site_areadis/currentPatch%area + + ! because the mortality rate due to impact for the cohorts which + ! had been in the understory and are now in the newly- + ! disturbed patch is very high, passing the imort directly to history + ! results in large numerical errors, on account of the sharply + ! reduced number densities. so instead pass this info via a + ! site-level diagnostic variable before reducing the number density. + + currentSite%imort_rate(currentCohort%size_class, currentCohort%pft) = & + currentSite%imort_rate(currentCohort%size_class, currentCohort%pft) + & + nc%n * ED_val_understorey_death / hlm_freq_day + + + currentSite%imort_carbonflux(currentCohort%pft) = & + currentSite%imort_carbonflux(currentCohort%pft) + & + (nc%n * ED_val_understorey_death / hlm_freq_day ) * & + total_c * g_per_kg * days_per_sec * years_per_day * ha_per_m2 + + currentSite%imort_abg_flux(currentCohort%size_class, currentCohort%pft) = & + currentSite%imort_abg_flux(currentCohort%size_class, currentCohort%pft) + & + (nc%n * ED_val_understorey_death / hlm_freq_day ) * & + ( (sapw_c + struct_c + store_c) * prt_params%allom_agb_frac(currentCohort%pft) + & + leaf_c ) * & + g_per_kg * days_per_sec * years_per_day * ha_per_m2 + + + ! Step 2: Apply survivor ship function based on the understory death fraction + ! remaining of understory plants of those that are knocked over + ! by the overstorey trees dying... + nc%n = nc%n * (1.0_r8 - ED_val_understorey_death) + + ! since the donor patch split and sent a fraction of its members + ! to the new patch and a fraction to be preserved in itself, + ! when reporting diagnostic rates, we must carry over the mortality rates from + ! the donor that were applied before the patch split. Remember this is only + ! for diagnostics. But think of it this way, the rates are weighted by + ! number density in EDCLMLink, and the number density of this new patch is donated + ! so with the number density must come the effective mortality rates. + + nc%cmort = currentCohort%cmort + nc%hmort = currentCohort%hmort + nc%bmort = currentCohort%bmort + nc%frmort = currentCohort%frmort + nc%smort = currentCohort%smort + nc%asmort = currentCohort%asmort + nc%dgmort = currentCohort%dgmort + nc%dmort = currentCohort%dmort + nc%lmort_direct = currentCohort%lmort_direct + nc%lmort_collateral = currentCohort%lmort_collateral + nc%lmort_infra = currentCohort%lmort_infra + + ! understory trees that might potentially be knocked over in the disturbance. + ! The existing (donor) patch should not have any impact mortality, it should + ! only lose cohorts due to the decrease in area. This is not mortality. + ! Besides, the current and newly created patch sum to unity + + currentCohort%n = currentCohort%n * (1._r8 - patch_site_areadis/currentPatch%area) + + else + ! grass is not killed by mortality disturbance events. Just move it into the new patch area. + ! Just split the grass into the existing and new patch structures + nc%n = currentCohort%n * patch_site_areadis/currentPatch%area + + ! Those remaining in the existing + currentCohort%n = currentCohort%n * (1._r8 - patch_site_areadis/currentPatch%area) + + nc%cmort = currentCohort%cmort + nc%hmort = currentCohort%hmort + nc%bmort = currentCohort%bmort + nc%frmort = currentCohort%frmort + nc%smort = currentCohort%smort + nc%asmort = currentCohort%asmort + nc%dgmort = currentCohort%dgmort + nc%dmort = currentCohort%dmort + nc%lmort_direct = currentCohort%lmort_direct + nc%lmort_collateral = currentCohort%lmort_collateral + nc%lmort_infra = currentCohort%lmort_infra + + endif woody_if_falldtype + endif in_canopy_if_falldtype + + ! Fire is the current disturbance + case (dtype_ifire) + + ! Number of members in the new patch, before we impose fire survivorship + nc%n = currentCohort%n * patch_site_areadis/currentPatch%area + ! loss of individuals from source patch due to area shrinking + currentCohort%n = currentCohort%n * (1._r8 - patch_site_areadis/currentPatch%area) - ! Survivorship of undestory woody plants. Two step process. - ! Step 1: Reduce current number of plants to reflect the - ! change in area. - ! The number density per square are doesn't change, - ! but since the patch is smaller and cohort counts - ! are absolute, reduce this number. + levcan = currentCohort%canopy_layer - nc%n = currentCohort%n * patch_site_areadis/currentPatch%area + if(levcan==ican_upper) then - ! because the mortality rate due to impact for the cohorts which - ! had been in the understory and are now in the newly- - ! disturbed patch is very high, passing the imort directly to history - ! results in large numerical errors, on account of the sharply - ! reduced number densities. so instead pass this info via a - ! site-level diagnostic variable before reducing the number density. + ! before changing number densities, track total rate of trees that died + ! due to fire, as well as from each fire mortality term + currentSite%fmort_rate_canopy(currentCohort%size_class, currentCohort%pft) = & + currentSite%fmort_rate_canopy(currentCohort%size_class, currentCohort%pft) + & + nc%n * currentCohort%fire_mort / hlm_freq_day - currentSite%imort_rate(currentCohort%size_class, currentCohort%pft) = & - currentSite%imort_rate(currentCohort%size_class, currentCohort%pft) + & - nc%n * ED_val_understorey_death / hlm_freq_day + currentSite%fmort_carbonflux_canopy(currentCohort%pft) = & + currentSite%fmort_carbonflux_canopy(currentCohort%pft) + & + (nc%n * currentCohort%fire_mort) * & + total_c * g_per_kg * days_per_sec * ha_per_m2 + else + ! understory + currentSite%fmort_rate_ustory(currentCohort%size_class, currentCohort%pft) = & + currentSite%fmort_rate_ustory(currentCohort%size_class, currentCohort%pft) + & + nc%n * currentCohort%fire_mort / hlm_freq_day - currentSite%imort_carbonflux(currentCohort%pft) = & - currentSite%imort_carbonflux(currentCohort%pft) + & - (nc%n * ED_val_understorey_death / hlm_freq_day ) * & - total_c * days_per_sec * years_per_day * ha_per_m2 + currentSite%fmort_carbonflux_ustory(currentCohort%pft) = & + currentSite%fmort_carbonflux_ustory(currentCohort%pft) + & + (nc%n * currentCohort%fire_mort) * & + total_c * g_per_kg * days_per_sec * ha_per_m2 + end if - currentSite%imort_abg_flux(currentCohort%size_class, currentCohort%pft) = & - currentSite%imort_abg_flux(currentCohort%size_class, currentCohort%pft) + & - (nc%n * ED_val_understorey_death / hlm_freq_day ) * & + currentSite%fmort_abg_flux(currentCohort%size_class, currentCohort%pft) = & + currentSite%fmort_abg_flux(currentCohort%size_class, currentCohort%pft) + & + (nc%n * currentCohort%fire_mort) * & ( (sapw_c + struct_c + store_c) * prt_params%allom_agb_frac(currentCohort%pft) + & - leaf_c ) * days_per_sec * years_per_day * ha_per_m2 + leaf_c ) * & + g_per_kg * days_per_sec * ha_per_m2 - ! Step 2: Apply survivor ship function based on the understory death fraction - ! remaining of understory plants of those that are knocked over - ! by the overstorey trees dying... - nc%n = nc%n * (1.0_r8 - ED_val_understorey_death) + currentSite%fmort_rate_cambial(currentCohort%size_class, currentCohort%pft) = & + currentSite%fmort_rate_cambial(currentCohort%size_class, currentCohort%pft) + & + nc%n * currentCohort%cambial_mort / hlm_freq_day + currentSite%fmort_rate_crown(currentCohort%size_class, currentCohort%pft) = & + currentSite%fmort_rate_crown(currentCohort%size_class, currentCohort%pft) + & + nc%n * currentCohort%crownfire_mort / hlm_freq_day - ! since the donor patch split and sent a fraction of its members - ! to the new patch and a fraction to be preserved in itself, - ! when reporting diagnostic rates, we must carry over the mortality rates from - ! the donor that were applied before the patch split. Remember this is only - ! for diagnostics. But think of it this way, the rates are weighted by - ! number density in EDCLMLink, and the number density of this new patch is donated - ! so with the number density must come the effective mortality rates. + ! loss of individual from fire in new patch. + nc%n = nc%n * (1.0_r8 - currentCohort%fire_mort) nc%cmort = currentCohort%cmort nc%hmort = currentCohort%hmort @@ -814,444 +958,325 @@ subroutine spawn_patches( currentSite, bc_in) nc%lmort_collateral = currentCohort%lmort_collateral nc%lmort_infra = currentCohort%lmort_infra - ! understory trees that might potentially be knocked over in the disturbance. - ! The existing (donor) patch should not have any impact mortality, it should - ! only lose cohorts due to the decrease in area. This is not mortality. - ! Besides, the current and newly created patch sum to unity - - currentCohort%n = currentCohort%n * (1._r8 - patch_site_areadis/currentPatch%area) - - else - ! grass is not killed by mortality disturbance events. Just move it into the new patch area. - ! Just split the grass into the existing and new patch structures - nc%n = currentCohort%n * patch_site_areadis/currentPatch%area - - ! Those remaining in the existing - currentCohort%n = currentCohort%n * (1._r8 - patch_site_areadis/currentPatch%area) - - nc%cmort = currentCohort%cmort - nc%hmort = currentCohort%hmort - nc%bmort = currentCohort%bmort - nc%frmort = currentCohort%frmort - nc%smort = currentCohort%smort - nc%asmort = currentCohort%asmort - nc%dgmort = currentCohort%dgmort - nc%dmort = currentCohort%dmort - nc%lmort_direct = currentCohort%lmort_direct - nc%lmort_collateral = currentCohort%lmort_collateral - nc%lmort_infra = currentCohort%lmort_infra - - endif - endif - - ! Fire is the current disturbance - elseif (i_disturbance_type .eq. dtype_ifire ) then - - ! Number of members in the new patch, before we impose fire survivorship - nc%n = currentCohort%n * patch_site_areadis/currentPatch%area - - ! loss of individuals from source patch due to area shrinking - currentCohort%n = currentCohort%n * (1._r8 - patch_site_areadis/currentPatch%area) - - levcan = currentCohort%canopy_layer - - if(levcan==ican_upper) then - - ! before changing number densities, track total rate of trees that died - ! due to fire, as well as from each fire mortality term - currentSite%fmort_rate_canopy(currentCohort%size_class, currentCohort%pft) = & - currentSite%fmort_rate_canopy(currentCohort%size_class, currentCohort%pft) + & - nc%n * currentCohort%fire_mort / hlm_freq_day - - currentSite%fmort_carbonflux_canopy(currentCohort%pft) = & - currentSite%fmort_carbonflux_canopy(currentCohort%pft) + & - (nc%n * currentCohort%fire_mort) * & - total_c * g_per_kg * days_per_sec * ha_per_m2 - - else - currentSite%fmort_rate_ustory(currentCohort%size_class, currentCohort%pft) = & - currentSite%fmort_rate_ustory(currentCohort%size_class, currentCohort%pft) + & - nc%n * currentCohort%fire_mort / hlm_freq_day - - currentSite%fmort_carbonflux_ustory(currentCohort%pft) = & - currentSite%fmort_carbonflux_ustory(currentCohort%pft) + & - (nc%n * currentCohort%fire_mort) * & - total_c * g_per_kg * days_per_sec * ha_per_m2 - end if - - currentSite%fmort_abg_flux(currentCohort%size_class, currentCohort%pft) = & - currentSite%fmort_abg_flux(currentCohort%size_class, currentCohort%pft) + & - (nc%n * currentCohort%fire_mort) * & - ( (sapw_c + struct_c + store_c) * prt_params%allom_agb_frac(currentCohort%pft) + & - leaf_c ) * & - g_per_kg * days_per_sec * ha_per_m2 - - - currentSite%fmort_rate_cambial(currentCohort%size_class, currentCohort%pft) = & - currentSite%fmort_rate_cambial(currentCohort%size_class, currentCohort%pft) + & - nc%n * currentCohort%cambial_mort / hlm_freq_day - currentSite%fmort_rate_crown(currentCohort%size_class, currentCohort%pft) = & - currentSite%fmort_rate_crown(currentCohort%size_class, currentCohort%pft) + & - nc%n * currentCohort%crownfire_mort / hlm_freq_day - - ! loss of individual from fire in new patch. - nc%n = nc%n * (1.0_r8 - currentCohort%fire_mort) - - nc%cmort = currentCohort%cmort - nc%hmort = currentCohort%hmort - nc%bmort = currentCohort%bmort - nc%frmort = currentCohort%frmort - nc%smort = currentCohort%smort - nc%asmort = currentCohort%asmort - nc%dgmort = currentCohort%dgmort - nc%dmort = currentCohort%dmort - nc%lmort_direct = currentCohort%lmort_direct - nc%lmort_collateral = currentCohort%lmort_collateral - nc%lmort_infra = currentCohort%lmort_infra - - - ! Some of of the leaf mass from living plants has been - ! burned off. Here, we remove that mass, and - ! tally it in the flux we sent to the atmosphere - - if(prt_params%woody(currentCohort%pft) == itrue)then - leaf_burn_frac = currentCohort%fraction_crown_burned - else - - ! Grasses determine their fraction of leaves burned here - - leaf_burn_frac = currentPatch%burnt_frac_litter(lg_sf) - endif - - ! Perform a check to make sure that spitfire gave - ! us reasonable mortality and burn fraction rates - - if( (leaf_burn_frac < 0._r8) .or. & - (leaf_burn_frac > 1._r8) .or. & - (currentCohort%fire_mort < 0._r8) .or. & - (currentCohort%fire_mort > 1._r8)) then - write(fates_log(),*) 'unexpected fire fractions' - 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__)) - end if - - do el = 1,num_elements - - leaf_m = nc%prt%GetState(leaf_organ, element_list(el)) - ! for woody plants burn only leaves - if(int(prt_params%woody(currentCohort%pft)) == itrue)then - - leaf_m = nc%prt%GetState(leaf_organ, element_list(el)) - - else - ! for grasses burn all aboveground tissues - leaf_m = nc%prt%GetState(leaf_organ, element_list(el)) + & - nc%prt%GetState(sapw_organ, element_list(el)) + & - nc%prt%GetState(struct_organ, element_list(el)) - - endif - - currentSite%mass_balance(el)%burn_flux_to_atm = & - currentSite%mass_balance(el)%burn_flux_to_atm + & - leaf_burn_frac * leaf_m * nc%n - end do - - ! Here the mass is removed from the plant - - if(int(prt_params%woody(currentCohort%pft)) == itrue)then - call PRTBurnLosses(nc%prt, leaf_organ, leaf_burn_frac) - else - call PRTBurnLosses(nc%prt, leaf_organ, leaf_burn_frac) - call PRTBurnLosses(nc%prt, sapw_organ, leaf_burn_frac) - call PRTBurnLosses(nc%prt, struct_organ, leaf_burn_frac) - endif - - currentCohort%fraction_crown_burned = 0.0_r8 - nc%fraction_crown_burned = 0.0_r8 - - - - ! Logging is the current disturbance - elseif (i_disturbance_type .eq. dtype_ilog ) then - ! If this cohort is in the upper canopy. It generated - if(currentCohort%canopy_layer == 1)then + ! Some of of the leaf mass from living plants has been + ! burned off. Here, we remove that mass, and + ! tally it in the flux we sent to the atmosphere - ! calculate the survivorship of disturbed trees because non-harvested - nc%n = currentCohort%n * currentCohort%l_degrad - ! nc%n = (currentCohort%l_degrad / (currentCohort%l_degrad + & - ! currentCohort%lmort_direct + currentCohort%lmort_collateral + - ! currentCohort%lmort_infra) ) * & - ! currentCohort%n * patch_site_areadis/currentPatch%area + if(prt_params%woody(currentCohort%pft) == itrue)then + leaf_burn_frac = currentCohort%fraction_crown_burned + else - ! Reduce counts in the existing/donor patch according to the logging rate - currentCohort%n = currentCohort%n * & - (1.0_r8 - min(1.0_r8,(currentCohort%lmort_direct + & - currentCohort%lmort_collateral + & - currentCohort%lmort_infra + currentCohort%l_degrad))) + ! Grasses determine their fraction of leaves burned here - nc%cmort = currentCohort%cmort - nc%hmort = currentCohort%hmort - nc%bmort = currentCohort%bmort - nc%frmort = currentCohort%frmort - nc%smort = currentCohort%smort - nc%asmort = currentCohort%asmort - nc%dgmort = currentCohort%dgmort - nc%dmort = currentCohort%dmort + leaf_burn_frac = currentPatch%burnt_frac_litter(lg_sf) + endif - ! since these are the ones that weren't logged, - ! set the logging mortality rates as zero - nc%lmort_direct = 0._r8 - nc%lmort_collateral = 0._r8 - nc%lmort_infra = 0._r8 + ! Perform a check to make sure that spitfire gave + ! us reasonable mortality and burn fraction rates - else - - ! What to do with cohorts in the understory of a logging generated - ! disturbance patch? - - if(prt_params%woody(currentCohort%pft) == itrue)then - - - ! Survivorship of undestory woody plants. Two step process. - ! Step 1: Reduce current number of plants to reflect the - ! change in area. - ! The number density per square are doesn't change, - ! but since the patch is smaller - ! and cohort counts are absolute, reduce this number. - nc%n = currentCohort%n * patch_site_areadis/currentPatch%area - - ! because the mortality rate due to impact for the cohorts which had - ! been in the understory and are now in the newly- - ! disturbed patch is very high, passing the imort directly to - ! history results in large numerical errors, on account - ! of the sharply reduced number densities. so instead pass this info - ! via a site-level diagnostic variable before reducing - ! the number density. - currentSite%imort_rate(currentCohort%size_class, currentCohort%pft) = & - currentSite%imort_rate(currentCohort%size_class, currentCohort%pft) + & - nc%n * currentPatch%fract_ldist_not_harvested * & - logging_coll_under_frac / hlm_freq_day - - currentSite%imort_carbonflux(currentCohort%pft) = & - currentSite%imort_carbonflux(currentCohort%pft) + & - (nc%n * currentPatch%fract_ldist_not_harvested * & - logging_coll_under_frac/ hlm_freq_day ) * & - total_c * days_per_sec * years_per_day * ha_per_m2 - - currentSite%imort_abg_flux(currentCohort%size_class, currentCohort%pft) = & - currentSite%imort_abg_flux(currentCohort%size_class, currentCohort%pft) + & - (nc%n * currentPatch%fract_ldist_not_harvested * & - logging_coll_under_frac/ hlm_freq_day ) * & - ( ( sapw_c + struct_c + store_c) * prt_params%allom_agb_frac(currentCohort%pft) + & - leaf_c ) * days_per_sec * years_per_day * ha_per_m2 - - - ! Step 2: Apply survivor ship function based on the understory death fraction - - ! remaining of understory plants of those that are knocked - ! over by the overstorey trees dying... - ! LOGGING SURVIVORSHIP OF UNDERSTORY PLANTS IS SET AS A NEW PARAMETER - ! in the fatesparameter files - nc%n = nc%n * (1.0_r8 - & - (1.0_r8-currentPatch%fract_ldist_not_harvested) * logging_coll_under_frac) - - ! Step 3: Reduce the number count of cohorts in the - ! original/donor/non-disturbed patch to reflect the area change - currentCohort%n = currentCohort%n * (1._r8 - patch_site_areadis/currentPatch%area) - - nc%cmort = currentCohort%cmort - nc%hmort = currentCohort%hmort - nc%bmort = currentCohort%bmort - nc%frmort = currentCohort%frmort - nc%smort = currentCohort%smort - nc%asmort = currentCohort%asmort - nc%dgmort = currentCohort%dgmort - nc%dmort = currentCohort%dmort - nc%lmort_direct = currentCohort%lmort_direct - nc%lmort_collateral = currentCohort%lmort_collateral - nc%lmort_infra = currentCohort%lmort_infra - - else - - ! grass is not killed by mortality disturbance events. - ! Just move it into the new patch area. - ! Just split the grass into the existing and new patch structures + if( (leaf_burn_frac < 0._r8) .or. & + (leaf_burn_frac > 1._r8) .or. & + (currentCohort%fire_mort < 0._r8) .or. & + (currentCohort%fire_mort > 1._r8)) then + write(fates_log(),*) 'unexpected fire fractions' + 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__)) + end if + + do el = 1,num_elements + + leaf_m = nc%prt%GetState(leaf_organ, element_list(el)) + ! for woody plants burn only leaves + if(int(prt_params%woody(currentCohort%pft)) == itrue)then + + leaf_m = nc%prt%GetState(leaf_organ, element_list(el)) + + else + ! for grasses burn all aboveground tissues + leaf_m = nc%prt%GetState(leaf_organ, element_list(el)) + & + nc%prt%GetState(sapw_organ, element_list(el)) + & + nc%prt%GetState(struct_organ, element_list(el)) + + endif + + currentSite%mass_balance(el)%burn_flux_to_atm = & + currentSite%mass_balance(el)%burn_flux_to_atm + & + leaf_burn_frac * leaf_m * nc%n + end do + + ! Here the mass is removed from the plant + + if(int(prt_params%woody(currentCohort%pft)) == itrue)then + call PRTBurnLosses(nc%prt, leaf_organ, leaf_burn_frac) + else + call PRTBurnLosses(nc%prt, leaf_organ, leaf_burn_frac) + call PRTBurnLosses(nc%prt, sapw_organ, leaf_burn_frac) + call PRTBurnLosses(nc%prt, struct_organ, leaf_burn_frac) + endif + + currentCohort%fraction_crown_burned = 0.0_r8 + nc%fraction_crown_burned = 0.0_r8 + + + + ! Logging is the current disturbance + case (dtype_ilog) + + ! If this cohort is in the upper canopy. It generated + in_canopy_if_logdtype: if(currentCohort%canopy_layer == 1)then + + ! calculate the survivorship of disturbed trees because non-harvested + nc%n = currentCohort%n * currentCohort%l_degrad + ! nc%n = (currentCohort%l_degrad / (currentCohort%l_degrad + & + ! currentCohort%lmort_direct + currentCohort%lmort_collateral + + ! currentCohort%lmort_infra) ) * & + ! currentCohort%n * patch_site_areadis/currentPatch%area + + ! Reduce counts in the existing/donor patch according to the logging rate + currentCohort%n = currentCohort%n * & + (1.0_r8 - min(1.0_r8,(currentCohort%lmort_direct + & + currentCohort%lmort_collateral + & + currentCohort%lmort_infra + currentCohort%l_degrad))) + + nc%cmort = currentCohort%cmort + nc%hmort = currentCohort%hmort + nc%bmort = currentCohort%bmort + nc%frmort = currentCohort%frmort + nc%smort = currentCohort%smort + nc%asmort = currentCohort%asmort + nc%dgmort = currentCohort%dgmort + nc%dmort = currentCohort%dmort + + ! since these are the ones that weren't logged, + ! set the logging mortality rates as zero + nc%lmort_direct = 0._r8 + nc%lmort_collateral = 0._r8 + nc%lmort_infra = 0._r8 + + else + + ! What to do with cohorts in the understory of a logging generated + ! disturbance patch? + + woody_if_logdtype: if(prt_params%woody(currentCohort%pft) == itrue)then + + + ! Survivorship of undestory woody plants. Two step process. + ! Step 1: Reduce current number of plants to reflect the + ! change in area. + ! The number density per square are doesn't change, + ! but since the patch is smaller + ! and cohort counts are absolute, reduce this number. + nc%n = currentCohort%n * patch_site_areadis/currentPatch%area + + ! because the mortality rate due to impact for the cohorts which had + ! been in the understory and are now in the newly- + ! disturbed patch is very high, passing the imort directly to + ! history results in large numerical errors, on account + ! of the sharply reduced number densities. so instead pass this info + ! via a site-level diagnostic variable before reducing + ! the number density. + currentSite%imort_rate(currentCohort%size_class, currentCohort%pft) = & + currentSite%imort_rate(currentCohort%size_class, currentCohort%pft) + & + nc%n * currentPatch%fract_ldist_not_harvested * & + logging_coll_under_frac / hlm_freq_day + + currentSite%imort_carbonflux(currentCohort%pft) = & + currentSite%imort_carbonflux(currentCohort%pft) + & + (nc%n * currentPatch%fract_ldist_not_harvested * & + logging_coll_under_frac/ hlm_freq_day ) * & + total_c * g_per_kg * days_per_sec * years_per_day * ha_per_m2 + + currentSite%imort_abg_flux(currentCohort%size_class, currentCohort%pft) = & + currentSite%imort_abg_flux(currentCohort%size_class, currentCohort%pft) + & + (nc%n * currentPatch%fract_ldist_not_harvested * & + logging_coll_under_frac/ hlm_freq_day ) * & + ( ( sapw_c + struct_c + store_c) * prt_params%allom_agb_frac(currentCohort%pft) + & + leaf_c ) * days_per_sec * years_per_day * ha_per_m2 + + ! Step 2: Apply survivor ship function based on the understory death fraction + + ! remaining of understory plants of those that are knocked + ! over by the overstorey trees dying... + ! LOGGING SURVIVORSHIP OF UNDERSTORY PLANTS IS SET AS A NEW PARAMETER + ! in the fatesparameter files + nc%n = nc%n * (1.0_r8 - & + (1.0_r8-currentPatch%fract_ldist_not_harvested) * logging_coll_under_frac) + + ! Step 3: Reduce the number count of cohorts in the + ! original/donor/non-disturbed patch to reflect the area change + currentCohort%n = currentCohort%n * (1._r8 - patch_site_areadis/currentPatch%area) + + nc%cmort = currentCohort%cmort + nc%hmort = currentCohort%hmort + nc%bmort = currentCohort%bmort + nc%frmort = currentCohort%frmort + nc%smort = currentCohort%smort + nc%asmort = currentCohort%asmort + nc%dgmort = currentCohort%dgmort + nc%dmort = currentCohort%dmort + nc%lmort_direct = currentCohort%lmort_direct + nc%lmort_collateral = currentCohort%lmort_collateral + nc%lmort_infra = currentCohort%lmort_infra + + else + + ! grass is not killed by mortality disturbance events. + ! Just move it into the new patch area. + ! Just split the grass into the existing and new patch structures + nc%n = currentCohort%n * patch_site_areadis/currentPatch%area + + ! Those remaining in the existing + currentCohort%n = currentCohort%n * (1._r8 - patch_site_areadis/currentPatch%area) + + ! No grass impact mortality imposed on the newly created patch + nc%cmort = currentCohort%cmort + nc%hmort = currentCohort%hmort + nc%bmort = currentCohort%bmort + nc%frmort = currentCohort%frmort + nc%smort = currentCohort%smort + nc%asmort = currentCohort%asmort + nc%dgmort = currentCohort%dgmort + nc%dmort = currentCohort%dmort + nc%lmort_direct = currentCohort%lmort_direct + nc%lmort_collateral = currentCohort%lmort_collateral + nc%lmort_infra = currentCohort%lmort_infra + + endif woody_if_logdtype ! is/is-not woody + + endif in_canopy_if_logdtype ! Select canopy layer + + ! Land use change is the current disturbance type + case (dtype_ilandusechange) + + ! Number of members in the new patch, before we impose LUC survivorship nc%n = currentCohort%n * patch_site_areadis/currentPatch%area - ! Those remaining in the existing + ! loss of individuals from source patch due to area shrinking currentCohort%n = currentCohort%n * (1._r8 - patch_site_areadis/currentPatch%area) - ! No grass impact mortality imposed on the newly created patch - nc%cmort = currentCohort%cmort - nc%hmort = currentCohort%hmort - nc%bmort = currentCohort%bmort - nc%frmort = currentCohort%frmort - nc%smort = currentCohort%smort - nc%asmort = currentCohort%asmort - nc%dgmort = currentCohort%dgmort - nc%dmort = currentCohort%dmort - nc%lmort_direct = currentCohort%lmort_direct - nc%lmort_collateral = currentCohort%lmort_collateral - nc%lmort_infra = currentCohort%lmort_infra + ! now apply survivorship based on the type of landuse transition + if ( clearing_matrix(i_donorpatch_landuse_type,i_landusechange_receiverpatchlabel) ) then + ! kill everything + nc%n = 0._r8 + end if + + case default + write(fates_log(),*) 'unknown disturbance mode?' + write(fates_log(),*) 'i_disturbance_type: ',i_disturbance_type + call endrun(msg=errMsg(sourcefile, __LINE__)) + end select disttype_case ! Select disturbance mode + + ! if some plants in the new temporary cohort survived the transfer to the new patch, + ! then put the cohort into the linked list. + cohort_n_gt_zero: if (nc%n > 0.0_r8) then + storebigcohort => newPatch%tallest + storesmallcohort => newPatch%shortest + if(associated(newPatch%tallest))then + tnull = 0 + else + tnull = 1 + newPatch%tallest => nc + nc%taller => null() + endif + + if(associated(newPatch%shortest))then + snull = 0 + else + snull = 1 + newPatch%shortest => nc + nc%shorter => null() + endif + !nc%patchptr => new_patch + call insert_cohort(newPatch, nc, newPatch%tallest, newPatch%shortest, & + tnull, snull, storebigcohort, storesmallcohort) + + newPatch%tallest => storebigcohort + newPatch%shortest => storesmallcohort - endif ! is/is-not woody - - endif ! Select canopy layer - - else - write(fates_log(),*) 'unknown disturbance mode?' - write(fates_log(),*) 'i_disturbance_type: ',i_disturbance_type - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if ! Select disturbance mode - - if (nc%n > 0.0_r8) then - storebigcohort => new_patch%tallest - storesmallcohort => new_patch%shortest - if(associated(new_patch%tallest))then - tnull = 0 + else + ! sadly, no plants in the cohort survived. on the bright side, we can deallocate their memory. + call nc%FreeMemory() + deallocate(nc, stat=istat, errmsg=smsg) + if (istat/=0) then + write(fates_log(),*) 'dealloc005: fail on deallocate(nc):'//trim(smsg) + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + endif cohort_n_gt_zero + + currentCohort => currentCohort%taller + enddo cohortloop + + call sort_cohorts(currentPatch) + + !update area of donor patch + oldarea = currentPatch%area + currentPatch%area = currentPatch%area - patch_site_areadis + + ! for all disturbance rates that haven't been resolved yet, increase their amount so that + ! they are the same amount of gridcell-scale disturbance relative to the original patch size + if (i_disturbance_type .lt. N_DIST_TYPES) then + do i_dist2 = i_disturbance_type+1,N_DIST_TYPES-1 + currentPatch%disturbance_rates(i_dist2) = currentPatch%disturbance_rates(i_dist2) & + * oldarea / currentPatch%area + end do + do i_dist2 = 1,n_landuse_cats + currentPatch%landuse_transition_rates(i_dist2) = currentPatch%landuse_transition_rates(i_dist2) & + * oldarea / currentPatch%area + end do else - tnull = 1 - new_patch%tallest => nc - nc%taller => null() - endif + do i_dist2 = i_landusechange_receiverpatchlabel+1,n_landuse_cats + currentPatch%landuse_transition_rates(i_dist2) = currentPatch%landuse_transition_rates(i_dist2) & + * oldarea / currentPatch%area + end do + end if - if(associated(new_patch%shortest))then - snull = 0 - else - snull = 1 - new_patch%shortest => nc - nc%shorter => null() - endif - !nc%patchptr => new_patch - call insert_cohort(new_patch, nc, new_patch%tallest, new_patch%shortest, & - tnull, snull, storebigcohort, storesmallcohort) + ! sort out the cohorts, since some of them may be so small as to need removing. + ! the first call to terminate cohorts removes sparse number densities, + ! the second call removes for all other reasons (sparse culling must happen + ! before fusion) + call terminate_cohorts(currentSite, currentPatch, 1,16,bc_in) + call fuse_cohorts(currentSite,currentPatch, bc_in) + call terminate_cohorts(currentSite, currentPatch, 2,16,bc_in) + call sort_cohorts(currentPatch) - new_patch%tallest => storebigcohort - new_patch%shortest => storesmallcohort - else + end if areadis_gt_zero_if ! if ( newPatch%area > nearzero ) then - ! Get rid of the new temporary cohort - call nc%FreeMemory() - deallocate(nc, stat=istat, errmsg=smsg) - if (istat/=0) then - write(fates_log(),*) 'dealloc005: fail on deallocate(nc):'//trim(smsg) - call endrun(msg=errMsg(sourcefile, __LINE__)) - endif - endif + end if patchlabel_matches_lutype_if - currentCohort => currentCohort%taller - enddo ! currentCohort - call sort_cohorts(currentPatch) - - !update area of donor patch - oldarea = currentPatch%area - currentPatch%area = currentPatch%area - patch_site_areadis - - ! for all disturbance rates that haven't been resolved yet, increase their amount so that - ! they are the same amount of gridcell-scale disturbance relative to the original patch size - if (i_disturbance_type .ne. N_DIST_TYPES) then - do i_dist2 = i_disturbance_type+1,N_DIST_TYPES - currentPatch%disturbance_rates(i_dist2) = currentPatch%disturbance_rates(i_dist2) & - * oldarea / currentPatch%area - end do - end if - - ! sort out the cohorts, since some of them may be so small as to need removing. - ! the first call to terminate cohorts removes sparse number densities, - ! the second call removes for all other reasons (sparse culling must happen - ! before fusion) - call terminate_cohorts(currentSite, currentPatch, 1,16,bc_in) - call fuse_cohorts(currentSite,currentPatch, bc_in) - call terminate_cohorts(currentSite, currentPatch, 2,16,bc_in) - call sort_cohorts(currentPatch) - - end if ! if ( new_patch%area > nearzero ) then - - end if cp_nocomp_matches_2_if - currentPatch => currentPatch%younger - - enddo ! currentPatch patch loop. - - !*************************/ - !** INSERT NEW PATCH(ES) INTO LINKED LIST - !*************************/ - - if ( site_areadis_primary .gt. nearzero) then - currentPatch => currentSite%youngest_patch - ! insert new youngest primary patch after all the secondary patches, if there are any. - ! this requires first finding the current youngest primary to insert the new one ahead of - if (currentPatch%anthro_disturbance_label .eq. secondaryforest ) then - found_youngest_primary = .false. - do while(associated(currentPatch) .and. .not. found_youngest_primary) - currentPatch => currentPatch%older - if (associated(currentPatch)) then - if (currentPatch%anthro_disturbance_label .eq. primaryforest) then - found_youngest_primary = .true. - endif - endif - end do - if (associated(currentPatch)) then - ! the case where we've found a youngest primary patch - new_patch_primary%older => currentPatch - new_patch_primary%younger => currentPatch%younger - currentPatch%younger%older => new_patch_primary - currentPatch%younger => new_patch_primary - else - ! the case where we haven't, because the patches are all secondaary, - ! and are putting a primary patch at the oldest end of the - ! linked list (not sure how this could happen, but who knows...) - new_patch_primary%older => null() - new_patch_primary%younger => currentSite%oldest_patch - currentSite%oldest_patch%older => new_patch_primary - currentSite%oldest_patch => new_patch_primary - endif - else - ! the case where there are no secondary patches at the start of the linked list (prior logic) - new_patch_primary%older => currentPatch - new_patch_primary%younger => null() - currentPatch%younger => new_patch_primary - currentSite%youngest_patch => new_patch_primary - endif - endif + end if cp_nocomp_matches_2_if + currentPatch => currentPatch%younger - ! insert first secondary at the start of the list - if ( site_areadis_secondary .gt. nearzero) then - currentPatch => currentSite%youngest_patch - new_patch_secondary%older => currentPatch - new_patch_secondary%younger=> null() - currentPatch%younger => new_patch_secondary - currentSite%youngest_patch => new_patch_secondary - endif + enddo patchloop ! currentPatch patch loop. + !*************************/ + !** INSERT NEW PATCH(ES) INTO LINKED LIST + !*************************/ - ! sort out the cohorts, since some of them may be so small as to need removing. - ! the first call to terminate cohorts removes sparse number densities, - ! the second call removes for all other reasons (sparse culling must happen - ! before fusion) + if ( site_areadis .gt. nearzero) then - if ( site_areadis_primary .gt. nearzero) then - call terminate_cohorts(currentSite, new_patch_primary, 1,17, bc_in) - call fuse_cohorts(currentSite,new_patch_primary, bc_in) - call terminate_cohorts(currentSite, new_patch_primary, 2,17, bc_in) - call sort_cohorts(new_patch_primary) - endif + call InsertPatch(currentSite, newPatch) - if ( site_areadis_secondary .gt. nearzero) then - call terminate_cohorts(currentSite, new_patch_secondary, 1,18,bc_in) - call fuse_cohorts(currentSite,new_patch_secondary, bc_in) - call terminate_cohorts(currentSite, new_patch_secondary, 2,18,bc_in) - call sort_cohorts(new_patch_secondary) - endif + ! sort out the cohorts, since some of them may be so small as to need removing. + ! the first call to terminate cohorts removes sparse number densities, + ! the second call removes for all other reasons (sparse culling must happen + ! before fusion) - endif !end new_patch area + call terminate_cohorts(currentSite, newPatch, 1,17, bc_in) + call fuse_cohorts(currentSite,newPatch, bc_in) + call terminate_cohorts(currentSite, newPatch, 2,17, bc_in) + call sort_cohorts(newPatch) + endif - call check_patch_area(currentSite) - call set_patchno(currentSite) + call check_patch_area(currentSite) + call set_patchno(currentSite) + end do landusechange_receiverpatchlabel_loop + end do landuse_donortype_loop end do disturbance_type_loop end do nocomp_pft_loop @@ -2098,8 +2123,269 @@ subroutine mortality_litter_fluxes(currentSite, currentPatch, & return end subroutine mortality_litter_fluxes + ! ============================================================================ + + subroutine landusechange_litter_fluxes(currentSite, currentPatch, & + newPatch, patch_site_areadis, bc_in, & + clearing_matrix_element) + ! + ! !DESCRIPTION: + ! CWD pool from land use change. + ! Carbon going from felled trees into CWD pool + ! Either kill everything or nothing on disturbed land, depending on clearing matrix + ! + ! !USES: + use SFParamsMod, only : SF_VAL_CWD_FRAC + ! + ! !ARGUMENTS: + type(ed_site_type) , intent(inout), target :: currentSite + type(fates_patch_type) , intent(inout), target :: currentPatch ! Donor Patch + type(fates_patch_type) , intent(inout), target :: newPatch ! New Patch + real(r8) , intent(in) :: patch_site_areadis ! Area being donated + type(bc_in_type) , intent(in) :: bc_in + logical , intent(in) :: clearing_matrix_element ! whether or not to clear vegetation + + ! + ! !LOCAL VARIABLES: + + type(fates_cohort_type), pointer :: currentCohort + type(litter_type), pointer :: new_litt + type(litter_type), pointer :: curr_litt + type(site_massbal_type), pointer :: site_mass + type(site_fluxdiags_type), pointer :: flux_diags + + real(r8) :: donatable_mass ! non-burned litter mass provided by the donor [kg] + ! some may or may not be retained by the donor + real(r8) :: burned_mass ! the mass of litter that was supposed to be provided + ! by the donor, but was burned [kg] + real(r8) :: remainder_area ! current patch's remaining area after donation [m2] + real(r8) :: retain_frac ! the fraction of litter mass retained by the donor patch + real(r8) :: bcroot ! amount of below ground coarse root per cohort kg + real(r8) :: bstem ! amount of above ground stem biomass per cohort kg + real(r8) :: leaf_burn_frac ! fraction of leaves burned + real(r8) :: leaf_m ! leaf mass [kg] + real(r8) :: fnrt_m ! fineroot mass [kg] + real(r8) :: sapw_m ! sapwood mass [kg] + real(r8) :: store_m ! storage mass [kg] + real(r8) :: struct_m ! structure mass [kg] + real(r8) :: repro_m ! Reproductive mass (seeds/flowers) [kg] + real(r8) :: num_dead_trees ! total number of dead trees passed in with the burn area + real(r8) :: num_live_trees ! total number of live trees passed in with the burn area + real(r8) :: donate_m2 ! area normalization for litter mass destined to new patch [m-2] + real(r8) :: retain_m2 ! area normalization for litter mass staying in donor patch [m-2] + real(r8) :: dcmpy_frac ! fraction of mass going to each decomposability partition + integer :: el ! element loop index + integer :: sl ! soil layer index + integer :: c ! loop index for coarse woody debris pools + integer :: pft ! loop index for plant functional types + integer :: dcmpy ! loop index for decomposability pool + integer :: element_id ! parteh compatible global element index + real(r8) :: trunk_product_site ! flux of carbon in trunk products exported off site [ kgC/site ] + ! (note we are accumulating over the patch, but scale is site level) + real(r8) :: woodproduct_mass ! mass that ends up in wood products [kg] + + ! the following two parameters are new to this logic. + real(r8), parameter :: burn_frac_landusetransition = 0.5_r8 ! what fraction of plant fines are burned during a land use transition? + real(r8), parameter :: woodproduct_frac_landusetransition = 0.5_r8 ! what fraction of trunk carbon is turned into wood products during a land use transition? + + !--------------------------------------------------------------------- + + clear_veg_if: if (clearing_matrix_element) then + + ! If plant hydraulics are turned on, account for water leaving the plant-soil + ! mass balance through the dead trees + if (hlm_use_planthydro == itrue) then + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + num_dead_trees = (currentCohort%n*patch_site_areadis/currentPatch%area) + call AccumulateMortalityWaterStorage(currentSite,currentCohort,num_dead_trees) + currentCohort => currentCohort%taller + end do + end if + + + ! If/when sending litter fluxes to the donor patch, we divide the total + ! mass sent to that patch, by the area it will have remaining + ! after it donates area. + ! i.e. subtract the area it is donating. + + remainder_area = currentPatch%area - patch_site_areadis + + ! Calculate the fraction of litter to be retained versus donated + ! vis-a-vis the new and donor patch (if the area remaining + ! in the original donor patch is small, don't bother + ! retaining anything.) + retain_frac = (1.0_r8-landusechange_localization) * & + remainder_area/(newPatch%area+remainder_area) + + if(remainder_area > rsnbl_math_prec) then + retain_m2 = retain_frac/remainder_area + donate_m2 = (1.0_r8-retain_frac)/newPatch%area + else + retain_m2 = 0._r8 + donate_m2 = 1.0_r8/newPatch%area + end if + + do el = 1,num_elements + + ! Zero some site level accumulator diagnsotics + trunk_product_site = 0.0_r8 + + element_id = element_list(el) + site_mass => currentSite%mass_balance(el) + flux_diags => currentSite%flux_diags(el) + curr_litt => currentPatch%litter(el) ! Litter pool of "current" patch + new_litt => newPatch%litter(el) ! Litter pool of "new" patch + + ! ----------------------------------------------------------------------------- + ! PART 1) Handle mass fluxes associated with plants that died in the land use transition + ! ------------------------------------------------------------------------------ + + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + + pft = currentCohort%pft + + ! Number of trees that died because of the land use transition, per m2 of ground. + ! Divide their litter into the four litter streams, and spread + ! across ground surface. + ! ----------------------------------------------------------------------- + + fnrt_m = currentCohort%prt%GetState(fnrt_organ, element_id) + store_m = currentCohort%prt%GetState(store_organ, element_id) + repro_m = currentCohort%prt%GetState(repro_organ, element_id) + + if (prt_params%woody(currentCohort%pft) == itrue) then + ! Assumption: for woody plants fluxes from deadwood and sapwood go together in CWD pool + leaf_m = currentCohort%prt%GetState(leaf_organ,element_id) + sapw_m = currentCohort%prt%GetState(sapw_organ,element_id) + struct_m = currentCohort%prt%GetState(struct_organ,element_id) + else + ! for non-woody plants all stem fluxes go into the same leaf litter pool + leaf_m = currentCohort%prt%GetState(leaf_organ,element_id) + & + currentCohort%prt%GetState(sapw_organ,element_id) + & + currentCohort%prt%GetState(struct_organ,element_id) + sapw_m = 0._r8 + struct_m = 0._r8 + end if + + + ! Absolute number of dead trees being transfered in with the donated area + num_dead_trees = (currentCohort%n * & + patch_site_areadis/currentPatch%area) + + ! Contribution of dead trees to leaf litter + donatable_mass = num_dead_trees * (leaf_m+repro_m) * & + (1.0_r8-burn_frac_landusetransition) + + ! Contribution of dead trees to leaf burn-flux + burned_mass = num_dead_trees * (leaf_m+repro_m) * burn_frac_landusetransition + + do dcmpy=1,ndcmpy + dcmpy_frac = GetDecompyFrac(pft,leaf_organ,dcmpy) + new_litt%leaf_fines(dcmpy) = new_litt%leaf_fines(dcmpy) + & + donatable_mass*donate_m2*dcmpy_frac + curr_litt%leaf_fines(dcmpy) = curr_litt%leaf_fines(dcmpy) + & + donatable_mass*retain_m2*dcmpy_frac + end do + + site_mass%burn_flux_to_atm = site_mass%burn_flux_to_atm + burned_mass + + call set_root_fraction(currentSite%rootfrac_scr, pft, currentSite%zi_soil, & + bc_in%max_rooting_depth_index_col) + + ! Contribution of dead trees to root litter (no root burn flux to atm) + do dcmpy=1,ndcmpy + dcmpy_frac = GetDecompyFrac(pft,fnrt_organ,dcmpy) + do sl = 1,currentSite%nlevsoil + donatable_mass = num_dead_trees * (fnrt_m+store_m) * currentSite%rootfrac_scr(sl) + new_litt%root_fines(dcmpy,sl) = new_litt%root_fines(dcmpy,sl) + & + donatable_mass*donate_m2*dcmpy_frac + curr_litt%root_fines(dcmpy,sl) = curr_litt%root_fines(dcmpy,sl) + & + donatable_mass*retain_m2*dcmpy_frac + end do + end do + + ! Track as diagnostic fluxes + flux_diags%leaf_litter_input(pft) = & + flux_diags%leaf_litter_input(pft) + & + num_dead_trees * (leaf_m+repro_m) * (1.0_r8-burn_frac_landusetransition) + + flux_diags%root_litter_input(pft) = & + flux_diags%root_litter_input(pft) + & + (fnrt_m + store_m) * num_dead_trees + + ! coarse root biomass per tree + bcroot = (sapw_m + struct_m) * (1.0_r8 - prt_params%allom_agb_frac(pft) ) + + ! below ground coarse woody debris from felled trees + do c = 1,ncwd + do sl = 1,currentSite%nlevsoil + donatable_mass = num_dead_trees * SF_val_CWD_frac(c) * & + bcroot * currentSite%rootfrac_scr(sl) + + new_litt%bg_cwd(c,sl) = new_litt%bg_cwd(c,sl) + & + donatable_mass * donate_m2 + curr_litt%bg_cwd(c,sl) = curr_litt%bg_cwd(c,sl) + & + donatable_mass * retain_m2 + + ! track diagnostics + flux_diags%cwd_bg_input(c) = & + flux_diags%cwd_bg_input(c) + & + donatable_mass + enddo + end do + + ! stem biomass per tree + 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 + ! a portion may also be carried offsite as wood product + do c = 1,ncwd + donatable_mass = num_dead_trees * SF_val_CWD_frac(c) * bstem + if (c == 1 .or. c == 2) then ! these pools can burn + donatable_mass = donatable_mass * (1.0_r8-burn_frac_landusetransition) + burned_mass = num_dead_trees * SF_val_CWD_frac(c) * bstem * & + burn_frac_landusetransition + + site_mass%burn_flux_to_atm = site_mass%burn_flux_to_atm + burned_mass + else ! all other pools can end up as timber products but not burn + donatable_mass = donatable_mass * (1.0_r8-woodproduct_frac_landusetransition) + + woodproduct_mass = num_dead_trees * SF_val_CWD_frac(c) * bstem * & + woodproduct_frac_landusetransition + + trunk_product_site = trunk_product_site + & + woodproduct_mass + + site_mass%wood_product = site_mass%wood_product + & + woodproduct_mass + endif + new_litt%ag_cwd(c) = new_litt%ag_cwd(c) + donatable_mass * donate_m2 + curr_litt%ag_cwd(c) = curr_litt%ag_cwd(c) + donatable_mass * retain_m2 + flux_diags%cwd_ag_input(c) = flux_diags%cwd_ag_input(c) + donatable_mass + enddo + + currentCohort => currentCohort%taller + enddo + + ! Update the amount of carbon exported from the site through logging. + + if(element_id .eq. carbon12_element) then + currentSite%resources_management%trunk_product_site = & + currentSite%resources_management%trunk_product_site + & + trunk_product_site + end if + + + end do + + end if clear_veg_if + return + end subroutine landusechange_litter_fluxes + ! ============================================================================ - subroutine fuse_patches( csite, bc_in ) ! ! !DESCRIPTION: @@ -2120,14 +2406,13 @@ subroutine fuse_patches( csite, bc_in ) integer :: ft,z !counters for pft and height class real(r8) :: norm !normalized difference between biomass profiles real(r8) :: profiletol !tolerance of patch fusion routine. Starts off high and is reduced if there are too many patches. - integer :: nopatches(n_anthro_disturbance_categories) !number of patches presently in gridcell + integer :: nopatches(n_landuse_cats) !number of patches presently in gridcell integer :: iterate !switch of patch reduction iteration scheme. 1 to keep going, 0 to stop integer :: fuse_flag !do patches get fused (1) or not (0). - integer :: i_disttype !iterator over anthropogenic disturbance categories + integer :: i_lulabel !iterator over anthropogenic disturbance categories integer :: i_pftlabel !nocomp pft iterator real(r8) :: primary_land_fraction_beforefusion,primary_land_fraction_afterfusion integer :: pftlabelmin, pftlabelmax - real(r8) :: maxpatches(n_anthro_disturbance_categories) ! !--------------------------------------------------------------------- @@ -2138,31 +2423,14 @@ subroutine fuse_patches( csite, bc_in ) primary_land_fraction_beforefusion = 0._r8 primary_land_fraction_afterfusion = 0._r8 - nopatches(1:n_anthro_disturbance_categories) = 0 - - ! Its possible that, in nocomp modes, there are more categorically distinct patches than we allow as - ! primary patches in non-nocomp mode. So if this is the case, bump up the maximum number of primary patches - ! to let there be one for each type of nocomp PFT on the site. this is likely to lead to problems - ! if anthropogenic disturance is enabled. - if (hlm_use_nocomp.eq.itrue) then - maxpatches(primaryforest) = max(maxpatch_primary, sum(csite%use_this_pft)) - maxpatches(secondaryforest) = maxpatch_total - maxpatches(primaryforest) - if (maxpatch_total .lt. maxpatches(primaryforest)) then - write(fates_log(),*) 'too many PFTs and not enough patches for nocomp w/o fixed biogeog' - write(fates_log(),*) 'maxpatch_total,numpft',maxpatch_total,numpft, sum(csite%use_this_pft) - call endrun(msg=errMsg(sourcefile, __LINE__)) - endif - else - maxpatches(primaryforest) = maxpatch_primary - maxpatches(secondaryforest) = maxpatch_secondary - endif + nopatches(1:n_landuse_cats) = 0 currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) - nopatches(currentPatch%anthro_disturbance_label) = & - nopatches(currentPatch%anthro_disturbance_label) + 1 + nopatches(currentPatch%land_use_label) = & + nopatches(currentPatch%land_use_label) + 1 - if (currentPatch%anthro_disturbance_label .eq. primaryforest) then + if (currentPatch%land_use_label .eq. primaryland) then primary_land_fraction_beforefusion = primary_land_fraction_beforefusion + & currentPatch%area * AREA_INV endif @@ -2178,10 +2446,10 @@ subroutine fuse_patches( csite, bc_in ) endif !---------------------------------------------------------------------! - ! iterate over anthropogenic disturbance categories + ! iterate over land use categories !---------------------------------------------------------------------! - disttype_loop: do i_disttype = 1, n_anthro_disturbance_categories + lulabel_loop: do i_lulabel = 1, n_landuse_cats !---------------------------------------------------------------------! ! We only really care about fusing patches if nopatches > 1 ! @@ -2190,7 +2458,7 @@ subroutine fuse_patches( csite, bc_in ) iterate = 1 !---------------------------------------------------------------------! - ! Keep doing this until nopatches <= maxpatch_total ! + ! Keep doing this until nopatches <= maxpatches_by_landuse(i_lulabel)! !---------------------------------------------------------------------! iterate_eq_1_loop: do while(iterate == 1) @@ -2223,8 +2491,8 @@ subroutine fuse_patches( csite, bc_in ) ! only fuse patches whose anthropogenic disturbance category matches ! ! that of the outer loop that we are in ! !--------------------------------------------------------------------! - anthro_dist_labels_match_if: if ( tpp%anthro_disturbance_label .eq. i_disttype .and. & - currentPatch%anthro_disturbance_label .eq. i_disttype) then + landuse_labels_match_if: if ( tpp%land_use_label .eq. i_lulabel .and. & + currentPatch%land_use_label .eq. i_lulabel) then nocomp_pft_labels_match_if: if (hlm_use_nocomp .eq. ifalse .or. & (tpp%nocomp_pft_label .eq. i_pftlabel .and. & @@ -2327,10 +2595,10 @@ subroutine fuse_patches( csite, bc_in ) ! a patch x patch loop, reset the patch fusion tolerance to the starting ! ! value so that any subsequent fusions in this loop are done with that ! ! value. otherwise we can end up in a situation where we've loosened the ! - ! fusion tolerance to get nopatches <= maxpatch_total, but then, ! + ! fusion tolerance to get nopatches <= maxpatches_by_landuse(i_lulabel), but then, ! ! having accomplished that, we continue through all the patch x patch ! ! combinations and then all the patches get fused, ending up with ! - ! nopatches << maxpatch_total and losing all heterogeneity. ! + ! nopatches << maxpatches_by_landuse(i_lulabel) and losing all heterogeneity. ! !------------------------------------------------------------------------! profiletol = ED_val_patch_fusion_tol @@ -2338,7 +2606,7 @@ subroutine fuse_patches( csite, bc_in ) endif fuseflagset_if endif different_patches_if endif nocomp_pft_labels_match_if - endif anthro_dist_labels_match_if + endif landuse_labels_match_if endif both_associated_if tpp => tpp%older @@ -2357,16 +2625,16 @@ subroutine fuse_patches( csite, bc_in ) !---------------------------------------------------------------------! ! Is the number of patches larger than the maximum? ! !---------------------------------------------------------------------! - nopatches(i_disttype) = 0 + nopatches(i_lulabel) = 0 currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) - if (currentPatch%anthro_disturbance_label .eq. i_disttype) then - nopatches(i_disttype) = nopatches(i_disttype) +1 + if (currentPatch%land_use_label .eq. i_lulabel) then + nopatches(i_lulabel) = nopatches(i_lulabel) +1 endif currentPatch => currentPatch%older enddo - if(nopatches(i_disttype) > maxpatches(i_disttype))then + if(nopatches(i_lulabel) > maxpatches_by_landuse(i_lulabel))then iterate = 1 profiletol = profiletol * patch_fusion_tolerance_relaxation_increment @@ -2389,14 +2657,14 @@ subroutine fuse_patches( csite, bc_in ) iterate = 0 endif - enddo iterate_eq_1_loop ! iterate .eq. 1 ==> nopatches>maxpatch_total + enddo iterate_eq_1_loop ! iterate .eq. 1 ==> nopatches>maxpatches_by_landuse(i_lulabel) - end do disttype_loop + end do lulabel_loop currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) - if (currentPatch%anthro_disturbance_label .eq. primaryforest) then + if (currentPatch%land_use_label .eq. primaryland) then primary_land_fraction_afterfusion = primary_land_fraction_afterfusion + & currentPatch%area * AREA_INV endif @@ -2455,8 +2723,8 @@ subroutine fuse_2_patches(csite, dp, rp) call rp%litter(el)%FuseLitter(rp%area,dp%area,dp%litter(el)) end do - if ( rp%anthro_disturbance_label .ne. dp%anthro_disturbance_label) then - write(fates_log(),*) 'trying to fuse patches with different anthro_disturbance_label values' + if ( rp%land_use_label .ne. dp%land_use_label) then + write(fates_log(),*) 'trying to fuse patches with different land_use_label values' call endrun(msg=errMsg(sourcefile, __LINE__)) endif @@ -2505,8 +2773,9 @@ subroutine fuse_2_patches(csite, dp, rp) rp%zstar = (dp%zstar*dp%area + rp%zstar*rp%area) * inv_sum_area rp%c_stomata = (dp%c_stomata*dp%area + rp%c_stomata*rp%area) * inv_sum_area rp%c_lblayer = (dp%c_lblayer*dp%area + rp%c_lblayer*rp%area) * inv_sum_area - rp%radiation_error = (dp%radiation_error*dp%area + rp%radiation_error*rp%area) * inv_sum_area - + rp%rad_error(1) = (dp%rad_error(1)*dp%area + rp%rad_error(1)*rp%area) * inv_sum_area + rp%rad_error(2) = (dp%rad_error(2)*dp%area + rp%rad_error(2)*rp%area) * inv_sum_area + rp%area = rp%area + dp%area !THIS MUST COME AT THE END! !insert donor cohorts into recipient patch @@ -2625,16 +2894,19 @@ subroutine terminate_patches(currentSite) ! You should had fused integer :: count_cycles logical :: gotfused + logical :: current_patch_is_youngest_lutype real(r8) areatot ! variable for checking whether the total patch area is wrong. !--------------------------------------------------------------------- - + + ! Initialize the count cycles count_cycles = 0 + ! Start at the youngest patch in the list and assume that the largest patch is this patch currentPatch => currentSite%youngest_patch - do while(associated(currentPatch)) + do while(associated(currentPatch)) lessthan_min_patcharea_if: if(currentPatch%area <= min_patch_area)then - + nocomp_if: if (hlm_use_nocomp .eq. itrue) then gotfused = .false. @@ -2642,7 +2914,7 @@ subroutine terminate_patches(currentSite) do while(associated(patchpointer)) if ( .not.associated(currentPatch,patchpointer) .and. & patchpointer%nocomp_pft_label .eq. currentPatch%nocomp_pft_label .and. & - patchpointer%anthro_disturbance_label .eq. currentPatch%anthro_disturbance_label .and. & + patchpointer%land_use_label .eq. currentPatch%land_use_label .and. & .not. gotfused) then call fuse_2_patches(currentSite, patchpointer, currentPatch) @@ -2656,82 +2928,90 @@ subroutine terminate_patches(currentSite) if ( .not. gotfused ) then !! somehow didn't find a patch to fuse with. write(fates_log(),*) 'Warning. small nocomp patch wasnt able to find another patch to fuse with.', & - currentPatch%nocomp_pft_label, currentPatch%anthro_disturbance_label + currentPatch%nocomp_pft_label, currentPatch%land_use_label endif else nocomp_if - ! Even if the patch area is small, avoid fusing it into its neighbor - ! if it is the youngest of all patches. We do this in attempts to maintain - ! a discrete patch for very young patches - ! However, if the patch to be fused is excessivlely small, then fuse - ! at all costs. If it is not fused, it will make + ! Even if the patch area is small, avoid fusing it into its neighbor + ! if it is the youngest of all patches. We do this in attempts to maintain + ! a discrete patch for very young patches. + ! However, if the patch to be fused is excessively small, then fuse + ! at all costs. - notyoungest_if: if ( .not.associated(currentPatch,currentSite%youngest_patch) .or. & + notyoungest_if: if ( .not.associated(currentPatch,currentSite%youngest_patch) .or. & currentPatch%area <= min_patch_area_forced ) then - - gotfused = .false. - associated_older_if: if(associated(currentPatch%older) )then - - if(debug) & - write(fates_log(),*) 'fusing to older patch because this one is too small',& - currentPatch%area, & - currentPatch%older%area - - ! We set a pointer to this patch, because - ! it will be returned by the subroutine as de-referenced - - olderPatch => currentPatch%older - - distlabel_1_if: if (currentPatch%anthro_disturbance_label .eq. olderPatch%anthro_disturbance_label) then - - call fuse_2_patches(currentSite, olderPatch, currentPatch) - - ! The fusion process has updated the "older" pointer on currentPatch - ! for us. - - ! This logic checks to make sure that the younger patch is not the youngest - ! patch. As mentioned earlier, we try not to fuse it. - - gotfused = .true. - else distlabel_1_if !i.e. anthro labels of two patches are not the same - countcycles_if: if (count_cycles .gt. 0) then - ! if we're having an incredibly hard time fusing patches because of their differing anthropogenic disturbance labels, - ! since the size is so small, let's sweep the problem under the rug and change the tiny patch's label to that of its older sibling - ! and then allow them to fuse together. - currentPatch%anthro_disturbance_label = olderPatch%anthro_disturbance_label + gotfused = .false. + + associated_older_if: if(associated(currentPatch%older)) then + + if(debug) & + write(fates_log(),*) 'fusing to older patch because this one is too small',& + currentPatch%area, & + currentPatch%older%area + + ! We set a pointer to this patch, because + ! it will be returned by the subroutine as de-referenced + + olderPatch => currentPatch%older + + ! If the older patch has the same landuse label fuse the older (donor) patch into the current patch + distlabel_1_if: if (currentPatch%land_use_label .eq. olderPatch%land_use_label) then + + if(debug) & + write(fates_log(),*) 'terminate: fused to older patch, same label: ', currentPatch%land_use_label, olderPatch%land_use_label + call fuse_2_patches(currentSite, olderPatch, currentPatch) + + ! The fusion process has updated the "older" pointer on currentPatch + ! for us. + + ! This logic checks to make sure that the younger patch is not the youngest + ! patch. As mentioned earlier, we try not to fuse it. + gotfused = .true. - endif countcycles_if - endif distlabel_1_if - endif associated_older_if - - not_gotfused_if: if( .not. gotfused .and. associated(currentPatch%younger) ) then - - if(debug) & - write(fates_log(),*) 'fusing to younger patch because oldest one is too small', & - currentPatch%area + else distlabel_1_if !i.e. anthro labels of two patches are not the same + countcycles_if: if (count_cycles .gt. 0) then + ! if we're having an incredibly hard time fusing patches because of their differing anthropogenic disturbance labels, + ! since the size is so small, let's sweep the problem under the rug and change the tiny patch's label to that of its older sibling + ! and then allow them to fuse together. + currentPatch%land_use_label = olderPatch%land_use_label + currentPatch%age_since_anthro_disturbance = olderPatch%age_since_anthro_disturbance + call fuse_2_patches(currentSite, olderPatch, currentPatch) + gotfused = .true. + endif countcycles_if + endif distlabel_1_if + endif associated_older_if - youngerPatch => currentPatch%younger + not_gotfused_if: if( .not. gotfused .and. associated(currentPatch%younger) ) then + + if(debug) & + write(fates_log(),*) 'fusing to younger patch because oldest one is too small', & + currentPatch%area + + youngerPatch => currentPatch%younger + + distlabel_2_if: if (currentPatch%land_use_label .eq. youngerPatch%land_use_label) then - distlabel_2_if: if (currentPatch%anthro_disturbance_label .eq. youngerPatch% anthro_disturbance_label) then - - call fuse_2_patches(currentSite, youngerPatch, currentPatch) - - ! The fusion process has updated the "younger" pointer on currentPatch - - else distlabel_2_if - if (count_cycles .gt. 0) then - ! if we're having an incredibly hard time fusing patches because of their differing anthropogenic disturbance labels, - ! since the size is so small, let's sweep the problem under the rug and change the tiny patch's label to that of its younger sibling - currentPatch%anthro_disturbance_label = youngerPatch%anthro_disturbance_label call fuse_2_patches(currentSite, youngerPatch, currentPatch) + + ! The fusion process has updated the "younger" pointer on currentPatch + gotfused = .true. - endif ! count cycles - endif distlabel_2_if ! anthro labels - endif not_gotfused_if ! has an older patch - endif notyoungest_if ! is not the youngest patch + + else distlabel_2_if + if (count_cycles .gt. 0) then + ! if we're having an incredibly hard time fusing patches because of their differing anthropogenic disturbance labels, + ! since the size is so small, let's sweep the problem under the rug and change the tiny patch's label to that of its younger sibling + currentPatch%land_use_label = youngerPatch%land_use_label + currentPatch%age_since_anthro_disturbance = youngerPatch%age_since_anthro_disturbance + call fuse_2_patches(currentSite, youngerPatch, currentPatch) + gotfused = .true. + endif ! count cycles + endif distlabel_2_if ! anthro labels + endif not_gotfused_if ! has an older patch + endif notyoungest_if ! is not the youngest patch endif nocomp_if endif lessthan_min_patcharea_if ! very small patch @@ -2914,7 +3194,7 @@ subroutine get_frac_site_primary(site_in, frac_site_primary) frac_site_primary = 0._r8 currentPatch => site_in%oldest_patch do while (associated(currentPatch)) - if (currentPatch%anthro_disturbance_label .eq. primaryforest) then + if (currentPatch%land_use_label .eq. primaryland) then frac_site_primary = frac_site_primary + currentPatch%area * AREA_INV endif currentPatch => currentPatch%younger @@ -2922,4 +3202,170 @@ subroutine get_frac_site_primary(site_in, frac_site_primary) end subroutine get_frac_site_primary + ! ===================================================================================== + + subroutine InsertPatch(currentSite, newPatch) + + ! !DESCRIPTION: + ! Insert patch into linked list + ! + ! !USES: + ! + ! !ARGUMENTS: + type (ed_site_type), intent(inout) :: currentSite + type (fates_patch_type), intent(inout), pointer :: newPatch + + ! !LOCAL VARIABLES: + type (fates_patch_type), pointer :: currentPatch + integer :: insert_method ! Temporary dev + logical :: found_landuselabel_match + integer, parameter :: unordered_lul_groups= 1 + integer, parameter :: primaryland_oldest_group = 2 + integer, parameter :: numerical_order_lul_groups = 3 + integer, parameter :: age_order_only = 4 + + ! Insert new patch case options: + ! Option 1: Group the landuse types together, but the group order doesn't matter + ! Option 2: Option 1, but primarylands are forced to be the oldest group + ! Option 3: Option 1, but groups are in numerical order according to land use label index integer + ! (i.e. primarylands=1, secondarylands=2, ..., croplands=5) + ! Option 4: Don't group the patches by land use label. Simply add new patches to the youngest end. + + ! Hardcode the default insertion method. The options developed during FATES V1 land use are + ! currently being held for potential future usage. + insert_method = primaryland_oldest_group + + ! Start from the youngest patch and work to oldest, regarless of insertion_method + currentPatch => currentSite%youngest_patch + + ! For the three grouped cases, if the land use label of the youngest patch on the site + ! is a match to the new patch land use label, simply insert it as the new youngest. + ! This is applicable to the non-grouped option 4 method as well. + if (currentPatch%land_use_label .eq. newPatch%land_use_label ) then + newPatch%older => currentPatch + newPatch%younger => null() + currentPatch%younger => newPatch + currentSite%youngest_patch => newPatch + else + + ! If the current site youngest patch land use label doesn't match the new patch + ! land use label then work through the list until you find the matching type. + ! Since we've just checked the youngest patch, move to the next patch and + ! initialize the match flag to false. + found_landuselabel_match = .false. + currentPatch => currentPatch%older + select case(insert_method) + + ! Option 1 - order of land use label groups does not matter + case (unordered_lul_groups) + + do while(associated(currentPatch) .and. .not. found_landuselabel_match) + if (currentPatch%land_use_label .eq. newPatch%land_use_label) then + found_landuselabel_match = .true. + else + currentPatch => currentPatch%older + end if + end do + + ! In the case where we've found a land use label matching the new patch label, + ! insert the newPatch will as the youngest patch for that land use type. + if (associated(currentPatch)) then + newPatch%older => currentPatch + newPatch%younger => currentPatch%younger + currentPatch%younger%older => newPatch + currentPatch%younger => newPatch + else + ! In the case in which we get to the end of the list and haven't found + ! a landuse label match simply add the new patch to the youngest end. + newPatch%older => currentSite%youngest_patch + newPatch%younger => null() + currentSite%youngest_patch%younger => newPatch + currentSite%youngest_patch => newPatch + endif + + ! Option 2 - primaryland group must be on the oldest end + case (primaryland_oldest_group) + + do while(associated(currentPatch) .and. .not. found_landuselabel_match) + if (currentPatch%land_use_label .eq. newPatch%land_use_label) then + found_landuselabel_match = .true. + else + currentPatch => currentPatch%older + end if + end do + + ! In the case where we've found a land use label matching the new patch label, + ! insert the newPatch will as the youngest patch for that land use type. + if (associated(currentPatch)) then + newPatch%older => currentPatch + newPatch%younger => currentPatch%younger + currentPatch%younger%older => newPatch + currentPatch%younger => newPatch + else + ! In the case in which we get to the end of the list and haven't found + ! a landuse label match. + + ! If the new patch is primarylands add it to the oldest end of the list + if (newPatch%land_use_label .eq. primaryland) then + newPatch%older => null() + newPatch%younger => currentSite%oldest_patch + currentSite%oldest_patch%older => newPatch + currentSite%oldest_patch => newPatch + else + ! If the new patch land use type is not primaryland and we are at the + ! oldest end of the list, add it to the youngest end + newPatch%older => currentSite%youngest_patch + newPatch%younger => null() + currentSite%youngest_patch%younger => newPatch + currentSite%youngest_patch => newPatch + endif + endif + + ! Option 3 - groups are numerically ordered with primaryland group starting at oldest end. + case (numerical_order_lul_groups) + + ! If the youngest patch landuse label number is greater than the new + ! patch land use label number, the new patch must be inserted somewhere + ! in between oldest and youngest + do while(associated(currentPatch) .and. .not. found_landuselabel_match) + if (currentPatch%land_use_label .eq. newPatch%land_use_label .or. & + currentPatch%land_use_label .lt. newPatch%land_use_label) then + found_landuselabel_match = .true. + else + currentPatch => currentPatch%older + endif + end do + + ! In the case where we've found a landuse label matching the new patch label + ! insert the newPatch will as the youngest patch for that land use type. + if (associated(currentPatch)) then + + newPatch%older => currentPatch + newPatch%younger => currentPatch%younger + currentPatch%younger%older => newPatch + currentPatch%younger => newPatch + + else + + ! In the case were we get to the end, the new patch + ! must be numerically the smallest, so put it at the oldest position + newPatch%older => null() + newPatch%younger => currentSite%oldest_patch + currentSite%oldest_patch%older => newPatch + currentSite%oldest_patch => newPatch + + endif + + ! Option 4 - always add the new patch as the youngest regardless of land use label + case (age_order_only) + ! Set the current patch to the youngest patch + newPatch%older => currentSite%youngest_patch + newPatch%younger => null() + currentSite%youngest_patch%younger => newPatch + currentSite%youngest_patch => newPatch + end select + end if + + end subroutine InsertPatch + end module EDPatchDynamicsMod diff --git a/biogeochem/FatesAllometryMod.F90 b/biogeochem/FatesAllometryMod.F90 index 431219cfda..9cc8fbe4fd 100644 --- a/biogeochem/FatesAllometryMod.F90 +++ b/biogeochem/FatesAllometryMod.F90 @@ -92,12 +92,13 @@ module FatesAllometryMod use FatesConstantsMod, only : calloc_abs_error use FatesConstantsMod, only : fates_unset_r8 use FatesConstantsMod, only : itrue + 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 FatesGlobals , only : FatesWarn,N2S,A2S,I2S - use EDParamsMod , only : nlevleaf, dinc_vai - use EDParamsMod , only : nclmax + use EDParamsMod , only : nlevleaf,dinc_vai,dlower_vai + use EDParamsMod , only : nclmax use DamageMainMod , only : GetCrownReduction implicit none @@ -125,7 +126,8 @@ module FatesAllometryMod public :: set_root_fraction ! Generic wrapper to calculate normalized ! root profiles public :: leafc_from_treelai ! Calculate target leaf carbon for a given treelai for SP mode - + public :: VegAreaLayer + logical , parameter :: verbose_logging = .false. character(len=*), parameter :: sourcefile = __FILE__ @@ -2436,7 +2438,8 @@ real(r8) function decay_coeff_kn(pft,vcmax25top) end function decay_coeff_kn ! ===================================================================================== -subroutine ForceDBH( ipft, crowndamage, canopy_trim, elongf_leaf, elongf_stem, d, h, bdead, bl ) + + subroutine ForceDBH( ipft, crowndamage, canopy_trim, elongf_leaf, elongf_stem, d, h, bdead, bl ) ! ========================================================================= ! This subroutine estimates the diameter based on either the structural biomass @@ -2586,6 +2589,111 @@ subroutine ForceDBH( ipft, crowndamage, canopy_trim, elongf_leaf, elongf_stem, d return end subroutine ForceDBH + ! ========================================================================= + + subroutine VegAreaLayer(tree_lai,tree_sai,tree_height,iv,nv,pft,snow_depth, & + vai_top,vai_bot, elai_layer,esai_layer,tlai_layer,tsai_layer) + + ! ----------------------------------------------------------------------------------- + ! This routine returns the exposed leaf and stem areas (m2 of leaf and stem) per m2 of + ! ground inside the crown, for the leaf-layer specified. + ! ----------------------------------------------------------------------------------- + + real(r8),intent(in) :: tree_lai ! the in-crown leaf area index for the plant + ! [m2 leaf/m2 crown footprint] + real(r8),intent(in) :: tree_sai ! the in-crown stem area index for the plant + ! [m2 stem/m2 crown footprint] + real(r8),intent(in) :: tree_height ! the height of the plant [m] + integer,intent(in) :: iv ! vegetation layer index + integer,intent(in) :: nv ! this plants total number of veg layers + integer,intent(in) :: pft ! plant functional type index + real(r8),intent(in) :: snow_depth ! the depth of snow on the ground [m] + real(r8),intent(out) :: vai_top + real(r8),intent(out) :: vai_bot ! the VAI of the bin top and bottom + real(r8),intent(out) :: elai_layer ! exposed leaf area index of the layer + real(r8),intent(out) :: esai_layer ! exposed stem area index of the layer + real(r8),optional,intent(out) :: tlai_layer ! total leaf area index of the layer + real(r8),optional,intent(out) :: tsai_layer ! total stem area index of the layer + + ! [m2 of leaf in bin / m2 crown footprint] + real(r8) :: tree_vai ! the in-crown veg area index for the plant + real(r8) :: fraction_exposed ! fraction of the veg media that is above snow + real(r8) :: layer_top_height ! Physical height of the layer top relative to ground [m] + real(r8) :: layer_bot_height ! Physical height of the layer bottom relative to ground [m] + real(r8) :: tlai,tsai ! temporary total area indices [m2/m2] + real(r8) :: fleaf ! fraction of biomass in layer that is leaf + real(r8) :: remainder ! old-method: remainder of biomass in last bin + integer, parameter :: layer_height_const_depth = 1 ! constant physical depth assumption + integer, parameter :: layer_height_const_lad = 2 ! constant leaf area depth assumption + integer, parameter :: layer_height_method = layer_height_const_depth + + tree_vai = tree_lai + tree_sai + + if_any_vai: if(tree_vai>0._r8)then + + if(iv==0)then + vai_top = 0.0 + vai_bot = tree_vai + else + + if(iv>1)then + vai_top = dlower_vai(iv) - dinc_vai(iv) + else + vai_top = 0._r8 + end if + + if(iv fates_endrun + use FatesConstantsMod , only : r8 => fates_r8 + use FatesConstantsMod , only : itrue, ifalse + use FatesConstantsMod , only : fates_unset_int + use FatesConstantsMod , only : years_per_day + use FatesInterfaceTypesMod , only : bc_in_type + use FatesInterfaceTypesMod , only : hlm_use_luh + use FatesInterfaceTypesMod , only : hlm_num_luh2_states + use FatesInterfaceTypesMod , only : hlm_num_luh2_transitions + use FatesUtilsMod , only : FindIndex + use EDTypesMod , only : area_site => area + + ! CIME globals + use shr_log_mod , only : errMsg => shr_log_errMsg + + ! + implicit none + private + + character(len=*), parameter :: sourcefile = __FILE__ + + public :: get_landuse_transition_rates + public :: get_landusechange_rules + public :: get_luh_statedata + + + ! module data + integer, parameter :: max_luh2_types_per_fates_lu_type = 5 + + ! Define the mapping from the luh2 state names to the aggregated fates land use categories + type :: luh2_fates_lutype_map + + character(len=5), dimension(12) :: state_names = & + [character(len=5) :: 'primf','primn','secdf','secdn', & + 'pastr','range', 'urban', & + 'c3ann','c4ann','c3per','c4per','c3nfx'] + integer, dimension(12) :: landuse_categories = & + [primaryland, primaryland, secondaryland, secondaryland, & + pastureland, rangeland, fates_unset_int, & + cropland, cropland, cropland, cropland, cropland] + + contains + + procedure :: GetIndex => GetLUCategoryFromStateName + + end type luh2_fates_lutype_map + + + ! 03/10/2023 Created By Charlie Koven + ! ============================================================================ + +contains + + ! ============================================================================ + subroutine get_landuse_transition_rates(bc_in, landuse_transition_matrix) + + + ! The purpose of this routine is to ingest the land use transition rate information that the host model has read in from a dataset, + ! aggregate land use types to those being used in the simulation, and output a transition matrix that can be used to drive patch + ! disturbance rates. + + ! !ARGUMENTS: + type(bc_in_type) , intent(in) :: bc_in + real(r8), intent(inout) :: landuse_transition_matrix(n_landuse_cats, n_landuse_cats) ! [m2/m2/day] + + ! !LOCAL VARIABLES: + type(luh2_fates_lutype_map) :: lumap + integer :: i_donor, i_receiver, i_luh2_transitions, i_luh2_states, i_urban + character(5) :: donor_name, receiver_name + character(14) :: transition_name + real(r8) :: urban_fraction + real(r8) :: temp_vector(hlm_num_luh2_transitions) + logical :: modified_flag + + ! zero the transition matrix and the urban fraction + landuse_transition_matrix(:,:) = 0._r8 + urban_fraction = 0._r8 + + ! Check the LUH data incoming to see if any of the transitions are NaN + temp_vector = bc_in%hlm_luh_transitions + call CheckLUHData(temp_vector,modified_flag) + if (.not. modified_flag) then + ! identify urban fraction so that it can be factored into the land use state output + urban_fraction = bc_in%hlm_luh_states(FindIndex(bc_in%hlm_luh_state_names,'urban')) + end if + + !!TODO: may need some logic here to ask whether or not ot perform land use change on this timestep. current code occurs every day. + !!If not doing transition every day, need to update units. + + transitions_loop: do i_luh2_transitions = 1, hlm_num_luh2_transitions + + ! transition names are written in form xxxxx_to_yyyyy where x and y are donor and receiver state names + transition_name = bc_in%hlm_luh_transition_names(i_luh2_transitions) + donor_name = transition_name(1:5) + receiver_name = transition_name(10:14) + + ! Get the fates land use type index associated with the luh2 state types + i_donor= lumap%GetIndex(donor_name) + i_receiver = lumap%GetIndex(receiver_name) + + ! Avoid transitions with 'urban' as those are handled seperately + if (.not.(i_donor .eq. fates_unset_int .or. i_receiver .eq. fates_unset_int)) then + landuse_transition_matrix(i_donor,i_receiver) = & + landuse_transition_matrix(i_donor,i_receiver) + temp_vector(i_luh2_transitions) * years_per_day / (1._r8 - urban_fraction) + + end if + end do transitions_loop + + end subroutine get_landuse_transition_rates + + !---------------------------------------------------------------------------------------------------- + + function GetLUCategoryFromStateName(this, state_name) result(landuse_category) + + class(luh2_fates_lutype_map) :: this + character(len=5), intent(in) :: state_name + integer :: landuse_category + integer :: index_statename + + index_statename = FindIndex(this%state_names,state_name) + + ! Check that the result from the landuse_categories is not zero, which indicates that no + ! match was found. + if (index_statename .eq. 0) then + write(fates_log(),*) 'The input state name from the HLM does not match the FATES landuse state name options' + write(fates_log(),*) 'input state name: ', state_name + write(fates_log(),*) 'state name options: ', this%state_names + call endrun(msg=errMsg(sourcefile, __LINE__)) + else + landuse_category = this%landuse_categories(index_statename) + end if + + end function GetLUCategoryFromStateName + + !---------------------------------------------------------------------------------------------------- + + subroutine get_landusechange_rules(clearing_matrix) + + ! the purpose of this is to define a ruleset for when to clear the vegetation in transitioning from one land use type to another + + logical, intent(out) :: clearing_matrix(n_landuse_cats,n_landuse_cats) + + ! default value of ruleset 4 above means that plants are not cleared during land use change transitions to rangeland, whereas plants are + ! cleared in transitions to pasturelands and croplands. + integer, parameter :: ruleset = 4 ! ruleset to apply from table 1 of Ma et al (2020) https://doi.org/10.5194/gmd-13-3203-2020 + + ! clearing matrix applies from the donor to the receiver land use type of the newly-transferred patch area + ! values of clearing matrix: false => do not clear; true => clear + + clearing_matrix(:,:) = .false. + + select case(ruleset) + + case(1) + + ! note that this ruleset isnt exactly what is in Ma et al. rulesets 1 and 2, because FATES does not make the distinction + ! between forested and non-forested lands from a land use/land cover perspective. + clearing_matrix(:,cropland) = .true. + clearing_matrix(:,pastureland) = .true. + clearing_matrix(primaryland,rangeland) = .true. + clearing_matrix(secondaryland,rangeland) = .true. + + case(2) + + ! see comment on number 1 above + clearing_matrix(:,cropland) = .true. + clearing_matrix(primaryland,pastureland) = .true. + clearing_matrix(secondaryland,pastureland) = .true. + clearing_matrix(primaryland,rangeland) = .true. + clearing_matrix(secondaryland,rangeland) = .true. + + case(3) + + clearing_matrix(:,cropland) = .true. + clearing_matrix(:,pastureland) = .true. + clearing_matrix(:,rangeland) = .true. + + case(4) + + clearing_matrix(:,cropland) = .true. + clearing_matrix(:,pastureland) = .true. + clearing_matrix(:,rangeland) = .false. + + case(5) + + clearing_matrix(:,cropland) = .true. + clearing_matrix(:,pastureland) = .false. + clearing_matrix(:,rangeland) = .true. + + case(6) + + clearing_matrix(:,cropland) = .true. + clearing_matrix(:,pastureland) = .false. + clearing_matrix(:,rangeland) = .false. + + case(7) + + clearing_matrix(:,cropland) = .false. + clearing_matrix(:,pastureland) = .true. + clearing_matrix(:,rangeland) = .true. + + case(8) + + clearing_matrix(:,cropland) = .false. + clearing_matrix(:,pastureland) = .true. + clearing_matrix(:,rangeland) = .false. + + case(9) + + clearing_matrix(:,cropland) = .false. + clearing_matrix(:,pastureland) = .false. + clearing_matrix(:,rangeland) = .true. + + case default + + write(fates_log(),*) 'unknown clearing ruleset?' + write(fates_log(),*) 'ruleset: ', ruleset + call endrun(msg=errMsg(sourcefile, __LINE__)) + + end select + + end subroutine get_landusechange_rules + + !---------------------------------------------------------------------------------------------------- + + subroutine get_luh_statedata(bc_in, state_vector) + + type(bc_in_type) , intent(in) :: bc_in + real(r8), intent(out) :: state_vector(n_landuse_cats) ! [m2/m2] + + ! LOCALS + type(luh2_fates_lutype_map) :: lumap + real(r8) :: temp_vector(hlm_num_luh2_states) ! [m2/m2] + real(r8) :: urban_fraction + integer :: i_luh2_states + integer :: ii + character(5) :: state_name + logical :: modified_flag + + ! zero state vector and urban fraction + state_vector(:) = 0._r8 + urban_fraction = 0._r8 + + ! Check to see if the incoming state vector is NaN. + temp_vector = bc_in%hlm_luh_states + call CheckLUHData(temp_vector,modified_flag) + if (.not. modified_flag) then + ! identify urban fraction so that it can be factored into the land use state output + urban_fraction = bc_in%hlm_luh_states(FindIndex(bc_in%hlm_luh_state_names,'urban')) + end if + + ! loop over all states and add up the ones that correspond to a given fates land use type + do i_luh2_states = 1, hlm_num_luh2_states + + ! Get the luh2 state name and determine fates aggregated land use + ! type index from the state to lutype map + state_name = bc_in%hlm_luh_state_names(i_luh2_states) + ii = lumap%GetIndex(state_name) + + ! Avoid 'urban' states whose indices have been given unset values + if (ii .ne. fates_unset_int) then + state_vector(ii) = state_vector(ii) + & + temp_vector(i_luh2_states) / (1._r8 - urban_fraction) + end if + end do + + ! check to ensure total area == 1, and correct if not + if ( abs(sum(state_vector(:)) - 1._r8) .gt. nearzero ) then + write(fates_log(),*) 'warning: sum(state_vector) = ', sum(state_vector(:)) + state_vector = state_vector / sum(state_vector) + end if + + end subroutine get_luh_statedata + + !---------------------------------------------------------------------------------------------------- + + subroutine CheckLUHData(luh_vector,modified_flag) + + use shr_infnan_mod , only : isnan => shr_infnan_isnan + + real(r8), intent(inout) :: luh_vector(:) ! [m2/m2] + logical, intent(out) :: modified_flag + + ! Check to see if the incoming luh2 vector is NaN. + ! This suggests that there is a discepency where the HLM and LUH2 states + ! there is vegetated ground. E.g. LUH2 data is missing for glacier-margin regions such as Antarctica. + ! In this case, states should be Nan. If so, + ! set the current state to be all primary forest, and all transitions to be zero. + ! If only a portion of the vector is NaN, there is something amiss with + ! the data, so end the run. + + modified_flag = .false. + if (all(isnan(luh_vector))) then + luh_vector(:) = 0._r8 + ! Check if this is a state vector, otherwise leave transitions as zero + if (size(luh_vector) .eq. hlm_num_luh2_states) then + luh_vector(primaryland) = 1._r8 + end if + modified_flag = .true. + !write(fates_log(),*) 'WARNING: land use state is all NaN; setting state as all primary forest.' ! GL DIAG + else if (any(isnan(luh_vector))) then + if (any(.not. isnan(luh_vector))) then + write(fates_log(),*) 'ERROR: land use vector has NaN' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + end subroutine CheckLUHData + +end module FatesLandUseChangeMod diff --git a/biogeochem/FatesLitterMod.F90 b/biogeochem/FatesLitterMod.F90 index e16cce69db..7d55dc9aab 100644 --- a/biogeochem/FatesLitterMod.F90 +++ b/biogeochem/FatesLitterMod.F90 @@ -447,7 +447,7 @@ subroutine adjust_SF_CWD_frac(dbh,ncwd,SF_val_CWD_frac,SF_val_CWD_frac_adj) !ARGUMENTS real(r8), intent(in) :: dbh !dbh of cohort [cm] - type(integer), intent(in) :: ncwd !number of cwd pools + integer, intent(in) :: ncwd !number of cwd pools real(r8), intent(in) :: SF_val_CWD_frac(:) !fates parameter specifying the !fraction of struct + sapw going !to each CWD class diff --git a/biogeochem/FatesPatchMod.F90 b/biogeochem/FatesPatchMod.F90 index 8a38366217..d86e5c5d51 100644 --- a/biogeochem/FatesPatchMod.F90 +++ b/biogeochem/FatesPatchMod.F90 @@ -3,7 +3,8 @@ module FatesPatchMod use FatesConstantsMod, only : r8 => fates_r8 use FatesConstantsMod, only : fates_unset_r8 use FatesConstantsMod, only : fates_unset_int - use FatesConstantsMod, only : primaryforest, secondaryforest + use FatesConstantsMod, only : primaryland, secondaryland + use FatesConstantsMod, only : n_landuse_cats use FatesConstantsMod, only : TRS_regeneration use FatesGlobals, only : fates_log use FatesGlobals, only : endrun => fates_endrun @@ -15,14 +16,16 @@ module FatesPatchMod use FatesLitterMod, only : litter_type use PRTGenericMod, only : num_elements use PRTGenericMod, only : element_list - use EDParamsMod, only : maxSWb, nlevleaf, nclmax, maxpft + use EDParamsMod, only : nlevleaf, nclmax, maxpft use FatesConstantsMod, only : n_dbh_bins, n_dist_types - use FatesConstantsMod, only : n_rad_stream_types use FatesConstantsMod, only : t_water_freeze_k_1atm use FatesRunningMeanMod, only : ema_24hr, fixed_24hr, ema_lpa, ema_longterm use FatesRunningMeanMod, only : ema_sdlng_emerg_h2o, ema_sdlng_mort_par use FatesRunningMeanMod, only : ema_sdlng2sap_par, ema_sdlng_mdd - + use TwoStreamMLPEMod, only : twostream_type + use FatesRadiationMemMod,only : num_swb + use FatesRadiationMemMod,only : num_rad_stream_types + use FatesInterfaceTypesMod,only : hlm_hio_ignore_val use shr_infnan_mod, only : nan => shr_infnan_nan, assignment(=) use shr_log_mod, only : errMsg => shr_log_errMsg @@ -59,7 +62,7 @@ module FatesPatchMod real(r8) :: area ! patch area [m2] integer :: countcohorts ! number of cohorts in patch integer :: ncl_p ! number of occupied canopy layers - integer :: anthro_disturbance_label ! patch label for anthropogenic disturbance classification + integer :: land_use_label ! patch label for land use classification (primaryland, secondaryland, etc) real(r8) :: age_since_anthro_disturbance ! average age for secondary forest since last anthropogenic disturbance [years] !--------------------------------------------------------------------------- @@ -110,24 +113,21 @@ module FatesPatchMod real(r8) :: c_stomata ! mean stomatal conductance of all leaves in the patch [umol/m2/s] real(r8) :: c_lblayer ! mean boundary layer conductance of all leaves in the patch [umol/m2/s] - !TODO - can we delete these? - real(r8) :: layer_height_profile(nclmax,maxpft,nlevleaf) real(r8) :: psn_z(nclmax,maxpft,nlevleaf) - real(r8) :: nrmlzd_parprof_pft_dir_z(n_rad_stream_types,nclmax,maxpft,nlevleaf) - real(r8) :: nrmlzd_parprof_pft_dif_z(n_rad_stream_types,nclmax,maxpft,nlevleaf) - real(r8) :: nrmlzd_parprof_dir_z(n_rad_stream_types,nclmax,nlevleaf) - real(r8) :: nrmlzd_parprof_dif_z(n_rad_stream_types,nclmax,nlevleaf) + real(r8) :: nrmlzd_parprof_pft_dir_z(num_rad_stream_types,nclmax,maxpft,nlevleaf) + real(r8) :: nrmlzd_parprof_pft_dif_z(num_rad_stream_types,nclmax,maxpft,nlevleaf) !--------------------------------------------------------------------------- ! RADIATION - real(r8) :: radiation_error ! radiation error [W/m2] + real(r8) :: rad_error(num_swb) ! radiation consv error by band [W/m2] real(r8) :: fcansno ! fraction of canopy covered in snow [0-1] logical :: solar_zenith_flag ! integer flag specifying daylight (based on zenith angle) real(r8) :: solar_zenith_angle ! solar zenith angle [radians] - real(r8) :: gnd_alb_dif(maxSWb) ! ground albedo for diffuse rad, both bands [0-1] - real(r8) :: gnd_alb_dir(maxSWb) ! ground albedo for direct rad, both bands [0-1] - + real(r8) :: gnd_alb_dif(num_swb) ! ground albedo for diffuse rad, both bands [0-1] + real(r8) :: gnd_alb_dir(num_swb) ! ground albedo for direct rad, both bands [0-1] + + ! organized by canopy layer, pft, and leaf layer real(r8) :: fabd_sun_z(nclmax,maxpft,nlevleaf) ! sun fraction of direct light absorbed [0-1] real(r8) :: fabd_sha_z(nclmax,maxpft,nlevleaf) ! shade fraction of direct light absorbed [0-1] @@ -135,15 +135,14 @@ module FatesPatchMod real(r8) :: fabi_sha_z(nclmax,maxpft,nlevleaf) ! shade fraction of indirect light absorbed [0-1] real(r8) :: ed_parsun_z(nclmax,maxpft,nlevleaf) ! PAR absorbed in the sun [W/m2] real(r8) :: ed_parsha_z(nclmax,maxpft,nlevleaf) ! PAR absorbed in the shade [W/m2] + real(r8) :: f_sun(nclmax,maxpft,nlevleaf) ! fraction of leaves in the sun [0-1] real(r8) :: ed_laisun_z(nclmax,maxpft,nlevleaf) real(r8) :: ed_laisha_z(nclmax,maxpft,nlevleaf) - real(r8) :: f_sun(nclmax,maxpft,nlevleaf) ! fraction of leaves in the sun [0-1] + ! radiation profiles for comparison against observations real(r8) :: parprof_pft_dir_z(nclmax,maxpft,nlevleaf) ! direct-beam PAR profile through canopy, by canopy, PFT, leaf level [W/m2] real(r8) :: parprof_pft_dif_z(nclmax,maxpft,nlevleaf) ! diffuse PAR profile through canopy, by canopy, PFT, leaf level [W/m2] - real(r8) :: parprof_dir_z(nclmax,nlevleaf) ! direct-beam PAR profile through canopy, by canopy, leaf level [W/m2] - real(r8) :: parprof_dif_z(nclmax,nlevleaf) ! diffuse PAR profile through canopy, by canopy, leaf level [W/m2] real(r8), allocatable :: tr_soil_dir(:) ! fraction of incoming direct radiation transmitted to the soil as direct, by numSWB [0-1] real(r8), allocatable :: tr_soil_dif(:) ! fraction of incoming diffuse radiation that is transmitted to the soil as diffuse [0-1] @@ -154,6 +153,10 @@ module FatesPatchMod real(r8), allocatable :: sabs_dir(:) ! fraction of incoming direct radiation that is absorbed by the canopy real(r8), allocatable :: sabs_dif(:) ! fraction of incoming diffuse radiation that is absorbed by the canopy + ! Twostream data structures + type(twostream_type) :: twostr ! This holds all two-stream data and procedures + + !--------------------------------------------------------------------------- ! ROOTS @@ -169,10 +172,12 @@ module FatesPatchMod !--------------------------------------------------------------------------- ! DISTURBANCE - real(r8) :: disturbance_rates(n_dist_types) ! disturbance rate [0-1/day] from 1) mortality - ! 2) fire - ! 3) logging mortatliy - real(r8) :: fract_ldist_not_harvested ! fraction of logged area that is canopy trees that weren't harvested [0-1] + real(r8) :: disturbance_rates(n_dist_types) ! disturbance rate [0-1/day] from 1) mortality + ! 2) fire + ! 3) logging mortatliy + ! 4) land use change + real(r8) :: landuse_transition_rates(n_landuse_cats) ! land use tranision rate + real(r8) :: fract_ldist_not_harvested ! fraction of logged area that is canopy trees that weren't harvested [0-1] !--------------------------------------------------------------------------- @@ -296,7 +301,7 @@ subroutine NanValues(this) this%area = nan this%countcohorts = fates_unset_int this%ncl_p = fates_unset_int - this%anthro_disturbance_label = fates_unset_int + this%land_use_label = fates_unset_int this%age_since_anthro_disturbance = nan ! LEAF ORGANIZATION @@ -315,16 +320,13 @@ subroutine NanValues(this) this%ncan(:,:) = fates_unset_int this%c_stomata = nan this%c_lblayer = nan - this%layer_height_profile(:,:,:) = nan this%psn_z(:,:,:) = nan this%nrmlzd_parprof_pft_dir_z(:,:,:,:) = nan this%nrmlzd_parprof_pft_dif_z(:,:,:,:) = nan - this%nrmlzd_parprof_dir_z(:,:,:) = nan - this%nrmlzd_parprof_dir_z(:,:,:) = nan ! RADIATION - this%radiation_error = nan + this%rad_error(:) = nan this%fcansno = nan this%solar_zenith_flag = .false. this%solar_zenith_angle = nan @@ -333,7 +335,7 @@ subroutine NanValues(this) this%fabd_sun_z(:,:,:) = nan this%fabd_sha_z(:,:,:) = nan this%fabi_sun_z(:,:,:) = nan - this%fabi_sha_z(:,:,:) = nan + this%fabi_sha_z(:,:,:) = nan this%ed_laisun_z(:,:,:) = nan this%ed_laisha_z(:,:,:) = nan this%ed_parsun_z(:,:,:) = nan @@ -341,8 +343,6 @@ subroutine NanValues(this) this%f_sun(:,:,:) = nan this%parprof_pft_dir_z(:,:,:) = nan this%parprof_pft_dif_z(:,:,:) = nan - this%parprof_dir_z(:,:) = nan - this%parprof_dif_z(:,:) = nan this%tr_soil_dir(:) = nan this%tr_soil_dif(:) = nan this%tr_soil_dir_dif(:) = nan @@ -362,7 +362,10 @@ subroutine NanValues(this) ! DISTURBANCE this%disturbance_rates(:) = nan - this%fract_ldist_not_harvested = nan + this%fract_ldist_not_harvested = nan + + ! LAND USE + this%landuse_transition_rates(:) = nan ! LITTER AND COARSE WOODY DEBRIS this%fragmentation_scaler(:) = nan @@ -386,8 +389,8 @@ subroutine NanValues(this) this%scorch_ht(:) = nan this%frac_burnt = nan this%tfc_ros = nan - this%burnt_frac_litter(:) = nan - + this%burnt_frac_litter(:) = nan + end subroutine NanValues !=========================================================================== @@ -412,19 +415,17 @@ subroutine ZeroValues(this) this%psn_z(:,:,:) = 0.0_r8 this%nrmlzd_parprof_pft_dir_z(:,:,:,:) = 0.0_r8 this%nrmlzd_parprof_pft_dif_z(:,:,:,:) = 0.0_r8 - this%nrmlzd_parprof_dir_z(:,:,:) = 0.0_r8 - this%nrmlzd_parprof_dif_z(:,:,:) = 0.0_r8 ! RADIATION - this%radiation_error = 0.0_r8 + this%rad_error(:) = 0.0_r8 this%fabd_sun_z(:,:,:) = 0.0_r8 this%fabd_sha_z(:,:,:) = 0.0_r8 this%fabi_sun_z(:,:,:) = 0.0_r8 this%fabi_sha_z(:,:,:) = 0.0_r8 this%ed_parsun_z(:,:,:) = 0.0_r8 - this%ed_parsha_z(:,:,:) = 0.0_r8 - this%ed_laisun_z(:,:,:) = 0.0_r8 - this%ed_laisha_z(:,:,:) = 0.0_r8 + this%ed_parsha_z(:,:,:) = 0.0_r8 + this%ed_laisun_z(:,:,:) = 0._r8 + this%ed_laisha_z(:,:,:) = 0._r8 this%f_sun = 0.0_r8 this%tr_soil_dir_dif(:) = 0.0_r8 this%fab(:) = 0.0_r8 @@ -440,6 +441,9 @@ subroutine ZeroValues(this) this%disturbance_rates(:) = 0.0_r8 this%fract_ldist_not_harvested = 0.0_r8 + ! LAND USE + this%landuse_transition_rates(:) = 0.0_r8 + ! LITTER AND COARSE WOODY DEBRIS this%fragmentation_scaler(:) = 0.0_r8 @@ -582,15 +586,19 @@ subroutine Create(this, age, area, label, nocomp_pft, num_swb, num_pft, & ! initialize litter call this%InitLitter(num_pft, num_levsoil) - + + this%twostr%scelg => null() ! The radiation module will check if this + ! is associated, since it is not, it will then + ! initialize and allocate + ! assign known patch attributes this%age = age this%age_class = 1 this%area = area ! assign anthropgenic disturbance category and label - this%anthro_disturbance_label = label - if (label .eq. secondaryforest) then + this%land_use_label = label + if (label .eq. secondaryland) then this%age_since_anthro_disturbance = age else this%age_since_anthro_disturbance = fates_unset_r8 @@ -637,7 +645,12 @@ subroutine FreeMemory(this, regeneration_model, numpft) endif ccohort => ncohort end do - + + ! Deallocate Radiation scattering elements + if(associated(this%twostr%scelg)) then + call this%twostr%DeallocTwoStream() + end if + ! deallocate all litter objects do el=1,num_elements call this%litter(el)%DeallocateLitt() @@ -732,7 +745,7 @@ subroutine Dump(this) write(fates_log(),*) 'pa%c_stomata = ',this%c_stomata write(fates_log(),*) 'pa%c_lblayer = ',this%c_lblayer write(fates_log(),*) 'pa%disturbance_rates = ',this%disturbance_rates(:) - write(fates_log(),*) 'pa%anthro_disturbance_label = ',this%anthro_disturbance_label + write(fates_log(),*) 'pa%land_use_label = ',this%land_use_label write(fates_log(),*) '----------------------------------------' do el = 1, num_elements @@ -806,4 +819,4 @@ end subroutine CheckVars !=========================================================================== -end module FatesPatchMod \ No newline at end of file +end module FatesPatchMod diff --git a/biogeophys/EDBtranMod.F90 b/biogeophys/EDBtranMod.F90 index a785493d54..3e2401a033 100644 --- a/biogeophys/EDBtranMod.F90 +++ b/biogeophys/EDBtranMod.F90 @@ -12,6 +12,7 @@ module EDBtranMod use EDTypesMod , only : ed_site_type use FatesPatchMod, only : fates_patch_type use EDParamsMod, only : maxpft + use EDParamsMod, only : soil_tfrz_thresh use FatesCohortMod, only : fates_cohort_type use shr_kind_mod , only : r8 => shr_kind_r8 use FatesInterfaceTypesMod , only : bc_in_type, & @@ -48,7 +49,7 @@ logical function check_layer_water(h2o_liq_vol, tempk) check_layer_water = .false. if ( h2o_liq_vol .gt. 0._r8 ) then - if ( tempk .gt. tfrz-2._r8) then + if ( tempk .gt. soil_tfrz_thresh + tfrz) then check_layer_water = .true. end if end if diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index 9ed3d7dd6f..744e43ec16 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -66,7 +66,12 @@ module FATESPlantRespPhotosynthMod use PRTParametersMod, only : prt_params use EDPftvarcon , only : EDPftvarcon_inst use TemperatureType, only : temperature_type - + use FatesRadiationMemMod, only : norman_solver,twostr_solver + use EDParamsMod, only : radiation_model + use FatesRadiationMemMod, only : ipar + use FatesTwoStreamUtilsMod, only : FatesGetCohortAbsRad + use FatesAllometryMod , only : VegAreaLayer + ! CIME Globals use shr_log_mod , only : errMsg => shr_log_errMsg @@ -78,9 +83,9 @@ module FATESPlantRespPhotosynthMod character(len=*), parameter, private :: sourcefile = & __FILE__ - + character(len=1024) :: warn_msg ! for defining a warning message - + !------------------------------------------------------------------------------------- ! maximum stomatal resistance [s/m] (used across several procedures) @@ -103,14 +108,15 @@ module FATESPlantRespPhotosynthMod ! Constants used to define conductance models integer, parameter :: medlyn_model = 2 integer, parameter :: ballberry_model = 1 - + ! Alternatively, Gross Assimilation can be used to estimate ! leaf co2 partial pressure and therefore conductance. The default ! is to use anet integer, parameter :: net_assim_model = 1 integer, parameter :: gross_assim_model = 2 - - + + logical, parameter :: preserve_b4b = .true. + contains !-------------------------------------------------------------------------------------- @@ -144,7 +150,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) use DamageMainMod, only : GetCrownReduction use FatesInterfaceTypesMod, only : hlm_use_tree_damage - + ! ARGUMENTS: ! ----------------------------------------------------------------------------------- integer,intent(in) :: nsites @@ -210,7 +216,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) real(r8) :: tcsoi ! Temperature response function for root respiration. real(r8) :: tcwood ! Temperature response function for wood - real(r8) :: elai ! exposed LAI (patch scale) + real(r8) :: patch_la ! exposed leaf area (patch scale) real(r8) :: live_stem_n ! Live stem (above-ground sapwood) ! nitrogen content (kgN/plant) real(r8) :: live_croot_n ! Live coarse root (below-ground sapwood) @@ -232,15 +238,14 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) real(r8) :: maintresp_reduction_factor ! factor by which to reduce maintenance - ! respiration when storage pools are low + ! respiration when storage pools are low real(r8) :: b_leaf ! leaf biomass kgC real(r8) :: frac ! storage pool as a fraction of target leaf biomass - real(r8) :: check_elai ! This is a check on the effective LAI that is calculated ! over each cohort x layer. real(r8) :: cohort_eleaf_area ! This is the effective leaf area [m2] reported by each cohort real(r8) :: lnc_top ! Leaf nitrogen content per unit area at canopy top [gN/m2] real(r8) :: lmr25top ! canopy top leaf maint resp rate at 25C - ! for this plant or pft (umol CO2/m**2/s) + ! for this plant or pft (umol CO2/m**2/s) real(r8) :: leaf_inc ! LAI-only portion of the vegetation increment of dinc_vai real(r8) :: lai_canopy_above ! the LAI in the canopy layers above the layer of interest real(r8) :: lai_layers_above ! the LAI in the leaf layers, within the current canopy, @@ -264,7 +269,20 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) real(r8) :: sapw_n_bgw ! nitrogen in belowground portion of sapwood real(r8) :: sapw_n_agw ! nitrogen in aboveground portion of sapwood real(r8) :: sapw_n_undamaged ! nitrogen in sapwood of undamaged tree - + real(r8) :: rd_abs_leaf, rb_abs_leaf, r_abs_stem, r_abs_snow, rb_abs, rd_abs + real(r8) :: fsun + real(r8) :: par_per_sunla, par_per_shala ! PAR per sunlit and shaded leaf area [W/m2 leaf] + real(r8),dimension(75) :: cohort_vaitop + real(r8),dimension(75) :: cohort_vaibot + real(r8),dimension(75) :: cohort_layer_elai + real(r8),dimension(75) :: cohort_layer_esai + real(r8),dimension(75) :: cohort_layer_tlai + real(r8),dimension(75) :: cohort_layer_tsai + real(r8) :: cohort_elai + real(r8) :: cohort_esai + real(r8) :: laisun,laisha + real(r8) :: canopy_area + real(r8) :: elai ! ----------------------------------------------------------------------------------- ! Keeping these two definitions in case they need to be added later ! @@ -288,8 +306,8 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! Photosynthesis and stomatal conductance parameters, from: ! Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 ! ----------------------------------------------------------------------------------- - - + + associate( & c3psn => EDPftvarcon_inst%c3psn , & @@ -299,725 +317,851 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) stomatal_intercept => EDPftvarcon_inst%stomatal_intercept ) !Unstressed minimum stomatal conductance - do s = 1,nsites + do s = 1,nsites + + ! Multi-layer parameters scaled by leaf nitrogen profile. + ! Loop through each canopy layer to calculate nitrogen profile using + ! cumulative lai at the midpoint of the layer + + + + ! Pre-process some variables that are PFT dependent + ! but not environmentally dependent + ! ------------------------------------------------------------------------ + + allocate(rootfr_ft(numpft, bc_in(s)%nlevsoil)) + + do ft = 1,numpft + call set_root_fraction(rootfr_ft(ft,:), ft, & + bc_in(s)%zi_sisl, & + bc_in(s)%max_rooting_depth_index_col) + end do + + + ifp = 0 + currentpatch => sites(s)%oldest_patch + do while (associated(currentpatch)) + if_notbare: if(currentpatch%nocomp_pft_label.ne.nocomp_bareground)then + ifp = ifp+1 + NCL_p = currentPatch%NCL_p + + ! Part I. Zero output boundary conditions + ! --------------------------------------------------------------------------- + bc_out(s)%rssun_pa(ifp) = 0._r8 + bc_out(s)%rssha_pa(ifp) = 0._r8 + + g_sb_leaves = 0._r8 + patch_la = 0._r8 + + ! Part II. Filter out patches + ! Patch level filter flag for photosynthesis calculations + ! has a short memory, flags: + ! 1 = patch has not been called + ! 2 = patch is currently marked for photosynthesis + ! 3 = patch has been called for photosynthesis already + ! --------------------------------------------------------------------------- + if_filter2: if(bc_in(s)%filter_photo_pa(ifp)==2)then + + + ! Part III. Calculate the number of sublayers for each pft and layer. + ! And then identify which layer/pft combinations have things in them. + ! Output: + ! currentPatch%ncan(:,:) + ! currentPatch%canopy_mask(:,:) + call UpdateCanopyNCanNRadPresent(currentPatch) + + + ! Part IV. Identify some environmentally derived parameters: + ! These quantities are biologically irrelevant + ! Michaelis-Menten constant for CO2 (Pa) + ! Michaelis-Menten constant for O2 (Pa) + ! CO2 compensation point (Pa) + ! leaf boundary layer conductance of h20 + ! constrained vapor pressure + + call GetCanopyGasParameters(bc_in(s)%forc_pbot, & ! in + bc_in(s)%oair_pa(ifp), & ! in + bc_in(s)%t_veg_pa(ifp), & ! in + bc_in(s)%tgcm_pa(ifp), & ! in + bc_in(s)%eair_pa(ifp), & ! in + bc_in(s)%esat_tv_pa(ifp), & ! in + bc_in(s)%rb_pa(ifp), & ! in + mm_kco2, & ! out + mm_ko2, & ! out + co2_cpoint, & ! out + cf, & ! out + gb_mol, & ! out + ceair) ! out + + ! ------------------------------------------------------------------------ + ! Part VI: Loop over all leaf layers. + ! The concept of leaf layers is a result of the radiative transfer scheme. + ! A leaf layer has uniform radiation environment. Leaf layers are a group + ! of vegetation surfaces (stems and leaves) which inhabit the same + ! canopy-layer "CL", have the same functional type "ft" and within those + ! two partitions are further partitioned into vertical layers where + ! downwelling radiation attenuates in order. + ! In this phase we loop over the leaf layers and calculate the + ! photosynthesis and respiration of the layer (since all biophysical + ! properties are homogeneous). After this step, we can loop through + ! our cohort list, associate each cohort with its list of leaf-layers + ! and transfer these quantities to the cohort. + ! With plant hydraulics, we must realize that photosynthesis and + ! respiration will be different for leaves of each cohort in the leaf + ! layers, as they will have there own hydraulic limitations. + ! NOTE: Only need to flush mask on the number of used pfts, not the whole + ! scratch space. + ! ------------------------------------------------------------------------ + rate_mask_z(:,1:numpft,:) = .false. + + if_any_cohorts: if(currentPatch%countcohorts > 0.0)then + currentCohort => currentPatch%tallest + do_cohort_drive: do while (associated(currentCohort)) ! Cohort loop + + ! Identify the canopy layer (cl), functional type (ft) + ! and the leaf layer (IV) for this cohort + ft = currentCohort%pft + cl = currentCohort%canopy_layer + + ! Calculate the cohort specific elai profile + ! And the top and bottom edges of the veg area index + ! of each layer bin are. Note, if the layers + ! sink below the ground snow line, then the effective + ! LAI and SAI start to shrink to zero, as well as + ! the difference between vaitop and vaibot. + if(currentCohort%treesai>0._r8)then + do iv = 1,currentCohort%nv + call VegAreaLayer(currentCohort%treelai, & + currentCohort%treesai, & + currentCohort%height, & + iv, & + currentCohort%nv, & + currentCohort%pft, & + sites(s)%snow_depth, & + cohort_vaitop(iv), & + cohort_vaibot(iv), & + cohort_layer_elai(iv), & + cohort_layer_esai(iv)) + end do + + cohort_elai = sum(cohort_layer_elai(1:currentCohort%nv)) + cohort_esai = sum(cohort_layer_esai(1:currentCohort%nv)) + + + else + cohort_layer_elai(:) = 0._r8 + cohort_layer_esai(:) = 0._r8 + cohort_vaitop(:) = 0._r8 + cohort_vaibot(:) = 0._r8 + cohort_elai = 0._r8 + cohort_esai = 0._r8 + end if + + ! MLO. Assuming target to be related to leaf biomass when leaves are fully + ! flushed. But unsure whether this call is correct or not, shouldn't we get + ! the target value directly from the bstore_allom? + call bleaf(currentCohort%dbh,currentCohort%pft,& + currentCohort%crowndamage,currentCohort%canopy_trim,1.0_r8,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, carbon12_element), & + frac) + call lowstorage_maintresp_reduction(frac,currentCohort%pft, & + maintresp_reduction_factor) + + ! are there any leaves of this pft in this layer? + canopy_mask_if: if(currentPatch%canopy_mask(cl,ft) == 1)then + + ! Loop over leaf-layers + leaf_layer_loop : do iv = 1,currentCohort%nv + + ! ------------------------------------------------------------ + ! If we are doing plant hydro-dynamics (or any run-type + ! where cohorts may generate different photosynthetic rates + ! of other cohorts in the same canopy-pft-layer combo), + ! we re-calculate the leaf biophysical rates for the + ! cohort-layer combo of interest. + ! but in the vanilla case, we only re-calculate if it has + ! not been done yet. + ! Other cases where we need to solve for every cohort + ! in every leaf layer: nutrient dynamic mode, multiple leaf + ! age classes + ! ------------------------------------------------------------ + + rate_mask_if: if ( .not.rate_mask_z(iv,ft,cl) .or. & + (hlm_use_planthydro.eq.itrue) .or. & + (radiation_model .eq. twostr_solver ) .or. & + (nleafage > 1) .or. & + (hlm_parteh_mode .ne. prt_carbon_allom_hyp ) ) then + + if (hlm_use_planthydro.eq.itrue ) then + + stomatal_intercept_btran = max( cf/rsmax0,stomatal_intercept(ft)*currentCohort%co_hydr%btran ) + btran_eff = currentCohort%co_hydr%btran + + ! dinc_vai(:) is the total vegetation area index of each "leaf" layer + ! we convert to the leaf only portion of the increment + ! ------------------------------------------------------ + leaf_inc = dinc_vai(iv) * & + currentCohort%treelai/(currentCohort%treelai+currentCohort%treesai) + + ! Now calculate the cumulative top-down lai of the current layer's midpoint + lai_canopy_above = sum(currentPatch%canopy_layer_tlai(1:cl-1)) + + lai_layers_above = (dlower_vai(iv) - dinc_vai(iv)) * & + currentCohort%treelai/(currentCohort%treelai+currentCohort%treesai) + lai_current = min(leaf_inc, currentCohort%treelai - lai_layers_above) + cumulative_lai = lai_canopy_above + lai_layers_above + 0.5*lai_current + + leaf_psi = currentCohort%co_hydr%psi_ag(1) + + else + + stomatal_intercept_btran = max( cf/rsmax0,stomatal_intercept(ft)*currentPatch%btran_ft(ft) ) + + btran_eff = currentPatch%btran_ft(ft) + ! For consistency sake, we use total LAI here, and not exposed + ! if the plant is under-snow, it will be effectively dormant for + ! the purposes of nscaler + + cumulative_lai = sum(currentPatch%canopy_layer_tlai(1:cl-1)) + & + sum(currentPatch%tlai_profile(cl,ft,1:iv-1)) + & + 0.5*currentPatch%tlai_profile(cl,ft,iv) + + leaf_psi = fates_unset_r8 + + end if + + if(do_fates_salinity)then + btran_eff = btran_eff*currentPatch%bstress_sal_ft(ft) + endif - ! Multi-layer parameters scaled by leaf nitrogen profile. - ! Loop through each canopy layer to calculate nitrogen profile using - ! cumulative lai at the midpoint of the layer + ! Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 used + ! kn = 0.11. Here, derive kn from vcmax25 as in Lloyd et al + ! (2010) Biogeosciences, 7, 1833-1859 + kn = decay_coeff_kn(ft,currentCohort%vcmax25top) - ! Pre-process some variables that are PFT dependent - ! but not environmentally dependent - ! ------------------------------------------------------------------------ + ! Scale for leaf nitrogen profile + nscaler = exp(-kn * cumulative_lai) - allocate(rootfr_ft(numpft, bc_in(s)%nlevsoil)) + ! Leaf maintenance respiration to match the base rate used in CN + ! but with the new temperature functions for C3 and C4 plants. - do ft = 1,numpft - call set_root_fraction(rootfr_ft(ft,:), ft, & - bc_in(s)%zi_sisl, & - bc_in(s)%max_rooting_depth_index_col) - end do - - - ifp = 0 - currentpatch => sites(s)%oldest_patch - do while (associated(currentpatch)) - if(currentpatch%nocomp_pft_label.ne.nocomp_bareground)then - ifp = ifp+1 - NCL_p = currentPatch%NCL_p - - ! Part I. Zero output boundary conditions - ! --------------------------------------------------------------------------- - bc_out(s)%rssun_pa(ifp) = 0._r8 - bc_out(s)%rssha_pa(ifp) = 0._r8 - - g_sb_leaves = 0._r8 - check_elai = 0._r8 - - ! Part II. Filter out patches - ! Patch level filter flag for photosynthesis calculations - ! has a short memory, flags: - ! 1 = patch has not been called - ! 2 = patch is currently marked for photosynthesis - ! 3 = patch has been called for photosynthesis already - ! --------------------------------------------------------------------------- - if(bc_in(s)%filter_photo_pa(ifp)==2)then - - - ! Part III. Calculate the number of sublayers for each pft and layer. - ! And then identify which layer/pft combinations have things in them. - ! Output: - ! currentPatch%ncan(:,:) - ! currentPatch%canopy_mask(:,:) - call UpdateCanopyNCanNRadPresent(currentPatch) - - - ! Part IV. Identify some environmentally derived parameters: - ! These quantities are biologically irrelevant - ! Michaelis-Menten constant for CO2 (Pa) - ! Michaelis-Menten constant for O2 (Pa) - ! CO2 compensation point (Pa) - ! leaf boundary layer conductance of h20 - ! constrained vapor pressure - - call GetCanopyGasParameters(bc_in(s)%forc_pbot, & ! in - bc_in(s)%oair_pa(ifp), & ! in - bc_in(s)%t_veg_pa(ifp), & ! in - bc_in(s)%tgcm_pa(ifp), & ! in - bc_in(s)%eair_pa(ifp), & ! in - bc_in(s)%esat_tv_pa(ifp), & ! in - bc_in(s)%rb_pa(ifp), & ! in - mm_kco2, & ! out - mm_ko2, & ! out - co2_cpoint, & ! out - cf, & ! out - gb_mol, & ! out - ceair) ! out - - - - - ! ------------------------------------------------------------------------ - ! Part VI: Loop over all leaf layers. - ! The concept of leaf layers is a result of the radiative transfer scheme. - ! A leaf layer has uniform radiation environment. Leaf layers are a group - ! of vegetation surfaces (stems and leaves) which inhabit the same - ! canopy-layer "CL", have the same functional type "ft" and within those - ! two partitions are further partitioned into vertical layers where - ! downwelling radiation attenuates in order. - ! In this phase we loop over the leaf layers and calculate the - ! photosynthesis and respiration of the layer (since all biophysical - ! properties are homogeneous). After this step, we can loop through - ! our cohort list, associate each cohort with its list of leaf-layers - ! and transfer these quantities to the cohort. - ! With plant hydraulics, we must realize that photosynthesis and - ! respiration will be different for leaves of each cohort in the leaf - ! layers, as they will have there own hydraulic limitations. - ! NOTE: Only need to flush mask on the number of used pfts, not the whole - ! scratch space. - ! ------------------------------------------------------------------------ - rate_mask_z(:,1:numpft,:) = .false. - - if(currentPatch%countcohorts > 0.0)then ! Ignore empty patches - - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) ! Cohort loop - - ! Identify the canopy layer (cl), functional type (ft) - ! and the leaf layer (IV) for this cohort - ft = currentCohort%pft - cl = currentCohort%canopy_layer - - ! MLO. Assuming target to be related to leaf biomass when leaves are fully - ! flushed. But unsure whether this call is correct or not, shouldn't we get - ! the target value directly from the bstore_allom? - call bleaf(currentCohort%dbh,currentCohort%pft,& - currentCohort%crowndamage,currentCohort%canopy_trim,1.0_r8,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, carbon12_element), & - frac) - call lowstorage_maintresp_reduction(frac,currentCohort%pft, & - maintresp_reduction_factor) - - ! are there any leaves of this pft in this layer? - canopy_mask_if: if(currentPatch%canopy_mask(cl,ft) == 1)then - - ! Loop over leaf-layers - leaf_layer_loop : do iv = 1,currentCohort%nv - - ! ------------------------------------------------------------ - ! If we are doing plant hydro-dynamics (or any run-type - ! where cohorts may generate different photosynthetic rates - ! of other cohorts in the same canopy-pft-layer combo), - ! we re-calculate the leaf biophysical rates for the - ! cohort-layer combo of interest. - ! but in the vanilla case, we only re-calculate if it has - ! not been done yet. - ! Other cases where we need to solve for every cohort - ! in every leaf layer: nutrient dynamic mode, multiple leaf - ! age classes - ! ------------------------------------------------------------ - - rate_mask_if: if ( .not.rate_mask_z(iv,ft,cl) .or. & - (hlm_use_planthydro.eq.itrue) .or. & - (nleafage > 1) .or. & - (hlm_parteh_mode .ne. prt_carbon_allom_hyp ) ) then - - if (hlm_use_planthydro.eq.itrue ) then - - stomatal_intercept_btran = max( cf/rsmax0,stomatal_intercept(ft)*currentCohort%co_hydr%btran ) - btran_eff = currentCohort%co_hydr%btran - - ! dinc_vai(:) is the total vegetation area index of each "leaf" layer - ! we convert to the leaf only portion of the increment - ! ------------------------------------------------------ - leaf_inc = dinc_vai(iv) * & - currentCohort%treelai/(currentCohort%treelai+currentCohort%treesai) - - ! Now calculate the cumulative top-down lai of the current layer's midpoint - lai_canopy_above = sum(currentPatch%canopy_layer_tlai(1:cl-1)) - - lai_layers_above = (dlower_vai(iv) - dinc_vai(iv)) * & - currentCohort%treelai/(currentCohort%treelai+currentCohort%treesai) - lai_current = min(leaf_inc, currentCohort%treelai - lai_layers_above) - cumulative_lai = lai_canopy_above + lai_layers_above + 0.5*lai_current - - leaf_psi = currentCohort%co_hydr%psi_ag(1) - - else - - stomatal_intercept_btran = max( cf/rsmax0,stomatal_intercept(ft)*currentPatch%btran_ft(ft) ) - - btran_eff = currentPatch%btran_ft(ft) - ! For consistency sake, we use total LAI here, and not exposed - ! if the plant is under-snow, it will be effectively dormant for - ! the purposes of nscaler - - cumulative_lai = sum(currentPatch%canopy_layer_tlai(1:cl-1)) + & - sum(currentPatch%tlai_profile(cl,ft,1:iv-1)) + & - 0.5*currentPatch%tlai_profile(cl,ft,iv) - - leaf_psi = fates_unset_r8 - - end if - - if(do_fates_salinity)then - btran_eff = btran_eff*currentPatch%bstress_sal_ft(ft) - endif - - - ! Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 used - ! kn = 0.11. Here, derive kn from vcmax25 as in Lloyd et al - ! (2010) Biogeosciences, 7, 1833-1859 - - kn = decay_coeff_kn(ft,currentCohort%vcmax25top) - - ! Scale for leaf nitrogen profile - nscaler = exp(-kn * cumulative_lai) + ! CN respiration has units: g C / g N [leaf] / s. This needs to be + ! converted from g C / g N [leaf] / s to umol CO2 / m**2 [leaf] / s - ! Leaf maintenance respiration to match the base rate used in CN - ! but with the new temperature functions for C3 and C4 plants. - - ! CN respiration has units: g C / g N [leaf] / s. This needs to be - ! converted from g C / g N [leaf] / s to umol CO2 / m**2 [leaf] / s - - ! Then scale this value at the top of the canopy for canopy depth - ! Leaf nitrogen concentration at the top of the canopy (g N leaf / m**2 leaf) - select case(hlm_parteh_mode) - case (prt_carbon_allom_hyp) - - lnc_top = prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(leaf_organ))/slatop(ft) - - case (prt_cnp_flex_allom_hyp) + ! Then scale this value at the top of the canopy for canopy depth + ! Leaf nitrogen concentration at the top of the canopy (g N leaf / m**2 leaf) + select case(hlm_parteh_mode) + case (prt_carbon_allom_hyp) - leaf_c = currentCohort%prt%GetState(leaf_organ, carbon12_element) - if( (leaf_c*slatop(ft)) > nearzero) then - leaf_n = currentCohort%prt%GetState(leaf_organ, nitrogen_element) - lnc_top = leaf_n / (slatop(ft) * leaf_c ) - else lnc_top = prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(leaf_organ))/slatop(ft) - end if - - ! If one wants to break coupling with dynamic N conentrations, - ! use the stoichiometry parameter - ! lnc_top = prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(leaf_organ))/slatop(ft) - - end select - - ! Part VII: Calculate dark respiration (leaf maintenance) for this layer - - select case (maintresp_leaf_model) - - case (lmrmodel_ryan_1991) - - call LeafLayerMaintenanceRespiration_Ryan_1991( lnc_top, & ! in - nscaler, & ! in - ft, & ! in - bc_in(s)%t_veg_pa(ifp), & ! in - lmr_z(iv,ft,cl)) ! out - - case (lmrmodel_atkin_etal_2017) - - call LeafLayerMaintenanceRespiration_Atkin_etal_2017(lnc_top, & ! in - nscaler, & ! in - ft, & ! in - bc_in(s)%t_veg_pa(ifp), & ! in - currentPatch%tveg_lpa%GetMean(), & ! in - lmr_z(iv,ft,cl)) ! out - - case default - - write (fates_log(),*)'error, incorrect leaf respiration model specified' - call endrun(msg=errMsg(sourcefile, __LINE__)) - - end select - - ! Part VII: Calculate (1) maximum rate of carboxylation (vcmax), - ! (2) maximum electron transport rate, (3) triose phosphate - ! utilization rate and (4) the initial slope of CO2 response curve - ! (C4 plants). Earlier we calculated their base rates as dictated - ! by their plant functional type and some simple scaling rules for - ! nitrogen limitation baesd on canopy position (not prognostic). - ! These rates are the specific rates used in the actual photosynthesis - ! calculations that take localized environmental effects (temperature) - ! into consideration. - - - - call LeafLayerBiophysicalRates(currentPatch%ed_parsun_z(cl,ft,iv), & ! in - ft, & ! in - currentCohort%vcmax25top, & ! in - currentCohort%jmax25top, & ! in - currentCohort%kp25top, & ! in - nscaler, & ! in - bc_in(s)%t_veg_pa(ifp), & ! in - currentPatch%tveg_lpa%GetMean(), & ! in - currentPatch%tveg_longterm%GetMean(),& ! in - btran_eff, & ! in - vcmax_z, & ! out - jmax_z, & ! out - kp_z ) ! out - - ! Part IX: This call calculates the actual photosynthesis for the - ! leaf layer, as well as the stomatal resistance and the net assimilated carbon. - - call LeafLayerPhotosynthesis(currentPatch%f_sun(cl,ft,iv), & ! in - currentPatch%ed_parsun_z(cl,ft,iv), & ! in - currentPatch%ed_parsha_z(cl,ft,iv), & ! in - currentPatch%ed_laisun_z(cl,ft,iv), & ! in - currentPatch%ed_laisha_z(cl,ft,iv), & ! in - currentPatch%canopy_area_profile(cl,ft,iv), & ! in - ft, & ! in - vcmax_z, & ! in - jmax_z, & ! in - kp_z, & ! in - bc_in(s)%t_veg_pa(ifp), & ! in - bc_in(s)%esat_tv_pa(ifp), & ! in - bc_in(s)%forc_pbot, & ! in - bc_in(s)%cair_pa(ifp), & ! in - bc_in(s)%oair_pa(ifp), & ! in - btran_eff, & ! in - stomatal_intercept_btran, & ! in - cf, & ! in - gb_mol, & ! in - ceair, & ! in - mm_kco2, & ! in - mm_ko2, & ! in - co2_cpoint, & ! in - lmr_z(iv,ft,cl), & ! in - leaf_psi, & ! in - bc_in(s)%rb_pa(ifp), & ! in - currentPatch%psn_z(cl,ft,iv), & ! out - rs_z(iv,ft,cl), & ! out - anet_av_z(iv,ft,cl), & ! out - c13disc_z(cl,ft,iv)) ! out - - rate_mask_z(iv,ft,cl) = .true. - - end if rate_mask_if - end do leaf_layer_loop - - ! Zero cohort flux accumulators. - currentCohort%npp_tstep = 0.0_r8 - currentCohort%resp_tstep = 0.0_r8 - currentCohort%gpp_tstep = 0.0_r8 - currentCohort%rdark = 0.0_r8 - currentCohort%resp_m = 0.0_r8 - currentCohort%ts_net_uptake = 0.0_r8 - currentCohort%c13disc_clm = 0.0_r8 - - ! --------------------------------------------------------------- - ! Part VII: Transfer leaf flux rates (like maintenance respiration, - ! carbon assimilation and conductance) that are defined by the - ! leaf layer (which is area independent, ie /m2) onto each cohort - ! (where the rates become per cohort, ie /individual). Most likely - ! a sum over layers. - ! --------------------------------------------------------------- - nv = currentCohort%nv - call ScaleLeafLayerFluxToCohort(nv, & !in - currentPatch%psn_z(cl,ft,1:nv), & !in - lmr_z(1:nv,ft,cl), & !in - rs_z(1:nv,ft,cl), & !in - currentPatch%elai_profile(cl,ft,1:nv), & !in - c13disc_z(cl, ft, 1:nv), & !in - currentCohort%c_area, & !in - currentCohort%n, & !in - bc_in(s)%rb_pa(ifp), & !in - maintresp_reduction_factor, & !in - currentCohort%g_sb_laweight, & !out - currentCohort%gpp_tstep, & !out - currentCohort%rdark, & !out - currentCohort%c13disc_clm, & !out - cohort_eleaf_area) !out - - ! Net Uptake does not need to be scaled, just transfer directly - currentCohort%ts_net_uptake(1:nv) = anet_av_z(1:nv,ft,cl) * umolC_to_kgC - - else - - ! In this case, the cohort had no leaves, - ! so no productivity,conductance, transpiration uptake - ! or dark respiration - cohort_eleaf_area = 0.0_r8 - currentCohort%gpp_tstep = 0.0_r8 - currentCohort%rdark = 0.0_r8 - currentCohort%g_sb_laweight = 0.0_r8 - currentCohort%ts_net_uptake(:) = 0.0_r8 - - end if canopy_mask_if - - - ! ------------------------------------------------------------------ - ! Part VIII: Calculate maintenance respiration in the sapwood and - ! fine root pools. - ! ------------------------------------------------------------------ - - ! Calculate the amount of nitrogen in the above and below ground - ! stem and root pools, used for maint resp - ! We are using the fine-root C:N ratio as an approximation for - ! the sapwood pools. - ! Units are in (kgN/plant) - ! ------------------------------------------------------------------ - - sapw_c = currentCohort%prt%GetState(sapw_organ, carbon12_element) - fnrt_c = currentCohort%prt%GetState(fnrt_organ, carbon12_element) - - if (hlm_use_tree_damage .eq. itrue) then - - ! Crown damage currenly only reduces the aboveground portion of - ! sapwood. Therefore we calculate the aboveground and the belowground portion - ! sapwood for use in stem respiration. - call GetCrownReduction(currentCohort%crowndamage, crown_reduction) - - else - crown_reduction = 0.0_r8 - end if - - ! If crown reduction is zero, undamaged sapwood target will equal sapwood carbon - agb_frac = prt_params%allom_agb_frac(currentCohort%pft) - branch_frac = param_derived%branch_frac(currentCohort%pft) - sapw_c_undamaged = sapw_c / (1.0_r8 - (agb_frac * branch_frac * crown_reduction)) - - ! Undamaged below ground portion - sapw_c_bgw = sapw_c_undamaged * (1.0_r8 - agb_frac) - - ! Damaged aboveground portion - sapw_c_agw = sapw_c - sapw_c_bgw - - - select case(hlm_parteh_mode) - case (prt_carbon_allom_hyp) - live_stem_n = sapw_c_agw * prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(sapw_organ)) + case (prt_cnp_flex_allom_hyp) + + leaf_c = currentCohort%prt%GetState(leaf_organ, carbon12_element) + if( (leaf_c*slatop(ft)) > nearzero) then + leaf_n = currentCohort%prt%GetState(leaf_organ, nitrogen_element) + lnc_top = leaf_n / (slatop(ft) * leaf_c ) + else + lnc_top = prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(leaf_organ))/slatop(ft) + end if + + ! If one wants to break coupling with dynamic N conentrations, + ! use the stoichiometry parameter + ! lnc_top = prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(leaf_organ))/slatop(ft) + + end select + + ! Part VII: Calculate dark respiration (leaf maintenance) for this layer + + select case (maintresp_leaf_model) + + case (lmrmodel_ryan_1991) + + call LeafLayerMaintenanceRespiration_Ryan_1991( lnc_top, & ! in + nscaler, & ! in + ft, & ! in + bc_in(s)%t_veg_pa(ifp), & ! in + lmr_z(iv,ft,cl)) ! out + + case (lmrmodel_atkin_etal_2017) + + call LeafLayerMaintenanceRespiration_Atkin_etal_2017(lnc_top, & ! in + nscaler, & ! in + ft, & ! in + bc_in(s)%t_veg_pa(ifp), & ! in + currentPatch%tveg_lpa%GetMean(), & ! in + lmr_z(iv,ft,cl)) ! out + + case default + + write (fates_log(),*)'error, incorrect leaf respiration model specified' + call endrun(msg=errMsg(sourcefile, __LINE__)) + + end select + + ! Pre-process PAR absorbed per unit leaf area for different schemes + ! par_per_sunla = [W absorbed beam+diffuse radiation / m2 of sunlit leaves] + ! par_per_shala = [W absorbed diffuse radiation / m2 of shaded leaves] + ! fsun = [m2 of sunlit leaves / m2 of total leaves] + ! laisun: m2 of exposed leaf, per m2 of crown. If this is the lowest layer + ! for the pft/canopy group, than the m2 per crown is probably not + ! as large as the layer above. + ! ------------------------------------------------------------------ + + if_radsolver: if(radiation_model.eq.norman_solver) then + + laisun = currentPatch%ed_laisun_z(cl,ft,iv) + laisha = currentPatch%ed_laisha_z(cl,ft,iv) + par_per_sunla = currentPatch%ed_parsun_z(cl,ft,iv) + par_per_shala = currentPatch%ed_parsha_z(cl,ft,iv) + canopy_area = currentPatch%canopy_area_profile(cl,ft,iv) + fsun = currentPatch%f_sun(cl,ft,iv) + + else ! Two-stream + + if(cohort_layer_elai(iv) > nearzero .and. currentPatch%solar_zenith_flag) then + + call FatesGetCohortAbsRad(currentPatch, currentCohort, ipar, & + cohort_vaitop(iv), cohort_vaibot(iv), cohort_elai, cohort_esai, & + rb_abs, rd_abs, rb_abs_leaf, rd_abs_leaf, fsun) + + ! rd_abs_leaf: Watts of diffuse light absorbed by leaves over this + ! depth interval and ground footprint (m2) + ! rd_abs_leaf*fsun Watts of diffuse light absorbed by sunlit leaves + ! over this depth interval and ground footprint (m2) + ! rb_abs_leaf Watts of beam absorbed by sunlit leaves over this + ! depth interval and ground footprint (m2) + ! cohort_layer_elai*fsun Leaf area in sunlight within this interval and ground footprint + ! cohort_layer_elai*(1-fsun) Leaf area in shade within this interval and ground footprint + + laisun = (fsun*cohort_layer_elai(iv)) + laisha = ((1._r8 - fsun)*cohort_layer_elai(iv)) + if(fsun>nearzero) then + par_per_sunla = (rd_abs_leaf*fsun + rb_abs_leaf)! / laisun + else + par_per_sunla = 0._r8 + end if + par_per_shala = rd_abs_leaf*(1._r8-fsun) !/ laisha + canopy_area = 1._r8 !currentPatch%canopy_area_profile(cl,ft,iv) + + else + + par_per_sunla = 0._r8 + par_per_shala = 0._r8 + laisun = 0.5_r8*cohort_layer_elai(iv) + laisha = 0.5_r8*cohort_layer_elai(iv) + canopy_area = 1._r8 !currentPatch%canopy_area_profile(cl,ft,iv) + fsun = 0.5_r8 !avoid div0, should have no impact + + end if + + end if if_radsolver + + ! Part VII: Calculate (1) maximum rate of carboxylation (vcmax), + ! (2) maximum electron transport rate, (3) triose phosphate + ! utilization rate and (4) the initial slope of CO2 response curve + ! (C4 plants). Earlier we calculated their base rates as dictated + ! by their plant functional type and some simple scaling rules for + ! nitrogen limitation baesd on canopy position (not prognostic). + ! These rates are the specific rates used in the actual photosynthesis + ! calculations that take localized environmental effects (temperature) + ! into consideration. + + call LeafLayerBiophysicalRates(par_per_sunla, & ! in + ft, & ! in + currentCohort%vcmax25top, & ! in + currentCohort%jmax25top, & ! in + currentCohort%kp25top, & ! in + nscaler, & ! in + bc_in(s)%t_veg_pa(ifp), & ! in + currentPatch%tveg_lpa%GetMean(), & ! in + currentPatch%tveg_longterm%GetMean(),& ! in + btran_eff, & ! in + vcmax_z, & ! out + jmax_z, & ! out + kp_z ) ! out + + ! Part IX: This call calculates the actual photosynthesis for the + ! leaf layer, as well as the stomatal resistance and the net assimilated carbon. + + call LeafLayerPhotosynthesis(fsun, & ! in + par_per_sunla, & ! in + par_per_shala, & ! in + laisun, & ! in + laisha, & ! in + canopy_area, & ! in + ft, & ! in + vcmax_z, & ! in + jmax_z, & ! in + kp_z, & ! in + bc_in(s)%t_veg_pa(ifp), & ! in + bc_in(s)%esat_tv_pa(ifp), & ! in + bc_in(s)%forc_pbot, & ! in + bc_in(s)%cair_pa(ifp), & ! in + bc_in(s)%oair_pa(ifp), & ! in + btran_eff, & ! in + stomatal_intercept_btran, & ! in + cf, & ! in + gb_mol, & ! in + ceair, & ! in + mm_kco2, & ! in + mm_ko2, & ! in + co2_cpoint, & ! in + lmr_z(iv,ft,cl), & ! in + leaf_psi, & ! in + bc_in(s)%rb_pa(ifp), & ! in + currentPatch%psn_z(cl,ft,iv), & ! out + rs_z(iv,ft,cl), & ! out + anet_av_z(iv,ft,cl), & ! out + c13disc_z(cl,ft,iv)) ! out + + rate_mask_z(iv,ft,cl) = .true. + + end if rate_mask_if + end do leaf_layer_loop + + ! Zero cohort flux accumulators. + currentCohort%npp_tstep = 0.0_r8 + currentCohort%resp_tstep = 0.0_r8 + currentCohort%gpp_tstep = 0.0_r8 + currentCohort%rdark = 0.0_r8 + currentCohort%resp_m = 0.0_r8 + currentCohort%ts_net_uptake = 0.0_r8 + currentCohort%c13disc_clm = 0.0_r8 + + ! --------------------------------------------------------------- + ! Part VII: Transfer leaf flux rates (like maintenance respiration, + ! carbon assimilation and conductance) that are defined by the + ! leaf layer (which is area independent, ie /m2) onto each cohort + ! (where the rates become per cohort, ie /individual). Most likely + ! a sum over layers. + ! --------------------------------------------------------------- + nv = currentCohort%nv + + ! Temporary bypass to preserve B4B behavior + if(radiation_model.eq.norman_solver) then + + call ScaleLeafLayerFluxToCohort(nv, & !in + currentPatch%psn_z(cl,ft,1:nv), & !in + lmr_z(1:nv,ft,cl), & !in + rs_z(1:nv,ft,cl), & !in + currentPatch%elai_profile(cl,ft,1:nv), & !in + c13disc_z(cl, ft, 1:nv), & !in + currentCohort%c_area, & !in + currentCohort%n, & !in + bc_in(s)%rb_pa(ifp), & !in + maintresp_reduction_factor, & !in + currentCohort%g_sb_laweight, & !out + currentCohort%gpp_tstep, & !out + currentCohort%rdark, & !out + currentCohort%c13disc_clm, & !out + cohort_eleaf_area) !out + + else + + call ScaleLeafLayerFluxToCohort(nv, & !in + currentPatch%psn_z(cl,ft,1:nv), & !in + lmr_z(1:nv,ft,cl), & !in + rs_z(1:nv,ft,cl), & !in + cohort_layer_elai(1:nv), & !in + c13disc_z(cl, ft, 1:nv), & !in + currentCohort%c_area, & !in + currentCohort%n, & !in + bc_in(s)%rb_pa(ifp), & !in + maintresp_reduction_factor, & !in + currentCohort%g_sb_laweight, & !out + currentCohort%gpp_tstep, & !out + currentCohort%rdark, & !out + currentCohort%c13disc_clm, & !out + cohort_eleaf_area) !out + end if + + + ! Net Uptake does not need to be scaled, just transfer directly + currentCohort%ts_net_uptake(1:nv) = anet_av_z(1:nv,ft,cl) * umolC_to_kgC + + else + + ! In this case, the cohort had no leaves, + ! so no productivity,conductance, transpiration uptake + ! or dark respiration + cohort_eleaf_area = 0.0_r8 + currentCohort%gpp_tstep = 0.0_r8 + currentCohort%rdark = 0.0_r8 + currentCohort%g_sb_laweight = 0.0_r8 + currentCohort%ts_net_uptake(:) = 0.0_r8 + + end if canopy_mask_if + + + ! ------------------------------------------------------------------ + ! Part VIII: Calculate maintenance respiration in the sapwood and + ! fine root pools. + ! ------------------------------------------------------------------ + + ! Calculate the amount of nitrogen in the above and below ground + ! stem and root pools, used for maint resp + ! We are using the fine-root C:N ratio as an approximation for + ! the sapwood pools. + ! Units are in (kgN/plant) + ! ------------------------------------------------------------------ + + sapw_c = currentCohort%prt%GetState(sapw_organ, carbon12_element) + fnrt_c = currentCohort%prt%GetState(fnrt_organ, carbon12_element) + + if (hlm_use_tree_damage .eq. itrue) then - live_croot_n = sapw_c_bgw * prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(sapw_organ)) + ! Crown damage currenly only reduces the aboveground portion of + ! sapwood. Therefore we calculate the aboveground and the belowground portion + ! sapwood for use in stem respiration. + call GetCrownReduction(currentCohort%crowndamage, crown_reduction) - fnrt_n = fnrt_c * prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(fnrt_organ)) + else + crown_reduction = 0.0_r8 + end if - case(prt_cnp_flex_allom_hyp) + ! If crown reduction is zero, undamaged sapwood target will equal sapwood carbon + agb_frac = prt_params%allom_agb_frac(currentCohort%pft) + branch_frac = param_derived%branch_frac(currentCohort%pft) + sapw_c_undamaged = sapw_c / (1.0_r8 - (agb_frac * branch_frac * crown_reduction)) - live_stem_n = prt_params%allom_agb_frac(currentCohort%pft) * & - currentCohort%prt%GetState(sapw_organ, nitrogen_element) + ! Undamaged below ground portion + sapw_c_bgw = sapw_c_undamaged * (1.0_r8 - agb_frac) - live_croot_n = (1.0_r8-prt_params%allom_agb_frac(currentCohort%pft)) * & - currentCohort%prt%GetState(sapw_organ, nitrogen_element) + ! Damaged aboveground portion + sapw_c_agw = sapw_c - sapw_c_bgw - fnrt_n = currentCohort%prt%GetState(fnrt_organ, nitrogen_element) + select case(hlm_parteh_mode) + case (prt_carbon_allom_hyp) - if (hlm_use_tree_damage .eq. itrue) then + live_stem_n = sapw_c_agw * prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(sapw_organ)) - sapw_n = currentCohort%prt%GetState(sapw_organ, nitrogen_element) + live_croot_n = sapw_c_bgw * prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(sapw_organ)) - sapw_n_undamaged = sapw_n / & - (1.0_r8 - (agb_frac * branch_frac * crown_reduction)) - - sapw_n_bgw = sapw_n_undamaged * (1.0_r8 - agb_frac) - sapw_n_agw = sapw_n - sapw_n_bgw + fnrt_n = fnrt_c * prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(fnrt_organ)) - live_croot_n = sapw_n_bgw + case(prt_cnp_flex_allom_hyp) - live_stem_n = sapw_n_agw + live_stem_n = prt_params%allom_agb_frac(currentCohort%pft) * & + currentCohort%prt%GetState(sapw_organ, nitrogen_element) - end if + live_croot_n = (1.0_r8-prt_params%allom_agb_frac(currentCohort%pft)) * & + currentCohort%prt%GetState(sapw_organ, nitrogen_element) - ! If one wants to break coupling with dynamic N conentrations, - ! use the stoichiometry parameter - ! - ! live_stem_n = prt_params%allom_agb_frac(currentCohort%pft) * & - ! sapw_c * prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(sapw_organ)) - ! live_croot_n = (1.0_r8-prt_params%allom_agb_frac(currentCohort%pft)) * & - ! sapw_c * prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(sapw_organ)) - ! fnrt_n = fnrt_c * prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(fnrt_organ)) + fnrt_n = currentCohort%prt%GetState(fnrt_organ, nitrogen_element) - case default + if (hlm_use_tree_damage .eq. itrue) then + sapw_n = currentCohort%prt%GetState(sapw_organ, nitrogen_element) - end select + sapw_n_undamaged = sapw_n / & + (1.0_r8 - (agb_frac * branch_frac * crown_reduction)) - !------------------------------------------------------------------------------ - ! Calculate Whole Plant Respiration - ! (this doesn't really need to be in this iteration at all, surely?) - ! Response: (RGK 12-2016): I think the positioning of these calls is - ! appropriate as of now. Maintenance calculations in sapwood and roots - ! vary by cohort and with changing temperature at the minimum, and there are - ! no sub-pools chopping up those pools any finer that need to be dealt with. - !------------------------------------------------------------------------------ + sapw_n_bgw = sapw_n_undamaged * (1.0_r8 - agb_frac) + sapw_n_agw = sapw_n - sapw_n_bgw - ! Live stem MR (kgC/plant/s) (above ground sapwood) - ! ------------------------------------------------------------------ - if ( int(woody(ft)) == itrue) then - tcwood = q10_mr**((bc_in(s)%t_veg_pa(ifp)-tfrz - 20.0_r8)/10.0_r8) - ! kgC/s = kgN * kgC/kgN/s - currentCohort%livestem_mr = live_stem_n * maintresp_nonleaf_baserate * tcwood * maintresp_reduction_factor - else - currentCohort%livestem_mr = 0._r8 - end if + live_croot_n = sapw_n_bgw + live_stem_n = sapw_n_agw - ! Fine Root MR (kgC/plant/s) - ! and calculate the N fixation rate as a function of the fixation-specific root respiration - ! for now use dev_arbitrary_pft as scaling term between 0 and 1 as additional increment of root respiration used for N fixation - ! ------------------------------------------------------------------ - currentCohort%froot_mr = 0._r8 - currentCohort%sym_nfix_tstep = 0._r8 - - ! n_fixation is integrated over the course of the day - ! this variable is zeroed at the end of the FATES dynamics sequence + end if - do j = 1,bc_in(s)%nlevsoil - tcsoi = q10_mr**((bc_in(s)%t_soisno_sl(j)-tfrz - 20.0_r8)/10.0_r8) - - fnrt_mr_layer = fnrt_n * maintresp_nonleaf_baserate * tcsoi * rootfr_ft(ft,j) * maintresp_reduction_factor + ! If one wants to break coupling with dynamic N conentrations, + ! use the stoichiometry parameter + ! + ! live_stem_n = prt_params%allom_agb_frac(currentCohort%pft) * & + ! sapw_c * prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(sapw_organ)) + ! live_croot_n = (1.0_r8-prt_params%allom_agb_frac(currentCohort%pft)) * & + ! sapw_c * prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(sapw_organ)) + ! fnrt_n = fnrt_c * prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(fnrt_organ)) - ! calculate the cost of carbon for N fixation in each soil layer and calculate N fixation rate based on that [kgC / kgN] - call RootLayerNFixation(bc_in(s)%t_soisno_sl(j),ft,dtime,fnrt_mr_layer,fnrt_mr_nfix_layer,nfix_layer) - - currentCohort%froot_mr = currentCohort%froot_mr + fnrt_mr_nfix_layer + fnrt_mr_layer + case default - currentCohort%sym_nfix_tstep = currentCohort%sym_nfix_tstep + nfix_layer - - - enddo - ! Coarse Root MR (kgC/plant/s) (below ground sapwood) - ! ------------------------------------------------------------------ - if ( int(woody(ft)) == itrue) then - currentCohort%livecroot_mr = 0._r8 - do j = 1,bc_in(s)%nlevsoil - ! Soil temperature used to adjust base rate of MR - tcsoi = q10_mr**((bc_in(s)%t_soisno_sl(j)-tfrz - 20.0_r8)/10.0_r8) - currentCohort%livecroot_mr = currentCohort%livecroot_mr + & - live_croot_n * maintresp_nonleaf_baserate * tcsoi * & - rootfr_ft(ft,j) * maintresp_reduction_factor - enddo - else - currentCohort%livecroot_mr = 0._r8 - end if + end select + !------------------------------------------------------------------------------ + ! Calculate Whole Plant Respiration + ! (this doesn't really need to be in this iteration at all, surely?) + ! Response: (RGK 12-2016): I think the positioning of these calls is + ! appropriate as of now. Maintenance calculations in sapwood and roots + ! vary by cohort and with changing temperature at the minimum, and there are + ! no sub-pools chopping up those pools any finer that need to be dealt with. + !------------------------------------------------------------------------------ - ! ------------------------------------------------------------------ - ! Part IX: Perform some unit conversions (rate to integrated) and - ! calcualate some fluxes that are sums and nets of the base fluxes - ! ------------------------------------------------------------------ + ! Live stem MR (kgC/plant/s) (above ground sapwood) + ! ------------------------------------------------------------------ + if ( int(woody(ft)) == itrue) then + tcwood = q10_mr**((bc_in(s)%t_veg_pa(ifp)-tfrz - 20.0_r8)/10.0_r8) + ! kgC/s = kgN * kgC/kgN/s + currentCohort%livestem_mr = live_stem_n * maintresp_nonleaf_baserate * tcwood * maintresp_reduction_factor + else + currentCohort%livestem_mr = 0._r8 + end if - if ( debug ) write(fates_log(),*) 'EDPhoto 904 ', currentCohort%resp_m - if ( debug ) write(fates_log(),*) 'EDPhoto 905 ', currentCohort%rdark - if ( debug ) write(fates_log(),*) 'EDPhoto 906 ', currentCohort%livestem_mr - if ( debug ) write(fates_log(),*) 'EDPhoto 907 ', currentCohort%livecroot_mr - if ( debug ) write(fates_log(),*) 'EDPhoto 908 ', currentCohort%froot_mr + ! Fine Root MR (kgC/plant/s) + ! and calculate the N fixation rate as a function of the fixation-specific root respiration + ! for now use dev_arbitrary_pft as scaling term between 0 and 1 as additional increment of root respiration used for N fixation + ! ------------------------------------------------------------------ + currentCohort%froot_mr = 0._r8 + currentCohort%sym_nfix_tstep = 0._r8 + ! n_fixation is integrated over the course of the day + ! this variable is zeroed at the end of the FATES dynamics sequence - ! add on whole plant respiration values in kgC/indiv/s-1 - currentCohort%resp_m = currentCohort%livestem_mr + & - currentCohort%livecroot_mr + & - currentCohort%froot_mr + do j = 1,bc_in(s)%nlevsoil + tcsoi = q10_mr**((bc_in(s)%t_soisno_sl(j)-tfrz - 20.0_r8)/10.0_r8) - ! no drought response right now.. something like: - ! resp_m = resp_m * (1.0_r8 - currentPatch%btran_ft(currentCohort%pft) * & - ! EDPftvarcon_inst%resp_drought_response(ft)) + fnrt_mr_layer = fnrt_n * maintresp_nonleaf_baserate * tcsoi * rootfr_ft(ft,j) * maintresp_reduction_factor - currentCohort%resp_m = currentCohort%resp_m + currentCohort%rdark + ! calculate the cost of carbon for N fixation in each soil layer and calculate N fixation rate based on that [kgC / kgN] - ! save as a diagnostic the un-throttled maintenance respiration to be able to know how strong this is - currentCohort%resp_m_unreduced = currentCohort%resp_m / maintresp_reduction_factor + call RootLayerNFixation(bc_in(s)%t_soisno_sl(j),ft,dtime,fnrt_mr_layer,fnrt_mr_nfix_layer,nfix_layer) - ! convert from kgC/indiv/s to kgC/indiv/timestep - currentCohort%resp_m = currentCohort%resp_m * dtime - currentCohort%gpp_tstep = currentCohort%gpp_tstep * dtime - currentCohort%ts_net_uptake = currentCohort%ts_net_uptake * dtime + currentCohort%froot_mr = currentCohort%froot_mr + fnrt_mr_nfix_layer + fnrt_mr_layer - if ( debug ) write(fates_log(),*) 'EDPhoto 911 ', currentCohort%gpp_tstep - if ( debug ) write(fates_log(),*) 'EDPhoto 912 ', currentCohort%resp_tstep - if ( debug ) write(fates_log(),*) 'EDPhoto 913 ', currentCohort%resp_m + currentCohort%sym_nfix_tstep = currentCohort%sym_nfix_tstep + nfix_layer - currentCohort%resp_g_tstep = prt_params%grperc(ft) * & - (max(0._r8,currentCohort%gpp_tstep - currentCohort%resp_m)) + enddo + ! Coarse Root MR (kgC/plant/s) (below ground sapwood) + ! ------------------------------------------------------------------ + if ( int(woody(ft)) == itrue) then + currentCohort%livecroot_mr = 0._r8 + do j = 1,bc_in(s)%nlevsoil + ! Soil temperature used to adjust base rate of MR + tcsoi = q10_mr**((bc_in(s)%t_soisno_sl(j)-tfrz - 20.0_r8)/10.0_r8) + currentCohort%livecroot_mr = currentCohort%livecroot_mr + & + live_croot_n * maintresp_nonleaf_baserate * tcsoi * & + rootfr_ft(ft,j) * maintresp_reduction_factor + enddo + else + currentCohort%livecroot_mr = 0._r8 + end if - currentCohort%resp_tstep = currentCohort%resp_m + & - currentCohort%resp_g_tstep ! kgC/indiv/ts - currentCohort%npp_tstep = currentCohort%gpp_tstep - & - currentCohort%resp_tstep ! kgC/indiv/ts - ! Accumulate the combined conductance (stomatal+leaf boundary layer) - ! Note that currentCohort%g_sb_laweight is weighted by the leaf area - ! of each cohort and has units of [m/s] * [m2 leaf] + ! ------------------------------------------------------------------ + ! Part IX: Perform some unit conversions (rate to integrated) and + ! calcualate some fluxes that are sums and nets of the base fluxes + ! ------------------------------------------------------------------ - g_sb_leaves = g_sb_leaves + currentCohort%g_sb_laweight + if ( debug ) write(fates_log(),*) 'EDPhoto 904 ', currentCohort%resp_m + if ( debug ) write(fates_log(),*) 'EDPhoto 905 ', currentCohort%rdark + if ( debug ) write(fates_log(),*) 'EDPhoto 906 ', currentCohort%livestem_mr + if ( debug ) write(fates_log(),*) 'EDPhoto 907 ', currentCohort%livecroot_mr + if ( debug ) write(fates_log(),*) 'EDPhoto 908 ', currentCohort%froot_mr - ! Accumulate the total effective leaf area from all cohorts - ! in this patch. Normalize by canopy area outside the loop - check_elai = check_elai + cohort_eleaf_area - currentCohort => currentCohort%shorter - enddo ! end cohort loop. - end if !count_cohorts is more than zero. + ! add on whole plant respiration values in kgC/indiv/s-1 + currentCohort%resp_m = currentCohort%livestem_mr + & + currentCohort%livecroot_mr + & + currentCohort%froot_mr - check_elai = check_elai / currentPatch%total_canopy_area - elai = calc_areaindex(currentPatch,'elai') + ! no drought response right now.. something like: + ! resp_m = resp_m * (1.0_r8 - currentPatch%btran_ft(currentCohort%pft) * & + ! EDPftvarcon_inst%resp_drought_response(ft)) - ! Normalize canopy total conductance by the effective LAI - ! The value here was integrated over each cohort x leaf layer - ! and was weighted by m2 of effective leaf area for each layer + currentCohort%resp_m = currentCohort%resp_m + currentCohort%rdark + + ! save as a diagnostic the un-throttled maintenance respiration to be able to know how strong this is + currentCohort%resp_m_unreduced = currentCohort%resp_m / maintresp_reduction_factor - if(check_elai>tiny(check_elai)) then + ! convert from kgC/indiv/s to kgC/indiv/timestep + currentCohort%resp_m = currentCohort%resp_m * dtime + currentCohort%gpp_tstep = currentCohort%gpp_tstep * dtime + currentCohort%ts_net_uptake = currentCohort%ts_net_uptake * dtime - ! Normalize the leaf-area weighted canopy conductance - ! The denominator is the total effective leaf area in the canopy, - ! units of [m/s]*[m2] / [m2] = [m/s] - g_sb_leaves = g_sb_leaves / (elai*currentPatch%total_canopy_area) + if ( debug ) write(fates_log(),*) 'EDPhoto 911 ', currentCohort%gpp_tstep + if ( debug ) write(fates_log(),*) 'EDPhoto 912 ', currentCohort%resp_tstep + if ( debug ) write(fates_log(),*) 'EDPhoto 913 ', currentCohort%resp_m + + + currentCohort%resp_g_tstep = prt_params%grperc(ft) * & + (max(0._r8,currentCohort%gpp_tstep - currentCohort%resp_m)) + + + currentCohort%resp_tstep = currentCohort%resp_m + & + currentCohort%resp_g_tstep ! kgC/indiv/ts + currentCohort%npp_tstep = currentCohort%gpp_tstep - & + currentCohort%resp_tstep ! kgC/indiv/ts - if( g_sb_leaves > (1._r8/rsmax0) ) then + ! Accumulate the combined conductance (stomatal+leaf boundary layer) + ! Note that currentCohort%g_sb_laweight is weighted by the leaf area + ! of each cohort and has units of [m/s] * [m2 leaf] - ! Combined mean leaf resistance is the inverse of mean leaf conductance - r_sb_leaves = 1.0_r8/g_sb_leaves + g_sb_leaves = g_sb_leaves + currentCohort%g_sb_laweight - if (r_sb_leaves currentCohort%shorter + enddo do_cohort_drive - else + end if if_any_cohorts - ! Here we prevent super high resistances - ! and use a nominal value when conductance is low - r_stomata = rsmax0 + ! Normalize canopy total conductance by the effective LAI + ! The value here was integrated over each cohort x leaf layer + ! and was weighted by m2 of effective leaf area for each layer + ! preserve_b4b will be removed soon. This is kept here to prevent + ! round off errors in the baseline tests for the two-stream code (RGK 12-27-23) + if(preserve_b4b) then + patch_la = patch_la/ currentPatch%total_canopy_area + end if + + ! Normalize canopy total conductance by the effective LAI + ! The value here was integrated over each cohort x leaf layer + ! and was weighted by m2 of effective leaf area for each layer + + if_any_lai: if(patch_la>tiny(patch_la)) then + + ! Normalize the leaf-area weighted canopy conductance + ! The denominator is the total effective leaf area in the canopy, + ! units of [m/s]*[m2] / [m2] = [m/s] + ! preserve_b4b will be removed soon. This is kept here to prevent + ! round off errors in the baseline tests for the two-stream code (RGK 12-27-23) + if_preserve_b4b3: if(preserve_b4b) then + elai = calc_areaindex(currentPatch,'elai') + g_sb_leaves = g_sb_leaves / (elai*currentPatch%total_canopy_area) + else + g_sb_leaves = g_sb_leaves / max(0.1_r8*currentPatch%total_canopy_area,patch_la) + end if if_preserve_b4b3 + + + if_above_mincond: if( g_sb_leaves > (1._r8/rsmax0) ) then + + ! Combined mean leaf resistance is the inverse of mean leaf conductance + r_sb_leaves = 1.0_r8/g_sb_leaves + + if (r_sb_leaves currentPatch%younger + end do - ! But this will prevent it from using an unintialized value - bc_out(s)%rssun_pa(ifp) = rsmax0 - bc_out(s)%rssha_pa(ifp) = rsmax0 + deallocate(rootfr_ft) - ! This value is used for diagnostics, the molar form of conductance - ! is what is used in the field usually, so we track that form - currentPatch%c_stomata = cf / rsmax0 + end do !site loop - end if + end associate + end subroutine FatesPlantRespPhotosynthDrive - ! This value is used for diagnostics, the molar form of conductance - ! is what is used in the field usually, so we track that form - currentPatch%c_lblayer = cf / bc_in(s)%rb_pa(ifp) + ! =========================================================================================== - end if - end if ! not bare ground patch - currentPatch => currentPatch%younger - end do + subroutine RootLayerNFixation(t_soil,ft,dtime,fnrt_mr_layer,fnrt_mr_nfix_layer,nfix_layer) - deallocate(rootfr_ft) - end do !site loop + ! ------------------------------------------------------------------------------- + ! Symbiotic N Fixation is handled via Houlton et al 2008 and Fisher et al. 2010 + ! + ! A unifying framework for dinitrogen fixation in the terrestrial biosphere + ! Benjamin Z. Houlton, Ying-Ping Wang, Peter M. Vitousek & Christopher B. Field + ! Nature volume 454, pages327–330 (2008) https://doi.org/10.1038/nature07028 + ! + ! Carbon cost of plant nitrogen acquisition: A mechanistic, globally applicable model + ! of plant nitrogen uptake, retranslocation, and fixation. J. B. Fisher,S. Sitch,Y. + ! Malhi,R. A. Fisher,C. Huntingford,S.-Y. Tan. Global Biogeochemical Cycles. March + ! 2010 https://doi.org/10.1029/2009GB003621 + ! + ! ------------------------------------------------------------------------------ - end associate -end subroutine FatesPlantRespPhotosynthDrive -! =========================================================================================== + real(r8),intent(in) :: t_soil ! Temperature of the current soil layer [degC] + integer,intent(in) :: ft ! Functional type index + real(r8),intent(in) :: dtime ! Time step length [s] + real(r8),intent(in) :: fnrt_mr_layer ! Amount of maintenance respiration in the fine-roots + ! for all non-fixation related processes [kgC/s] + real(r8),intent(out) :: fnrt_mr_nfix_layer ! The added maintenance respiration due to nfixation + ! to be added as a surcharge to non-fixation MR [kgC] + real(r8),intent(out) :: nfix_layer ! The amount of N fixed in this layer through + ! symbiotic activity [kgN] -subroutine RootLayerNFixation(t_soil,ft,dtime,fnrt_mr_layer,fnrt_mr_nfix_layer,nfix_layer) + real(r8) :: c_cost_nfix ! carbon cost of N fixation [kgC/kgN] + real(r8) :: c_spent_nfix ! carbon spent on N fixation, per layer [kgC/plant/timestep] + ! N fixation parameters from Houlton et al (2008) and Fisher et al (2010) + real(r8), parameter :: s_fix = -6.25_r8 ! s parameter from FUN model (fisher et al 2010) + real(r8), parameter :: a_fix = -3.62_r8 ! a parameter from Houlton et al. 2010 (a = -3.62 +/- 0.52) + real(r8), parameter :: b_fix = 0.27_r8 ! b parameter from Houlton et al. 2010 (b = 0.27 +/-0.04) + real(r8), parameter :: c_fix = 25.15_r8 ! c parameter from Houlton et al. 2010 (c = 25.15 +/- 0.66) - ! ------------------------------------------------------------------------------- - ! Symbiotic N Fixation is handled via Houlton et al 2008 and Fisher et al. 2010 - ! - ! A unifying framework for dinitrogen fixation in the terrestrial biosphere - ! Benjamin Z. Houlton, Ying-Ping Wang, Peter M. Vitousek & Christopher B. Field - ! Nature volume 454, pages327–330 (2008) https://doi.org/10.1038/nature07028 - ! - ! Carbon cost of plant nitrogen acquisition: A mechanistic, globally applicable model - ! of plant nitrogen uptake, retranslocation, and fixation. J. B. Fisher,S. Sitch,Y. - ! Malhi,R. A. Fisher,C. Huntingford,S.-Y. Tan. Global Biogeochemical Cycles. March - ! 2010 https://doi.org/10.1029/2009GB003621 - ! - ! ------------------------------------------------------------------------------ + ! Amount of C spent (as part of MR respiration) on symbiotic fixation [kgC/s] + fnrt_mr_nfix_layer = fnrt_mr_layer * prt_params%nfix_mresp_scfrac(ft) - - real(r8),intent(in) :: t_soil ! Temperature of the current soil layer [degC] - integer,intent(in) :: ft ! Functional type index - real(r8),intent(in) :: dtime ! Time step length [s] - real(r8),intent(in) :: fnrt_mr_layer ! Amount of maintenance respiration in the fine-roots - ! for all non-fixation related processes [kgC/s] - - real(r8),intent(out) :: fnrt_mr_nfix_layer ! The added maintenance respiration due to nfixation - ! to be added as a surcharge to non-fixation MR [kgC] - real(r8),intent(out) :: nfix_layer ! The amount of N fixed in this layer through - ! symbiotic activity [kgN] + ! This is the unit carbon cost for nitrogen fixation. It is temperature dependant [kgC/kgN] + c_cost_nfix = s_fix * (exp(a_fix + b_fix * (t_soil-tfrz) & + * (1._r8 - 0.5_r8 * (t_soil-tfrz) / c_fix)) - 2._r8) - real(r8) :: c_cost_nfix ! carbon cost of N fixation [kgC/kgN] - real(r8) :: c_spent_nfix ! carbon spent on N fixation, per layer [kgC/plant/timestep] - - ! N fixation parameters from Houlton et al (2008) and Fisher et al (2010) - real(r8), parameter :: s_fix = -6.25_r8 ! s parameter from FUN model (fisher et al 2010) - real(r8), parameter :: a_fix = -3.62_r8 ! a parameter from Houlton et al. 2010 (a = -3.62 +/- 0.52) - real(r8), parameter :: b_fix = 0.27_r8 ! b parameter from Houlton et al. 2010 (b = 0.27 +/-0.04) - real(r8), parameter :: c_fix = 25.15_r8 ! c parameter from Houlton et al. 2010 (c = 25.15 +/- 0.66) - - ! Amount of C spent (as part of MR respiration) on symbiotic fixation [kgC/s] - fnrt_mr_nfix_layer = fnrt_mr_layer * prt_params%nfix_mresp_scfrac(ft) - - ! This is the unit carbon cost for nitrogen fixation. It is temperature dependant [kgC/kgN] - c_cost_nfix = s_fix * (exp(a_fix + b_fix * (t_soil-tfrz) & - * (1._r8 - 0.5_r8 * (t_soil-tfrz) / c_fix)) - 2._r8) - - ! Time integrated amount of carbon spent on fixation (in this layer) [kgC/plant/layer/tstep] - c_spent_nfix = fnrt_mr_nfix_layer * dtime - - ! Amount of nitrogen fixed in this layer [kgC/plant/layer/tstep]/[kgC/kgN] = [kgN/plant/layer/tstep] - nfix_layer = c_spent_nfix / c_cost_nfix - - return -end subroutine RootLayerNFixation + ! Time integrated amount of carbon spent on fixation (in this layer) [kgC/plant/layer/tstep] + c_spent_nfix = fnrt_mr_nfix_layer * dtime + + ! Amount of nitrogen fixed in this layer [kgC/plant/layer/tstep]/[kgC/kgN] = [kgN/plant/layer/tstep] + nfix_layer = c_spent_nfix / c_cost_nfix + + return + end subroutine RootLayerNFixation -! ======================================================================================= + ! ======================================================================================= subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in parsun_lsl, & ! in @@ -1462,972 +1606,971 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in end associate return -end subroutine LeafLayerPhotosynthesis + end subroutine LeafLayerPhotosynthesis -! ======================================================================================= + ! ======================================================================================= -function LeafHumidityStomaResis(leaf_psi, veg_tempk, ceair, can_press, veg_esat, & - rb, gstoma, ft) result(rstoma_out) - - ! ------------------------------------------------------------------------------------- - ! This calculates inner leaf humidity as a function of mesophyll water potential - ! Adopted from Vesala et al., 2017 https://www.frontiersin.org/articles/10.3389/fpls.2017.00054/full - ! - ! Equation 1 in Vesala et al: - ! lwp_star = wi/w0 = exp( k_lwp*leaf_psi*molar_mass_water/(rgas_J_k_mol * veg_tempk) ) - ! - ! Terms: - ! leaf_psi: leaf water potential [MPa] - ! k_lwp: inner leaf humidity scaling coefficient [-] - ! rgas_J_K_mol: universal gas constant, [J/K/mol], 8.3144598 - ! molar_mass_water, molar mass of water, [g/mol]: 18.0 - ! - ! Unit conversions: - ! 1 Pa = 1 N/m2 = 1 J/m3 - ! density of liquid water [kg/m3] = 1000 - ! - ! units of equation 1: exp( [MPa]*[g/mol]/( [J/K/mol] * [K] ) ) - ! [MJ/m3]*[g/mol]*[m3/kg]*[kg/g]*[J/MJ] / ([J/mol]) - ! dimensionless: [J/g]*[g/mol]/([J/mol]) - ! - ! Note: unit conversions drop out b/c [m3/kg]*[kg/g]*[J/MJ] = 1e-3*1.e-3*1e6 = 1.0 - ! - ! Junyan Ding 2021 - ! ------------------------------------------------------------------------------------- - - ! Arguments - real(r8) :: leaf_psi ! Leaf water potential [MPa] - real(r8) :: veg_tempk ! Leaf temperature [K] - real(r8) :: ceair ! vapor pressure of air, constrained [Pa] - real(r8) :: can_press ! Atmospheric pressure of canopy [Pa] - real(r8) :: veg_esat ! Saturated vapor pressure at veg surf [Pa] - real(r8) :: rb ! Leaf Boundary layer resistance [s/m] - real(r8) :: gstoma ! Stomatal Conductance of this leaf layer [m/s] - integer :: ft ! Plant Functional Type - real(r8) :: rstoma_out ! Total Stomatal resistance (stoma and BL) [s/m] - - ! Locals - real(r8) :: k_lwp ! Scaling coefficient for the ratio of leaf xylem - ! water potential to mesophyll water potential - real(r8) :: qs ! Specific humidity [g/kg] - real(r8) :: qsat ! Saturation specific humidity [g/kg] - real(r8) :: qsat_adj ! Adjusted saturation specific humidity [g/kg] - real(r8) :: lwp_star ! leaf water potential scaling coefficient - ! for inner leaf humidity, 0 means total dehydroted - ! leaf, 1 means total saturated leaf - - ! Note: to disable this control, set k_lwp to zero, LWP_star will be 1 - k_lwp = EDPftvarcon_inst%hydr_k_lwp(ft) - if (leaf_psi<0._r8) then - lwp_star = exp(k_lwp*leaf_psi*molar_mass_water/(rgas_J_K_mol *veg_tempk)) - else - lwp_star = 1._r8 - end if + function LeafHumidityStomaResis(leaf_psi, veg_tempk, ceair, can_press, veg_esat, & + rb, gstoma, ft) result(rstoma_out) - ! compute specific humidity from vapor pressure - ! q = molar_mass_ratio_vapdry*e/(can_press - (1-molar_mass_ratio_vapdry)*e) - ! source https://cran.r-project.org/web/packages/humidity/vignettes/humidity-measures.html - ! now adjust inner leaf humidity by LWP_star + ! ------------------------------------------------------------------------------------- + ! This calculates inner leaf humidity as a function of mesophyll water potential + ! Adopted from Vesala et al., 2017 https://www.frontiersin.org/articles/10.3389/fpls.2017.00054/full + ! + ! Equation 1 in Vesala et al: + ! lwp_star = wi/w0 = exp( k_lwp*leaf_psi*molar_mass_water/(rgas_J_k_mol * veg_tempk) ) + ! + ! Terms: + ! leaf_psi: leaf water potential [MPa] + ! k_lwp: inner leaf humidity scaling coefficient [-] + ! rgas_J_K_mol: universal gas constant, [J/K/mol], 8.3144598 + ! molar_mass_water, molar mass of water, [g/mol]: 18.0 + ! + ! Unit conversions: + ! 1 Pa = 1 N/m2 = 1 J/m3 + ! density of liquid water [kg/m3] = 1000 + ! + ! units of equation 1: exp( [MPa]*[g/mol]/( [J/K/mol] * [K] ) ) + ! [MJ/m3]*[g/mol]*[m3/kg]*[kg/g]*[J/MJ] / ([J/mol]) + ! dimensionless: [J/g]*[g/mol]/([J/mol]) + ! + ! Note: unit conversions drop out b/c [m3/kg]*[kg/g]*[J/MJ] = 1e-3*1.e-3*1e6 = 1.0 + ! + ! Junyan Ding 2021 + ! ------------------------------------------------------------------------------------- + + ! Arguments + real(r8) :: leaf_psi ! Leaf water potential [MPa] + real(r8) :: veg_tempk ! Leaf temperature [K] + real(r8) :: ceair ! vapor pressure of air, constrained [Pa] + real(r8) :: can_press ! Atmospheric pressure of canopy [Pa] + real(r8) :: veg_esat ! Saturated vapor pressure at veg surf [Pa] + real(r8) :: rb ! Leaf Boundary layer resistance [s/m] + real(r8) :: gstoma ! Stomatal Conductance of this leaf layer [m/s] + integer :: ft ! Plant Functional Type + real(r8) :: rstoma_out ! Total Stomatal resistance (stoma and BL) [s/m] + + ! Locals + real(r8) :: k_lwp ! Scaling coefficient for the ratio of leaf xylem + ! water potential to mesophyll water potential + real(r8) :: qs ! Specific humidity [g/kg] + real(r8) :: qsat ! Saturation specific humidity [g/kg] + real(r8) :: qsat_adj ! Adjusted saturation specific humidity [g/kg] + real(r8) :: lwp_star ! leaf water potential scaling coefficient + ! for inner leaf humidity, 0 means total dehydroted + ! leaf, 1 means total saturated leaf + + ! Note: to disable this control, set k_lwp to zero, LWP_star will be 1 + k_lwp = EDPftvarcon_inst%hydr_k_lwp(ft) + if (leaf_psi<0._r8) then + lwp_star = exp(k_lwp*leaf_psi*molar_mass_water/(rgas_J_K_mol *veg_tempk)) + else + lwp_star = 1._r8 + end if + + ! compute specific humidity from vapor pressure + ! q = molar_mass_ratio_vapdry*e/(can_press - (1-molar_mass_ratio_vapdry)*e) + ! source https://cran.r-project.org/web/packages/humidity/vignettes/humidity-measures.html + ! now adjust inner leaf humidity by LWP_star + + qs = molar_mass_ratio_vapdry * ceair / (can_press - (1._r8-molar_mass_ratio_vapdry) * ceair) + qsat = molar_mass_ratio_vapdry * veg_esat / (can_press - (1._r8-molar_mass_ratio_vapdry) * veg_esat) + qsat_adj = qsat*lwp_star + + ! Adjusting gs (compute a virtual gs) that will be passed to host model + + if ( qsat_adj < qs ) then + + ! if inner leaf vapor pressure is less then or equal to that at leaf surface + ! then set stomata resistance to be very large to stop the transpiration or back flow of vapor + rstoma_out = rsmax0 + + else + + rstoma_out = (qsat-qs)*( 1/gstoma + rb)/(qsat_adj - qs)-rb + + end if + + if (rstoma_out < nearzero ) then + write (fates_log(),*) 'qsat:', qsat, 'qs:', qs + write (fates_log(),*) 'LWP :', leaf_psi + write (fates_log(),*) 'ceair:', ceair, 'veg_esat:', veg_esat + write (fates_log(),*) 'rstoma_out:', rstoma_out, 'rb:', rb + write (fates_log(),*) 'LWP_star', lwp_star + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + end function LeafHumidityStomaResis + + + ! ===================================================================================== + + subroutine ScaleLeafLayerFluxToCohort(nv, & ! in currentCohort%nv + psn_llz, & ! in %psn_z(1:currentCohort%nv,ft,cl) + lmr_llz, & ! in lmr_z(1:currentCohort%nv,ft,cl) + rs_llz, & ! in rs_z(1:currentCohort%nv,ft,cl) + elai_llz, & ! in %elai_profile(cl,ft,1:currentCohort%nv) + c13disc_llz, & ! in c13disc_z(cl, ft, 1:currentCohort%nv) + c_area, & ! in currentCohort%c_area + nplant, & ! in currentCohort%n + rb, & ! in bc_in(s)%rb_pa(ifp) + maintresp_reduction_factor, & ! in + g_sb_laweight, & ! out currentCohort%g_sb_laweight [m/s] [m2-leaf] + gpp, & ! out currentCohort%gpp_tstep + rdark, & ! out currentCohort%rdark + c13disc_clm, & ! out currentCohort%c13disc_clm + cohort_eleaf_area ) ! out [m2] + + ! ------------------------------------------------------------------------------------ + ! This subroutine effectively integrates leaf carbon fluxes over the + ! leaf layers to give cohort totals. + ! Some arguments have the suffix "_llz". This indicates that the vector + ! is stratefied in the leaf-layer (ll) dimension, and is a portion of the calling + ! array which has the "_z" tag, thus "llz". + ! ------------------------------------------------------------------------------------ - qs = molar_mass_ratio_vapdry * ceair / (can_press - (1._r8-molar_mass_ratio_vapdry) * ceair) - qsat = molar_mass_ratio_vapdry * veg_esat / (can_press - (1._r8-molar_mass_ratio_vapdry) * veg_esat) - qsat_adj = qsat*lwp_star + use FatesConstantsMod, only : umolC_to_kgC - ! Adjusting gs (compute a virtual gs) that will be passed to host model + ! Arguments + integer, intent(in) :: nv ! number of active leaf layers + real(r8), intent(in) :: psn_llz(nv) ! layer photosynthesis rate (GPP) [umolC/m2leaf/s] + real(r8), intent(in) :: lmr_llz(nv) ! layer dark respiration rate [umolC/m2leaf/s] + real(r8), intent(in) :: rs_llz(nv) ! leaf layer stomatal resistance [s/m] + real(r8), intent(in) :: elai_llz(nv) ! exposed LAI per layer [m2 leaf/ m2 pft footprint] + real(r8), intent(in) :: c13disc_llz(nv) ! leaf layer c13 discrimination, weighted mean + real(r8), intent(in) :: c_area ! crown area m2/m2 + real(r8), intent(in) :: nplant ! indiv/m2 + real(r8), intent(in) :: rb ! leaf boundary layer resistance (s/m) + real(r8), intent(in) :: maintresp_reduction_factor ! factor by which to reduce maintenance respiration + real(r8), intent(out) :: g_sb_laweight ! Combined conductance (stomatal + boundary layer) for the cohort + ! weighted by leaf area [m/s]*[m2] + real(r8), intent(out) :: gpp ! GPP (kgC/indiv/s) + real(r8), intent(out) :: rdark ! Dark Leaf Respiration (kgC/indiv/s) + real(r8), intent(out) :: cohort_eleaf_area ! Effective leaf area of the cohort [m2] + real(r8), intent(out) :: c13disc_clm ! unpacked Cohort level c13 discrimination + real(r8) :: sum_weight ! sum of weight for unpacking d13c flux (c13disc_z) from + ! (canopy_layer, pft, leaf_layer) matrix to cohort (c13disc_clm) + + ! GPP IN THIS SUBROUTINE IS A RATE. THE CALLING ARGUMENT IS GPP_TSTEP. AFTER THIS + ! CALL THE RATE WILL BE MULTIPLIED BY THE INTERVAL TO GIVE THE INTEGRATED QUANT. + + ! Locals + integer :: il ! leaf layer index + real(r8) :: cohort_layer_eleaf_area ! the effective leaf area of the cohort's current layer [m2] + + cohort_eleaf_area = 0.0_r8 + g_sb_laweight = 0.0_r8 + gpp = 0.0_r8 + rdark = 0.0_r8 + + do il = 1, nv ! Loop over the leaf layers this cohort participates in + + + ! Cohort's total effective leaf area in this layer [m2] + ! leaf area index of the layer [m2/m2 ground] * [m2 ground] + ! elai_llz is the LAI for the whole PFT. Multiplying this by the ground + ! area this cohort contributes, give the cohort's portion of the leaf + ! area in this layer + cohort_layer_eleaf_area = elai_llz(il) * c_area + + ! Increment the cohort's total effective leaf area [m2] + cohort_eleaf_area = cohort_eleaf_area + cohort_layer_eleaf_area + + ! Leaf conductance (stomatal and boundary layer) + ! This should be the weighted average over the leaf surfaces. + ! Since this is relevant to the stomata, its weighting should be based + ! on total leaf area, and not really footprint area + ! [m/s] * [m2 cohort's leaf layer] + g_sb_laweight = g_sb_laweight + 1.0_r8/(rs_llz(il)+rb) * cohort_layer_eleaf_area + + ! GPP [umolC/m2leaf/s] * [m2 leaf ] -> [umolC/s] + gpp = gpp + psn_llz(il) * cohort_layer_eleaf_area + + ! Dark respiration + ! [umolC/m2leaf/s] * [m2 leaf] + rdark = rdark + lmr_llz(il) * cohort_layer_eleaf_area + + end do + + + + if (nv > 1) then + ! cohort%c13disc_clm as weighted mean of d13c flux at all related leave layers + sum_weight = sum(psn_llz(1:nv-1) * elai_llz(1:nv-1)) + if (sum_weight .eq. 0.0_r8) then + c13disc_clm = 0.0 + else + c13disc_clm = sum(c13disc_llz(1:nv-1) * psn_llz(1:nv-1) * elai_llz(1:nv-1)) / sum_weight + end if + + end if - if ( qsat_adj < qs ) then - ! if inner leaf vapor pressure is less then or equal to that at leaf surface - ! then set stomata resistance to be very large to stop the transpiration or back flow of vapor - rstoma_out = rsmax0 - - else + ! ----------------------------------------------------------------------------------- + ! We DO NOT normalize g_sb_laweight. + ! The units that we are passing back are [m/s] * [m2 effective leaf] + ! We will add these up over the whole patch, and then normalized + ! by the patch's total leaf area in the calling routine + ! ----------------------------------------------------------------------------------- - rstoma_out = (qsat-qs)*( 1/gstoma + rb)/(qsat_adj - qs)-rb - - end if - - if (rstoma_out < nearzero ) then - write (fates_log(),*) 'qsat:', qsat, 'qs:', qs - write (fates_log(),*) 'LWP :', leaf_psi - write (fates_log(),*) 'ceair:', ceair, 'veg_esat:', veg_esat - write (fates_log(),*) 'rstoma_out:', rstoma_out, 'rb:', rb - write (fates_log(),*) 'LWP_star', lwp_star - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if + ! ----------------------------------------------------------------------------------- + ! Convert dark respiration and GPP from [umol/s] to [kgC/plant/s] + ! Also, apply the maintenance respiration reduction factor + ! ----------------------------------------------------------------------------------- -end function LeafHumidityStomaResis + rdark = rdark * umolC_to_kgC * maintresp_reduction_factor / nplant + gpp = gpp * umolC_to_kgC / nplant + if ( debug ) then + write(fates_log(),*) 'EDPhoto 816 ', gpp + write(fates_log(),*) 'EDPhoto 817 ', psn_llz(1:nv) + write(fates_log(),*) 'EDPhoto 820 ', nv + write(fates_log(),*) 'EDPhoto 821 ', elai_llz(1:nv) + write(fates_log(),*) 'EDPhoto 843 ', rdark + write(fates_log(),*) 'EDPhoto 873 ', nv + write(fates_log(),*) 'EDPhoto 874 ', cohort_eleaf_area + endif -! ===================================================================================== + return + end subroutine ScaleLeafLayerFluxToCohort -subroutine ScaleLeafLayerFluxToCohort(nv, & ! in currentCohort%nv - psn_llz, & ! in %psn_z(1:currentCohort%nv,ft,cl) - lmr_llz, & ! in lmr_z(1:currentCohort%nv,ft,cl) - rs_llz, & ! in rs_z(1:currentCohort%nv,ft,cl) - elai_llz, & ! in %elai_profile(cl,ft,1:currentCohort%nv) - c13disc_llz, & ! in c13disc_z(cl, ft, 1:currentCohort%nv) - c_area, & ! in currentCohort%c_area - nplant, & ! in currentCohort%n - rb, & ! in bc_in(s)%rb_pa(ifp) - maintresp_reduction_factor, & ! in - g_sb_laweight, & ! out currentCohort%g_sb_laweight [m/s] [m2-leaf] - gpp, & ! out currentCohort%gpp_tstep - rdark, & ! out currentCohort%rdark - c13disc_clm, & ! out currentCohort%c13disc_clm - cohort_eleaf_area ) ! out [m2] + ! ===================================================================================== - ! ------------------------------------------------------------------------------------ - ! This subroutine effectively integrates leaf carbon fluxes over the - ! leaf layers to give cohort totals. - ! Some arguments have the suffix "_llz". This indicates that the vector - ! is stratefied in the leaf-layer (ll) dimension, and is a portion of the calling - ! array which has the "_z" tag, thus "llz". - ! ------------------------------------------------------------------------------------ + function ft1_f(tl, ha) result(ans) + ! + !!DESCRIPTION: + ! photosynthesis temperature response + ! + ! !REVISION HISTORY + ! Jinyun Tang separated it out from Photosynthesis, Feb. 07/2013 + ! 7/23/16: Copied over from CLM by Ryan Knox + ! + !!USES + use FatesConstantsMod, only : rgas => rgas_J_K_kmol - use FatesConstantsMod, only : umolC_to_kgC - - ! Arguments - integer, intent(in) :: nv ! number of active leaf layers - real(r8), intent(in) :: psn_llz(nv) ! layer photosynthesis rate (GPP) [umolC/m2leaf/s] - real(r8), intent(in) :: lmr_llz(nv) ! layer dark respiration rate [umolC/m2leaf/s] - real(r8), intent(in) :: rs_llz(nv) ! leaf layer stomatal resistance [s/m] - real(r8), intent(in) :: elai_llz(nv) ! exposed LAI per layer [m2 leaf/ m2 pft footprint] - real(r8), intent(in) :: c13disc_llz(nv) ! leaf layer c13 discrimination, weighted mean - real(r8), intent(in) :: c_area ! crown area m2/m2 - real(r8), intent(in) :: nplant ! indiv/m2 - real(r8), intent(in) :: rb ! leaf boundary layer resistance (s/m) - real(r8), intent(in) :: maintresp_reduction_factor ! factor by which to reduce maintenance respiration - real(r8), intent(out) :: g_sb_laweight ! Combined conductance (stomatal + boundary layer) for the cohort - ! weighted by leaf area [m/s]*[m2] - real(r8), intent(out) :: gpp ! GPP (kgC/indiv/s) - real(r8), intent(out) :: rdark ! Dark Leaf Respiration (kgC/indiv/s) - real(r8), intent(out) :: cohort_eleaf_area ! Effective leaf area of the cohort [m2] - real(r8), intent(out) :: c13disc_clm ! unpacked Cohort level c13 discrimination - real(r8) :: sum_weight ! sum of weight for unpacking d13c flux (c13disc_z) from - ! (canopy_layer, pft, leaf_layer) matrix to cohort (c13disc_clm) - - ! GPP IN THIS SUBROUTINE IS A RATE. THE CALLING ARGUMENT IS GPP_TSTEP. AFTER THIS - ! CALL THE RATE WILL BE MULTIPLIED BY THE INTERVAL TO GIVE THE INTEGRATED QUANT. - - ! Locals - integer :: il ! leaf layer index - real(r8) :: cohort_layer_eleaf_area ! the effective leaf area of the cohort's current layer [m2] - - cohort_eleaf_area = 0.0_r8 - g_sb_laweight = 0.0_r8 - gpp = 0.0_r8 - rdark = 0.0_r8 - - do il = 1, nv ! Loop over the leaf layers this cohort participates in - - - ! Cohort's total effective leaf area in this layer [m2] - ! leaf area index of the layer [m2/m2 ground] * [m2 ground] - ! elai_llz is the LAI for the whole PFT. Multiplying this by the ground - ! area this cohort contributes, give the cohort's portion of the leaf - ! area in this layer - cohort_layer_eleaf_area = elai_llz(il) * c_area - - ! Increment the cohort's total effective leaf area [m2] - cohort_eleaf_area = cohort_eleaf_area + cohort_layer_eleaf_area - - ! Leaf conductance (stomatal and boundary layer) - ! This should be the weighted average over the leaf surfaces. - ! Since this is relevant to the stomata, its weighting should be based - ! on total leaf area, and not really footprint area - ! [m/s] * [m2 cohort's leaf layer] - g_sb_laweight = g_sb_laweight + 1.0_r8/(rs_llz(il)+rb) * cohort_layer_eleaf_area - - ! GPP [umolC/m2leaf/s] * [m2 leaf ] -> [umolC/s] (This is cohort group sum) - gpp = gpp + psn_llz(il) * cohort_layer_eleaf_area - - ! Dark respiration - ! [umolC/m2leaf/s] * [m2 leaf] (This is the cohort group sum) - rdark = rdark + lmr_llz(il) * cohort_layer_eleaf_area - - end do - - - - if (nv > 1) then - ! cohort%c13disc_clm as weighted mean of d13c flux at all related leave layers - sum_weight = sum(psn_llz(1:nv-1) * elai_llz(1:nv-1)) - if (sum_weight .eq. 0.0_r8) then - c13disc_clm = 0.0 - else - c13disc_clm = sum(c13disc_llz(1:nv-1) * psn_llz(1:nv-1) * elai_llz(1:nv-1)) / sum_weight - end if - - end if - - - ! ----------------------------------------------------------------------------------- - ! We DO NOT normalize g_sb_laweight. - ! The units that we are passing back are [m/s] * [m2 effective leaf] - ! We will add these up over the whole patch, and then normalized - ! by the patch's total leaf area in the calling routine - ! ----------------------------------------------------------------------------------- - - ! ----------------------------------------------------------------------------------- - ! Convert dark respiration and GPP from [umol/s] to [kgC/plant/s] - ! Also, apply the maintenance respiration reduction factor - ! ----------------------------------------------------------------------------------- - - rdark = rdark * umolC_to_kgC * maintresp_reduction_factor / nplant - gpp = gpp * umolC_to_kgC / nplant - - if ( debug ) then - write(fates_log(),*) 'EDPhoto 816 ', gpp - write(fates_log(),*) 'EDPhoto 817 ', psn_llz(1:nv) - write(fates_log(),*) 'EDPhoto 820 ', nv - write(fates_log(),*) 'EDPhoto 821 ', elai_llz(1:nv) - write(fates_log(),*) 'EDPhoto 843 ', rdark - write(fates_log(),*) 'EDPhoto 873 ', nv - write(fates_log(),*) 'EDPhoto 874 ', cohort_eleaf_area - endif + ! + ! !ARGUMENTS: + real(r8), intent(in) :: tl ! leaf temperature in photosynthesis temperature function (K) + real(r8), intent(in) :: ha ! activation energy in photosynthesis temperature function (J/mol) + ! + ! !LOCAL VARIABLES: + real(r8) :: ans + !------------------------------------------------------------------------------- - return -end subroutine ScaleLeafLayerFluxToCohort + ans = exp( ha / (rgas*1.e-3_r8*(tfrz+25._r8)) * (1._r8 - (tfrz+25._r8)/tl) ) -! ===================================================================================== + return + end function ft1_f -function ft1_f(tl, ha) result(ans) - ! - !!DESCRIPTION: - ! photosynthesis temperature response - ! - ! !REVISION HISTORY - ! Jinyun Tang separated it out from Photosynthesis, Feb. 07/2013 - ! 7/23/16: Copied over from CLM by Ryan Knox - ! - !!USES - use FatesConstantsMod, only : rgas => rgas_J_K_kmol - - ! - ! !ARGUMENTS: - real(r8), intent(in) :: tl ! leaf temperature in photosynthesis temperature function (K) - real(r8), intent(in) :: ha ! activation energy in photosynthesis temperature function (J/mol) - ! - ! !LOCAL VARIABLES: - real(r8) :: ans - !------------------------------------------------------------------------------- + ! ===================================================================================== - ans = exp( ha / (rgas*1.e-3_r8*(tfrz+25._r8)) * (1._r8 - (tfrz+25._r8)/tl) ) + function fth_f(tl,hd,se,scaleFactor) result(ans) + ! + !!DESCRIPTION: + !photosynthesis temperature inhibition + ! + ! !REVISION HISTORY + ! Jinyun Tang separated it out from Photosynthesis, Feb. 07/2013 + ! 7/23/16: Copied over from CLM by Ryan Knox + ! + use FatesConstantsMod, only : rgas => rgas_J_K_kmol - return -end function ft1_f + ! + ! !ARGUMENTS: + real(r8), intent(in) :: tl ! leaf temperature in photosynthesis temp function (K) + real(r8), intent(in) :: hd ! deactivation energy in photosynthesis temp function (J/mol) + real(r8), intent(in) :: se ! entropy term in photosynthesis temp function (J/mol/K) + real(r8), intent(in) :: scaleFactor ! scaling factor for high temp inhibition (25 C = 1.0) + ! + ! !LOCAL VARIABLES: + real(r8) :: ans + !------------------------------------------------------------------------------- -! ===================================================================================== + ans = scaleFactor / ( 1._r8 + exp( (-hd+se*tl) / (rgas*1.e-3_r8*tl) ) ) -function fth_f(tl,hd,se,scaleFactor) result(ans) - ! - !!DESCRIPTION: - !photosynthesis temperature inhibition - ! - ! !REVISION HISTORY - ! Jinyun Tang separated it out from Photosynthesis, Feb. 07/2013 - ! 7/23/16: Copied over from CLM by Ryan Knox - ! - use FatesConstantsMod, only : rgas => rgas_J_K_kmol + return + end function fth_f - ! - ! !ARGUMENTS: - real(r8), intent(in) :: tl ! leaf temperature in photosynthesis temp function (K) - real(r8), intent(in) :: hd ! deactivation energy in photosynthesis temp function (J/mol) - real(r8), intent(in) :: se ! entropy term in photosynthesis temp function (J/mol/K) - real(r8), intent(in) :: scaleFactor ! scaling factor for high temp inhibition (25 C = 1.0) - ! - ! !LOCAL VARIABLES: - real(r8) :: ans - !------------------------------------------------------------------------------- + ! ===================================================================================== - ans = scaleFactor / ( 1._r8 + exp( (-hd+se*tl) / (rgas*1.e-3_r8*tl) ) ) + function fth25_f(hd,se)result(ans) + ! + !!DESCRIPTION: + ! scaling factor for photosynthesis temperature inhibition + ! + ! !REVISION HISTORY: + ! Jinyun Tang separated it out from Photosynthesis, Feb. 07/2013 + ! 7/23/16: Copied over from CLM by Ryan Knox + ! + !!USES - return -end function fth_f + use FatesConstantsMod, only : rgas => rgas_J_K_kmol -! ===================================================================================== + ! + ! !ARGUMENTS: + real(r8), intent(in) :: hd ! deactivation energy in photosynthesis temp function (J/mol) + real(r8), intent(in) :: se ! entropy term in photosynthesis temp function (J/mol/K) + ! + ! !LOCAL VARIABLES: + real(r8) :: ans + !------------------------------------------------------------------------------- -function fth25_f(hd,se)result(ans) - ! - !!DESCRIPTION: - ! scaling factor for photosynthesis temperature inhibition - ! - ! !REVISION HISTORY: - ! Jinyun Tang separated it out from Photosynthesis, Feb. 07/2013 - ! 7/23/16: Copied over from CLM by Ryan Knox - ! - !!USES + ans = 1._r8 + exp( (-hd+se*(tfrz+25._r8)) / (rgas*1.e-3_r8*(tfrz+25._r8)) ) - use FatesConstantsMod, only : rgas => rgas_J_K_kmol + return + end function fth25_f - ! - ! !ARGUMENTS: - real(r8), intent(in) :: hd ! deactivation energy in photosynthesis temp function (J/mol) - real(r8), intent(in) :: se ! entropy term in photosynthesis temp function (J/mol/K) - ! - ! !LOCAL VARIABLES: - real(r8) :: ans - !------------------------------------------------------------------------------- + ! ===================================================================================== - ans = 1._r8 + exp( (-hd+se*(tfrz+25._r8)) / (rgas*1.e-3_r8*(tfrz+25._r8)) ) + subroutine quadratic_f (a, b, c, r1, r2) + ! + ! !DESCRIPTION: + !==============================================================================! + !----------------- Solve quadratic equation for its two roots -----------------! + !==============================================================================! + ! This solution is mostly derived from: + ! Press WH, Teukolsky SA, Vetterling WT, Flannery BP. 1992. Numerical Recipes + ! in Fortran77: The Art of Scientific Computing. 2nd edn. Cambridge + ! University Press, Cambridge UK, ISBN 0-521-43064-X. + ! Available at: http://numerical.recipes/oldverswitcher.html, section 5.6. + ! + ! !REVISION HISTORY: + ! 4/5/10: Adapted from /home/bonan/ecm/psn/An_gs_iterative.f90 by Keith Oleson + ! 7/23/16: Copied over from CLM by Ryan Knox + ! 12/30/23: Instead of issuing errors when a=0, solve the trivial cases too. + ! Check determinant sign, and stop the run when it is negative. + ! + ! !USES: + ! + ! !ARGUMENTS: + real(r8), intent(in) :: a,b,c ! Terms for quadratic equation + real(r8), intent(out) :: r1,r2 ! Roots of quadratic equation + ! + ! !LOCAL VARIABLES: + real(r8) :: discriminant ! Discriminant + real(r8) :: q ! Temporary term for quadratic solution + logical :: a_offzero ! Is a close to zero? + logical :: b_offzero ! Is b close to zero? + logical :: c_offzero ! Is c close to zero? + ! ! Local constants: + real(r8), parameter :: discard = 1.e36_r8 ! Large number for discarding answer + !------------------------------------------------------------------------------ + + ! Save logical tests. + a_offzero = abs(a) > nearzero + b_offzero = abs(b) > nearzero + c_offzero = abs(c) > nearzero + + if (a_offzero .and. ( b_offzero .or. c_offzero ) ) then + ! Quadratic equation with two non-zero solutions (but may be complex solutions) + discriminant = b*b - 4._r8 * a * c + + ! Proceed only when the discriminant is non-negative or only tiny negative + if (discriminant >= - nearzero) then + ! Coerce discriminant to non-negative + discriminant = max(0._r8,discriminant) + + ! Find q as in the numerical recipes. If b or c are non-zero, q cannot + ! be zero, no need for additional checks. + q = - 0.5_r8 * (b + sign(sqrt(discriminant),b)) + r1 = q / a + r2 = c / q + else + ! Negative discriminant, stop the run. + write (fates_log(),'(a)') '---~---' + write (fates_log(),'(a)') ' Fatal error!' + write (fates_log(),'(a)') ' Quadratic equation discriminant is negative.' + write (fates_log(),'(a)') '---~---' + write (fates_log(),'(a,1x,es12.5)') ' a = ',a + write (fates_log(),'(a,1x,es12.5)') ' b = ',b + write (fates_log(),'(a,1x,es12.5)') ' c = ',c + write (fates_log(),'(a,1x,es12.5)') ' discriminant = ',discriminant + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + else if (a_offzero) then + ! b and c are nearly zero. Both roots must be zero. + r1 = 0._r8 + r2 = 0._r8 + else if (b_offzero) then + ! "a" is not zero, not a true quadratic equation. Single root. + r1 = - c / b + r2 = discard + else + ! Both a and b are zero, this really doesn't make any sense and should never + ! happen. If it does, issue an error and stop the run. + write (fates_log(),'(a)') '---~---' + write (fates_log(),'(a)') ' Fatal error!' + write (fates_log(),'(a)') ' This solver expects ''a'' and/or ''b'' to be non-zero.' + write (fates_log(),'(a)') '---~---' + write (fates_log(),'(a,1x,es12.5)') ' a = ',a + write (fates_log(),'(a,1x,es12.5)') ' b = ',b + write (fates_log(),'(a,1x,es12.5)') ' c = ',c + write (fates_log(),'(a)') '---~---' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + return + end subroutine quadratic_f + + ! ==================================================================================== + + subroutine quadratic_fast (a, b, c, r1, r2) + ! + ! !DESCRIPTION: + !==============================================================================! + !----------------- Solve quadratic equation for its two roots -----------------! + ! THIS METHOD SIMPLY REMOVES THE DIV0 CHECK AND ERROR REPORTING ! + !==============================================================================! + ! Solution from Press et al (1986) Numerical Recipes: The Art of Scientific + ! Computing (Cambridge University Press, Cambridge), pp. 145. + ! + ! !REVISION HISTORY: + ! 4/5/10: Adapted from /home/bonan/ecm/psn/An_gs_iterative.f90 by Keith Oleson + ! 7/23/16: Copied over from CLM by Ryan Knox + ! + ! !USES: + ! + ! !ARGUMENTS: + real(r8), intent(in) :: a,b,c ! Terms for quadratic equation + real(r8), intent(out) :: r1,r2 ! Roots of quadratic equation + ! + ! !LOCAL VARIABLES: + real(r8) :: q ! Temporary term for quadratic solution + !------------------------------------------------------------------------------ - return -end function fth25_f + ! if (a == 0._r8) then + ! write (fates_log(),*) 'Quadratic solution error: a = ',a + ! call endrun(msg=errMsg(sourcefile, __LINE__)) + ! end if -! ===================================================================================== + if (b >= 0._r8) then + q = -0.5_r8 * (b + sqrt(b*b - 4._r8*a*c)) + else + q = -0.5_r8 * (b - sqrt(b*b - 4._r8*a*c)) + end if -subroutine quadratic_f (a, b, c, r1, r2) - ! - ! !DESCRIPTION: - !==============================================================================! - !----------------- Solve quadratic equation for its two roots -----------------! - !==============================================================================! - ! This solution is mostly derived from: - ! Press WH, Teukolsky SA, Vetterling WT, Flannery BP. 1992. Numerical Recipes - ! in Fortran77: The Art of Scientific Computing. 2nd edn. Cambridge - ! University Press, Cambridge UK, ISBN 0-521-43064-X. - ! Available at: http://numerical.recipes/oldverswitcher.html, section 5.6. - ! - ! !REVISION HISTORY: - ! 4/5/10: Adapted from /home/bonan/ecm/psn/An_gs_iterative.f90 by Keith Oleson - ! 7/23/16: Copied over from CLM by Ryan Knox - ! 12/30/23: Instead of issuing errors when a=0, solve the trivial cases too. - ! Check determinant sign, and stop the run when it is negative. - ! - ! !USES: - ! - ! !ARGUMENTS: - real(r8), intent(in) :: a,b,c ! Terms for quadratic equation - real(r8), intent(out) :: r1,r2 ! Roots of quadratic equation - ! - ! !LOCAL VARIABLES: - real(r8) :: discriminant ! Discriminant - real(r8) :: q ! Temporary term for quadratic solution - logical :: a_offzero ! Is a close to zero? - logical :: b_offzero ! Is b close to zero? - logical :: c_offzero ! Is c close to zero? - ! ! Local constants: - real(r8), parameter :: discard = 1.e36_r8 ! Large number for discarding answer - !------------------------------------------------------------------------------ - - - ! Save logical tests. - a_offzero = abs(a) > nearzero - b_offzero = abs(b) > nearzero - c_offzero = abs(c) > nearzero - - if (a_offzero .and. ( b_offzero .or. c_offzero ) ) then - ! Quadratic equation with two non-zero solutions (but may be complex solutions) - discriminant = b*b - 4._r8 * a * c - - ! Proceed only when the discriminant is non-negative or only tiny negative - if (discriminant >= - nearzero) then - ! Coerce discriminant to non-negative - discriminant = max(0._r8,discriminant) - - ! Find q as in the numerical recipes. If b or c are non-zero, q cannot - ! be zero, no need for additional checks. - q = - 0.5_r8 * (b + sign(sqrt(discriminant),b)) - r1 = q / a - r2 = c / q - else - ! Negative discriminant, stop the run. - write (fates_log(),'(a)') '---~---' - write (fates_log(),'(a)') ' Fatal error!' - write (fates_log(),'(a)') ' Quadratic equation discriminant is negative.' - write (fates_log(),'(a)') '---~---' - write (fates_log(),'(a,1x,es12.5)') ' a = ',a - write (fates_log(),'(a,1x,es12.5)') ' b = ',b - write (fates_log(),'(a,1x,es12.5)') ' c = ',c - write (fates_log(),'(a,1x,es12.5)') ' discriminant = ',discriminant - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - else if (a_offzero) then - ! b and c are nearly zero. Both roots must be zero. - r1 = 0._r8 - r2 = 0._r8 - else if (b_offzero) then - ! "a" is not zero, not a true quadratic equation. Single root. - r1 = - c / b - r2 = discard - else - ! Both a and b are zero, this really doesn't make any sense and should never - ! happen. If it does, issue an error and stop the run. - write (fates_log(),'(a)') '---~---' - write (fates_log(),'(a)') ' Fatal error!' - write (fates_log(),'(a)') ' This solver expects ''a'' and/or ''b'' to be non-zero.' - write (fates_log(),'(a)') '---~---' - write (fates_log(),'(a,1x,es12.5)') ' a = ',a - write (fates_log(),'(a,1x,es12.5)') ' b = ',b - write (fates_log(),'(a,1x,es12.5)') ' c = ',c - write (fates_log(),'(a)') '---~---' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if + r1 = q / a + ! if (q /= 0._r8) then + r2 = c / q + ! else + ! r2 = 1.e36_r8 + ! end if - return -end subroutine quadratic_f + end subroutine quadratic_fast -! ==================================================================================== -subroutine quadratic_fast (a, b, c, r1, r2) - ! - ! !DESCRIPTION: - !==============================================================================! - !----------------- Solve quadratic equation for its two roots -----------------! - ! THIS METHOD SIMPLY REMOVES THE DIV0 CHECK AND ERROR REPORTING ! - !==============================================================================! - ! Solution from Press et al (1986) Numerical Recipes: The Art of Scientific - ! Computing (Cambridge University Press, Cambridge), pp. 145. - ! - ! !REVISION HISTORY: - ! 4/5/10: Adapted from /home/bonan/ecm/psn/An_gs_iterative.f90 by Keith Oleson - ! 7/23/16: Copied over from CLM by Ryan Knox - ! - ! !USES: - ! - ! !ARGUMENTS: - real(r8), intent(in) :: a,b,c ! Terms for quadratic equation - real(r8), intent(out) :: r1,r2 ! Roots of quadratic equation - ! - ! !LOCAL VARIABLES: - real(r8) :: q ! Temporary term for quadratic solution - !------------------------------------------------------------------------------ - - ! if (a == 0._r8) then - ! write (fates_log(),*) 'Quadratic solution error: a = ',a - ! call endrun(msg=errMsg(sourcefile, __LINE__)) - ! end if - - if (b >= 0._r8) then - q = -0.5_r8 * (b + sqrt(b*b - 4._r8*a*c)) - else - q = -0.5_r8 * (b - sqrt(b*b - 4._r8*a*c)) - end if - - r1 = q / a - ! if (q /= 0._r8) then - r2 = c / q - ! else - ! r2 = 1.e36_r8 - ! end if - -end subroutine quadratic_fast - - -! ==================================================================================== - -subroutine UpdateCanopyNCanNRadPresent(currentPatch) - - ! --------------------------------------------------------------------------------- - ! This subroutine calculates two patch level quanities: - ! currentPatch%ncan and - ! currentPatch%canopy_mask - ! - ! currentPatch%ncan(:,:) is a two dimensional array that indicates - ! the total number of leaf layers (including those that are not exposed to light) - ! in each canopy layer and for each functional type. - ! - ! currentPatch%nrad(:,:) is a two dimensional array that indicates - ! the total number of EXPOSED leaf layers, but for all intents and purposes - ! in the photosynthesis routine, this appears to be the same as %ncan... - ! - ! currentPatch%canopy_mask(:,:) has the same dimensions, is binary, and - ! indicates whether or not leaf layers are present (by evaluating the canopy area - ! profile). - ! --------------------------------------------------------------------------------- - - ! Arguments - type(fates_patch_type), target :: currentPatch - type(fates_cohort_type), pointer :: currentCohort - - ! Locals - integer :: cl ! Canopy Layer Index - integer :: ft ! Function Type Index - integer :: iv ! index of the exposed leaf layer for each canopy layer and pft - - ! Loop through the cohorts in this patch, associate each cohort with a layer and PFT - ! and use the cohort's memory of how many layer's it takes up to assign the maximum - ! of the layer/pft index it is in - ! --------------------------------------------------------------------------------- - - currentPatch%ncan(:,:) = 0 - ! redo the canopy structure algorithm to get round a - ! bug that is happening for site 125, FT13. - currentCohort => currentPatch%tallest - do while(associated(currentCohort)) - - currentPatch%ncan(currentCohort%canopy_layer,currentCohort%pft) = & - max(currentPatch%ncan(currentCohort%canopy_layer,currentCohort%pft), & - currentCohort%NV) - - currentCohort => currentCohort%shorter - - enddo !cohort - - ! NRAD = NCAN ... - currentPatch%nrad = currentPatch%ncan - - ! Now loop through and identify which layer and pft combo has scattering elements - do cl = 1,nclmax - do ft = 1,numpft - currentPatch%canopy_mask(cl,ft) = 0 - do iv = 1, currentPatch%nrad(cl,ft); - if(currentPatch%canopy_area_profile(cl,ft,iv) > 0._r8)then - currentPatch%canopy_mask(cl,ft) = 1 - end if - end do !iv - enddo !ft - enddo !cl + ! ==================================================================================== - return -end subroutine UpdateCanopyNCanNRadPresent - -! ==================================================================================== - -subroutine GetCanopyGasParameters(can_press, & - can_o2_partialpress, & - veg_tempk, & - air_tempk, & - air_vpress, & - veg_esat, & - rb, & - mm_kco2, & - mm_ko2, & - co2_cpoint, & - cf, & - gb_mol, & - ceair) - - ! --------------------------------------------------------------------------------- - ! This subroutine calculates the specific Michaelis Menten Parameters (pa) for CO2 - ! and O2, as well as the CO2 compentation point. - ! --------------------------------------------------------------------------------- - - use FatesConstantsMod, only: umol_per_mol - use FatesConstantsMod, only: mmol_per_mol - use FatesConstantsMod, only: umol_per_kmol - use FatesConstantsMod, only : rgas => rgas_J_K_kmol - - ! Arguments - real(r8), intent(in) :: can_press ! Air pressure within the canopy (Pa) - real(r8), intent(in) :: can_o2_partialpress ! Partial press of o2 in the canopy (Pa) - real(r8), intent(in) :: veg_tempk ! The temperature of the vegetation (K) - real(r8), intent(in) :: air_tempk ! Temperature of canopy air (K) - real(r8), intent(in) :: air_vpress ! Vapor pressure of canopy air (Pa) - real(r8), intent(in) :: veg_esat ! Saturated vapor pressure at veg surf (Pa) - real(r8), intent(in) :: rb ! Leaf Boundary layer resistance (s/m) - - real(r8), intent(out) :: mm_kco2 ! Michaelis-Menten constant for CO2 (Pa) - real(r8), intent(out) :: mm_ko2 ! Michaelis-Menten constant for O2 (Pa) - real(r8), intent(out) :: co2_cpoint ! CO2 compensation point (Pa) - real(r8), intent(out) :: cf ! conversion factor between molar form and velocity form - ! of conductance and resistance: [umol/m3] - real(r8), intent(out) :: gb_mol ! leaf boundary layer conductance (umol H2O/m**2/s) - real(r8), intent(out) :: ceair ! vapor pressure of air, constrained (Pa) - - ! Locals - real(r8) :: kc25 ! Michaelis-Menten constant for CO2 at 25C (Pa) - real(r8) :: ko25 ! Michaelis-Menten constant for O2 at 25C (Pa) - real(r8) :: sco ! relative specificity of rubisco - real(r8) :: cp25 ! CO2 compensation point at 25C (Pa) - - ! --------------------------------------------------------------------------------- - ! Intensive values (per mol of air) - ! kc, ko, currentPatch, from: Bernacchi et al (2001) - ! Plant, Cell and Environment 24:253-259 - ! --------------------------------------------------------------------------------- - - real(r8), parameter :: mm_kc25_umol_per_mol = 404.9_r8 - real(r8), parameter :: mm_ko25_mmol_per_mol = 278.4_r8 - real(r8), parameter :: co2_cpoint_umol_per_mol = 42.75_r8 - - ! Activation energy, from: - ! Bernacchi et al (2001) Plant, Cell and Environment 24:253-259 - ! Bernacchi et al (2003) Plant, Cell and Environment 26:1419-1430 - - real(r8), parameter :: kcha = 79430._r8 ! activation energy for kc (J/mol) - real(r8), parameter :: koha = 36380._r8 ! activation energy for ko (J/mol) - real(r8), parameter :: cpha = 37830._r8 ! activation energy for cp (J/mol) - - - ! Derive sco from currentPatch and O2 using present-day O2 (0.209 mol/mol) and re-calculate - ! currentPatch to account for variation in O2 using currentPatch = 0.5 O2 / sco - - ! FIXME (RGK 11-30-2016 THere are more constants here, but I don't have enough information - ! about what they are or do, so I can't give them more descriptive names. Someone please - ! fill this in when possible) - - kc25 = ( mm_kc25_umol_per_mol / umol_per_mol ) * can_press - ko25 = ( mm_ko25_mmol_per_mol / mmol_per_mol ) * can_press - sco = 0.5_r8 * 0.209_r8 / (co2_cpoint_umol_per_mol / umol_per_mol ) - cp25 = 0.5_r8 * can_o2_partialpress / sco - - if( veg_tempk.gt.150_r8 .and. veg_tempk.lt.350_r8 )then - mm_kco2 = kc25 * ft1_f(veg_tempk, kcha) - mm_ko2 = ko25 * ft1_f(veg_tempk, koha) - co2_cpoint = cp25 * ft1_f(veg_tempk, cpha) - else - mm_kco2 = 1.0_r8 - mm_ko2 = 1.0_r8 - co2_cpoint = 1.0_r8 - end if - - ! --------------------------------------------------------------------------------- - ! - ! cf is the conversion factor between molar form and velocity form - ! of conductance and resistance: [umol/m3] - ! - ! i.e. - ! [m/s] * [umol/m3] -> [umol/m2/s] - ! - ! Breakdown of the conversion factor: [ umol / m3 ] - ! - ! Rgas [J /K /kmol] - ! Air Potential Temperature [ K ] - ! Canopy Pressure [ Pa ] - ! conversion: umol/kmol = 1e9 - ! - ! [ Pa * K * kmol umol/kmol / J K ] = [ Pa * umol / J ] - ! since: 1 Pa = 1 N / m2 - ! [ Pa * umol / J ] = [ N * umol / J m2 ] - ! since: 1 J = 1 N * m - ! [ N * umol / J m2 ] = [ N * umol / N m3 ] - ! [ umol / m3 ] - ! - ! -------------------------------------------------------------------------------- - - cf = can_press/(rgas * air_tempk )*umol_per_kmol - gb_mol = (1._r8/ rb) * cf - - ! Constrain eair >= 0.05*esat_tv so that solution does not blow up. This ensures - ! that hs does not go to zero. Also eair <= veg_esat so that hs <= 1 - ceair = min( max(air_vpress, 0.05_r8*veg_esat ),veg_esat ) + subroutine UpdateCanopyNCanNRadPresent(currentPatch) + ! --------------------------------------------------------------------------------- + ! This subroutine calculates two patch level quanities: + ! currentPatch%ncan and + ! currentPatch%canopy_mask + ! + ! currentPatch%ncan(:,:) is a two dimensional array that indicates + ! the total number of leaf layers (including those that are not exposed to light) + ! in each canopy layer and for each functional type. + ! + ! currentPatch%nrad(:,:) is a two dimensional array that indicates + ! the total number of EXPOSED leaf layers, but for all intents and purposes + ! in the photosynthesis routine, this appears to be the same as %ncan... + ! + ! currentPatch%canopy_mask(:,:) has the same dimensions, is binary, and + ! indicates whether or not leaf layers are present (by evaluating the canopy area + ! profile). + ! --------------------------------------------------------------------------------- + ! Arguments + type(fates_patch_type), target :: currentPatch + type(fates_cohort_type), pointer :: currentCohort - return -end subroutine GetCanopyGasParameters - -! ==================================================================================== - -subroutine LeafLayerMaintenanceRespiration_Ryan_1991(lnc_top, & - nscaler, & - ft, & - veg_tempk, & - lmr) - - use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm - use FatesConstantsMod, only : umolC_to_kgC - use FatesConstantsMod, only : g_per_kg - use EDPftvarcon , only : EDPftvarcon_inst - - ! ----------------------------------------------------------------------- - ! Base maintenance respiration rate for plant tissues maintresp_leaf_ryan1991_baserate - ! M. Ryan, 1991. Effects of climate change on plant respiration. - ! Ecological Applications, 1(2), 157-167. - ! Original expression is br = 0.0106 molC/(molN h) - ! Conversion by molecular weights of C and N gives 2.525e-6 gC/(gN s) - ! Which is the default value of maintresp_nonleaf_baserate - - ! Arguments - real(r8), intent(in) :: lnc_top ! Leaf nitrogen content per unit area at canopy top [gN/m2] - real(r8), intent(in) :: nscaler ! Scale for leaf nitrogen profile - integer, intent(in) :: ft ! (plant) Functional Type Index - real(r8), intent(in) :: veg_tempk ! vegetation temperature - real(r8), intent(out) :: lmr ! Leaf Maintenance Respiration (umol CO2/m**2/s) - - ! Locals - real(r8) :: lmr25 ! leaf layer: leaf maintenance respiration rate at 25C (umol CO2/m**2/s) - real(r8) :: lmr25top ! canopy top leaf maint resp rate at 25C for this pft (umol CO2/m**2/s) - integer :: c3c4_path_index ! Index for which photosynthetic pathway - - ! Parameter - real(r8), parameter :: lmrha = 46390._r8 ! activation energy for lmr (J/mol) - real(r8), parameter :: lmrhd = 150650._r8 ! deactivation energy for lmr (J/mol) - real(r8), parameter :: lmrse = 490._r8 ! entropy term for lmr (J/mol/K) - real(r8), parameter :: lmrc = 1.15912391_r8 ! scaling factor for high - ! temperature inhibition (25 C = 1.0) - - lmr25top = EDPftvarcon_inst%maintresp_leaf_ryan1991_baserate(ft) * (1.5_r8 ** ((25._r8 - 20._r8)/10._r8)) - lmr25top = lmr25top * lnc_top / (umolC_to_kgC * g_per_kg) - - - ! Part I: Leaf Maintenance respiration: umol CO2 / m**2 [leaf] / s - ! ---------------------------------------------------------------------------------- - lmr25 = lmr25top * nscaler - - ! photosynthetic pathway: 0. = c4, 1. = c3 - c3c4_path_index = nint(EDPftvarcon_inst%c3psn(ft)) - - if (c3c4_path_index == c3_path_index) then - ! temperature sensitivity of C3 plants - lmr = lmr25 * ft1_f(veg_tempk, lmrha) * & - fth_f(veg_tempk, lmrhd, lmrse, lmrc) - else - ! temperature sensitivity of C4 plants - lmr = lmr25 * 2._r8**((veg_tempk-(tfrz+25._r8))/10._r8) - lmr = lmr / (1._r8 + exp( 1.3_r8*(veg_tempk-(tfrz+55._r8)) )) - endif - - ! Any hydrodynamic limitations could go here, currently none - ! lmr = lmr * (nothing) - -end subroutine LeafLayerMaintenanceRespiration_Ryan_1991 - -! ==================================================================================== - -subroutine LeafLayerMaintenanceRespiration_Atkin_etal_2017(lnc_top, & - nscaler, & - ft, & - veg_tempk, & - tgrowth, & - lmr) - - use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm - use FatesConstantsMod, only : umolC_to_kgC - use FatesConstantsMod, only : g_per_kg - use FatesConstantsMod, only : lmr_b - use FatesConstantsMod, only : lmr_c - use FatesConstantsMod, only : lmr_TrefC - use FatesConstantsMod, only : lmr_r_1 - use FatesConstantsMod, only : lmr_r_2 - use EDPftvarcon , only : EDPftvarcon_inst - - ! Arguments - real(r8), intent(in) :: lnc_top ! Leaf nitrogen content per unit area at canopy top [gN/m2] - integer, intent(in) :: ft ! (plant) Functional Type Index - real(r8), intent(in) :: nscaler ! Scale for leaf nitrogen profile - real(r8), intent(in) :: veg_tempk ! vegetation temperature (degrees K) - real(r8), intent(in) :: tgrowth ! lagged vegetation temperature averaged over acclimation timescale (degrees K) - real(r8), intent(out) :: lmr ! Leaf Maintenance Respiration (umol CO2/m**2/s) - - ! Locals - real(r8) :: lmr25 ! leaf layer: leaf maintenance respiration rate at 25C (umol CO2/m**2/s) - real(r8) :: r_0 ! base respiration rate, PFT-dependent (umol CO2/m**2/s) - real(r8) :: r_t_ref ! acclimated ref respiration rate (umol CO2/m**2/s) - real(r8) :: lmr25top ! canopy top leaf maint resp rate at 25C for this pft (umol CO2/m**2/s) - - ! parameter values of r_0 as listed in Atkin et al 2017: (umol CO2/m**2/s) - ! Broad-leaved trees 1.7560 - ! Needle-leaf trees 1.4995 - ! Shrubs 2.0749 - ! C3 herbs/grasses 2.1956 - ! In the absence of better information, we use the same value for C4 grasses as C3 grasses. - - ! note that this code uses the relationship between leaf N and respiration from Atkin et al - ! for the top of the canopy, but then assumes proportionality with N through the canopy. - - ! r_0 currently put into the EDPftvarcon_inst%dev_arbitrary_pft - ! all figs in Atkin et al 2017 stop at zero Celsius so we will assume acclimation is fixed below that - r_0 = EDPftvarcon_inst%maintresp_leaf_atkin2017_baserate(ft) - r_t_ref = max( 0._r8, nscaler * (r_0 + lmr_r_1 * lnc_top + lmr_r_2 * max(0._r8, (tgrowth - tfrz) )) ) - - if (r_t_ref .eq. 0._r8) then - warn_msg = 'Rdark is negative at this temperature and is capped at 0. tgrowth (C): '//trim(N2S(tgrowth-tfrz))//' pft: '//trim(I2S(ft)) - call FatesWarn(warn_msg,index=4) - end if - - lmr = r_t_ref * exp(lmr_b * (veg_tempk - tfrz - lmr_TrefC) + lmr_c * & - ((veg_tempk-tfrz)**2 - lmr_TrefC**2)) - -end subroutine LeafLayerMaintenanceRespiration_Atkin_etal_2017 - -! ==================================================================================== - -subroutine LeafLayerBiophysicalRates( parsun_lsl, & - ft, & - vcmax25top_ft, & - jmax25top_ft, & - co2_rcurve_islope25top_ft, & - nscaler, & - veg_tempk, & - t_growth, & - t_home, & - btran, & - vcmax, & - jmax, & - co2_rcurve_islope ) - - ! --------------------------------------------------------------------------------- - ! This subroutine calculates the localized rates of several key photosynthesis - ! rates. By localized, we mean specific to the plant type and leaf layer, - ! which factors in leaf physiology, as well as environmental effects. - ! This procedure should be called prior to iterative solvers, and should - ! have pre-calculated the reference rates for the pfts before this. - ! - ! The output biophysical rates are: - ! vcmax: maximum rate of carboxilation, - ! jmax: maximum electron transport rate, - ! co2_rcurve_islope: initial slope of CO2 response curve (C4 plants) - ! --------------------------------------------------------------------------------- - - use EDPftvarcon , only : EDPftvarcon_inst - - ! Arguments - ! ------------------------------------------------------------------------------ - - real(r8), intent(in) :: parsun_lsl ! PAR absorbed in sunlit leaves for this layer - integer, intent(in) :: ft ! (plant) Functional Type Index - real(r8), intent(in) :: nscaler ! Scale for leaf nitrogen profile - real(r8), intent(in) :: vcmax25top_ft ! canopy top maximum rate of carboxylation at 25C - ! for this pft (umol CO2/m**2/s) - real(r8), intent(in) :: jmax25top_ft ! canopy top maximum electron transport rate at 25C - ! for this pft (umol electrons/m**2/s) - real(r8), intent(in) :: co2_rcurve_islope25top_ft ! initial slope of CO2 response curve - ! (C4 plants) at 25C, canopy top, this pft - real(r8), intent(in) :: veg_tempk ! vegetation temperature - real(r8), intent(in) :: t_growth ! T_growth (short-term running mean temperature) (K) - real(r8), intent(in) :: t_home ! T_home (long-term running mean temperature) (K) - real(r8), intent(in) :: btran ! transpiration wetness factor (0 to 1) - - real(r8), intent(out) :: vcmax ! maximum rate of carboxylation (umol co2/m**2/s) - real(r8), intent(out) :: jmax ! maximum electron transport rate - ! (umol electrons/m**2/s) - real(r8), intent(out) :: co2_rcurve_islope ! initial slope of CO2 response curve (C4 plants) - - ! Locals - ! ------------------------------------------------------------------------------- - real(r8) :: vcmax25 ! leaf layer: maximum rate of carboxylation at 25C - ! (umol CO2/m**2/s) - real(r8) :: jmax25 ! leaf layer: maximum electron transport rate at 25C - ! (umol electrons/m**2/s) - real(r8) :: co2_rcurve_islope25 ! leaf layer: Initial slope of CO2 response curve - ! (C4 plants) at 25C - integer :: c3c4_path_index ! Index for which photosynthetic pathway - - ! Parameters - ! --------------------------------------------------------------------------------- - real(r8) :: vcmaxha ! activation energy for vcmax (J/mol) - real(r8) :: jmaxha ! activation energy for jmax (J/mol) - real(r8) :: vcmaxhd ! deactivation energy for vcmax (J/mol) - real(r8) :: jmaxhd ! deactivation energy for jmax (J/mol) - real(r8) :: vcmaxse ! entropy term for vcmax (J/mol/K) - real(r8) :: jmaxse ! entropy term for jmax (J/mol/K) - real(r8) :: t_growth_celsius ! average growing temperature - real(r8) :: t_home_celsius ! average home temperature - real(r8) :: jvr ! ratio of Jmax25 / Vcmax25 - real(r8) :: vcmaxc ! scaling factor for high temperature inhibition (25 C = 1.0) - real(r8) :: jmaxc ! scaling factor for high temperature inhibition (25 C = 1.0) - - select case(photo_tempsens_model) - case (photosynth_acclim_model_none) !No temperature acclimation - vcmaxha = EDPftvarcon_inst%vcmaxha(FT) - jmaxha = EDPftvarcon_inst%jmaxha(FT) - vcmaxhd = EDPftvarcon_inst%vcmaxhd(FT) - jmaxhd = EDPftvarcon_inst%jmaxhd(FT) - vcmaxse = EDPftvarcon_inst%vcmaxse(FT) - jmaxse = EDPftvarcon_inst%jmaxse(FT) - case (photosynth_acclim_model_kumarathunge_etal_2019) !Kumarathunge et al. temperature acclimation, Thome=30-year running mean - t_growth_celsius = t_growth-tfrz - t_home_celsius = t_home-tfrz - vcmaxha = (42.6_r8 + (1.14_r8*t_growth_celsius))*1e3_r8 !J/mol - jmaxha = 40.71_r8*1e3_r8 !J/mol - vcmaxhd = 200._r8*1e3_r8 !J/mol - jmaxhd = 200._r8*1e3_r8 !J/mol - vcmaxse = (645.13_r8 - (0.38_r8*t_growth_celsius)) - jmaxse = 658.77_r8 - (0.84_r8*t_home_celsius) - 0.52_r8*(t_growth_celsius-t_home_celsius) - jvr = 2.56_r8 - (0.0375_r8*t_home_celsius)-(0.0202_r8*(t_growth_celsius-t_home_celsius)) - case default - write (fates_log(),*)'error, incorrect leaf photosynthesis temperature acclimation model specified' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end select - - vcmaxc = fth25_f(vcmaxhd, vcmaxse) - jmaxc = fth25_f(jmaxhd, jmaxse) - - if ( parsun_lsl <= 0._r8) then ! night time - vcmax = 0._r8 - jmax = 0._r8 - co2_rcurve_islope = 0._r8 - else ! day time - - ! Vcmax25top was already calculated to derive the nscaler function - vcmax25 = vcmax25top_ft * nscaler - select case(photo_tempsens_model) - case (photosynth_acclim_model_none) - jmax25 = jmax25top_ft * nscaler - case (photosynth_acclim_model_kumarathunge_etal_2019) - jmax25 = vcmax25*jvr - case default - write (fates_log(),*)'error, incorrect leaf photosynthesis temperature acclimation model specified' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end select - - co2_rcurve_islope25 = co2_rcurve_islope25top_ft * nscaler - - ! Adjust for temperature - ! photosynthetic pathway: 0. = c4, 1. = c3 - c3c4_path_index = nint(EDPftvarcon_inst%c3psn(ft)) - - if (c3c4_path_index == c3_path_index) then - vcmax = vcmax25 * ft1_f(veg_tempk, vcmaxha) * fth_f(veg_tempk, vcmaxhd, vcmaxse, vcmaxc) - else - vcmax = vcmax25 * 2._r8**((veg_tempk-(tfrz+25._r8))/10._r8) - vcmax = vcmax / (1._r8 + exp( 0.2_r8*((tfrz+15._r8)-veg_tempk ) )) - vcmax = vcmax / (1._r8 + exp( 0.3_r8*(veg_tempk-(tfrz+40._r8)) )) - end if - - jmax = jmax25 * ft1_f(veg_tempk, jmaxha) * fth_f(veg_tempk, jmaxhd, jmaxse, jmaxc) - - !q10 response of product limited psn. - co2_rcurve_islope = co2_rcurve_islope25 * 2._r8**((veg_tempk-(tfrz+25._r8))/10._r8) - end if + ! Locals + integer :: cl ! Canopy Layer Index + integer :: ft ! Function Type Index + integer :: iv ! index of the exposed leaf layer for each canopy layer and pft - ! Adjust for water limitations - vcmax = vcmax * btran + ! Loop through the cohorts in this patch, associate each cohort with a layer and PFT + ! and use the cohort's memory of how many layer's it takes up to assign the maximum + ! of the layer/pft index it is in + ! --------------------------------------------------------------------------------- - return + currentPatch%ncan(:,:) = 0 + ! redo the canopy structure algorithm to get round a + ! bug that is happening for site 125, FT13. + currentCohort => currentPatch%tallest + do while(associated(currentCohort)) + + currentPatch%ncan(currentCohort%canopy_layer,currentCohort%pft) = & + max(currentPatch%ncan(currentCohort%canopy_layer,currentCohort%pft), & + currentCohort%NV) + + currentCohort => currentCohort%shorter + + enddo !cohort + + ! NRAD = NCAN ... + currentPatch%nrad = currentPatch%ncan + + ! Now loop through and identify which layer and pft combo has scattering elements + do cl = 1,nclmax + do ft = 1,numpft + currentPatch%canopy_mask(cl,ft) = 0 + do iv = 1, currentPatch%nrad(cl,ft); + if(currentPatch%canopy_area_profile(cl,ft,iv) > 0._r8)then + currentPatch%canopy_mask(cl,ft) = 1 + end if + end do !iv + enddo !ft + enddo !cl + + return + end subroutine UpdateCanopyNCanNRadPresent + + ! ==================================================================================== + + subroutine GetCanopyGasParameters(can_press, & + can_o2_partialpress, & + veg_tempk, & + air_tempk, & + air_vpress, & + veg_esat, & + rb, & + mm_kco2, & + mm_ko2, & + co2_cpoint, & + cf, & + gb_mol, & + ceair) + + ! --------------------------------------------------------------------------------- + ! This subroutine calculates the specific Michaelis Menten Parameters (pa) for CO2 + ! and O2, as well as the CO2 compentation point. + ! --------------------------------------------------------------------------------- + + use FatesConstantsMod, only: umol_per_mol + use FatesConstantsMod, only: mmol_per_mol + use FatesConstantsMod, only: umol_per_kmol + use FatesConstantsMod, only : rgas => rgas_J_K_kmol + + ! Arguments + real(r8), intent(in) :: can_press ! Air pressure within the canopy (Pa) + real(r8), intent(in) :: can_o2_partialpress ! Partial press of o2 in the canopy (Pa) + real(r8), intent(in) :: veg_tempk ! The temperature of the vegetation (K) + real(r8), intent(in) :: air_tempk ! Temperature of canopy air (K) + real(r8), intent(in) :: air_vpress ! Vapor pressure of canopy air (Pa) + real(r8), intent(in) :: veg_esat ! Saturated vapor pressure at veg surf (Pa) + real(r8), intent(in) :: rb ! Leaf Boundary layer resistance (s/m) + + real(r8), intent(out) :: mm_kco2 ! Michaelis-Menten constant for CO2 (Pa) + real(r8), intent(out) :: mm_ko2 ! Michaelis-Menten constant for O2 (Pa) + real(r8), intent(out) :: co2_cpoint ! CO2 compensation point (Pa) + real(r8), intent(out) :: cf ! conversion factor between molar form and velocity form + ! of conductance and resistance: [umol/m3] + real(r8), intent(out) :: gb_mol ! leaf boundary layer conductance (umol H2O/m**2/s) + real(r8), intent(out) :: ceair ! vapor pressure of air, constrained (Pa) + + ! Locals + real(r8) :: kc25 ! Michaelis-Menten constant for CO2 at 25C (Pa) + real(r8) :: ko25 ! Michaelis-Menten constant for O2 at 25C (Pa) + real(r8) :: sco ! relative specificity of rubisco + real(r8) :: cp25 ! CO2 compensation point at 25C (Pa) + + ! --------------------------------------------------------------------------------- + ! Intensive values (per mol of air) + ! kc, ko, currentPatch, from: Bernacchi et al (2001) + ! Plant, Cell and Environment 24:253-259 + ! --------------------------------------------------------------------------------- + + real(r8), parameter :: mm_kc25_umol_per_mol = 404.9_r8 + real(r8), parameter :: mm_ko25_mmol_per_mol = 278.4_r8 + real(r8), parameter :: co2_cpoint_umol_per_mol = 42.75_r8 + + ! Activation energy, from: + ! Bernacchi et al (2001) Plant, Cell and Environment 24:253-259 + ! Bernacchi et al (2003) Plant, Cell and Environment 26:1419-1430 + + real(r8), parameter :: kcha = 79430._r8 ! activation energy for kc (J/mol) + real(r8), parameter :: koha = 36380._r8 ! activation energy for ko (J/mol) + real(r8), parameter :: cpha = 37830._r8 ! activation energy for cp (J/mol) + + + ! Derive sco from currentPatch and O2 using present-day O2 (0.209 mol/mol) and re-calculate + ! currentPatch to account for variation in O2 using currentPatch = 0.5 O2 / sco + + ! FIXME (RGK 11-30-2016 THere are more constants here, but I don't have enough information + ! about what they are or do, so I can't give them more descriptive names. Someone please + ! fill this in when possible) + + kc25 = ( mm_kc25_umol_per_mol / umol_per_mol ) * can_press + ko25 = ( mm_ko25_mmol_per_mol / mmol_per_mol ) * can_press + sco = 0.5_r8 * 0.209_r8 / (co2_cpoint_umol_per_mol / umol_per_mol ) + cp25 = 0.5_r8 * can_o2_partialpress / sco + + if( veg_tempk.gt.150_r8 .and. veg_tempk.lt.350_r8 )then + mm_kco2 = kc25 * ft1_f(veg_tempk, kcha) + mm_ko2 = ko25 * ft1_f(veg_tempk, koha) + co2_cpoint = cp25 * ft1_f(veg_tempk, cpha) + else + mm_kco2 = 1.0_r8 + mm_ko2 = 1.0_r8 + co2_cpoint = 1.0_r8 + end if + + ! --------------------------------------------------------------------------------- + ! + ! cf is the conversion factor between molar form and velocity form + ! of conductance and resistance: [umol/m3] + ! + ! i.e. + ! [m/s] * [umol/m3] -> [umol/m2/s] + ! + ! Breakdown of the conversion factor: [ umol / m3 ] + ! + ! Rgas [J /K /kmol] + ! Air Potential Temperature [ K ] + ! Canopy Pressure [ Pa ] + ! conversion: umol/kmol = 1e9 + ! + ! [ Pa * K * kmol umol/kmol / J K ] = [ Pa * umol / J ] + ! since: 1 Pa = 1 N / m2 + ! [ Pa * umol / J ] = [ N * umol / J m2 ] + ! since: 1 J = 1 N * m + ! [ N * umol / J m2 ] = [ N * umol / N m3 ] + ! [ umol / m3 ] + ! + ! -------------------------------------------------------------------------------- + + cf = can_press/(rgas * air_tempk )*umol_per_kmol + gb_mol = (1._r8/ rb) * cf + + ! Constrain eair >= 0.05*esat_tv so that solution does not blow up. This ensures + ! that hs does not go to zero. Also eair <= veg_esat so that hs <= 1 + ceair = min( max(air_vpress, 0.05_r8*veg_esat ),veg_esat ) + + + + return + end subroutine GetCanopyGasParameters + + ! ==================================================================================== - end subroutine LeafLayerBiophysicalRates - -subroutine lowstorage_maintresp_reduction(frac, pft, maintresp_reduction_factor) - - ! This subroutine reduces maintenance respiration rates when storage pool is low. The premise - ! of this is that mortality of plants increases when storage is low because they are not able - ! to repair tissues, generate defense compounds, etc. This reduction is reflected in a reduced - ! maintenance demand. The output of this function takes the form of a curve between 0 and 1, - ! and the curvature of the function is determined by a parameter. - - ! Uses - use EDPftvarcon , only : EDPftvarcon_inst - - ! Arguments - ! ------------------------------------------------------------------------------ - real(r8), intent(in) :: frac ! ratio of storage to target leaf biomass - integer, intent(in) :: pft ! what pft is this cohort? - real(r8), intent(out) :: maintresp_reduction_factor ! the factor by which to reduce maintenance respiration - - ! -------------------------------------------------------------------------------- - ! Parameters are at the PFT level: - ! fates_maintresp_reduction_curvature controls the curvature of this. - ! If this parameter is zero, then there is no reduction until the plant dies at storage = 0. - ! If this parameter is one, then there is a linear reduction in respiration below the storage point. - ! Intermediate values will give some (concave-downwards) curvature. - ! - ! maintresp_reduction_intercept controls the maximum amount of throttling. - ! zero means no throttling at any point, so it turns this mechanism off completely and so - ! allows an entire cohort to die via negative carbon-induced termination mortality. - ! one means complete throttling, so no maintenance respiration at all, when out of carbon. - ! --------------------------------------------------------------------------------- - - if( frac .lt. 1._r8 )then - if ( abs(EDPftvarcon_inst%maintresp_reduction_curvature(pft)-1._r8) > nearzero ) then - maintresp_reduction_factor = (1._r8 - EDPftvarcon_inst%maintresp_reduction_intercept(pft)) + & - EDPftvarcon_inst%maintresp_reduction_intercept(pft) * & - (1._r8 - EDPftvarcon_inst%maintresp_reduction_curvature(pft)**frac) & - / (1._r8-EDPftvarcon_inst%maintresp_reduction_curvature(pft)) - else ! avoid nan answer for linear case - maintresp_reduction_factor = (1._r8 - EDPftvarcon_inst%maintresp_reduction_intercept(pft)) + & - EDPftvarcon_inst%maintresp_reduction_intercept(pft) * frac - endif - - else - maintresp_reduction_factor = 1._r8 - endif - - -end subroutine lowstorage_maintresp_reduction + subroutine LeafLayerMaintenanceRespiration_Ryan_1991(lnc_top, & + nscaler, & + ft, & + veg_tempk, & + lmr) + + use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm + use FatesConstantsMod, only : umolC_to_kgC + use FatesConstantsMod, only : g_per_kg + use EDPftvarcon , only : EDPftvarcon_inst + + ! ----------------------------------------------------------------------- + ! Base maintenance respiration rate for plant tissues maintresp_leaf_ryan1991_baserate + ! M. Ryan, 1991. Effects of climate change on plant respiration. + ! Ecological Applications, 1(2), 157-167. + ! Original expression is br = 0.0106 molC/(molN h) + ! Conversion by molecular weights of C and N gives 2.525e-6 gC/(gN s) + ! Which is the default value of maintresp_nonleaf_baserate + + ! Arguments + real(r8), intent(in) :: lnc_top ! Leaf nitrogen content per unit area at canopy top [gN/m2] + real(r8), intent(in) :: nscaler ! Scale for leaf nitrogen profile + integer, intent(in) :: ft ! (plant) Functional Type Index + real(r8), intent(in) :: veg_tempk ! vegetation temperature + real(r8), intent(out) :: lmr ! Leaf Maintenance Respiration (umol CO2/m**2/s) + + ! Locals + real(r8) :: lmr25 ! leaf layer: leaf maintenance respiration rate at 25C (umol CO2/m**2/s) + real(r8) :: lmr25top ! canopy top leaf maint resp rate at 25C for this pft (umol CO2/m**2/s) + integer :: c3c4_path_index ! Index for which photosynthetic pathway + + ! Parameter + real(r8), parameter :: lmrha = 46390._r8 ! activation energy for lmr (J/mol) + real(r8), parameter :: lmrhd = 150650._r8 ! deactivation energy for lmr (J/mol) + real(r8), parameter :: lmrse = 490._r8 ! entropy term for lmr (J/mol/K) + real(r8), parameter :: lmrc = 1.15912391_r8 ! scaling factor for high + ! temperature inhibition (25 C = 1.0) + + lmr25top = EDPftvarcon_inst%maintresp_leaf_ryan1991_baserate(ft) * (1.5_r8 ** ((25._r8 - 20._r8)/10._r8)) + lmr25top = lmr25top * lnc_top / (umolC_to_kgC * g_per_kg) + + + ! Part I: Leaf Maintenance respiration: umol CO2 / m**2 [leaf] / s + ! ---------------------------------------------------------------------------------- + lmr25 = lmr25top * nscaler + + ! photosynthetic pathway: 0. = c4, 1. = c3 + c3c4_path_index = nint(EDPftvarcon_inst%c3psn(ft)) + + if (c3c4_path_index == c3_path_index) then + ! temperature sensitivity of C3 plants + lmr = lmr25 * ft1_f(veg_tempk, lmrha) * & + fth_f(veg_tempk, lmrhd, lmrse, lmrc) + else + ! temperature sensitivity of C4 plants + lmr = lmr25 * 2._r8**((veg_tempk-(tfrz+25._r8))/10._r8) + lmr = lmr / (1._r8 + exp( 1.3_r8*(veg_tempk-(tfrz+55._r8)) )) + endif + + ! Any hydrodynamic limitations could go here, currently none + ! lmr = lmr * (nothing) + + end subroutine LeafLayerMaintenanceRespiration_Ryan_1991 + + ! ==================================================================================== + + subroutine LeafLayerMaintenanceRespiration_Atkin_etal_2017(lnc_top, & + nscaler, & + ft, & + veg_tempk, & + tgrowth, & + lmr) + + use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm + use FatesConstantsMod, only : umolC_to_kgC + use FatesConstantsMod, only : g_per_kg + use FatesConstantsMod, only : lmr_b + use FatesConstantsMod, only : lmr_c + use FatesConstantsMod, only : lmr_TrefC + use FatesConstantsMod, only : lmr_r_1 + use FatesConstantsMod, only : lmr_r_2 + use EDPftvarcon , only : EDPftvarcon_inst + + ! Arguments + real(r8), intent(in) :: lnc_top ! Leaf nitrogen content per unit area at canopy top [gN/m2] + integer, intent(in) :: ft ! (plant) Functional Type Index + real(r8), intent(in) :: nscaler ! Scale for leaf nitrogen profile + real(r8), intent(in) :: veg_tempk ! vegetation temperature (degrees K) + real(r8), intent(in) :: tgrowth ! lagged vegetation temperature averaged over acclimation timescale (degrees K) + real(r8), intent(out) :: lmr ! Leaf Maintenance Respiration (umol CO2/m**2/s) + + ! Locals + real(r8) :: lmr25 ! leaf layer: leaf maintenance respiration rate at 25C (umol CO2/m**2/s) + real(r8) :: r_0 ! base respiration rate, PFT-dependent (umol CO2/m**2/s) + real(r8) :: r_t_ref ! acclimated ref respiration rate (umol CO2/m**2/s) + real(r8) :: lmr25top ! canopy top leaf maint resp rate at 25C for this pft (umol CO2/m**2/s) + + ! parameter values of r_0 as listed in Atkin et al 2017: (umol CO2/m**2/s) + ! Broad-leaved trees 1.7560 + ! Needle-leaf trees 1.4995 + ! Shrubs 2.0749 + ! C3 herbs/grasses 2.1956 + ! In the absence of better information, we use the same value for C4 grasses as C3 grasses. + + ! note that this code uses the relationship between leaf N and respiration from Atkin et al + ! for the top of the canopy, but then assumes proportionality with N through the canopy. + + ! r_0 currently put into the EDPftvarcon_inst%dev_arbitrary_pft + ! all figs in Atkin et al 2017 stop at zero Celsius so we will assume acclimation is fixed below that + r_0 = EDPftvarcon_inst%maintresp_leaf_atkin2017_baserate(ft) + r_t_ref = max( 0._r8, nscaler * (r_0 + lmr_r_1 * lnc_top + lmr_r_2 * max(0._r8, (tgrowth - tfrz) )) ) + + if (r_t_ref .eq. 0._r8) then + warn_msg = 'Rdark is negative at this temperature and is capped at 0. tgrowth (C): '//trim(N2S(tgrowth-tfrz))//' pft: '//trim(I2S(ft)) + call FatesWarn(warn_msg,index=4) + end if + + lmr = r_t_ref * exp(lmr_b * (veg_tempk - tfrz - lmr_TrefC) + lmr_c * & + ((veg_tempk-tfrz)**2 - lmr_TrefC**2)) + + end subroutine LeafLayerMaintenanceRespiration_Atkin_etal_2017 + + ! ==================================================================================== + + subroutine LeafLayerBiophysicalRates( parsun_per_la, & + ft, & + vcmax25top_ft, & + jmax25top_ft, & + co2_rcurve_islope25top_ft, & + nscaler, & + veg_tempk, & + t_growth, & + t_home, & + btran, & + vcmax, & + jmax, & + co2_rcurve_islope ) + + ! --------------------------------------------------------------------------------- + ! This subroutine calculates the localized rates of several key photosynthesis + ! rates. By localized, we mean specific to the plant type and leaf layer, + ! which factors in leaf physiology, as well as environmental effects. + ! This procedure should be called prior to iterative solvers, and should + ! have pre-calculated the reference rates for the pfts before this. + ! + ! The output biophysical rates are: + ! vcmax: maximum rate of carboxilation, + ! jmax: maximum electron transport rate, + ! co2_rcurve_islope: initial slope of CO2 response curve (C4 plants) + ! --------------------------------------------------------------------------------- + + use EDPftvarcon , only : EDPftvarcon_inst + + ! Arguments + ! ------------------------------------------------------------------------------ + + real(r8), intent(in) :: parsun_per_la ! PAR absorbed per sunlit leaves for this layer + integer, intent(in) :: ft ! (plant) Functional Type Index + real(r8), intent(in) :: nscaler ! Scale for leaf nitrogen profile + real(r8), intent(in) :: vcmax25top_ft ! canopy top maximum rate of carboxylation at 25C + ! for this pft (umol CO2/m**2/s) + real(r8), intent(in) :: jmax25top_ft ! canopy top maximum electron transport rate at 25C + ! for this pft (umol electrons/m**2/s) + real(r8), intent(in) :: co2_rcurve_islope25top_ft ! initial slope of CO2 response curve + ! (C4 plants) at 25C, canopy top, this pft + real(r8), intent(in) :: veg_tempk ! vegetation temperature + real(r8), intent(in) :: t_growth ! T_growth (short-term running mean temperature) (K) + real(r8), intent(in) :: t_home ! T_home (long-term running mean temperature) (K) + real(r8), intent(in) :: btran ! transpiration wetness factor (0 to 1) + + real(r8), intent(out) :: vcmax ! maximum rate of carboxylation (umol co2/m**2/s) + real(r8), intent(out) :: jmax ! maximum electron transport rate + ! (umol electrons/m**2/s) + real(r8), intent(out) :: co2_rcurve_islope ! initial slope of CO2 response curve (C4 plants) + + ! Locals + ! ------------------------------------------------------------------------------- + real(r8) :: vcmax25 ! leaf layer: maximum rate of carboxylation at 25C + ! (umol CO2/m**2/s) + real(r8) :: jmax25 ! leaf layer: maximum electron transport rate at 25C + ! (umol electrons/m**2/s) + real(r8) :: co2_rcurve_islope25 ! leaf layer: Initial slope of CO2 response curve + ! (C4 plants) at 25C + integer :: c3c4_path_index ! Index for which photosynthetic pathway + + ! Parameters + ! --------------------------------------------------------------------------------- + real(r8) :: vcmaxha ! activation energy for vcmax (J/mol) + real(r8) :: jmaxha ! activation energy for jmax (J/mol) + real(r8) :: vcmaxhd ! deactivation energy for vcmax (J/mol) + real(r8) :: jmaxhd ! deactivation energy for jmax (J/mol) + real(r8) :: vcmaxse ! entropy term for vcmax (J/mol/K) + real(r8) :: jmaxse ! entropy term for jmax (J/mol/K) + real(r8) :: t_growth_celsius ! average growing temperature + real(r8) :: t_home_celsius ! average home temperature + real(r8) :: jvr ! ratio of Jmax25 / Vcmax25 + real(r8) :: vcmaxc ! scaling factor for high temperature inhibition (25 C = 1.0) + real(r8) :: jmaxc ! scaling factor for high temperature inhibition (25 C = 1.0) + + select case(photo_tempsens_model) + case (photosynth_acclim_model_none) !No temperature acclimation + vcmaxha = EDPftvarcon_inst%vcmaxha(FT) + jmaxha = EDPftvarcon_inst%jmaxha(FT) + vcmaxhd = EDPftvarcon_inst%vcmaxhd(FT) + jmaxhd = EDPftvarcon_inst%jmaxhd(FT) + vcmaxse = EDPftvarcon_inst%vcmaxse(FT) + jmaxse = EDPftvarcon_inst%jmaxse(FT) + case (photosynth_acclim_model_kumarathunge_etal_2019) !Kumarathunge et al. temperature acclimation, Thome=30-year running mean + t_growth_celsius = t_growth-tfrz + t_home_celsius = t_home-tfrz + vcmaxha = (42.6_r8 + (1.14_r8*t_growth_celsius))*1e3_r8 !J/mol + jmaxha = 40.71_r8*1e3_r8 !J/mol + vcmaxhd = 200._r8*1e3_r8 !J/mol + jmaxhd = 200._r8*1e3_r8 !J/mol + vcmaxse = (645.13_r8 - (0.38_r8*t_growth_celsius)) + jmaxse = 658.77_r8 - (0.84_r8*t_home_celsius) - 0.52_r8*(t_growth_celsius-t_home_celsius) + jvr = 2.56_r8 - (0.0375_r8*t_home_celsius)-(0.0202_r8*(t_growth_celsius-t_home_celsius)) + case default + write (fates_log(),*)'error, incorrect leaf photosynthesis temperature acclimation model specified' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end select + + vcmaxc = fth25_f(vcmaxhd, vcmaxse) + jmaxc = fth25_f(jmaxhd, jmaxse) + + if(parsun_per_la <= 0._r8) then + vcmax = 0._r8 + jmax = 0._r8 + co2_rcurve_islope = 0._r8 + else ! day time + + ! Vcmax25top was already calculated to derive the nscaler function + vcmax25 = vcmax25top_ft * nscaler + select case(photo_tempsens_model) + case (photosynth_acclim_model_none) + jmax25 = jmax25top_ft * nscaler + case (photosynth_acclim_model_kumarathunge_etal_2019) + jmax25 = vcmax25*jvr + case default + write (fates_log(),*)'error, incorrect leaf photosynthesis temperature acclimation model specified' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end select + + co2_rcurve_islope25 = co2_rcurve_islope25top_ft * nscaler + + ! Adjust for temperature + ! photosynthetic pathway: 0. = c4, 1. = c3 + c3c4_path_index = nint(EDPftvarcon_inst%c3psn(ft)) + + if (c3c4_path_index == c3_path_index) then + vcmax = vcmax25 * ft1_f(veg_tempk, vcmaxha) * fth_f(veg_tempk, vcmaxhd, vcmaxse, vcmaxc) + else + vcmax = vcmax25 * 2._r8**((veg_tempk-(tfrz+25._r8))/10._r8) + vcmax = vcmax / (1._r8 + exp( 0.2_r8*((tfrz+15._r8)-veg_tempk ) )) + vcmax = vcmax / (1._r8 + exp( 0.3_r8*(veg_tempk-(tfrz+40._r8)) )) + end if + + jmax = jmax25 * ft1_f(veg_tempk, jmaxha) * fth_f(veg_tempk, jmaxhd, jmaxse, jmaxc) + + !q10 response of product limited psn. + co2_rcurve_islope = co2_rcurve_islope25 * 2._r8**((veg_tempk-(tfrz+25._r8))/10._r8) + end if + + ! Adjust for water limitations + vcmax = vcmax * btran + + return + + end subroutine LeafLayerBiophysicalRates + + subroutine lowstorage_maintresp_reduction(frac, pft, maintresp_reduction_factor) + + ! This subroutine reduces maintenance respiration rates when storage pool is low. The premise + ! of this is that mortality of plants increases when storage is low because they are not able + ! to repair tissues, generate defense compounds, etc. This reduction is reflected in a reduced + ! maintenance demand. The output of this function takes the form of a curve between 0 and 1, + ! and the curvature of the function is determined by a parameter. + + ! Uses + use EDPftvarcon , only : EDPftvarcon_inst + + ! Arguments + ! ------------------------------------------------------------------------------ + real(r8), intent(in) :: frac ! ratio of storage to target leaf biomass + integer, intent(in) :: pft ! what pft is this cohort? + real(r8), intent(out) :: maintresp_reduction_factor ! the factor by which to reduce maintenance respiration + + ! -------------------------------------------------------------------------------- + ! Parameters are at the PFT level: + ! fates_maintresp_reduction_curvature controls the curvature of this. + ! If this parameter is zero, then there is no reduction until the plant dies at storage = 0. + ! If this parameter is one, then there is a linear reduction in respiration below the storage point. + ! Intermediate values will give some (concave-downwards) curvature. + ! + ! maintresp_reduction_intercept controls the maximum amount of throttling. + ! zero means no throttling at any point, so it turns this mechanism off completely and so + ! allows an entire cohort to die via negative carbon-induced termination mortality. + ! one means complete throttling, so no maintenance respiration at all, when out of carbon. + ! --------------------------------------------------------------------------------- + + if( frac .lt. 1._r8 )then + if ( abs(EDPftvarcon_inst%maintresp_reduction_curvature(pft)-1._r8) > nearzero ) then + maintresp_reduction_factor = (1._r8 - EDPftvarcon_inst%maintresp_reduction_intercept(pft)) + & + EDPftvarcon_inst%maintresp_reduction_intercept(pft) * & + (1._r8 - EDPftvarcon_inst%maintresp_reduction_curvature(pft)**frac) & + / (1._r8-EDPftvarcon_inst%maintresp_reduction_curvature(pft)) + else ! avoid nan answer for linear case + maintresp_reduction_factor = (1._r8 - EDPftvarcon_inst%maintresp_reduction_intercept(pft)) + & + EDPftvarcon_inst%maintresp_reduction_intercept(pft) * frac + endif + + else + maintresp_reduction_factor = 1._r8 + endif + + + end subroutine lowstorage_maintresp_reduction end module FATESPlantRespPhotosynthMod diff --git a/functional_unit_testing/radiation/RadiationUTestDriver.py b/functional_unit_testing/radiation/RadiationUTestDriver.py new file mode 100644 index 0000000000..b7c32d74d3 --- /dev/null +++ b/functional_unit_testing/radiation/RadiationUTestDriver.py @@ -0,0 +1,1133 @@ +# ======================================================================================= +# +# For usage: $python RadiationUTestDriver.py --help +# +# This script runs unit tests on the two-stream functions. +# +# +# ======================================================================================= + +import matplotlib as mpl +#mpl.use('Agg') +import matplotlib.pyplot as plt +from datetime import datetime +import argparse +#from matplotlib.backends.backend_pdf import PdfPages +import platform +import xml.etree.ElementTree as ET +import numpy as np +import matplotlib +import os +import sys +import getopt +import code # For development: code.interact(local=locals()) code.interact(local=dict(globals(), **locals())) +import time +import importlib +import csv +import ctypes +from ctypes import * +from operator import add +sys.path.append('../shared/py_src') +from PyF90Utils import c8, ci, cchar, c8_arr, ci_arr, ccharnb + +font = {'family' : 'sans-serif', + 'weight' : 'normal', + 'size' : 11} + +matplotlib.rc('font', **font) + + +# Instantiate the F90 modules +f90_shr_obj = ctypes.CDLL('bld/WrapShrMod.o',mode=ctypes.RTLD_GLOBAL) +f90_mem_obj = ctypes.CDLL('bld/FatesRadiationMemMod.o',mode=ctypes.RTLD_GLOBAL) +f90_twostr_obj = ctypes.CDLL('bld/TwoStreamMLPEMod.o',mode=ctypes.RTLD_GLOBAL) +f90_wrap_obj = ctypes.CDLL('bld/RadiationWrapMod.o',mode=ctypes.RTLD_GLOBAL) + + +# Create aliases for the calls and define arguments if it helps with clarity +alloc_twostream_call = f90_wrap_obj.__radiationwrapmod_MOD_initallocate +dealloc_twostream_call = f90_wrap_obj.__radiationwrapmod_MOD_dealloc +alloc_radparams_call = f90_twostr_obj.__twostreammlpemod_MOD_allocateradparams +set_radparams_call = f90_wrap_obj.__radiationwrapmod_MOD_setradparam +set_radparams_call.argtypes = [POINTER(c_double),POINTER(c_int),POINTER(c_int),c_char_p,c_long] +param_prep_call = f90_twostr_obj.__twostreammlpemod_MOD_radparamprep + +setup_canopy_call = f90_wrap_obj.__radiationwrapmod_MOD_setupcanopy +setup_canopy_call.argtypes = [POINTER(c_int),POINTER(c_int),POINTER(c_int), \ + POINTER(c_double),POINTER(c_double),POINTER(c_double)] + +grndsnow_albedo_call = f90_wrap_obj.__radiationwrapmod_MOD_setgroundsnow +grndsnow_albedo_call.argtypes = [POINTER(c_int),POINTER(c_double),c_char_p,c_long] + +canopy_prep_call = f90_wrap_obj.__radiationwrapmod_MOD_wrapcanopyprep +zenith_prep_call = f90_wrap_obj.__radiationwrapmod_MOD_wrapzenithprep +solver_call = f90_wrap_obj.__radiationwrapmod_MOD_wrapsolve +setdown_call = f90_wrap_obj.__radiationwrapmod_MOD_wrapsetdownwelling + +getintens_call = f90_wrap_obj.__radiationwrapmod_MOD_wrapgetintensity +getabsrad_call = f90_wrap_obj.__radiationwrapmod_MOD_wrapgetabsrad +getparams_call = f90_wrap_obj.__radiationwrapmod_MOD_wrapgetparams +forceparam_call = f90_wrap_obj.__radiationwrapmod_MOD_wrapforceparams +forceparam_call.argtypes = [POINTER(c_int),POINTER(c_int),POINTER(c_int),POINTER(c_double),c_char_p,c_long] + +leaf_rhonir = [0.46, 0.41, 0.39, 0.46, 0.41, 0.41, 0.46, 0.41, 0.41, 0.28, 0.28, 0.28 ] +leaf_rhovis = [0.11, 0.09, 0.08, 0.11, 0.08, 0.08, 0.11, 0.08, 0.08, 0.05, 0.05, 0.05 ] +leaf_taunir = [0.33, 0.32, 0.42, 0.33, 0.43, 0.43, 0.33, 0.43, 0.43, 0.4, 0.4, 0.4 ] +leaf_tauvis = [0.06, 0.04, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.05, 0.05, 0.05] +leaf_xl = [0.32, 0.01, 0.01, 0.32, 0.2, 0.59, 0.32, 0.59, 0.59, -0.23, -0.23, -0.23] +leaf_clumping_index = [0.85, 0.85, 0.8, 0.85, 0.85, 0.9, 0.85, 0.9, 0.9, 0.75, 0.75, 0.75] +stem_rhonir = [0.49, 0.36, 0.36, 0.49, 0.49, 0.49, 0.49, 0.49, 0.49, 0.53, 0.53, 0.53] +stem_rhovis = [0.21, 0.12, 0.12, 0.21, 0.21, 0.21, 0.21, 0.21, 0.21, 0.31, 0.31, 0.31] +stem_taunir = [0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.25, 0.25, 0.25] +stem_tauvis = [0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.12, 0.12, 0.12] + + +visb = 1 +nirb = 2 + +normalized_boundary = 1 +absolute_boundary = 2 + +class elem_type: + def __init__(self,n_vai): + + self.area = -9.0 + self.lai = -9.0 + self.sai = -9.0 + + self.n_vai = n_vai + self.avai = np.zeros([n_vai]) + self.r_dn = np.zeros([n_vai]) + self.r_up = np.zeros([n_vai]) + self.r_b = np.zeros([n_vai]) + self.r_abs = np.zeros([n_vai]) + #self.sunfrac = np.zeros([n_vai]) + +class patch_type: + def __init__(self,ground_albedo_diff,ground_albedo_beam): + self.ground_albedo_beam = ground_albedo_diff + self.ground_albedo_beam = ground_albedo_beam + self.cohorts = [] + + # uses the form: + # patch.cohorts.append(cohort_type(n_vai,lai,sai)) + +class cohort_type: + def __init__(self,n_vai,area_frac,lai,sai,pft): + + self.n_vai = n_vai + #self.avai = np.zeros([n_vai]) + dvai = (lai+sai)/n_vai + self.avai = np.linspace(dvai,lai+sai,num=n_vai) + self.rd_abs_leaf = np.zeros([n_vai]) + self.rb_abs_leaf = np.zeros([n_vai]) + self.r_abs_stem = np.zeros([n_vai]) + self.sunfrac = np.zeros([n_vai]) + self.pft = pft + +def main(argv): + + # All tests will use 2 bands 1=vis, 2=nir + + # Initialize radiation parameters + n_bands = 2 + n_pft = 12 + + iret = alloc_radparams_call(ci(n_pft),ci(n_bands)) + + for ft in range(n_pft): + + pft=ft+1 + # rho (vis+nir) + iret = set_radparams_call(c_double(leaf_rhovis[ft]),c_int(pft),c_int(visb),*ccharnb("rhol")) + iret = set_radparams_call(c_double(leaf_rhonir[ft]),c_int(pft),c_int(nirb),*ccharnb("rhol")) + iret = set_radparams_call(c_double(stem_rhovis[ft]),c_int(pft),c_int(visb),*ccharnb("rhos")) + iret = set_radparams_call(c_double(stem_rhonir[ft]),c_int(pft),c_int(nirb),*ccharnb("rhos")) + # tau (vis+nir) + iret = set_radparams_call(c_double(leaf_tauvis[ft]),c_int(pft),c_int(visb),*ccharnb("taul")) + iret = set_radparams_call(c_double(leaf_taunir[ft]),c_int(pft),c_int(nirb),*ccharnb("taul")) + iret = set_radparams_call(c_double(stem_tauvis[ft]),c_int(pft),c_int(visb),*ccharnb("taus")) + iret = set_radparams_call(c_double(stem_taunir[ft]),c_int(pft),c_int(nirb),*ccharnb("taus")) + # orientations + iret = set_radparams_call(c_double(leaf_xl[ft]),c_int(pft),c_int(0),*ccharnb("xl")) + iret = set_radparams_call(c_double(leaf_clumping_index[ft]),c_int(pft),c_int(0),*ccharnb("clumping_index")) + + # Process the core 2Stream parameters from parameters in file + iret = param_prep_call(ci(n_pft)) + + if(False): + TestCrash() + + if(False): + ParallelElementPerturbDist() + + if(False): + SunFracTests() + + if(True): + SingleElementPerturbTest() + + if(False): + SerialParallelCanopyTest() + + plt.show() + +def TestCrash(): + + # This is used to diagnose a specific failure. This is probably + # reconstructed from the output dump of a failed solve. + + xmlfile = "f45error_elements.xml" + xmlroot = ET.parse(xmlfile).getroot() + print("\nOpenend: "+xmlfile) + + cosz = float(xmlroot.find('cosz').text.strip()) + ib = int(xmlroot.find('band_id').text.strip()) + #elem = xmlroot.find('time_control') + + # Iterate through canopy layers + areas = [] + print("Loading Layers") + for can in xmlroot.iter('can'): + print("canopy layer: {}".format(int(can.attrib['id'].strip()))) + # Iterate through elements in each layer + can_id = int(can.attrib['id'].strip()) + for elem in can.iter('elem'): + elem_id = int(elem.attrib['id'].strip()) + textlist = elem.text.split(',') + pft = int(textlist[0].strip()) + lai = float(textlist[1].strip()) + sai = float(textlist[2].strip()) + area = float(textlist[3].strip()) + + areas.append(area) + + code.interact(local=dict(globals(), **locals())) + + +def SerialParallelCanopyTest(): + + + # Lets first construct a bunch of cohorts, 5 cohorts + # equal area, but folding by 2 in LAI + + cohort_lai = np.array([0.25,0.5,1.0,2.0,4.0]) + cohort_area = np.array([0.2,0.2,0.2,0.2,0.2]) + n_cohorts = len(cohort_lai) + + sai_frac = 0.1 + + pft = 1 + + # Serial approach: 5 layers with veg and ghost + n_col = 2 + n_layer = 5 + iret = alloc_twostream_call(ci(n_layer),ci(n_col)) + + #class cohort_type: + #def __init__(self,n_vai,area_frac,lai,sai,pft) + + # Five elements (cohorts), each take up 20% of the space + area_frac = 0.2 + serialc = [] + serialc.append(cohort_type(100,area_frac,cohort_lai[0],cohort_lai[0]*sai_frac,pft)) + serialc.append(cohort_type(100,area_frac,cohort_lai[1],cohort_lai[1]*sai_frac,pft)) + serialc.append(cohort_type(100,area_frac,cohort_lai[2],cohort_lai[2]*sai_frac,pft)) + serialc.append(cohort_type(100,area_frac,cohort_lai[3],cohort_lai[3]*sai_frac,pft)) + serialc.append(cohort_type(100,area_frac,cohort_lai[4],cohort_lai[4]*sai_frac,pft)) + + parallelc = [] + parallelc.append(cohort_type(100,area_frac,cohort_lai[0],cohort_lai[0]*sai_frac,pft)) + parallelc.append(cohort_type(100,area_frac,cohort_lai[1],cohort_lai[1]*sai_frac,pft)) + parallelc.append(cohort_type(100,area_frac,cohort_lai[2],cohort_lai[2]*sai_frac,pft)) + parallelc.append(cohort_type(100,area_frac,cohort_lai[3],cohort_lai[3]*sai_frac,pft)) + parallelc.append(cohort_type(100,area_frac,cohort_lai[4],cohort_lai[4]*sai_frac,pft)) + + # Setup serial canopy "s_elems" + + s_elems = [] + #s_elems.append([]) + + n_vai = 100 + + + + dvai = 0.05 + for i in range(n_layer): + s_elems.append([]) + # Serial Setup + ican = i+1 + icol = 1 + area = np.sum(cohort_area[i:]) + if(i==0): + lai = cohort_lai[i] + else: + lai = cohort_lai[i]-cohort_lai[i-1] + + sai = lai*sai_frac + + n_vai = int((lai+sai)/dvai) + s_elems[i].append(elem_type(n_vai)) + + s_elems[i][-1].lai = lai + s_elems[i][-1].sai = sai + s_elems[i][-1].area = area + s_elems[i][-1].avai = np.linspace(0,lai+sai,num=n_vai) + iret = setup_canopy_call(c_int(ican),c_int(icol),c_int(pft),c_double(area),c_double(lai),c_double(sai)) + + icol = 2 + area = 1-np.sum(cohort_area[i:]) + s_elems[i].append(elem_type(1)) + s_elems[i][-1].lai = 0.0 + s_elems[i][-1].sai = 0.0 + s_elems[i][-1].area = area + lai = 0.0 + sai = 0.0 + air_pft = 0 + iret = setup_canopy_call(c_int(ican),c_int(icol),c_int(air_pft),c_double(area),c_double(lai),c_double(sai)) + + # Decide on a band: + ib = visb + + cd_r_beam = c_double(-9.0) + cd_r_diff_up = c_double(-9.0) + cd_r_diff_dn = c_double(-9.0) + cd_kb = c_double(-9.0) + cd_kd = c_double(-9.0) + cd_om = c_double(-9.0) + cd_betad = c_double(-9.0) + cd_betab = c_double(-9.0) + cd_rd_abs_leaf = c_double(-9.0) + cd_rb_abs_leaf = c_double(-9.0) + cd_r_abs_stem = c_double(-9.0) + cd_r_abs_snow = c_double(-9.0) + cd_leaf_sun_frac = c_double(-9.0) + + cd_albedo_beam = c_double(-9.0) + cd_albedo_diff = c_double(-9.0) + cd_canabs_beam = c_double(-9.0) + cd_canabs_diff = c_double(-9.0) + cd_ffbeam_beam = c_double(-9.0) + cd_ffdiff_beam = c_double(-9.0) + cd_ffdiff_diff = c_double(-9.0) + + + R_beam = 1. + R_diff = 1. + cosz = np.cos(0.0) + + ground_albedo_diff = 0.3 + ground_albedo_beam = 0.3 + frac_snow = 0.0 + + iret = grndsnow_albedo_call(c_int(visb),c_double(ground_albedo_diff),*ccharnb('albedo_grnd_diff')) + iret = grndsnow_albedo_call(c_int(visb),c_double(ground_albedo_beam),*ccharnb('albedo_grnd_beam')) + iret = grndsnow_albedo_call(c_int(nirb),c_double(ground_albedo_diff),*ccharnb('albedo_grnd_diff')) + iret = grndsnow_albedo_call(c_int(nirb),c_double(ground_albedo_beam),*ccharnb('albedo_grnd_beam')) + iret = canopy_prep_call(c8(frac_snow)) + iret = zenith_prep_call(c8(cosz)) + iret = solver_call(ci(ib),ci(normalized_boundary),c8(1.0),c8(1.0), \ + byref(cd_albedo_beam),byref(cd_albedo_diff), \ + byref(cd_canabs_beam),byref(cd_canabs_diff), \ + byref(cd_ffbeam_beam),byref(cd_ffdiff_beam),byref(cd_ffdiff_diff)) + iret = setdown_call(ci(ib),c8(R_beam),c8(R_diff)) + + for i in range(n_layer): + + ican = i+1 + icol = 1 + for iv in range(s_elems[i][0].n_vai): + iret = getintens_call(ci(ican),ci(icol),ci(ib),c8(s_elems[i][0].avai[iv]),byref(cd_r_diff_dn),byref(cd_r_diff_up),byref(cd_r_beam)) + s_elems[i][0].r_dn[iv] = cd_r_diff_dn.value + s_elems[i][0].r_up[iv] = cd_r_diff_up.value + s_elems[i][0].r_b[iv] = cd_r_beam.value + if(iv>0): + s_elems[i][0].r_abs[iv-1] = (s_elems[i][0].r_dn[iv]-s_elems[i][0].r_dn[iv-1]) + \ + (s_elems[i][0].r_up[iv-1]-s_elems[i][0].r_up[iv]) + \ + (s_elems[i][0].r_b[iv]-s_elems[i][0].r_b[iv-1]) + + icol=2 + for iv in range(s_elems[i][1].n_vai): + iret = getintens_call(ci(ican),ci(icol),ci(ib),c8(s_elems[i][1].avai[iv]),byref(cd_r_diff_dn),byref(cd_r_diff_up),byref(cd_r_beam)) + s_elems[i][1].r_dn[iv] = cd_r_diff_dn.value + s_elems[i][1].r_up[iv] = cd_r_diff_up.value + s_elems[i][1].r_b[iv] = cd_r_beam.value + print('air: {} {} {}'.format(ican,icol,cd_r_beam.value)) + if(iv>0): + s_elems[i][1].r_abs[iv-1] = (s_elems[i][1].r_dn[iv]-s_elems[i][1].r_dn[iv-1]) + \ + (s_elems[i][1].r_up[iv-1]-s_elems[i][1].r_up[iv]) + \ + (s_elems[i][1].r_b[iv]-s_elems[i][1].r_b[iv-1]) + + # Lets get the absorbed radiation from the cohorts + + #class cohort_type: + #def __init__(self,n_vai,lai,sai): + #self.n_vai = n_vai + ##self.avai = np.zeros([n_vai]) + #dvai = (lai+sai/n_vai) + #self.avai = np.linspace(dvai,lai+sai,num=n_vai) + #self.rabs_leaf = np.zeros([n_vai]) + #self.rabs_stem = np.zeros([n_vai]) + + for i in range(len(serialc)): + for iv in range(serialc[i].n_vai): + + vai_bot = serialc[i].avai[iv] + + ican = np.sum(serialc[i].avai[iv]>(cohort_lai*(1+sai_frac))) + if(ican>0): + vai_above = cohort_lai[ican-1]*(1+sai_frac) + else: + vai_above = 0. + + vai_bot = serialc[i].avai[iv]-vai_above + if(iv==0): + vai_top = 0 + else: + vai_top = np.max([0,serialc[i].avai[iv-1]-vai_above]) + + #print(i,iv,serialc[i].avai[iv],vai_above,vai_bot,vai_top,ican,cohort_lai*(1+sai_frac)) + icol = 1 # b/c 2 is air + iret = getabsrad_call(ci(ican+1),ci(icol),ci(ib),c8(vai_top),c8(vai_bot), \ + byref(cd_rd_abs_leaf),byref(cd_rb_abs_leaf),byref(cd_r_abs_stem), \ + byref(cd_r_abs_snow),byref(cd_leaf_sun_frac)) + serialc[i].rd_abs_leaf[iv] = cd_rd_abs_leaf.value + serialc[i].rb_abs_leaf[iv] = cd_rb_abs_leaf.value + serialc[i].r_abs_stem[iv] = cd_r_abs_stem.value + serialc[i].sunfrac[iv] = cd_leaf_sun_frac.value + + + + # Plot out absorbances and sun fractions in cohorts only + # --------------------------------------------- + + + + max_rd_abs_leaf = 0 + max_rb_abs_leaf = 0 + max_r_abs_stem = 0 + max_r_abs = 0 + maxlai = 0 + max_sunfrac = 0 + for i in range(n_cohorts): + max_rd_abs_leaf = np.max([max_rd_abs_leaf,np.max(serialc[i].rd_abs_leaf) ]) + max_rb_abs_leaf = np.max([max_rb_abs_leaf,np.max(serialc[i].rb_abs_leaf) ]) + max_r_abs_stem = np.max([max_r_abs_stem,np.max(serialc[i].r_abs_stem) ]) + max_r_abs = np.max([max_r_abs,np.max(serialc[i].r_abs_stem+serialc[i].rd_abs_leaf+serialc[i].rb_abs_leaf) ]) + maxlai = np.max([maxlai,np.max(serialc[i].avai) ]) + max_sunfrac = np.max([max_sunfrac,np.max(serialc[i].sunfrac)]) + + fig, axs = plt.subplots(ncols=n_cohorts,nrows=1,figsize=(6,3)) + ax1s = axs.reshape(-1) + + y0 = 0.1 + xpad = 0.1 + dx = (1.0-2*xpad)/float(n_cohorts) + dy = 0.8 + + ic=0 + x0 = xpad + for i in range(n_cohorts): + + ax = ax1s[ic] + ap = ax.plot(serialc[i].rd_abs_leaf+serialc[i].rb_abs_leaf+serialc[i].r_abs_stem ,serialc[i].avai) + ax.set_ylim([0,maxlai]) + ax.invert_yaxis() + ax.set_xlabel('[W/m2]') + ax.set_xlim([0,max_r_abs]) + + ax.set_title('Cohort {}'.format(i+1)) + if(i==0): + + ax.set_ylabel('Absorbed Radiation\nVAI [m2/m2]') + else: + ax.set_yticklabels([]) + + ax.grid(True) + ax.set_position([x0,y0,dx,dy]) + x0 = x0+dx + ic=ic+1 + + fig, axs = plt.subplots(ncols=n_cohorts,nrows=1,figsize=(6,3)) + ax1s = axs.reshape(-1) + + y0 = 0.1 + xpad = 0.1 + dx = (1.0-2*xpad)/float(n_cohorts) + dy = 0.8 + + # Sun fractions + ic=0 + x0 = xpad + for i in range(n_cohorts): + + ax = ax1s[ic] + ap = ax.plot(serialc[i].sunfrac ,serialc[i].avai) + ax.set_ylim([0,maxlai]) + ax.invert_yaxis() + ax.set_xlabel('[m2/m2]') + ax.set_xlim([0,max_sunfrac]) + + ax.set_title('Cohort {}'.format(i+1)) + if(i==0): + + ax.set_ylabel('Sunlit fraction of leaves [m2/m2]') + else: + ax.set_yticklabels([]) + + ax.grid(True) + ax.set_position([x0,y0,dx,dy]) + x0 = x0+dx + ic=ic+1 + + dealloc_twostream_call() + + + + if(False): + PlotRadMaps(s_elems,0,'Beam Radiation [W/m2]') + PlotRadMaps(s_elems,1,'Downwelling Diffuse Radiation [W/m2]') + PlotRadMaps(s_elems,2,'Upwelling Diffuse Radiation [W/m2]') + + # Setup paralell canopy p_elems + p_elems = [] + iret = alloc_twostream_call(ci(1),ci(n_cohorts)) + # Only one layer, so just one append + p_elems.append([]) + for i in range(n_cohorts): + + icol = i+1 + ican = 1 + # Parallel + + p_elems[0].append(elem_type(n_vai)) + lai = cohort_lai[i] + sai = sai_frac * cohort_lai[i] + area = cohort_area[i] + p_elems[0][-1].lai = lai + p_elems[0][-1].sai = sai + p_elems[0][-1].area = area + p_elems[0][-1].avai = np.linspace(0,cohort_lai[i]*(1.+sai_frac),num=n_vai) + iret = setup_canopy_call(c_int(ican),c_int(icol),c_int(pft),c_double(area),c_double(lai),c_double(sai)) + + iret = grndsnow_albedo_call(c_int(visb),c_double(ground_albedo_diff),*ccharnb('albedo_grnd_diff')) + iret = grndsnow_albedo_call(c_int(visb),c_double(ground_albedo_beam),*ccharnb('albedo_grnd_beam')) + iret = grndsnow_albedo_call(c_int(nirb),c_double(ground_albedo_diff),*ccharnb('albedo_grnd_diff')) + iret = grndsnow_albedo_call(c_int(nirb),c_double(ground_albedo_beam),*ccharnb('albedo_grnd_beam')) + iret = canopy_prep_call(c8(frac_snow)) + iret = zenith_prep_call(c8(cosz)) + iret = solver_call(ci(ib),ci(normalized_boundary),c8(1.0),c8(1.0), \ + byref(cd_albedo_beam),byref(cd_albedo_diff), \ + byref(cd_canabs_beam),byref(cd_canabs_diff), \ + byref(cd_ffbeam_beam),byref(cd_ffdiff_beam),byref(cd_ffdiff_diff)) + iret = setdown_call(ci(ib),c8(R_beam),c8(R_diff)) + + ican = 1 + for i in range(n_cohorts): + icol = i+1 + for iv in range(p_elems[0][i].n_vai): + iret = getintens_call(ci(ican),ci(icol),ci(ib),c8(p_elems[0][i].avai[iv]),byref(cd_r_diff_dn),byref(cd_r_diff_up),byref(cd_r_beam)) + p_elems[0][i].r_dn[iv] = cd_r_diff_dn.value + p_elems[0][i].r_up[iv] = cd_r_diff_up.value + p_elems[0][i].r_b[iv] = cd_r_beam.value + if(iv>0): + p_elems[0][i].r_abs[iv-1] = (p_elems[0][i].r_dn[iv]-p_elems[0][i].r_dn[iv-1]) + \ + (p_elems[0][i].r_up[iv-1]-p_elems[0][i].r_up[iv]) + \ + (p_elems[0][i].r_b[iv]-p_elems[0][i].r_b[iv-1]) + + dealloc_twostream_call() + if(True): + PlotRadMaps(p_elems,0,'Beam Radiation [W/m2]') + PlotRadMaps(p_elems,1,'Downwelling Diffuse Radiation [W/m2]') + PlotRadMaps(p_elems,2,'Upwelling Diffuse Radiation [W/m2]') + +def SunFracTests(): + + + n_col = 1 + n_layer = 1 + iret = alloc_twostream_call(ci(n_layer),ci(n_col)) + + ican = 1 # Single canopy layer + icol = 1 # Single PFT + pft = 1 # Use PFT number 1 + area = 1.0 # Assume only 90% of the ground is covered + lai = 5.0 # LAI + sai = 0.5 # SAI + vai = lai+sai + iret = setup_canopy_call(c_int(1),c_int(1),c_int(pft),c_double(area),c_double(lai),c_double(sai)) + + # Decide on a band: + ib = visb + cd_r_beam = c_double(-9.0) + cd_r_diff_up = c_double(-9.0) + cd_r_diff_dn = c_double(-9.0) + cd_kb = c_double(-9.0) + cd_kd = c_double(-9.0) + cd_om = c_double(-9.0) + cd_betad = c_double(-9.0) + cd_betab = c_double(-9.0) + + R_beam = 1. + R_diff = 0. + cosz = np.cos(0.0) + n_vai = 200 + n_cosz = 100 + + dv = vai/n_vai + vai_a = np.linspace(dv,vai,num=n_vai) + cosz_a = np.linspace(0,1.0,num=n_cosz) + kb_a = np.zeros([n_cosz]) + lsf_a = np.zeros([n_cosz,n_vai]) + rbeamsf_a = np.zeros([n_cosz,n_vai]) + rbeam_a = np.zeros([n_cosz,n_vai]) + + + + cd_rd_abs_leaf = c_double(-9.0) + cd_rb_abs_leaf = c_double(-9.0) + cd_r_abs_stem = c_double(-9.0) + cd_r_abs_snow = c_double(-9.0) + cd_leaf_sun_frac = c_double(-9.0) + cd_albedo_beam = c_double(-9.0) + cd_albedo_diff = c_double(-9.0) + cd_canabs_beam = c_double(-9.0) + cd_canabs_diff = c_double(-9.0) + cd_ffbeam_beam = c_double(-9.0) + cd_ffdiff_beam = c_double(-9.0) + cd_ffdiff_diff = c_double(-9.0) + cd_r_diff_dn = c_double(-9.0) + cd_r_diff_up = c_double(-9.0) + cd_r_beam = c_double(-9.0) + + ground_albedo_diff = 0.3 + ground_albedo_beam = 0.3 + frac_snow = 0.5 + + iret = grndsnow_albedo_call(c_int(ib),c_double(ground_albedo_diff),*ccharnb('albedo_grnd_diff')) + iret = grndsnow_albedo_call(c_int(ib),c_double(ground_albedo_beam),*ccharnb('albedo_grnd_beam')) + + iret = canopy_prep_call(c8(frac_snow)) + + for ic,cosz in enumerate(cosz_a): + iret = zenith_prep_call(c8(cosz)) + + iret = solver_call(ci(ib),ci(normalized_boundary),c8(1.0),c8(1.0), \ + byref(cd_albedo_beam),byref(cd_albedo_diff), \ + byref(cd_canabs_beam),byref(cd_canabs_diff), \ + byref(cd_ffbeam_beam),byref(cd_ffdiff_beam),byref(cd_ffdiff_diff)) + + iret = setdown_call(ci(ib),c8(R_beam),c8(R_diff)) + + iret = getparams_call(ci(ican),ci(icol),ci(ib),byref(cd_kb), \ + byref(cd_kd),byref(cd_om),byref(cd_betad),byref(cd_betab)) + + kb_a[ic] = cd_betab.value + + for iv in range(n_vai): + + if(iv==0): + vai_top = 0. + else: + vai_top = vai_a[iv-1] + + vai_bot = vai_a[iv] + + + iret = getabsrad_call(ci(ican),ci(icol),ci(ib),c8(vai_top),c8(vai_bot), \ + byref(cd_rd_abs_leaf),byref(cd_rb_abs_leaf),byref(cd_r_abs_stem), \ + byref(cd_r_abs_snow),byref(cd_leaf_sun_frac)) + + iret = getintens_call(ci(ican),ci(icol),ci(ib),c8(vai_bot),byref(cd_r_diff_dn), \ + byref(cd_r_diff_up),byref(cd_r_beam)) + + lsf_a[ic,iv] = cd_leaf_sun_frac.value + + #sun_area = (vai_bot - vai_top)*cd_leaf_sun_frac.value/cd_kb.value + sun_area = (vai_bot - vai_top)*cd_kb.value + rbeam_a[ic,iv] = cd_r_beam.value + + if(iv==0): + rbeamsf_a[ic,iv] = R_beam*(1.0 - sun_area) + #print(rbeamsf_a[ic,iv],sun_area,vai_bot,vai_top,cd_leaf_sun_frac.value,vai_a[iv]) + #exit(0) + else: + rbeamsf_a[ic,iv] = rbeamsf_a[ic,iv-1]*(1.0 - sun_area) + #print(rbeamsf_a[ic,iv]) + + fig, axs = plt.subplots(ncols=2,nrows=2,figsize=(9,5)) + ax1s = axs.reshape(-1) + + ic0 = [2,25,50,99] + + for ia,ax in enumerate(ax1s): + + #Plot LSF profiles at 4 different cosz's + + ap = ax.plot(lsf_a[ic0[ia],:],vai_a[:],rbeam_a[ic0[ia],:],vai_a[:]) + ax.invert_yaxis() + ax.set_title('cos(z) = {:.2f}'.format(cosz_a[ic0[ia]])) + ax.set_xlabel('[Sun Fraction]') + ax.set_xlim([0,1]) + ax.grid(True) + if(ia<2): + ax.set_xlabel('') + ax.set_xticklabels([]) + #if(ia==0): + # ax.set_ylabel('Absorbed Radiation\nVAI [m2/m2]') + #else: + # ax.set_yticklabels([]) + plt.tight_layout() + + fig2, axs = plt.subplots(ncols=2,nrows=2,figsize=(9,5)) + ax1s = axs.reshape(-1) + + ic0 = [2,25,50,99] + + for ia,ax in enumerate(ax1s): + + #Plot LSF profiles at 4 different cosz's + + ap = ax.plot(rbeam_a[ic0[ia],:],vai_a[:],rbeamsf_a[ic0[ia],:],vai_a[:]) + ax.invert_yaxis() + ax.set_title('cos(z) = {:.2f}'.format(cosz_a[ic0[ia]])) + ax.set_xlabel('[Beam Fraction]') + ax.set_xlim([0,1]) + ax.grid(True) + if(ia<2): + ax.set_xlabel('') + ax.set_xticklabels([]) + #if(ia==0): + # ax.set_ylabel('Absorbed Radiation\nVAI [m2/m2]') + #else: + # ax.set_yticklabels([]) + plt.tight_layout() + + + dealloc_twostream_call() + + +def ParallelElementPerturbDist(): + + + # Lets first construct a bunch of cohorts, 5 cohorts + # equal area, but folding by 2 in LAI + + cohort_lai = np.array([0.25,0.5,1.0,2.0,4.0]) + cohort_area = np.array([0.9,0.19,0.19,0.19,0.19]) + n_cohorts = len(cohort_lai) + + sai_frac = 0.1 + + pft = 1 + + # Serial approach: 5 layers with veg and ghost + n_col = n_cohorts+1 + n_layer = 1 + iret = alloc_twostream_call(ci(n_layer),ci(n_col)) + + for icol in range(n_col-1): + iret = setup_canopy_call(c_int(1),c_int(icol+1),c_int(pft), \ + c_double(cohort_area[icol]),c_double(cohort_lai[icol]),c_double(cohort_lai[icol]*sai_frac)) + + # Add the air element + iret = setup_canopy_call(c_int(1),c_int(n_col),c_int(0),c_double(1.0-np.sum(cohort_area)),c_double(0.0),c_double(0.0)) + + num_params = 9 + paramsets = [] + + labels = ["clumping_index","leaf_rhonir","leaf_rhovis","leaf_taunir","leaf_tauvis", \ + "stem_rhonir","stem_rhovis","stem_taunir","stem_tauvis"] + + ic = 0 + with open('albedo_callib_param_vals.csv', newline='') as csvfile: + + reader = csv.reader(csvfile, delimiter=',') + next(reader, None) + nsets=0 + for irow, rowtext in enumerate(reader): + ic=ic+1 + if(ic==num_params): + ic=0 + nsets=nsets+1 + + with open('albedo_callib_param_vals.csv', newline='') as csvfile: + paramset = np.zeros([num_params,nsets]) + reader = csv.reader(csvfile, delimiter=',') + next(reader, None) + ic=0 + iset=0 + for irow, rowtext in enumerate(reader): + paramset[ic,iset] = float(rowtext[3]) + ic=ic+1 + if(ic==num_params): + ic=0 + iset=iset+1 + + + fig1, axs = plt.subplots(3,3,figsize=(9,7)) + ax1s = axs.reshape(-1) + + for ip,ax in enumerate(ax1s): + + ap = ax.hist(paramset[ip,:]) + #ax1.set_ylabel('Integrated VAI [m2/m2]') + ax.set_title(labels[ip]) + ax.grid(True) + + plt.tight_layout() + plt.show() + dealloc_twostream_call() + + +def SingleElementPerturbTest(): + + + # =================================================================================== + # In this test, we have a canopy that is constructed from a single cohort + # and therefore a single element. The cohort does not cover all of the ground + # so their is an air element in parallel with the leaf/stem element. + + ground_albedo_diff = 0.1 + ground_albedo_beam = 0.1 + veg_frac_snow = 0.0 + + patch = patch_type(ground_albedo_diff,ground_albedo_beam) + + # Vegetation cohort + area_frac = 0.9 + lai = 2.0 + sai = 0.5 + pft = 1 + air_pft = 0 + patch.cohorts.append(cohort_type(100,area_frac,lai,sai,pft)) + + # Open space (air) + patch.cohorts.append(cohort_type(100,1.0-area_frac,0.,0.,air_pft)) + + + n_col = 2 + n_layer = 1 + iret = alloc_twostream_call(ci(n_layer),ci(n_col)) + + ican = 1 # Single canopy layer + icol = 1 # Single PFT + pft = 1 # Use PFT number 1 + vai = lai+sai + iret = setup_canopy_call(c_int(1),c_int(1),c_int(pft),c_double(area_frac),c_double(lai),c_double(sai)) + iret = setup_canopy_call(c_int(1),c_int(2),c_int(0),c_double(1.0-area_frac),c_double(0.0),c_double(0.0)) + + # Decide on a band: + + ib = visb + + cd_r_beam = c_double(-9.0) + cd_r_diff_up = c_double(-9.0) + cd_r_diff_dn = c_double(-9.0) + cd_kb = c_double(-9.0) + cd_kd = c_double(-9.0) + cd_om = c_double(-9.0) + cd_betad = c_double(-9.0) + cd_betab = c_double(-9.0) + + + # Make parameter pertubations, bump up 50% + pp_dict = {} + pp_dict['Kb'] = 1.5*0.66118239744 #74 #*1.5 + pp_dict['Kd'] = 1.5*0.9063246621781269 #*1.5 + pp_dict['om'] = 1.5*0.17819999999999997 #*1.5 + pp_dict['betab'] = 1.5*0.48253004714288084 #*1.5 + pp_dict['betad'] = 1.5*0.5999777777777778 #*1.5 + + R_beam = 1.0 + R_diff = 1.0 + cosz = np.cos(0.0) + n_vai = 100 + vai_a = np.linspace(0,vai,num=n_vai) + + dv = vai/n_vai + + r_diff_up = np.zeros(n_vai) + r_diff_dn = np.zeros(n_vai) + r_beam = np.zeros(n_vai) + + drdv_diff_up = np.zeros(n_vai-1) # Delta + drdv_diff_dn = np.zeros(n_vai-1) # Delta + drdv_ubeam = np.zeros(n_vai-1) # Delta + drdv_dbeam = np.zeros(n_vai-1) # Delta + + p_r_diff_up = np.zeros([n_vai,len(pp_dict)]) + p_r_diff_dn = np.zeros([n_vai,len(pp_dict)]) + p_r_beam = np.zeros([n_vai,len(pp_dict)]) + p_drdv_diff_up = np.zeros([n_vai-1,len(pp_dict)]) + p_drdv_diff_dn = np.zeros([n_vai-1,len(pp_dict)]) + p_drdv_ubeam = np.zeros([n_vai-1,len(pp_dict)]) + p_drdv_dbeam = np.zeros([n_vai-1,len(pp_dict)]) + + cd_albedo_beam = c_double(-9.0) + cd_albedo_diff = c_double(-9.0) + cd_canabs_beam = c_double(-9.0) + cd_canabs_diff = c_double(-9.0) + cd_ffbeam_beam = c_double(-9.0) + cd_ffdiff_beam = c_double(-9.0) + cd_ffdiff_diff = c_double(-9.0) + + + iret = grndsnow_albedo_call(c_int(ib),c_double(ground_albedo_diff),*ccharnb('albedo_grnd_diff')) + iret = grndsnow_albedo_call(c_int(ib),c_double(ground_albedo_beam),*ccharnb('albedo_grnd_beam')) + iret = canopy_prep_call(c8(veg_frac_snow)) + iret = zenith_prep_call(c8(cosz)) + + iret = solver_call(ci(ib),ci(normalized_boundary),c8(1.0),c8(1.0), \ + byref(cd_albedo_beam),byref(cd_albedo_diff), \ + byref(cd_canabs_beam),byref(cd_canabs_diff), \ + byref(cd_ffbeam_beam),byref(cd_ffdiff_beam),byref(cd_ffdiff_diff)) + + iret = setdown_call(ci(ib),c8(R_beam),c8(R_diff)) + + iret = getparams_call(ci(ican),ci(icol),ci(ib),byref(cd_kb), \ + byref(cd_kd),byref(cd_om),byref(cd_betad),byref(cd_betab)) + + #print(cd_kb.value,cd_kd.value,cd_om.value,cd_betad.value,cd_betab.value) + #exit(0) + + + for iv in range(n_vai): + iret = getintens_call(ci(ican),ci(icol),ci(ib),c8(vai_a[iv]),byref(cd_r_diff_dn), \ + byref(cd_r_diff_up),byref(cd_r_beam)) + + r_beam[iv] = cd_r_beam.value + r_diff_up[iv] = cd_r_diff_up.value + r_diff_dn[iv] = cd_r_diff_dn.value + + if(iv>0): + drdv_ubeam[iv-1] = -cd_om.value*cd_betab.value*(r_beam[iv]-r_beam[iv-1])/dv + drdv_dbeam[iv-1] = -cd_om.value*(1.-cd_betab.value)*(r_beam[iv]-r_beam[iv-1])/dv + drdv_diff_dn[iv-1] = -(r_diff_dn[iv]-r_diff_dn[iv-1])/dv + drdv_diff_up[iv-1] = (r_diff_up[iv]-r_diff_up[iv-1])/dv + + # Redo the scattering with perturbations + i = -1 + for key,val in pp_dict.items(): + i=i+1 + iret = canopy_prep_call(c8(veg_frac_snow)) + iret = zenith_prep_call(c8(cosz)) + iret = forceparam_call(c_int(ican),c_int(icol),ci(ib),c_double(val),*ccharnb(key)) + + iret = solver_call(ci(ib),ci(normalized_boundary),c8(1.0),c8(1.0), \ + byref(cd_albedo_beam),byref(cd_albedo_diff), \ + byref(cd_canabs_beam),byref(cd_canabs_diff), \ + byref(cd_ffbeam_beam),byref(cd_ffdiff_beam),byref(cd_ffdiff_diff)) + + iret = setdown_call(ci(ib),c8(R_beam),c8(R_diff)) + + for iv in range(n_vai): + iret = getintens_call(ci(ican),ci(icol),ci(ib),c8(vai_a[iv]),byref(cd_r_diff_dn),byref(cd_r_diff_up),byref(cd_r_beam)) + + #print(iv,i,cd_r_beam.value) + p_r_beam[iv,i] = cd_r_beam.value + p_r_diff_up[iv,i] = cd_r_diff_up.value + p_r_diff_dn[iv,i] = cd_r_diff_dn.value + + if(iv>0): + p_drdv_ubeam[iv-1] = -cd_om.value*cd_betab.value*(p_r_beam[iv]-p_r_beam[iv-1])/dv + p_drdv_dbeam[iv-1] = -cd_om.value*(1.-cd_betab.value)*(p_r_beam[iv]-p_r_beam[iv-1])/dv + p_drdv_diff_dn[iv-1] = -(p_r_diff_dn[iv]-p_r_diff_dn[iv-1])/dv + p_drdv_diff_up[iv-1] = (p_r_diff_up[iv]-p_r_diff_up[iv-1])/dv + + + fig1, ((ax1,ax2),(ax3,ax4)) = plt.subplots(2,2,figsize=(6.5,5.5)) + + ap = ax1.plot(r_beam,vai_a,p_r_beam[:,i],vai_a) + first_color = ap[0].get_color() + last_color = ap[-1].get_color() + ax1.invert_yaxis() + ax1.set_xlabel('') + ax1.set_ylabel('Integrated VAI [m2/m2]') + ax1.set_title('Beam Intensity [W/m2]') + ax1.grid(True) + + ax2.plot(r_diff_dn,vai_a,p_r_diff_dn[:,i],vai_a) + ax2.invert_yaxis() + ax2.set_xlabel('') + ax2.set_yticklabels('') + ax2.set_ylabel('') + ax2.set_title('Down Diffuse Intensity [W/m2] ') + ax2.grid(True) + + ax3.plot(r_diff_up,vai_a,p_r_diff_up[:,i],vai_a) + ax3.invert_yaxis() + ax3.set_xlabel('') + ax3.set_ylabel('Integrated VAI [m2/m2]') + ax3.set_title('Up Diffuse Intensity [W/m2]') + ax3.grid(True) + + ax4.axis("off") + ax4.set_axis_off() + + if(ib==visb): + band_name = "Visible" + elif(ib==nirb): + band_name = "Near Infrared" + else: + print("Unknown band") + exit(2) + + + param_str = r"""In-element Scattering Profiles +Broad band: {0} +$cos(\phi) = ${1:.2f} +$K_b = ${2:.2f} +$K_d = ${3:.2f} +$\omega = ${4:.2f} +$\beta_b = ${5:.2f} +$\beta_d = ${6:.2f} +$\alpha_{{gd}} = ${7:.2f} +$\alpha_{{gb}} = ${8:.2f}""".format(band_name,cosz,cd_kb.value,cd_kd.value,cd_om.value,cd_betab.value,cd_betad.value,ground_albedo_diff,ground_albedo_beam) + ax4.text(0.1, 0.5, param_str, horizontalalignment='left', \ + verticalalignment='center', transform=ax4.transAxes,backgroundcolor=[1.0,1.0,1.0],fontsize=11,color=first_color) + ax4.text(0.5,0.5,r"{0}={1:.2f}".format(key,val),color=last_color) + plt.subplots_adjust(wspace=0.1, hspace=0.25) + plt.tight_layout() + plt.show() + + + dealloc_twostream_call() + + +# Plotting Functions + + +def PlotRadMaps(elems,rtype,plt_title): + + fig, ax = plt.subplots(ncols=1,nrows=1,figsize=(5,5)) + + cmap = mpl.cm.Reds + #code.interact(local=dict(globals(), **locals())) + n_layer = len(elems) + total_vai = 0 + for i in range(n_layer): + max_vai = 0. + for j in range(len(elems[i])): + max_vai = np.max([max_vai,elems[i][j].lai+elems[i][j].sai]) + total_vai = total_vai + max_vai + + ax.set_ylim([0,total_vai]) + + total_vai = 0 + rect = [] + rcolor = [] + for i in range(n_layer): + # + max_vai = 0. + area_off = 0. + for j in range(len(elems[i])): + max_vai = np.max([max_vai,elems[i][j].lai+elems[i][j].sai]) + for j in range(len(elems[i])): + for iv in range(elems[i][j].n_vai): + if(rtype==0): + rel_intense = np.max([0,elems[i][j].r_b[iv]]) + elif(rtype==1): + rel_intense = np.max([0,elems[i][j].r_dn[iv]]) + elif(rtype==2): + rel_intense = np.max([0,elems[i][j].r_up[iv]]) + + if(iv==0): + yoff = total_vai + dvai = elems[i][j].avai[iv] + else: + yoff = total_vai+elems[i][j].avai[iv-1] + dvai = elems[i][j].avai[iv]-elems[i][j].avai[iv-1] + rect.append(mpl.patches.Rectangle((area_off,yoff),elems[i][j].area,dvai)) + rcolor.append(rel_intense) + area_off = area_off + elems[i][j].area + + total_vai = total_vai + max_vai + + # Air + #rel_intense = np.max([0,np.min([1.,elems[1][i].r_dn[0]/R_diff])]) + #rel_intense = np.max([0,elems[1][i].r_dn[0]]) + #if(rtype==0): + # rel_intense = np.max([0,elems[1][i].r_b[0]]) + #elif(rtype==1): + # rel_intense = np.max([0,elems[1][i].r_dn[0]]) + #elif(rtype==2): + # rel_intense = np.max([0,elems[1][i].r_up[0]]) + + + #rect.append(mpl.patches.Rectangle((elems[0][i].area,total_vai),(1.-elems[0][i].area),(elems[0][i].lai+elems[0][i].sai))) #,color = [rel_intense,0.5,0.5])) + #rcolor.append(rel_intense) + + p = mpl.collections.PatchCollection(rect,cmap = cmap,alpha = 1.0) + p.set_array(rcolor) + im = ax.add_collection(p) + + + #code.interact(local=dict(globals(), **locals())) + + ax.invert_yaxis() + ax.set_ylabel('Integrated Vegetated Area Index') + ax.set_xlabel('Ground Area Fraction') + ax.set_title(plt_title) #) + plt.colorbar(im) + plt.show() + +def PlotRadLines(): + + fig, axs = plt.subplots(ncols=2,nrows=n_layer,figsize=(8,8)) + ax1s = axs.reshape(-1) + ic=0 + y0 = 0.9 + ypad = 0.1 + dy = (y0-ypad)/n_layer + xpad = 0.1 + xwid = 1-2*xpad + + for i in range(n_layer): + + ax = ax1s[ic] + ap = ax.plot(elems[0][i].r_dn,elems[0][i].avai) + ax.set_ylim([np.min(elems[0][i].avai),np.max(elems[0][i].avai)]) + ax.invert_yaxis() + ax.set_xlabel('') + ax.set_xlim([0,R_diff]) + ax.set_ylabel('VAI [m2/m2]') + if(i==0): + ax.set_title('Diffuse Down Intensity [W/m2]') + if(i!=n_layer-1): + ax.set_xticklabels([]) + ax.grid(True) + y0 = y0-dy + x0 = xpad + dx = 0.4 + #dx = elems[0][i].area*(1-2*xpad) + ax.set_position([x0,y0,dx,dy]) + ic=ic+1 + + ax = ax1s[ic] + ap = ax.plot([elems[1][i].r_dn[0],elems[1][i].r_dn[-1]],[0,1]) + ax.invert_yaxis() + ax.set_xlabel('') + ax.set_xlim([0,R_diff]) + if(i==0): + ax.set_title('Diffuse Down Intensity [W/m2]') + if(i!=n_layer-1): + ax.set_xticklabels([]) + ax.set_ylabel('') + ax.set_yticklabels([]) + ax.set_yticks([]) + ax.set_ylim([0,1]) + x0 = xpad+dx + dx=0.4 + #dx = elems[1][i].area*(1-2*xpad) + ax.set_position([x0,y0,dx,dy]) + ax.grid(True) + ic=ic+1 + + + +# ======================================================================================= +# This is the actual call to main + +if __name__ == "__main__": + main(sys.argv) diff --git a/functional_unit_testing/radiation/bld/README b/functional_unit_testing/radiation/bld/README new file mode 100644 index 0000000000..dc7db6c15f --- /dev/null +++ b/functional_unit_testing/radiation/bld/README @@ -0,0 +1 @@ +This is a placeholder to force git to initialize the bld directory \ No newline at end of file diff --git a/functional_unit_testing/radiation/build_radiation_f90_objects.sh b/functional_unit_testing/radiation/build_radiation_f90_objects.sh new file mode 100755 index 0000000000..0f10a98f64 --- /dev/null +++ b/functional_unit_testing/radiation/build_radiation_f90_objects.sh @@ -0,0 +1,26 @@ +#!/bin/bash + +# Path to FATES src + +FC='gfortran' + +F_OPTS="-shared -fPIC -g -O0 -ffpe-trap=zero,overflow,underflow -fbacktrace -fbounds-check -Wall" +#F_OPTS="-shared -fPIC -O" + + +MOD_FLAG="-J" + +rm -f bld/*.o +rm -f bld/*.mod + +# Build the new file with constants + +${FC} ${F_OPTS} -I bld/ ${MOD_FLAG} bld/ -o bld/FatesConstantsMod.o ../../main/FatesConstantsMod.F90 +${FC} ${F_OPTS} -I bld/ ${MOD_FLAG} bld/ -o bld/WrapShrMod.o f90_src/WrapShrMod.F90 +${FC} ${F_OPTS} -I bld/ ${MOD_FLAG} bld/ -o bld/FatesRadiationMemMod.o ../../radiation/FatesRadiationMemMod.F90 +${FC} ${F_OPTS} -I bld/ ${MOD_FLAG} bld/ -o bld/TwoStreamMLPEMod.o ../../radiation/TwoStreamMLPEMod.F90 +${FC} ${F_OPTS} -I bld/ ${MOD_FLAG} bld/ -o bld/RadiationWrapMod.o f90_src/RadiationWrapMod.F90 + + + + diff --git a/functional_unit_testing/radiation/f90_src/RadiationWrapMod.F90 b/functional_unit_testing/radiation/f90_src/RadiationWrapMod.F90 new file mode 100644 index 0000000000..90c31d21a8 --- /dev/null +++ b/functional_unit_testing/radiation/f90_src/RadiationWrapMod.F90 @@ -0,0 +1,276 @@ +module RadiationWrapMod + + use TwoStreamMLPEMod + use iso_c_binding, only : c_char + use iso_c_binding, only : c_int + use iso_c_binding, only : r8 => c_double + + implicit none + public + save + + integer(kind=c_int), parameter :: param_string_length = 32 + + type(twostream_type) :: twostream + + +contains + + subroutine InitAllocate(n_layer,n_column) + + integer(kind=c_int), intent(in) :: n_layer + integer(kind=c_int), intent(in) :: n_column + + integer(kind=c_int) :: ican + + + call twostream%AllocInitTwoStream((/1,2/),n_layer,n_column) + + + twostream%n_lyr = n_layer + + do ican = 1,n_layer + twostream%n_col(ican) = n_column + end do + + twostream%force_prep = .true. + + call twostream%GetNScel() + + twostream%frac_snow = 0._r8 + twostream%frac_snow_old = 1._r8 + + print*,"Allocated twostream instance" + print*," with ",twostream%n_scel," elements" + + return + end subroutine InitAllocate + + + subroutine Dealloc() + + call twostream%DeallocTwoStream() + + end subroutine Dealloc + + + subroutine SetRadParam(val,pft,ib,pname) + + real(r8), intent(in) :: val + character(kind=c_char,len=*), intent(in) :: pname + integer(kind=c_int), intent(in) :: pft + integer(kind=c_int), intent(in) :: ib + + select case(trim(pname)) + case('rhol') + rad_params%rhol(ib,pft) = val + case('rhos') + rad_params%rhos(ib,pft) = val + case('taul') + rad_params%taul(ib,pft) = val + case('taus') + rad_params%taus(ib,pft) = val + case('xl') + rad_params%xl(pft) = val + case('clumping_index') + rad_params%clumping_index(pft) = val + case default + print*,"An unknown parameter name was sent to the parameter" + print*,"initialization function." + print*,"name:--",trim(pname),"--" + stop + end select + + end subroutine SetRadParam + + ! ============================================================================= + + subroutine SetGroundSnow(ib,val,pname) + + real(r8), intent(in) :: val + integer, intent(in) :: ib + character(kind=c_char,len=*), intent(in) :: pname + + select case(trim(pname)) + case('albedo_grnd_diff') + twostream%band(ib)%albedo_grnd_diff = val + case('albedo_grnd_beam') + twostream%band(ib)%albedo_grnd_beam = val + case default + print*,"An unknown parameter name was sent to ground/snow" + print*,"initialization function." + print*,"name:--",trim(pname),"--" + stop + end select + end subroutine SetGroundSnow + + ! ============================================================================= + + subroutine SetupCanopy(ican,icol,pft,area,lai,sai) + + integer(kind=c_int), intent(in) :: ican ! Canopy layer index + integer(kind=c_int), intent(in) :: icol ! Column (pft) position index + integer(kind=c_int), intent(in) :: pft ! PFT index + real(r8), intent(in) :: area ! columns fraction of the ground + real(r8), intent(in) :: lai ! LAI + real(r8), intent(in) :: sai + + + twostream%scelg(ican,icol)%pft = pft + twostream%scelg(ican,icol)%area = area + twostream%scelg(ican,icol)%lai = lai + twostream%scelg(ican,icol)%sai = sai + + return + end subroutine SetupCanopy + + subroutine WrapCanopyPrep(frac_snow) + + real(kind=r8),intent(in) :: frac_snow + + call twostream%CanopyPrep(frac_snow) + + end subroutine WrapCanopyPrep + + subroutine WrapZenithPrep(cosz) + + real(kind=r8),intent(in) :: cosz + + call twostream%ZenithPrep(cosz) + + return + end subroutine WrapZenithPrep + + subroutine WrapSetDownwelling(ib,Rbeam_atm,Rdiff_atm) + + integer(c_int) :: ib + real(r8) :: Rbeam_atm ! Intensity of beam radiation at top of canopy [W/m2 ground] + real(r8) :: Rdiff_atm ! Intensity of diffuse radiation at top of canopy [W/m2 ground] + + twostream%band(ib)%Rbeam_atm = Rbeam_atm + twostream%band(ib)%Rdiff_atm = Rdiff_atm + + return + end subroutine WrapSetDownwelling + + + subroutine WrapSolve(ib,boundary_type,Rbeam_atm,Rdiff_atm, & + albedo_beam, & + albedo_diff, & + frac_abs_can_beam, & + frac_abs_can_diff, & + frac_beam_grnd_beam, & + frac_diff_grnd_beam, & + frac_diff_grnd_diff) + + integer(c_int) :: ib + integer(c_int) :: boundary_type + + real(r8) :: albedo_beam + real(r8) :: albedo_diff + real(r8) :: err_solve + real(r8) :: err_consv + real(r8) :: frac_abs_can_beam + real(r8) :: frac_abs_can_diff + real(r8) :: frac_beam_grnd_beam + real(r8) :: frac_diff_grnd_beam + real(r8) :: frac_diff_grnd_diff + real(r8) :: Rbeam_atm ! Intensity of beam radiation at top of canopy [W/m2 ground] + real(r8) :: Rdiff_atm ! Intensity of diffuse radiation at top of canopy [W/m2 ground] + + real(r8) :: taulamb(50) + real(r8) :: omega(50,50) + integer :: ipiv(50) + + call twostream%Solve(ib,boundary_type, & + Rbeam_atm,Rdiff_atm, & + taulamb, & + omega, & + ipiv, & + albedo_beam, & + albedo_diff, & + err_solve, & + err_consv, & + frac_abs_can_beam, & + frac_abs_can_diff, & + frac_beam_grnd_beam, & + frac_diff_grnd_beam, & + frac_diff_grnd_diff) + + return + end subroutine WrapSolve + + subroutine WrapGetIntensity(ican,icol,ib,vai,r_diff_dn,r_diff_up,r_beam) + + integer(c_int) :: ican, icol + integer(c_int) :: ib + real(r8) :: vai + real(r8) :: r_diff_dn + real(r8) :: r_diff_up + real(r8) :: r_beam + + r_diff_dn = twostream%GetRdDn(ican,icol,ib,vai) + r_diff_up = twostream%GetRdUp(ican,icol,ib,vai) + r_beam = twostream%GetRb(ican,icol,ib,vai) + + return + end subroutine WrapGetIntensity + + subroutine WrapGetAbsRad(ican,icol,ib,vai_top,vai_bot,Rd_abs_leaf,Rb_abs_leaf,R_abs_stem,R_abs_snow,leaf_sun_frac) + + integer(c_int) :: ican, icol + integer(c_int) :: ib + real(r8) :: vai_top,vai_bot + real(r8) :: Rd_abs_leaf,Rb_abs_leaf,R_abs_stem,R_abs_snow,leaf_sun_frac,Rb_abs,Rd_abs + + call twostream%GetAbsRad(ican,icol,ib,vai_top,vai_bot,Rb_abs,Rd_abs,Rd_abs_leaf,Rb_abs_leaf,R_abs_stem,R_abs_snow,leaf_sun_frac) + + return + end subroutine WrapGetAbsRad + + subroutine WrapGetParams(ican,icol,ib,Kb,Kd,om,betad,betab) + + integer(c_int) :: ican, icol + integer(c_int) :: ib + real(r8) :: Kb,Kd,om,betad,betab + + Kb = twostream%scelg(ican,icol)%Kb + Kd = twostream%scelg(ican,icol)%Kd + om = twostream%band(ib)%scelb(ican,icol)%om + betad = twostream%band(ib)%scelb(ican,icol)%betad + betab = twostream%band(ib)%scelb(ican,icol)%betab + + return + end subroutine WrapGetParams + + subroutine WrapForceParams(ican,icol,ib,val,pname) + + ! This will overwrite the 2-stream parameters + ! that are derived from the fates params + + integer(c_int) :: ican, icol + integer(c_int) :: ib + real(r8), intent(in) :: val + character(kind=c_char,len=*), intent(in) :: pname + + select case(trim(pname)) + case('Kb') + twostream%scelg(ican,icol)%Kb = val + case('Kd') + twostream%scelg(ican,icol)%Kd = val + case('om') + twostream%band(ib)%scelb(ican,icol)%om = val + case('betab') + twostream%band(ib)%scelb(ican,icol)%betab = val + case('betad') + twostream%band(ib)%scelb(ican,icol)%betad = val + case default + print*,"An unknown parameter name was sent to the parameter" + print*,"initialization function." + print*,"name:--",trim(pname),"--" + stop + end select + + end subroutine WrapForceParams + +end module RadiationWrapMod diff --git a/functional_unit_testing/radiation/f90_src/WrapShrMod.F90 b/functional_unit_testing/radiation/f90_src/WrapShrMod.F90 new file mode 100644 index 0000000000..7bc093b4d5 --- /dev/null +++ b/functional_unit_testing/radiation/f90_src/WrapShrMod.F90 @@ -0,0 +1,31 @@ +module shr_log_mod + use iso_c_binding, only : c_char + use iso_c_binding, only : c_int + + 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=4) :: cline ! character version of int + character(kind=c_char,len=128) :: ans + + write(cline,'(I4)') line + ans = "source: " // trim(source) // " line: "// trim(cline) + + end function shr_log_errMsg + +end module shr_log_mod + +module shr_sys_mod + + public :: shr_sys_abort + +contains + + subroutine shr_sys_abort + call exit(0) + end subroutine shr_sys_abort + +end module shr_sys_mod diff --git a/functional_unit_testing/shared/py_src/PyF90Utils.py b/functional_unit_testing/shared/py_src/PyF90Utils.py index a9ffaf89ad..3665b59785 100644 --- a/functional_unit_testing/shared/py_src/PyF90Utils.py +++ b/functional_unit_testing/shared/py_src/PyF90Utils.py @@ -19,6 +19,9 @@ def cchar(fchar): def cchar3(fchar): return(byref(c_char(fchar.encode('utf-8')))) +def ccharnb(fchar): + return([c_char_p(fchar.encode('utf-8')),c_long(len(fchar))]) + # We do NOT pass arrays back by reference # This is because we will need to get their length # on the argument diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 5e4a76f698..fd44f07bbe 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -8,8 +8,10 @@ module EDInitMod use FatesConstantsMod , only : ifalse use FatesConstantsMod , only : itrue use FatesConstantsMod , only : fates_unset_int + use FatesConstantsMod , only : primaryland + use FatesConstantsMod , only : nearzero + use FatesConstantsMod , only : n_landuse_cats use FatesConstantsMod , only : fates_unset_r8 - use FatesConstantsMod , only : primaryforest use FatesConstantsMod , only : nearzero, area_error_4, area_error_3 use FatesGlobals , only : endrun => fates_endrun use EDParamsMod , only : nclmax @@ -17,7 +19,6 @@ module EDInitMod use FatesGlobals , only : fates_log use FatesInterfaceTypesMod , only : hlm_is_restart use FatesInterfaceTypesMod , only : hlm_current_tod - use FatesInterfaceTypesMod , only : hlm_numSWb use EDPftvarcon , only : EDPftvarcon_inst use PRTParametersMod , only : prt_params use EDCohortDynamicsMod , only : create_cohort, fuse_cohorts, sort_cohorts @@ -26,6 +27,7 @@ module EDInitMod use EDPhysiologyMod , only : calculate_sp_properties use ChecksBalancesMod , only : SiteMassStock use FatesInterfaceTypesMod , only : hlm_day_of_year + use FatesRadiationMemMod , only : num_swb use EDTypesMod , only : ed_site_type use FatesPatchMod , only : fates_patch_type use FatesCohortMod , only : fates_cohort_type @@ -52,6 +54,7 @@ module EDInitMod use FatesInterfaceTypesMod , only : hlm_use_fixed_biogeog use FatesInterfaceTypesMod , only : hlm_use_tree_damage use FatesInterfaceTypesMod , only : hlm_use_sp + use FatesInterfaceTypesMod , only : hlm_use_luh use FatesInterfaceTypesMod , only : numpft use FatesInterfaceTypesMod , only : nleafage use FatesInterfaceTypesMod , only : nlevsclass @@ -87,6 +90,7 @@ module EDInitMod use PRTGenericMod, only : SetState use FatesSizeAgeTypeIndicesMod,only : get_age_class_index use DamageMainMod, only : undamaged_class + use FatesInterfaceTypesMod , only : hlm_num_luh2_transitions ! CIME GLOBALS use shr_log_mod , only : errMsg => shr_log_errMsg @@ -95,7 +99,6 @@ module EDInitMod private logical :: debug = .false. - integer :: istat ! return status code character(len=255) :: smsg ! Message string for deallocation errors character(len=*), parameter, private :: sourcefile = & @@ -263,10 +266,7 @@ subroutine zero_site( site_in ) ! Disturbance rates tracking site_in%primary_land_patchfusion_error = 0.0_r8 - site_in%potential_disturbance_rates(:) = 0.0_r8 - site_in%disturbance_rates_secondary_to_secondary(:) = 0.0_r8 - site_in%disturbance_rates_primary_to_secondary(:) = 0.0_r8 - site_in%disturbance_rates_primary_to_primary(:) = 0.0_r8 + site_in%disturbance_rates(:,:,:) = 0.0_r8 ! FIRE site_in%acc_ni = 0.0_r8 ! daily nesterov index accumulating over time. time unlimited theoretically. @@ -540,6 +540,7 @@ subroutine init_patches( nsites, sites, bc_in) use FatesPlantHydraulicsMod, only : updateSizeDepRhizHydProps use FatesInventoryInitMod, only : initialize_sites_by_inventory + use FatesLandUseChangeMod, only : get_luh_statedata ! ! !ARGUMENTS @@ -562,11 +563,17 @@ subroutine init_patches( nsites, sites, bc_in) integer :: start_patch integer :: num_new_patches integer :: nocomp_pft - real(r8) :: newparea + real(r8) :: newparea, newparea_withlanduse real(r8) :: total !check on area - real(r8) :: litt_init + real(r8) :: litt_init !invalid for satphen, 0 otherwise real(r8) :: old_carea integer :: is_first_patch + ! integer :: n_luh_states + ! integer :: luh_state_counter + real(r8) :: state_vector(n_landuse_cats) ! [m2/m2] + integer :: i_lu, i_lu_state + integer :: n_active_landuse_cats + type(ed_site_type), pointer :: sitep type(fates_patch_type), pointer :: newppft(:) @@ -602,11 +609,14 @@ subroutine init_patches( nsites, sites, bc_in) call SiteMassStock(sites(s),el,sites(s)%mass_balance(el)%old_stock, & biomass_stock,litter_stock,seed_stock) end do + call set_patchno(sites(s)) enddo - + else - do s = 1, nsites + ! state_vector(:) = 0._r8 + + sites_loop: do s = 1, nsites sites(s)%sp_tlai(:) = 0._r8 sites(s)%sp_tsai(:) = 0._r8 sites(s)%sp_htop(:) = 0._r8 @@ -627,8 +637,36 @@ subroutine init_patches( nsites, sites, bc_in) num_new_patches = 1 end if !nocomp + ! read in luh state data to determine initial land use types + if (hlm_use_luh .eq. itrue) then + + ! Set the number of active land use categories to the maximum number + ! This could be updated in the future to allow a variable number of + ! categories based on which states are zero + n_active_landuse_cats = n_landuse_cats + call get_luh_statedata(bc_in(s), state_vector) + ! n_luh_states = 0 + ! do i_lu = 1, hlm_num_luh2_transitions + ! if ( state_vector(i_lu) .gt. nearzero ) then + ! n_luh_states = n_luh_states +1 + ! end if + ! end do + + ! if (n_luh_states .eq. 0) then + ! write(fates_log(),*) 'error. n_luh_states .eq. 0.' + ! call endrun(msg=errMsg(sourcefile, __LINE__)) + ! endif + else + ! If LUH2 data is not being used, we initialize with primarylands, + ! i.e. array index equals '1' + n_active_landuse_cats = primaryland + state_vector(:) = 0._r8 + state_vector(primaryland) = 1._r8 + endif + is_first_patch = itrue - do n = start_patch, num_new_patches + ! luh_state_counter = 0 + new_patch_nocomp_loop: do n = start_patch, num_new_patches ! set the PFT index for patches if in nocomp mode. if(hlm_use_nocomp.eq.itrue)then @@ -653,57 +691,66 @@ subroutine init_patches( nsites, sites, bc_in) newparea = area end if !nocomp mode - if(newparea.gt.0._r8)then ! Stop patches being initilialized when PFT not present in nocomop mode - allocate(newp) - call newp%Create(age, newparea, primaryforest, nocomp_pft, & - hlm_numSWb, numpft, sites(s)%nlevsoil, hlm_current_tod, & - regeneration_model) - - if(is_first_patch.eq.itrue)then !is this the first patch? - ! set poointers for first patch (or only patch, if nocomp is false) - newp%patchno = 1 - newp%younger => null() - newp%older => null() - sites(s)%youngest_patch => newp - sites(s)%oldest_patch => newp - is_first_patch = ifalse - else - ! Set pointers for N>1 patches. Note this only happens when nocomp mode s on. - ! The new patch is the 'youngest' one, arbitrarily. - newp%patchno = nocomp_pft - newp%older => sites(s)%youngest_patch - newp%younger => null() - sites(s)%youngest_patch%younger => newp - sites(s)%youngest_patch => newp - end if - - ! Initialize the litter pools to zero, these - ! pools will be populated by looping over the existing patches - ! and transfering in mass - if(hlm_use_sp.eq.itrue)then - litt_init = fates_unset_r8 - else - litt_init = 0._r8 - end if - do el=1,num_elements - call newp%litter(el)%InitConditions(init_leaf_fines=litt_init, & - init_root_fines=litt_init, & - init_ag_cwd=litt_init, & - init_bg_cwd=litt_init, & - init_seed=litt_init, & - init_seed_germ=litt_init) - end do - - sitep => sites(s) - if(hlm_use_sp.eq.itrue)then - if(nocomp_pft.ne.0)then !don't initialize cohorts for SP bare ground patch - call init_cohorts(sitep, newp, bc_in(s)) - end if - else ! normal non SP case always call init cohorts - call init_cohorts(sitep, newp, bc_in(s)) - end if - end if - end do !no new patches + luh_state_loop: do i_lu_state = 1, n_active_landuse_cats + lu_state_present_if: if ( state_vector(i_lu_state) .gt. nearzero ) then + + newparea_withlanduse = newparea * state_vector(i_lu_state) + + ! for now, spread nocomp PFTs evenly across land use types + new_patch_area_gt_zero: if(newparea_withlanduse.gt.0._r8)then ! Stop patches being initilialized when PFT not present in nocomop mode + allocate(newp) + + call newp%Create(age, newparea_withlanduse, i_lu_state, nocomp_pft, & + num_swb, numpft, sites(s)%nlevsoil, hlm_current_tod, & + regeneration_model) + + if(is_first_patch.eq.itrue)then !is this the first patch? + ! set poointers for first patch (or only patch, if nocomp is false) + newp%patchno = 1 + newp%younger => null() + newp%older => null() + sites(s)%youngest_patch => newp + sites(s)%oldest_patch => newp + is_first_patch = ifalse + else + ! Set pointers for N>1 patches. Note this only happens when nocomp mode s on. + ! The new patch is the 'youngest' one, arbitrarily. + newp%patchno = nocomp_pft + (i_lu_state-1) * numpft + newp%older => sites(s)%youngest_patch + newp%younger => null() + sites(s)%youngest_patch%younger => newp + sites(s)%youngest_patch => newp + end if + + ! Initialize the litter pools to zero, these + ! pools will be populated by looping over the existing patches + ! and transfering in mass + if(hlm_use_sp.eq.itrue)then + litt_init = fates_unset_r8 + else + litt_init = 0._r8 + end if + do el=1,num_elements + call newp%litter(el)%InitConditions(init_leaf_fines=litt_init, & + init_root_fines=litt_init, & + init_ag_cwd=litt_init, & + init_bg_cwd=litt_init, & + init_seed=litt_init, & + init_seed_germ=litt_init) + end do + + sitep => sites(s) + if(hlm_use_sp.eq.itrue)then + if(nocomp_pft.ne.0)then !don't initialize cohorts for SP bare ground patch + call init_cohorts(sitep, newp, bc_in(s)) + end if + else ! normal non SP case always call init cohorts + call init_cohorts(sitep, newp, bc_in(s)) + end if + end if new_patch_area_gt_zero + end if lu_state_present_if + end do luh_state_loop + end do new_patch_nocomp_loop !no new patches !check if the total area adds to the same as site area total = 0.0_r8 @@ -757,7 +804,7 @@ subroutine init_patches( nsites, sites, bc_in) call set_patchno(sites(s)) - enddo !s + enddo sites_loop !s end if ! zero all the patch fire variables for the first timestep diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 2b29157512..159e942c6a 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -74,7 +74,7 @@ module EDMainMod use EDTypesMod , only : phen_dstat_moiston use EDTypesMod , only : phen_dstat_timeon use FatesConstantsMod , only : itrue,ifalse - use FatesConstantsMod , only : primaryforest, secondaryforest + use FatesConstantsMod , only : primaryland, secondaryland use FatesConstantsMod , only : nearzero use FatesConstantsMod , only : m2_per_ha use FatesConstantsMod , only : sec_per_day @@ -439,7 +439,7 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) endif ! add age increment to secondary forest patches as well - if (currentPatch%anthro_disturbance_label .eq. secondaryforest) then + if (currentPatch%land_use_label .ne. primaryland) then currentPatch%age_since_anthro_disturbance = & currentPatch%age_since_anthro_disturbance + hlm_freq_day endif @@ -472,7 +472,7 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) mean_temp = currentPatch%tveg24%GetMean() call Mortality_Derivative(currentSite, currentCohort, bc_in, & currentPatch%btran_ft, mean_temp, & - currentPatch%anthro_disturbance_label, & + currentPatch%land_use_label, & currentPatch%age_since_anthro_disturbance, frac_site_primary, & harvestable_forest_c, harvest_tag) @@ -765,7 +765,7 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) end subroutine ed_integrate_state_variables !-------------------------------------------------------------------------------! - subroutine ed_update_site( currentSite, bc_in, bc_out ) + subroutine ed_update_site( currentSite, bc_in, bc_out, is_restarting ) ! ! !DESCRIPTION: ! Calls routines to consolidate the ED growth process. @@ -781,17 +781,19 @@ subroutine ed_update_site( currentSite, bc_in, bc_out ) type(ed_site_type) , intent(inout), target :: currentSite type(bc_in_type) , intent(in) :: bc_in type(bc_out_type) , intent(inout) :: bc_out + logical,intent(in) :: is_restarting ! is this called during restart read? ! ! !LOCAL VARIABLES: type (fates_patch_type) , pointer :: currentPatch !----------------------------------------------------------------------- - if(hlm_use_sp.eq.ifalse)then + + if(hlm_use_sp.eq.ifalse .and. (.not.is_restarting))then call canopy_spread(currentSite) end if call TotalBalanceCheck(currentSite,6) - if(hlm_use_sp.eq.ifalse)then + if(hlm_use_sp.eq.ifalse .and. (.not.is_restarting) )then call canopy_structure(currentSite, bc_in) endif @@ -805,22 +807,22 @@ subroutine ed_update_site( currentSite, bc_in, bc_out ) currentPatch => currentSite%oldest_patch do while(associated(currentPatch)) - ! Is termination really needed here? - ! Canopy_structure just called it several times! (rgk) - call terminate_cohorts(currentSite, currentPatch, 1, 11, bc_in) - call terminate_cohorts(currentSite, currentPatch, 2, 11, bc_in) - - ! This cohort count is used in the photosynthesis loop - call count_cohorts(currentPatch) - - ! Update the total area of by patch age class array - currentSite%area_by_age(currentPatch%age_class) = & - currentSite%area_by_age(currentPatch%age_class) + currentPatch%area - - currentPatch => currentPatch%younger + if(.not.is_restarting)then + call terminate_cohorts(currentSite, currentPatch, 1, 11, bc_in) + call terminate_cohorts(currentSite, currentPatch, 2, 11, bc_in) + end if + ! This cohort count is used in the photosynthesis loop + call count_cohorts(currentPatch) + + ! Update the total area of by patch age class array + currentSite%area_by_age(currentPatch%age_class) = & + currentSite%area_by_age(currentPatch%age_class) + currentPatch%area + + currentPatch => currentPatch%younger + enddo - + ! The HLMs need to know about nutrient demand, and/or ! root mass and affinities call PrepNutrientAquisitionBCs(currentSite,bc_in,bc_out) @@ -832,10 +834,9 @@ subroutine ed_update_site( 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 - - if(hlm_use_sp.eq.ifalse)then - call trim_canopy(currentSite) + if( hlm_day_of_year == hlm_days_per_year-1 .and. (.not.is_restarting)) then + if(hlm_use_sp.eq.ifalse)then + call trim_canopy(currentSite) endif endif @@ -968,7 +969,7 @@ subroutine TotalBalanceCheck (currentSite, call_index ) write(fates_log(),*) 'BG CWD (by layer): ', sum(litt%bg_cwd,dim=1) write(fates_log(),*) 'leaf litter:',sum(litt%leaf_fines) write(fates_log(),*) 'root litter (by layer): ',sum(litt%root_fines,dim=1) - write(fates_log(),*) 'anthro_disturbance_label: ',currentPatch%anthro_disturbance_label + write(fates_log(),*) 'land_use_label: ',currentPatch%land_use_label write(fates_log(),*) 'use_this_pft: ', currentSite%use_this_pft(:) if(print_cohorts)then write(fates_log(),*) '---- Biomass by cohort and organ -----' diff --git a/main/EDParamsMod.F90 b/main/EDParamsMod.F90 index 438d387213..beaf11e140 100644 --- a/main/EDParamsMod.F90 +++ b/main/EDParamsMod.F90 @@ -10,6 +10,7 @@ module EDParamsMod use FatesGlobals , only : fates_log use FatesGlobals , only : endrun => fates_endrun use FatesConstantsMod, only : fates_unset_r8 + use FatesConstantsMod, only : n_landuse_cats ! CIME Globals use shr_log_mod , only : errMsg => shr_log_errMsg @@ -95,41 +96,17 @@ module EDParamsMod integer, public :: n_uptake_mode integer, public :: p_uptake_mode + real(r8), parameter, public :: soil_tfrz_thresh = -2.0_r8 ! Soil temperature threshold below which hydraulic failure mortality is off (non-hydro only) in degrees C + integer, parameter, public :: nclmax = 2 ! Maximum number of canopy layers - + ! parameters that govern the VAI (LAI+SAI) bins used in radiative transfer code integer, parameter, public :: nlevleaf = 30 ! number of leaf+stem layers in each canopy layer real(r8), public :: dinc_vai(nlevleaf) = fates_unset_r8 ! VAI bin widths array real(r8), public :: dlower_vai(nlevleaf) = fates_unset_r8 ! lower edges of VAI bins - ! TODO: we use this cp_maxSWb only because we have a static array q(size=2) of - ! land-ice abledo for vis and nir. This should be a parameter, which would - ! get us on track to start using multi-spectral or hyper-spectral (RGK 02-2017) - - integer, parameter, public :: maxSWb = 2 ! maximum number of broad-bands in the - ! shortwave spectrum cp_numSWb <= cp_maxSWb - ! this is just for scratch-array purposes - ! if cp_numSWb is larger than this value - ! simply bump this number up as needed - -integer, parameter, public :: ivis = 1 ! This is the array index for short-wave - ! radiation in the visible spectrum, as expected - ! in boundary condition files and parameter - ! files. This will be compared with - ! the HLM's expectation in FatesInterfaceMod -integer, parameter, public :: inir = 2 ! This is the array index for short-wave - ! radiation in the near-infrared spectrum, as expected - ! in boundary condition files and parameter - ! files. This will be compared with - ! the HLM's expectation in FatesInterfaceMod - -integer, parameter, public :: ipar = ivis ! The photosynthetically active band - ! can be approximated to be equal to the visible band - - - -integer, parameter, public :: maxpft = 16 ! maximum number of PFTs allowed + integer, parameter, public :: maxpft = 16 ! maximum number of PFTs allowed real(r8),protected,public :: q10_mr ! Q10 for respiration rate (for soil fragmenation and plant respiration) (unitless) real(r8),protected,public :: q10_froz ! Q10 for frozen-soil respiration rates (for soil fragmentation) (unitless) @@ -197,6 +174,7 @@ module EDParamsMod character(len=param_string_length),parameter,public :: ED_name_history_height_bin_edges= "fates_history_height_bin_edges" character(len=param_string_length),parameter,public :: ED_name_history_coageclass_bin_edges = "fates_history_coageclass_bin_edges" character(len=param_string_length),parameter,public :: ED_name_history_damage_bin_edges = "fates_history_damage_bin_edges" + character(len=param_string_length),parameter,public :: ED_name_maxpatches_by_landuse = "fates_maxpatches_by_landuse" ! Hydraulics Control Parameters (ONLY RELEVANT WHEN USE_FATES_HYDR = TRUE) ! ---------------------------------------------------------------------------------------------- @@ -247,13 +225,9 @@ module EDParamsMod ! The number of patches specified in the parameter file may be over-written. ! For instance, in SP mode, we want the same number of primary patches as the number of PFTs ! in the fates parameter file, and zero secondary. + ! thus they are not protected here. - integer, public :: maxpatch_primary - character(len=param_string_length), parameter, public :: maxpatch_primary_name = "fates_maxpatch_primary" - - integer, public :: maxpatch_secondary - character(len=param_string_length), parameter, public :: maxpatch_secondary_name = "fates_maxpatch_secondary" - + integer, public :: maxpatches_by_landuse(n_landuse_cats) integer, public :: maxpatch_total ! Maximum allowable cohorts per patch @@ -359,8 +333,6 @@ subroutine FatesParamsInit() stomatal_model = -9 regeneration_model = -9 stomatal_assim_model = -9 - maxpatch_primary = -9 - maxpatch_secondary = -9 max_cohort_per_patch = -9 hydr_kmax_rsurf1 = nan hydr_kmax_rsurf2 = nan @@ -397,7 +369,7 @@ subroutine FatesRegisterParams(fates_params) use FatesParametersInterface, only : dimension_name_history_size_bins, dimension_name_history_age_bins use FatesParametersInterface, only : dimension_name_history_height_bins, dimension_name_hydr_organs use FatesParametersInterface, only : dimension_name_history_coage_bins, dimension_name_history_damage_bins - use FatesParametersInterface, only : dimension_shape_scalar + use FatesParametersInterface, only : dimension_shape_scalar, dimension_name_landuse implicit none @@ -411,6 +383,7 @@ subroutine FatesRegisterParams(fates_params) character(len=param_string_length), parameter :: dim_names_coageclass(1) = (/dimension_name_history_coage_bins/) character(len=param_string_length), parameter :: dim_names_hydro_organs(1) = (/dimension_name_hydr_organs/) character(len=param_string_length), parameter :: dim_names_damageclass(1)= (/dimension_name_history_damage_bins/) + character(len=param_string_length), parameter :: dim_names_landuse(1)= (/dimension_name_landuse/) call FatesParamsInit() @@ -516,12 +489,6 @@ subroutine FatesRegisterParams(fates_params) call fates_params%RegisterParameter(name=stomatal_assim_name, dimension_shape=dimension_shape_scalar, & dimension_names=dim_names_scalar) - call fates_params%RegisterParameter(name=maxpatch_primary_name, dimension_shape=dimension_shape_scalar, & - dimension_names=dim_names_scalar) - - call fates_params%RegisterParameter(name=maxpatch_secondary_name, dimension_shape=dimension_shape_scalar, & - dimension_names=dim_names_scalar) - call fates_params%RegisterParameter(name=maxcohort_name, dimension_shape=dimension_shape_scalar, & dimension_names=dim_names_scalar) @@ -617,6 +584,9 @@ subroutine FatesRegisterParams(fates_params) call fates_params%RegisterParameter(name=ED_name_history_damage_bin_edges, dimension_shape=dimension_shape_1d, & dimension_names=dim_names_damageclass) + call fates_params%RegisterParameter(name=ED_name_maxpatches_by_landuse, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names_landuse) + end subroutine FatesRegisterParams @@ -624,6 +594,7 @@ end subroutine FatesRegisterParams subroutine FatesReceiveParams(fates_params) use FatesParametersInterface, only : fates_parameters_type, dimension_name_scalar + use FatesConstantsMod, only: primaryland, secondaryland, rangeland, pastureland, cropland implicit none @@ -631,6 +602,7 @@ subroutine FatesReceiveParams(fates_params) real(r8) :: tmpreal ! local real variable for changing type on read real(r8), allocatable :: hydr_htftype_real(:) + real(r8) :: tmp_vector_by_landuse(n_landuse_cats) ! local real vector for changing type on read call fates_params%RetrieveParameter(name=ED_name_photo_temp_acclim_timescale, & data=photo_temp_acclim_timescale) @@ -733,16 +705,6 @@ subroutine FatesReceiveParams(fates_params) call fates_params%RetrieveParameter(name=stomatal_assim_name, & data=tmpreal) stomatal_assim_model = nint(tmpreal) - - call fates_params%RetrieveParameter(name=maxpatch_primary_name, & - data=tmpreal) - maxpatch_primary = nint(tmpreal) - - call fates_params%RetrieveParameter(name=maxpatch_secondary_name, & - data=tmpreal) - maxpatch_secondary = nint(tmpreal) - - maxpatch_total = maxpatch_primary+maxpatch_secondary call fates_params%RetrieveParameter(name=maxcohort_name, & data=tmpreal) @@ -846,6 +808,12 @@ subroutine FatesReceiveParams(fates_params) call fates_params%RetrieveParameterAllocate(name=ED_name_history_damage_bin_edges, & data=ED_val_history_damage_bin_edges) + call fates_params%RetrieveParameter(name=ED_name_maxpatches_by_landuse, & + data=tmp_vector_by_landuse) + + maxpatches_by_landuse(:) = nint(tmp_vector_by_landuse(:)) + maxpatch_total = sum(maxpatches_by_landuse(:)) + call fates_params%RetrieveParameterAllocate(name=ED_name_hydr_htftype_node, & data=hydr_htftype_real) allocate(hydr_htftype_node(size(hydr_htftype_real))) diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index d344f82c8d..5745141c70 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -6,7 +6,9 @@ module EDPftvarcon ! read and initialize vegetation (PFT) constants. ! ! !USES: - use EDParamsMod , only : maxSWb, ivis, inir + + use FatesRadiationMemMod, only: num_swb,ivis,inir + use FatesRadiationMemMod, only: norman_solver,twostr_solver use FatesConstantsMod, only : r8 => fates_r8 use FatesConstantsMod, only : nearzero use FatesConstantsMod, only : itrue, ifalse @@ -1338,7 +1340,7 @@ subroutine Receive_PFT_numrad(this, fates_params) lower_bound_1 = lower_bound_pft upper_bound_1 = lower_bound_pft + dimension_sizes(1) - 1 lower_bound_2 = lower_bound_general - upper_bound_2 = maxSWb ! When we have radiation parameters read in as a vector + upper_bound_2 = num_swb ! When we have radiation parameters read in as a vector ! We will compare the vector dimension size that we ! read-in to the parameterized size that fates expects @@ -1789,10 +1791,10 @@ subroutine FatesCheckParams(is_master) if(.not.is_master) return - if(radiation_model.ne.1) then - write(fates_log(),*) 'The only available canopy radiation model' - write(fates_log(),*) 'is the Norman scheme: fates_rad_model = 1' - write(fates_log(),*) 'The two-stream scheme is not available yet' + if(.not.any(radiation_model == [norman_solver,twostr_solver])) then + write(fates_log(),*) 'The only available canopy radiation models' + write(fates_log(),*) 'are the Norman and Two-stream schemes, ' + write(fates_log(),*) 'fates_rad_model = 1 or 2 ...' write(fates_log(),*) 'You specified fates_rad_model = ',radiation_model write(fates_log(),*) 'Aborting' call endrun(msg=errMsg(sourcefile, __LINE__)) @@ -1918,7 +1920,7 @@ subroutine FatesCheckParams(is_master) ! xl must be between -0.4 and 0.6 according to Bonan (2019) doi:10.1017/9781107339217 pg. 238 !----------------------------------------------------------------------------------- if (EDPftvarcon_inst%xl(ipft) < -0.4 .or. EDPftvarcon_inst%xl(ipft) > 0.6) then - write(fates_log(),*) 'fates_rad_leaf_xl for pft ', ipft, ' is outside the allowed range of -0.6 to 0.4' + write(fates_log(),*) 'fates_rad_leaf_xl for pft ', ipft, ' is outside the allowed range of -0.4 to 0.6' write(fates_log(),*) 'Aborting' call endrun(msg=errMsg(sourcefile, __LINE__)) end if diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index ca524dfcb9..34e5f319d7 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -19,16 +19,16 @@ module EDTypesMod use PRTGenericMod, only : carbon12_element use FatesLitterMod, only : litter_type use FatesLitterMod, only : ncwd, NFSC - use FatesConstantsMod, only : n_anthro_disturbance_categories use FatesConstantsMod, only : days_per_year use FatesRunningMeanMod, only : rmean_type,rmean_arr_type use FatesConstantsMod, only : fates_unset_r8 use FatesInterfaceTypesMod,only : bc_in_type use FatesInterfaceTypesMod,only : bc_out_type + use FatesConstantsMod , only : n_landuse_cats use FatesInterfaceTypesMod,only : hlm_parteh_mode use FatesCohortMod, only : fates_cohort_type use FatesPatchMod, only : fates_patch_type - use EDParamsMod, only : maxSWb, nclmax, nlevleaf, maxpft + use EDParamsMod, only : nclmax, nlevleaf, maxpft use FatesConstantsMod, only : n_dbh_bins, n_dist_types use shr_log_mod, only : errMsg => shr_log_errMsg @@ -87,7 +87,6 @@ module EDTypesMod ! BIOLOGY/BIOGEOCHEMISTRY integer , parameter, public :: num_vegtemp_mem = 10 ! Window of time over which we track temp for cold sensecence (days) - ! Phenology status flag definitions (cold type is cstat, dry type is dstat) integer, parameter, public :: phen_cstat_nevercold = 0 ! This (location/plant) has not experienced a cold period over a large number @@ -266,7 +265,24 @@ module EDTypesMod ! which is used for fixation - + ! Two-stream scratch arrays + real(r8), allocatable :: omega_2str(:,:) ! This is the matrix that is inverted to solve + ! the linear system of equations in the two-stream + ! radiation module. This array will grow + ! and shrink depending on how many scattering + ! elements there are. This matrix is square, + ! and needs to be larger than 2 x number-of-elements + ! for each patch on the site + + real(r8), allocatable :: taulambda_2str(:) ! These are the coefficients of the two-stream + ! linear system of equations (ie the unknowns, "lambda") + ! As well as the left-side (constants, "tau"). Since + ! the LAPACK solver dgesv uses the latter + ! as the argument and over-writes, we only + ! need one array + + integer, allocatable :: ipiv_2str(:) ! pivot indices for the lapack 2str solver + ! SP mode target PFT level variables real(r8), allocatable :: sp_tlai(:) ! target TLAI per FATES pft real(r8), allocatable :: sp_tsai(:) ! target TSAI per FATES pft @@ -426,12 +442,10 @@ module EDTypesMod real(r8), allocatable :: seed_in(:) ! amount of seed dispersed into the site from neighbouring cells [kg/site/day] ! site-level variables to keep track of the disturbance rates, both actual and "potential" - real(r8) :: disturbance_rates_primary_to_primary(N_DIST_TYPES) ! actual disturbance rates from primary patches to primary patches [m2/m2/day] - real(r8) :: disturbance_rates_primary_to_secondary(N_DIST_TYPES) ! actual disturbance rates from primary patches to secondary patches [m2/m2/day] - real(r8) :: disturbance_rates_secondary_to_secondary(N_DIST_TYPES) ! actual disturbance rates from secondary patches to secondary patches [m2/m2/day] - real(r8) :: potential_disturbance_rates(N_DIST_TYPES) ! "potential" disturb rates (i.e. prior to the "which is most" logic) [m2/m2/day] - real(r8) :: primary_land_patchfusion_error ! error term in total area of primary patches associated with patch fusion [m2/m2/day] - + real(r8) :: disturbance_rates(N_DIST_TYPES,n_landuse_cats, n_landuse_cats) ! actual disturbance rates for each disturbance type [m2/m2/day] + real(r8) :: primary_land_patchfusion_error ! error term in total area of primary patches associated with patch fusion [m2/m2/day] + real(r8) :: landuse_transition_matrix(n_landuse_cats, n_landuse_cats) ! land use transition matrix as read in from HLM and aggregated to FATES land use types [m2/m2/year] + end type ed_site_type ! Make public necessary subroutines and functions @@ -502,6 +516,6 @@ subroutine dump_site(csite) return end subroutine dump_site - + end module EDTypesMod diff --git a/main/FatesConstantsMod.F90 b/main/FatesConstantsMod.F90 index fbc4e96c29..df3a719204 100644 --- a/main/FatesConstantsMod.F90 +++ b/main/FatesConstantsMod.F90 @@ -34,22 +34,24 @@ module FatesConstantsMod ! are used, but this helps allocate scratch ! space and output arrays. - integer, parameter, public :: n_rad_stream_types = 2 ! The number of radiation streams used (direct/diffuse) - integer , parameter, public :: N_DBH_BINS = 6 ! no. of dbh bins used when comparing patches real(fates_r8), parameter, public :: patchfusion_dbhbin_loweredges(N_DBH_BINS) = & (/0._fates_r8, 5._fates_r8, 20._fates_r8, 50._fates_r8, 100._fates_r8, 150._fates_r8/) ! array of bin lower edges for comparing patches - integer , parameter, public :: N_DIST_TYPES = 3 ! Disturbance Modes 1) tree-fall, 2) fire, 3) logging + integer , parameter, public :: N_DIST_TYPES = 4 ! Disturbance Modes 1) tree-fall, 2) fire, 3) logging, 4) land-use change integer , parameter, public :: dtype_ifall = 1 ! index for naturally occuring tree-fall generated event integer , parameter, public :: dtype_ifire = 2 ! index for fire generated disturbance event integer , parameter, public :: dtype_ilog = 3 ! index for logging generated disturbance event + integer , parameter, public :: dtype_ilandusechange = 4 ! index for land use change disturbance (not including logging) ! Labels for patch disturbance history - integer, parameter, public :: n_anthro_disturbance_categories = 2 - integer, parameter, public :: primaryforest = 1 - integer, parameter, public :: secondaryforest = 2 + integer, parameter, public :: n_landuse_cats = 5 + integer, parameter, public :: primaryland = 1 + integer, parameter, public :: secondaryland = 2 + integer, parameter, public :: rangeland = 3 + integer, parameter, public :: pastureland = 4 + integer, parameter, public :: cropland = 5 integer, parameter, public :: leaves_on = 2 ! Flag specifying that a deciduous plant has leaves diff --git a/main/FatesGlobals.F90 b/main/FatesGlobals.F90 index ebc0f326ff..299fb5d5fb 100644 --- a/main/FatesGlobals.F90 +++ b/main/FatesGlobals.F90 @@ -5,6 +5,7 @@ module FatesGlobals ! immediately obvious home. use FatesConstantsMod , only : r8 => fates_r8 + use TwoStreamMLPEMod , only : TwoStreamLogInit implicit none private ! By default everything is private @@ -63,6 +64,8 @@ subroutine FatesGlobalsInit(log_unit,global_verbose) fates_log_ = log_unit fates_global_verbose_ = global_verbose + call TwoStreamLogInit(log_unit) + end subroutine FatesGlobalsInit ! ===================================================================================== diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index c530656bda..81bfef2792 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -14,6 +14,7 @@ module FatesHistoryInterfaceMod use FatesGlobals , only : endrun => fates_endrun use EDParamsMod , only : nclmax, maxpft use FatesConstantsMod , only : ican_upper + use FatesRadiationMemMod , only : num_swb use PRTGenericMod , only : element_pos use PRTGenericMod , only : num_elements use PRTGenericMod , only : prt_cnp_flex_allom_hyp @@ -84,7 +85,7 @@ module FatesHistoryInterfaceMod use FatesConstantsMod , only : dens_fresh_liquid_water use FatesConstantsMod , only : grav_earth use FatesLitterMod , only : litter_type - use FatesConstantsMod , only : secondaryforest + use FatesConstantsMod , only : secondaryland use PRTGenericMod , only : leaf_organ, fnrt_organ, sapw_organ use PRTGenericMod , only : struct_organ, store_organ, repro_organ @@ -277,6 +278,9 @@ module FatesHistoryInterfaceMod ! Size-class x PFT LAI states integer :: ih_lai_canopy_si_scpf integer :: ih_lai_understory_si_scpf + ! Size-class x PFT LAI states + integer :: ih_crownarea_canopy_si_scpf + integer :: ih_crownarea_understory_si_scpf integer :: ih_totvegc_scpf integer :: ih_leafc_scpf @@ -308,13 +312,11 @@ module FatesHistoryInterfaceMod integer :: ih_growth_resp_secondary_si integer :: ih_primaryland_fusion_error_si - integer :: ih_disturbance_rate_p2p_si - integer :: ih_disturbance_rate_p2s_si - integer :: ih_disturbance_rate_s2s_si + integer :: ih_area_si_landuse + integer :: ih_disturbance_rate_si_lulu integer :: ih_fire_disturbance_rate_si integer :: ih_logging_disturbance_rate_si integer :: ih_fall_disturbance_rate_si - integer :: ih_potential_disturbance_rate_si integer :: ih_harvest_carbonflux_si integer :: ih_harvest_debt_si integer :: ih_harvest_debt_sec_si @@ -606,7 +608,7 @@ module FatesHistoryInterfaceMod integer :: ih_c_stomata_si_age integer :: ih_c_lblayer_si_age integer :: ih_agesince_anthrodist_si_age - integer :: ih_secondaryforest_area_si_age + integer :: ih_secondarylands_area_si_age integer :: ih_area_burnt_si_age ! integer :: ih_fire_rate_of_spread_front_si_age integer :: ih_fire_intensity_si_age @@ -686,8 +688,6 @@ module FatesHistoryInterfaceMod integer :: ih_fabi_sha_si_cnlf integer :: ih_ts_net_uptake_si_cnlf integer :: ih_crownarea_si_cnlf - integer :: ih_parprof_dir_si_cnlf - integer :: ih_parprof_dif_si_cnlf ! indices to (site x [canopy layer x leaf layer x pft]) variables integer :: ih_parsun_z_si_cnlfpft @@ -771,6 +771,7 @@ module FatesHistoryInterfaceMod integer, private :: levelcwd_index_, levelage_index_ integer, private :: levcacls_index_, levcapf_index_ integer, private :: levclscpf_index_ + integer, private :: levlanduse_index_, levlulu_index_, levlupft_index_ contains @@ -813,6 +814,9 @@ module FatesHistoryInterfaceMod procedure :: levelage_index procedure :: levagefuel_index procedure :: levclscpf_index + procedure :: levlanduse_index + procedure :: levlulu_index + procedure :: levlupft_index ! private work functions procedure, private :: define_history_vars @@ -841,6 +845,9 @@ module FatesHistoryInterfaceMod procedure, private :: set_levheight_index procedure, private :: set_levagefuel_index procedure, private :: set_levclscpf_index + procedure, private :: set_levlanduse_index + procedure, private :: set_levlulu_index + procedure, private :: set_levlupft_index procedure, private :: set_levelem_index procedure, private :: set_levelpft_index @@ -879,6 +886,7 @@ subroutine Init(this, num_threads, fates_bounds) use FatesIODimensionsMod, only : levelem, levelpft use FatesIODimensionsMod, only : levelcwd, levelage, levclscpf use FatesIODimensionsMod, only : levcdpf, levcdsc, levcdam + use FatesIODimensionsMod, only : levlanduse, levlulu, levlupft implicit none @@ -1018,6 +1026,21 @@ subroutine Init(this, num_threads, fates_bounds) call this%dim_bounds(dim_count)%Init(levclscpf, num_threads, & fates_bounds%clscpf_begin, fates_bounds%clscpf_end) + dim_count = dim_count + 1 + call this%set_levlanduse_index(dim_count) + call this%dim_bounds(dim_count)%Init(levlanduse, num_threads, & + fates_bounds%landuse_begin, fates_bounds%landuse_end) + + dim_count = dim_count + 1 + call this%set_levlulu_index(dim_count) + call this%dim_bounds(dim_count)%Init(levlulu, num_threads, & + fates_bounds%lulu_begin, fates_bounds%lulu_end) + + dim_count = dim_count + 1 + call this%set_levlupft_index(dim_count) + call this%dim_bounds(dim_count)%Init(levlupft, num_threads, & + fates_bounds%lupft_begin, fates_bounds%lupft_end) + end subroutine Init ! ====================================================================== @@ -1138,6 +1161,18 @@ subroutine SetThreadBoundsEach(this, thread_index, thread_bounds) call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%clscpf_begin, thread_bounds%clscpf_end) + index = this%levlanduse_index() + call this%dim_bounds(index)%SetThreadBounds(thread_index, & + thread_bounds%landuse_begin, thread_bounds%landuse_end) + + index = this%levlulu_index() + call this%dim_bounds(index)%SetThreadBounds(thread_index, & + thread_bounds%lulu_begin, thread_bounds%lulu_end) + + index = this%levlupft_index() + call this%dim_bounds(index)%SetThreadBounds(thread_index, & + thread_bounds%lupft_begin, thread_bounds%lupft_end) + end subroutine SetThreadBoundsEach ! =================================================================================== @@ -1153,6 +1188,7 @@ subroutine assemble_history_output_types(this) use FatesIOVariableKindMod, only : site_elem_r8, site_elpft_r8 use FatesIOVariableKindMod, only : site_elcwd_r8, site_elage_r8, site_clscpf_r8 use FatesIOVariableKindMod, only : site_cdpf_r8, site_cdsc_r8, site_cdam_r8 + use FatesIOVariableKindMod, only : site_landuse_r8, site_lulu_r8, site_lupft_r8 implicit none @@ -1236,7 +1272,16 @@ subroutine assemble_history_output_types(this) call this%set_dim_indices(site_clscpf_r8, 1, this%column_index()) call this%set_dim_indices(site_clscpf_r8, 2, this%levclscpf_index()) - + + call this%set_dim_indices(site_landuse_r8, 1, this%column_index()) + call this%set_dim_indices(site_landuse_r8, 2, this%levlanduse_index()) + + call this%set_dim_indices(site_lulu_r8, 1, this%column_index()) + call this%set_dim_indices(site_lulu_r8, 2, this%levlulu_index()) + + call this%set_dim_indices(site_lupft_r8, 1, this%column_index()) + call this%set_dim_indices(site_lupft_r8, 2, this%levlupft_index()) + end subroutine assemble_history_output_types ! =================================================================================== @@ -1650,6 +1695,51 @@ end function levclscpf_index ! ====================================================================================== + subroutine set_levlanduse_index(this, index) + implicit none + class(fates_history_interface_type), intent(inout) :: this + integer, intent(in) :: index + this%levlanduse_index_ = index + end subroutine set_levlanduse_index + + integer function levlanduse_index(this) + implicit none + class(fates_history_interface_type), intent(in) :: this + levlanduse_index = this%levlanduse_index_ + end function levlanduse_index + + ! ====================================================================================== + + subroutine set_levlulu_index(this, index) + implicit none + class(fates_history_interface_type), intent(inout) :: this + integer, intent(in) :: index + this%levlulu_index_ = index + end subroutine set_levlulu_index + + integer function levlulu_index(this) + implicit none + class(fates_history_interface_type), intent(in) :: this + levlulu_index = this%levlulu_index_ + end function levlulu_index + + ! ====================================================================================== + + subroutine set_levlupft_index(this, index) + implicit none + class(fates_history_interface_type), intent(inout) :: this + integer, intent(in) :: index + this%levlupft_index_ = index + end subroutine set_levlupft_index + + integer function levlupft_index(this) + implicit none + class(fates_history_interface_type), intent(in) :: this + levlupft_index = this%levlupft_index_ + end function levlupft_index + + ! ====================================================================================== + subroutine zero_site_hvars(this, currentSite, upfreq_in) ! This routine zero's a history diagnostic variable @@ -1796,6 +1886,7 @@ subroutine init_dim_kinds_maps(this) use FatesIOVariableKindMod, only : site_elem_r8, site_elpft_r8 use FatesIOVariableKindMod, only : site_elcwd_r8, site_elage_r8, site_clscpf_r8 use FatesIOVariableKindMod, only : site_cdpf_r8, site_cdsc_r8, site_cdam_r8 + use FatesIOVariableKindMod, only : site_landuse_r8, site_lulu_r8, site_lupft_r8 implicit none @@ -1909,6 +2000,18 @@ subroutine init_dim_kinds_maps(this) index = index + 1 call this%dim_kinds(index)%Init(site_clscpf_r8, 2) + ! site x land use class + index = index + 1 + call this%dim_kinds(index)%Init(site_landuse_r8, 2) + + ! site x land use x land use class + index = index + 1 + call this%dim_kinds(index)%Init(site_lulu_r8, 2) + + ! site x land use x pft + index = index + 1 + call this%dim_kinds(index)%Init(site_lupft_r8, 2) + ! FIXME(bja, 2016-10) assert(index == fates_history_num_dim_kinds) end subroutine init_dim_kinds_maps @@ -2117,6 +2220,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) use FatesLitterMod , only : ncwd use FatesConstantsMod , only : ican_upper use FatesConstantsMod , only : ican_ustory + use FatesConstantsMod , only : n_landuse_cats use FatesSizeAgeTypeIndicesMod, only : get_sizeage_class_index use FatesSizeAgeTypeIndicesMod, only : get_sizeagepft_class_index use FatesSizeAgeTypeIndicesMod, only : get_agepft_class_index @@ -2212,6 +2316,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) real(r8) :: storec_understory_scpf(numpft*nlevsclass) integer :: return_code + integer :: i_dist, j_dist type(fates_patch_type),pointer :: cpatch type(fates_cohort_type),pointer :: ccohort @@ -2286,13 +2391,10 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_canopy_biomass_si => this%hvars(ih_canopy_biomass_si)%r81d, & hio_understory_biomass_si => this%hvars(ih_understory_biomass_si)%r81d, & hio_primaryland_fusion_error_si => this%hvars(ih_primaryland_fusion_error_si)%r81d, & - hio_disturbance_rate_p2p_si => this%hvars(ih_disturbance_rate_p2p_si)%r81d, & - hio_disturbance_rate_p2s_si => this%hvars(ih_disturbance_rate_p2s_si)%r81d, & - hio_disturbance_rate_s2s_si => this%hvars(ih_disturbance_rate_s2s_si)%r81d, & + hio_disturbance_rate_si_lulu => this%hvars(ih_disturbance_rate_si_lulu)%r82d, & hio_fire_disturbance_rate_si => this%hvars(ih_fire_disturbance_rate_si)%r81d, & hio_logging_disturbance_rate_si => this%hvars(ih_logging_disturbance_rate_si)%r81d, & hio_fall_disturbance_rate_si => this%hvars(ih_fall_disturbance_rate_si)%r81d, & - hio_potential_disturbance_rate_si => this%hvars(ih_potential_disturbance_rate_si)%r81d, & hio_harvest_carbonflux_si => this%hvars(ih_harvest_carbonflux_si)%r81d, & hio_harvest_debt_si => this%hvars(ih_harvest_debt_si)%r81d, & hio_harvest_debt_sec_si => this%hvars(ih_harvest_debt_sec_si)%r81d, & @@ -2318,6 +2420,8 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_bleaf_understory_si_scpf => this%hvars(ih_bleaf_understory_si_scpf)%r82d, & hio_lai_canopy_si_scpf => this%hvars(ih_lai_canopy_si_scpf)%r82d, & hio_lai_understory_si_scpf => this%hvars(ih_lai_understory_si_scpf)%r82d, & + hio_crownarea_canopy_si_scpf => this%hvars(ih_crownarea_canopy_si_scpf)%r82d, & + hio_crownarea_understory_si_scpf => this%hvars(ih_crownarea_understory_si_scpf)%r82d, & hio_mortality_canopy_si_scpf => this%hvars(ih_mortality_canopy_si_scpf)%r82d, & hio_mortality_canopy_secondary_si_scls => this%hvars(ih_mortality_canopy_secondary_si_scls)%r82d, & hio_mortality_understory_si_scpf => this%hvars(ih_mortality_understory_si_scpf)%r82d, & @@ -2449,6 +2553,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_yesterdaycanopylevel_canopy_si_scls => this%hvars(ih_yesterdaycanopylevel_canopy_si_scls)%r82d, & hio_yesterdaycanopylevel_understory_si_scls => this%hvars(ih_yesterdaycanopylevel_understory_si_scls)%r82d, & hio_area_si_age => this%hvars(ih_area_si_age)%r82d, & + hio_area_si_landuse => this%hvars(ih_area_si_landuse)%r82d, & hio_lai_si_age => this%hvars(ih_lai_si_age)%r82d, & hio_lai_secondary_si => this%hvars(ih_lai_secondary_si)%r81d, & hio_canopy_area_si_age => this%hvars(ih_canopy_area_si_age)%r82d, & @@ -2460,7 +2565,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_biomass_secondary_forest_si => this%hvars(ih_biomass_secondary_forest_si)%r81d, & hio_woodproduct_si => this%hvars(ih_woodproduct_si)%r81d, & hio_agesince_anthrodist_si_age => this%hvars(ih_agesince_anthrodist_si_age)%r82d, & - hio_secondaryforest_area_si_age => this%hvars(ih_secondaryforest_area_si_age)%r82d, & + hio_secondarylands_area_si_age => this%hvars(ih_secondarylands_area_si_age)%r82d, & hio_area_burnt_si_age => this%hvars(ih_area_burnt_si_age)%r82d, & ! hio_fire_rate_of_spread_front_si_age => this%hvars(ih_fire_rate_of_spread_front_si_age)%r82d, & hio_fire_intensity_si_age => this%hvars(ih_fire_intensity_si_age)%r82d, & @@ -2643,27 +2748,24 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) ! error in primary lands from patch fusion [m2 m-2 day-1] -> [m2 m-2 yr-1] hio_primaryland_fusion_error_si(io_si) = sites(s)%primary_land_patchfusion_error * days_per_year - ! output site-level disturbance rates [m2 m-2 day-1] -> [m2 m-2 yr-1] - hio_disturbance_rate_p2p_si(io_si) = sum(sites(s)%disturbance_rates_primary_to_primary(1:N_DIST_TYPES)) * days_per_year - hio_disturbance_rate_p2s_si(io_si) = sum(sites(s)%disturbance_rates_primary_to_secondary(1:N_DIST_TYPES)) * days_per_year - hio_disturbance_rate_s2s_si(io_si) = sum(sites(s)%disturbance_rates_secondary_to_secondary(1:N_DIST_TYPES)) * days_per_year + ! roll up disturbance rates in land-use x land-use array into a single dimension + do i_dist = 1, n_landuse_cats + do j_dist = 1, n_landuse_cats + hio_disturbance_rate_si_lulu(io_si, i_dist+n_landuse_cats*(j_dist-1)) = sum(sites(s)%disturbance_rates(1:n_dist_types,i_dist, j_dist)) * & + days_per_year + end do + end do - hio_fire_disturbance_rate_si(io_si) = (sites(s)%disturbance_rates_primary_to_primary(dtype_ifire) + & - sites(s)%disturbance_rates_primary_to_secondary(dtype_ifire) + & - sites(s)%disturbance_rates_secondary_to_secondary(dtype_ifire)) * & - days_per_year + ! output site-level disturbance rates [m2 m-2 day-1] -> [m2 m-2 yr-1] - TO DO rework this - hio_logging_disturbance_rate_si(io_si) = (sites(s)%disturbance_rates_primary_to_primary(dtype_ilog) + & - sites(s)%disturbance_rates_primary_to_secondary(dtype_ilog) + & - sites(s)%disturbance_rates_secondary_to_secondary(dtype_ilog)) * & - days_per_year + hio_fire_disturbance_rate_si(io_si) = sum(sites(s)%disturbance_rates(dtype_ifire,1:n_landuse_cats,1:n_landuse_cats)) * & + days_per_year - hio_fall_disturbance_rate_si(io_si) = (sites(s)%disturbance_rates_primary_to_primary(dtype_ifall) + & - sites(s)%disturbance_rates_primary_to_secondary(dtype_ifall) + & - sites(s)%disturbance_rates_secondary_to_secondary(dtype_ifall)) * & - days_per_year + hio_logging_disturbance_rate_si(io_si) = sum(sites(s)%disturbance_rates(dtype_ilog,1:n_landuse_cats,1:n_landuse_cats)) * & + days_per_year - hio_potential_disturbance_rate_si(io_si) = sum(sites(s)%potential_disturbance_rates(1:N_DIST_TYPES)) * days_per_year + hio_fall_disturbance_rate_si(io_si) = sum(sites(s)%disturbance_rates(dtype_ifall,1:n_landuse_cats,1:n_landuse_cats)) * & + days_per_year hio_harvest_carbonflux_si(io_si) = sites(s)%mass_balance(element_pos(carbon12_element))%wood_product * AREA_INV @@ -2674,7 +2776,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) ! Increment the number of patches per site hio_npatches_si(io_si) = hio_npatches_si(io_si) + 1._r8 - if ( cpatch%anthro_disturbance_label .eq. secondaryforest ) then + if ( cpatch%land_use_label .eq. secondaryland ) then hio_npatches_sec_si(io_si) = hio_npatches_sec_si(io_si) + 1._r8 end if @@ -2684,6 +2786,9 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_area_si_age(io_si,cpatch%age_class) = hio_area_si_age(io_si,cpatch%age_class) & + cpatch%area * AREA_INV + hio_area_si_landuse(io_si, cpatch%land_use_label) = hio_area_si_landuse(io_si, cpatch%land_use_label)& + + cpatch%area * AREA_INV + ! 24hr veg temperature hio_tveg24(io_si) = hio_tveg24(io_si) + & (cpatch%tveg24%GetMean()- t_water_freeze_k_1atm)*cpatch%area*AREA_INV @@ -2713,7 +2818,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) endif ! some diagnostics on secondary forest area and its age distribution - if ( cpatch%anthro_disturbance_label .eq. secondaryforest ) then + if ( cpatch%land_use_label .eq. secondaryland ) then hio_fraction_secondary_forest_si(io_si) = hio_fraction_secondary_forest_si(io_si) + & cpatch%area * AREA_INV @@ -2723,13 +2828,10 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_agesince_anthrodist_si_age(io_si,ageclass_since_anthrodist) & + cpatch%area * AREA_INV - hio_secondaryforest_area_si_age(io_si,cpatch%age_class) = & - hio_secondaryforest_area_si_age(io_si,cpatch%age_class) & + hio_secondarylands_area_si_age(io_si,cpatch%age_class) = & + hio_secondarylands_area_si_age(io_si,cpatch%age_class) & + cpatch%area * AREA_INV - endif - ! Secondary forest mean LAI - if ( cpatch%anthro_disturbance_label .eq. secondaryforest ) then hio_lai_secondary_si(io_si) = hio_lai_secondary_si(io_si) & + sum(cpatch%tlai_profile(:,:,:)) * cpatch%total_canopy_area end if @@ -2799,7 +2901,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) ! Increment the number of cohorts per site hio_ncohorts_si(io_si) = hio_ncohorts_si(io_si) + 1._r8 - if ( cpatch%anthro_disturbance_label .eq. secondaryforest ) then + if ( cpatch%land_use_label .eq. secondaryland ) then hio_ncohorts_sec_si(io_si) = hio_ncohorts_sec_si(io_si) + 1._r8 end if @@ -2915,7 +3017,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_nindivs_si_pft(io_si,ft) = hio_nindivs_si_pft(io_si,ft) + & ccohort%n * AREA_INV - if ( cpatch%anthro_disturbance_label .eq. secondaryforest ) then + if ( cpatch%land_use_label .eq. secondaryland ) then hio_nindivs_sec_si_pft(io_si,ft) = hio_nindivs_sec_si_pft(io_si,ft) + & ccohort%n * AREA_INV end if @@ -2923,7 +3025,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_biomass_si_pft(io_si, ft) = hio_biomass_si_pft(io_si, ft) + & (ccohort%n * AREA_INV) * total_m - if ( cpatch%anthro_disturbance_label .eq. secondaryforest ) then + if ( cpatch%land_use_label .eq. secondaryland ) then hio_biomass_sec_si_pft(io_si, ft) = hio_biomass_sec_si_pft(io_si, ft) + & (ccohort%n * AREA_INV) * total_m end if @@ -2933,7 +3035,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) + total_m * ccohort%n * AREA_INV ! track the total biomass on all secondary lands - if ( cpatch%anthro_disturbance_label .eq. secondaryforest ) then + if ( cpatch%land_use_label .eq. secondaryland ) then hio_biomass_secondary_forest_si(io_si) = hio_biomass_secondary_forest_si(io_si) + & total_m * ccohort%n * AREA_INV endif @@ -3063,7 +3165,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_npp_si_pft(io_si, ft) = hio_npp_si_pft(io_si, ft) + & ccohort%npp_acc_hold * n_perm2 / days_per_year / sec_per_day - if ( cpatch%anthro_disturbance_label .eq. secondaryforest ) then + if ( cpatch%land_use_label .eq. secondaryland ) then hio_gpp_sec_si_pft(io_si, ft) = hio_gpp_sec_si_pft(io_si, ft) + & ccohort%gpp_acc_hold * n_perm2 / days_per_year / sec_per_day hio_npp_sec_si_pft(io_si, ft) = hio_npp_sec_si_pft(io_si, ft) + & @@ -3204,7 +3306,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_m9_si_scls(io_si,scls) = hio_m9_si_scls(io_si,scls) + ccohort%smort*ccohort%n / m2_per_ha ! Examine secondary forest mortality and mortality rates - if(cpatch%anthro_disturbance_label .eq. secondaryforest) then + if(cpatch%land_use_label .eq. secondaryland) then if (hlm_use_cohort_age_tracking .eq.itrue) then hio_m10_sec_si_scls(io_si,scls) = hio_m10_sec_si_scls(io_si,scls) + & @@ -3359,6 +3461,9 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) leaf_m * ccohort%n / m2_per_ha hio_lai_canopy_si_scpf(io_si,scpf) = hio_lai_canopy_si_scpf(io_si,scpf) + & ccohort%treelai*ccohort%c_area * AREA_INV + hio_crownarea_canopy_si_scpf(io_si,scpf) = hio_crownarea_canopy_si_scpf(io_si,scpf) + & + ccohort%c_area * AREA_INV + hio_canopy_biomass_si(io_si) = hio_canopy_biomass_si(io_si) + n_perm2 * total_m @@ -3384,7 +3489,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_trimming_canopy_si_scls(io_si,scls) = hio_trimming_canopy_si_scls(io_si,scls) + & ccohort%n * ccohort%canopy_trim / m2_per_ha hio_crown_area_canopy_si_scls(io_si,scls) = hio_crown_area_canopy_si_scls(io_si,scls) + & - ccohort%c_area / m2_per_ha + ccohort%c_area * AREA_INV hio_gpp_canopy_si_scpf(io_si,scpf) = hio_gpp_canopy_si_scpf(io_si,scpf) + & n_perm2*ccohort%gpp_acc_hold / days_per_year / sec_per_day hio_ar_canopy_si_scpf(io_si,scpf) = hio_ar_canopy_si_scpf(io_si,scpf) + & @@ -3502,6 +3607,8 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) n_perm2 * total_m hio_lai_understory_si_scpf(io_si,scpf) = hio_lai_understory_si_scpf(io_si,scpf) + & ccohort%treelai*ccohort%c_area * AREA_INV + hio_crownarea_understory_si_scpf(io_si,scpf) = hio_crownarea_understory_si_scpf(io_si,scpf) + & + ccohort%c_area * AREA_INV !hio_mortality_understory_si_scpf(io_si,scpf) = hio_mortality_understory_si_scpf(io_si,scpf)+ & ! (ccohort%bmort + ccohort%hmort + ccohort%cmort + @@ -3516,7 +3623,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_m3_mortality_understory_si_scpf(io_si,scpf) = hio_m3_mortality_understory_si_scpf(io_si,scpf) + & ccohort%cmort * ccohort%n / m2_per_ha - if ( cpatch%anthro_disturbance_label .eq. secondaryforest ) then + if ( cpatch%land_use_label .eq. secondaryland ) then hio_mortality_canopy_secondary_si_scls(io_si,scls) = hio_mortality_canopy_secondary_si_scls(io_si,scls) + & (ccohort%bmort + ccohort%hmort + ccohort%cmort + & ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n / m2_per_ha + & @@ -3533,7 +3640,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_trimming_understory_si_scls(io_si,scls) = hio_trimming_understory_si_scls(io_si,scls) + & ccohort%n * ccohort%canopy_trim / m2_per_ha hio_crown_area_understory_si_scls(io_si,scls) = hio_crown_area_understory_si_scls(io_si,scls) + & - ccohort%c_area / m2_per_ha + ccohort%c_area * AREA_INV hio_gpp_understory_si_scpf(io_si,scpf) = hio_gpp_understory_si_scpf(io_si,scpf) + & n_perm2*ccohort%gpp_acc_hold / days_per_year / sec_per_day hio_ar_understory_si_scpf(io_si,scpf) = hio_ar_understory_si_scpf(io_si,scpf) + & @@ -3836,7 +3943,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) sites(s)%fmort_rate_canopy(i_scls, i_pft) / m2_per_ha ! Shijie: Think about how to add later? - !if ( cpatch%anthro_disturbance_label .eq. secondaryforest ) then + !if ( cpatch%land_use_label .eq. secondaryland ) then ! hio_mortality_canopy_secondary_si_scls(io_si,i_scls) = hio_mortality_canopy_secondary_si_scls(io_si,i_scls) + & ! sites(s)%term_nindivs_canopy(i_scls,i_pft) * days_per_year / m2_per_ha !end if @@ -4489,8 +4596,6 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) hio_fabd_sha_si_cnlf => this%hvars(ih_fabd_sha_si_cnlf)%r82d, & hio_fabi_sun_si_cnlf => this%hvars(ih_fabi_sun_si_cnlf)%r82d, & hio_fabi_sha_si_cnlf => this%hvars(ih_fabi_sha_si_cnlf)%r82d, & - hio_parprof_dir_si_cnlf => this%hvars(ih_parprof_dir_si_cnlf)%r82d, & - hio_parprof_dif_si_cnlf => this%hvars(ih_parprof_dif_si_cnlf)%r82d, & hio_parprof_dir_si_cnlfpft => this%hvars(ih_parprof_dir_si_cnlfpft)%r82d, & hio_parprof_dif_si_cnlfpft => this%hvars(ih_parprof_dif_si_cnlfpft)%r82d, & hio_fabd_sun_top_si_can => this%hvars(ih_fabd_sun_top_si_can)%r82d, & @@ -4552,7 +4657,7 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) cpatch%c_lblayer * cpatch%total_canopy_area * mol_per_umol hio_rad_error_si(io_si) = hio_rad_error_si(io_si) + & - cpatch%radiation_error * cpatch%area * AREA_INV + max(abs(cpatch%rad_error(1)),abs(cpatch%rad_error(2))) * cpatch%area * AREA_INV ! Only accumulate the instantaneous vegetation temperature for vegetated patches if (cpatch%patchno .ne. 0) then @@ -4594,7 +4699,7 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) ccohort%resp_m_unreduced * n_perm2 * per_dt_tstep ! Secondary forest only - if ( cpatch%anthro_disturbance_label .eq. secondaryforest ) then + if ( cpatch%land_use_label .eq. secondaryland ) then hio_npp_secondary_si(io_si) = hio_npp_secondary_si(io_si) + & npp * n_perm2 * per_dt_tstep hio_gpp_secondary_si(io_si) = hio_gpp_secondary_si(io_si) + & @@ -4800,20 +4905,6 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) end do end do - ! PFT-mean radiation profiles - do ican = 1, cpatch%ncl_p - do ileaf = 1, maxval(cpatch%nrad(ican,:)) - - ! calculate where we are on multiplexed dimensions - cnlf_indx = ileaf + (ican-1) * nlevleaf - ! - hio_parprof_dir_si_cnlf(io_si,cnlf_indx) = hio_parprof_dir_si_cnlf(io_si,cnlf_indx) + & - cpatch%parprof_dir_z(ican,ileaf) * cpatch%area * AREA_INV - hio_parprof_dif_si_cnlf(io_si,cnlf_indx) = hio_parprof_dif_si_cnlf(io_si,cnlf_indx) + & - cpatch%parprof_dif_z(ican,ileaf) * cpatch%area * AREA_INV - end do - end do - ipa = ipa + 1 cpatch => cpatch%younger end do !patch loop @@ -5280,6 +5371,7 @@ subroutine define_history_vars(this, initialize_variables) use FatesIOVariableKindMod, only : site_scagpft_r8, site_agepft_r8 use FatesIOVariableKindMod, only : site_elem_r8, site_elpft_r8, site_clscpf_r8 use FatesIOVariableKindMod, only : site_elcwd_r8, site_elage_r8 + use FatesIOVariableKindMod, only : site_landuse_r8, site_lulu_r8 implicit none @@ -5660,6 +5752,17 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & index=ih_biomass_si_age) + ! land use type resolved variables + call this%set_history_var(vname='FATES_PATCHAREA_LU', units='m2 m-2', & + long='patch area by land use type', use_default='active', & + avgflag='A', vtype=site_landuse_r8, hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index=ih_area_si_landuse) + + call this%set_history_var(vname='FATES_DISTURBANCE_RATE_MATRIX_LULU', units='m2 m-2 yr-1', & + long='disturbance rates by land use type x land use type matrix', use_default='active', & + avgflag='A', vtype=site_lulu_r8, hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index=ih_disturbance_rate_si_lulu) + ! Secondary forest area and age diagnostics call this%set_history_var(vname='FATES_SECONDARY_FOREST_FRACTION', & @@ -5693,7 +5796,7 @@ subroutine define_history_vars(this, initialize_variables) long='secondary forest patch area age distribution since any kind of disturbance', & use_default='inactive', avgflag='A', vtype=site_age_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & - index=ih_secondaryforest_area_si_age) + index=ih_secondarylands_area_si_age) ! Fire Variables @@ -6336,27 +6439,6 @@ subroutine define_history_vars(this, initialize_variables) upfreq=1, ivar=ivar, initialize=initialize_variables, & index = ih_primaryland_fusion_error_si) - call this%set_history_var(vname='FATES_DISTURBANCE_RATE_P2P', & - units='m2 m-2 yr-1', & - long='disturbance rate from primary to primary lands', & - use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, & - index = ih_disturbance_rate_p2p_si) - - call this%set_history_var(vname='FATES_DISTURBANCE_RATE_P2S', & - units='m2 m-2 yr-1', & - long='disturbance rate from primary to secondary lands', & - use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, & - index = ih_disturbance_rate_p2s_si ) - - call this%set_history_var(vname='FATES_DISTURBANCE_RATE_S2S', & - units='m2 m-2 yr-1', & - long='disturbance rate from secondary to secondary lands', & - use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, & - index = ih_disturbance_rate_s2s_si) - call this%set_history_var(vname='FATES_DISTURBANCE_RATE_FIRE', & units='m2 m-2 yr-1', long='disturbance rate from fire', & use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & @@ -6375,13 +6457,6 @@ subroutine define_history_vars(this, initialize_variables) upfreq=1, ivar=ivar, initialize=initialize_variables, & index = ih_fall_disturbance_rate_si) - call this%set_history_var(vname='FATES_DISTURBANCE_RATE_POTENTIAL', & - units='m2 m-2 yr-1', & - long='potential (i.e., including unresolved) disturbance rate', & - use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, & - index = ih_potential_disturbance_rate_si) - call this%set_history_var(vname='FATES_HARVEST_CARBON_FLUX', & units='kg m-2 yr-1', & long='harvest carbon flux in kg carbon per m2 per year', & @@ -6718,18 +6793,6 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & index = ih_parprof_dif_si_cnlfpft) - call this%set_history_var(vname='FATES_PARPROF_DIR_CLLL', units='W m-2', & - long='radiative profile of direct PAR through each canopy and leaf layer (averaged across PFTs)', & - use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & - hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & - index = ih_parprof_dir_si_cnlf) - - call this%set_history_var(vname='FATES_PARPROF_DIF_CLLL', units='W m-2', & - long='radiative profile of diffuse PAR through each canopy and leaf layer (averaged across PFTs)', & - use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & - hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & - index = ih_parprof_dif_si_cnlf) - call this%set_history_var(vname='FATES_FABD_SUN_TOPLF_CL', units='1', & long='sun fraction of direct light absorbed by the top leaf layer of each canopy layer', & use_default='inactive', avgflag='A', vtype=site_can_r8, & @@ -7227,6 +7290,13 @@ subroutine define_history_vars(this, initialize_variables) ivar=ivar, initialize=initialize_variables, & index = ih_lai_canopy_si_scpf ) + call this%set_history_var(vname='FATES_CROWNAREA_CANOPY_SZPF', & + units = 'm2 m-2', & + long='Total crown area of canopy plants by pft/size', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_crownarea_canopy_si_scpf ) + call this%set_history_var(vname='FATES_NPLANT_CANOPY_SZPF', units = 'm-2', & long='number of canopy plants by size/pft per m2', & use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & @@ -7262,6 +7332,13 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_lai_understory_si_scpf ) + call this%set_history_var(vname='FATES_CROWNAREA_USTORY_SZPF', & + units = 'm2 m-2', & + long='Total crown area of understory plants by pft/size', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_crownarea_understory_si_scpf ) + call this%set_history_var(vname='FATES_NPLANT_USTORY_SZPF', & units = 'm-2', & long='density of understory plants by pft/size in number of plants per m2', & diff --git a/main/FatesHistoryVariableType.F90 b/main/FatesHistoryVariableType.F90 index 5902496a2c..83cbdb8c1c 100644 --- a/main/FatesHistoryVariableType.F90 +++ b/main/FatesHistoryVariableType.F90 @@ -16,6 +16,7 @@ module FatesHistoryVariableType use FatesIOVariableKindMod, only : site_elem_r8, site_elpft_r8 use FatesIOVariableKindMod, only : site_elcwd_r8, site_elage_r8 use FatesIOVariableKindMod, only : iotype_index, site_agefuel_r8, site_clscpf_r8 + use FatesIOVariableKindMod, only : site_landuse_r8, site_lulu_r8 use shr_log_mod , only : errMsg => shr_log_errMsg @@ -31,7 +32,7 @@ module FatesHistoryVariableType ! This type is instanteated in the HLM-FATES interface (clmfates_interfaceMod.F90) type, public :: fates_history_variable_type - character(len=32) :: vname + character(len=40) :: vname character(len=24) :: units character(len=128) :: long character(len=24) :: use_default ! States whether a variable should be turned @@ -208,6 +209,14 @@ subroutine Init(this, vname, units, long, use_default, & allocate(this%r82d(lb1:ub1, lb2:ub2)) this%r82d(:,:) = flushval + case(site_landuse_r8) + allocate(this%r82d(lb1:ub1, lb2:ub2)) + this%r82d(:,:) = flushval + + case(site_lulu_r8) + allocate(this%r82d(lb1:ub1, lb2:ub2)) + this%r82d(:,:) = flushval + case(site_clscpf_r8) allocate(this%r82d(lb1:ub1, lb2:ub2)) this%r82d(:,:) = flushval @@ -338,6 +347,11 @@ subroutine Flush(this, thread, dim_bounds, dim_kinds) this%r82d(lb1:ub1, lb2:ub2) = this%flushval case(site_clscpf_r8) this%r82d(lb1:ub1, lb2:ub2) = this%flushval + case(site_landuse_r8) + this%r82d(lb1:ub1, lb2:ub2) = this%flushval + case(site_lulu_r8) + this%r82d(lb1:ub1, lb2:ub2) = this%flushval + case default write(fates_log(),*) 'fates history variable type undefined while flushing history variables' call endrun(msg=errMsg(sourcefile, __LINE__)) diff --git a/main/FatesIODimensionsMod.F90 b/main/FatesIODimensionsMod.F90 index 92488d00a9..ed487d7eed 100644 --- a/main/FatesIODimensionsMod.F90 +++ b/main/FatesIODimensionsMod.F90 @@ -35,6 +35,9 @@ module FatesIODimensionsMod character(*), parameter, public :: levelpft = 'fates_levelpft' character(*), parameter, public :: levelcwd = 'fates_levelcwd' character(*), parameter, public :: levelage = 'fates_levelage' + character(*), parameter, public :: levlanduse = 'fates_levlanduse' + character(*), parameter, public :: levlulu = 'fates_levlulu' + character(*), parameter, public :: levlupft = 'fates_levlupft' ! column = This is a structure that records where FATES column boundaries ! on each thread point to in the host IO array, this structure @@ -115,7 +118,16 @@ module FatesIODimensionsMod ! levcdam = This is the structure that records the boundaries for the ! number of crown damage classes dimension - + + ! levlanduse = this is the structure that records the boundaries for the + ! land use class dimension + + ! levlulu = this is the structure that records the boundaries for the + ! (land use class) x (land use class) dimension + + ! levlupft = this is the structure that records the boundaries for the + ! (land use class) x pft dimension + type, public :: fates_bounds_type integer :: cohort_begin integer :: cohort_end @@ -171,6 +183,12 @@ module FatesIODimensionsMod integer :: agefuel_end integer :: clscpf_begin integer :: clscpf_end + integer :: landuse_begin + integer :: landuse_end + integer :: lulu_begin + integer :: lulu_end + integer :: lupft_begin + integer :: lupft_end end type fates_bounds_type diff --git a/main/FatesIOVariableKindMod.F90 b/main/FatesIOVariableKindMod.F90 index 84dd8e692f..07df7b8270 100644 --- a/main/FatesIOVariableKindMod.F90 +++ b/main/FatesIOVariableKindMod.F90 @@ -41,6 +41,9 @@ module FatesIOVariableKindMod character(*), parameter, public :: site_agepft_r8 = 'SI_AGEPFT_R8' character(*), parameter, public :: site_agefuel_r8 = 'SI_AGEFUEL_R8' character(*), parameter, public :: site_clscpf_r8 = 'SI_CLSCPF_R8' + character(*), parameter, public :: site_landuse_r8 = 'SI_LANDUSE_R8' + character(*), parameter, public :: site_lulu_r8 = 'SI_LULU_R8' + character(*), parameter, public :: site_lupft_r8 = 'SI_LUPFT_R8' ! Element, and multiplexed element dimensions character(*), parameter, public :: site_elem_r8 = 'SI_ELEM_R8' @@ -48,7 +51,6 @@ module FatesIOVariableKindMod character(*), parameter, public :: site_elcwd_r8 = 'SI_ELEMCWD_R8' character(*), parameter, public :: site_elage_r8 = 'SI_ELEMAGE_R8' - ! NOTE(RGK, 2016) %active is not used yet. Was intended as a check on the HLM->FATES ! control parameter passing to ensure all active dimension types received all ! dimensioning specifications from the host, but we currently arent using those diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index ffc1f0231c..7b5b72ad9e 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -16,13 +16,10 @@ module FatesInterfaceMod use EDParamsMod , only : ED_val_vai_width_increase_factor use EDParamsMod , only : ED_val_history_damage_bin_edges use EDParamsMod , only : maxpatch_total - use EDParamsMod , only : maxpatch_primary - use EDParamsMod , only : maxpatch_secondary + use EDParamsMod , only : maxpatches_by_landuse use EDParamsMod , only : max_cohort_per_patch + use FatesRadiationMemMod , only : num_swb,ivis,inir use EDParamsMod , only : regeneration_model - use EDParamsMod , only : maxSWb - use EDParamsMod , only : ivis - use EDParamsMod , only : inir use EDParamsMod , only : nclmax use EDParamsMod , only : nlevleaf use EDParamsMod , only : maxpft @@ -41,6 +38,9 @@ module FatesInterfaceMod use FatesConstantsMod , only : days_per_year use FatesConstantsMod , only : TRS_regeneration use FatesConstantsMod , only : g_per_kg + use FatesConstantsMod , only : n_landuse_cats + use FatesConstantsMod , only : primaryland + use FatesConstantsMod , only : secondaryland use FatesGlobals , only : fates_global_verbose use FatesGlobals , only : fates_log use FatesGlobals , only : endrun => fates_endrun @@ -64,9 +64,14 @@ module FatesInterfaceMod 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 EDParamsMod , only : p_uptake_mode - use EDParamsMod , only : n_uptake_mode + use FatesParametersInterface , only : fates_param_reader_type + use FatesParametersInterface , only : fates_parameters_type + use EDParamsMod , only : FatesRegisterParams, FatesReceiveParams + use SFParamsMod , only : SpitFireRegisterParams, SpitFireReceiveParams + use PRTInitParamsFATESMod , only : PRTRegisterParams, PRTReceiveParams + use FatesSynchronizedParamsMod, only : FatesSynchronizedParamsInst + use EDParamsMod , only : p_uptake_mode + use EDParamsMod , only : n_uptake_mode use EDTypesMod , only : ed_site_type use FatesConstantsMod , only : prescribed_p_uptake use FatesConstantsMod , only : prescribed_n_uptake @@ -103,6 +108,7 @@ module FatesInterfaceMod use FatesHistoryInterfaceMod , only : fates_hist use FatesHydraulicsMemMod , only : nshell use FatesHydraulicsMemMod , only : nlevsoi_hyd_max + use FatesTwoStreamUtilsMod, only : TransferRadParams ! CIME Globals use shr_log_mod , only : errMsg => shr_log_errMsg @@ -171,6 +177,8 @@ module FatesInterfaceMod public :: set_bcs public :: UpdateFatesRMeansTStep public :: InitTimeAveragingGlobals + + private :: FatesReadParameters public :: DetermineGridCellNeighbors logical :: debug = .false. ! for debugging this module @@ -397,12 +405,18 @@ subroutine zero_bcs(fates,s) fates%bc_out(s)%hrv_deadstemc_to_prod10c = 0.0_r8 fates%bc_out(s)%hrv_deadstemc_to_prod100c = 0.0_r8 + if (hlm_use_luh .eq. itrue) then + fates%bc_in(s)%hlm_luh_states(:) = 0.0_r8 + fates%bc_in(s)%hlm_luh_transitions(:) = 0.0_r8 + end if + return end subroutine zero_bcs ! =========================================================================== - subroutine allocate_bcin(bc_in, nlevsoil_in, nlevdecomp_in, num_lu_harvest_cats,natpft_lb,natpft_ub) + subroutine allocate_bcin(bc_in, nlevsoil_in, nlevdecomp_in, num_lu_harvest_cats, num_luh2_states, & + num_luh2_transitions, natpft_lb,natpft_ub) ! --------------------------------------------------------------------------------- ! Allocate and Initialze the FATES boundary condition vectors @@ -413,6 +427,8 @@ subroutine allocate_bcin(bc_in, nlevsoil_in, nlevdecomp_in, num_lu_harvest_cats, integer,intent(in) :: nlevsoil_in integer,intent(in) :: nlevdecomp_in integer,intent(in) :: num_lu_harvest_cats + integer,intent(in) :: num_luh2_states + integer,intent(in) :: num_luh2_transitions integer,intent(in) :: natpft_lb,natpft_ub ! dimension bounds of the array holding surface file pft data ! Allocate input boundaries @@ -483,8 +499,8 @@ subroutine allocate_bcin(bc_in, nlevsoil_in, nlevdecomp_in, num_lu_harvest_cats, allocate(bc_in%precip24_pa(maxpatch_total)) ! Radiation - allocate(bc_in%solad_parb(maxpatch_total,hlm_numSWb)) - allocate(bc_in%solai_parb(maxpatch_total,hlm_numSWb)) + allocate(bc_in%solad_parb(maxpatch_total,num_swb)) + allocate(bc_in%solai_parb(maxpatch_total,num_swb)) ! Hydrology allocate(bc_in%smp_sl(nlevsoil_in)) @@ -516,8 +532,8 @@ subroutine allocate_bcin(bc_in, nlevsoil_in, nlevdecomp_in, num_lu_harvest_cats, allocate(bc_in%filter_vegzen_pa(maxpatch_total)) allocate(bc_in%coszen_pa(maxpatch_total)) allocate(bc_in%fcansno_pa(maxpatch_total)) - allocate(bc_in%albgr_dir_rb(hlm_numSWb)) - allocate(bc_in%albgr_dif_rb(hlm_numSWb)) + allocate(bc_in%albgr_dir_rb(num_swb)) + allocate(bc_in%albgr_dif_rb(num_swb)) ! Plant-Hydro BC's if (hlm_use_planthydro.eq.itrue) then @@ -548,6 +564,14 @@ subroutine allocate_bcin(bc_in, nlevsoil_in, nlevdecomp_in, num_lu_harvest_cats, allocate(bc_in%pft_areafrac(natpft_lb:natpft_ub)) + ! LUH2 state and transition data + if (hlm_use_luh .eq. itrue) then + allocate(bc_in%hlm_luh_states(num_luh2_states)) + allocate(bc_in%hlm_luh_state_names(num_luh2_states)) + allocate(bc_in%hlm_luh_transitions(num_luh2_transitions)) + allocate(bc_in%hlm_luh_transition_names(num_luh2_transitions)) + end if + ! Variables for SP mode. if(hlm_use_sp.eq.itrue) then allocate(bc_in%hlm_sp_tlai(natpft_lb:natpft_ub)) @@ -586,13 +610,13 @@ subroutine allocate_bcout(bc_out, nlevsoil_in, nlevdecomp_in) allocate(bc_out%rssha_pa(maxpatch_total)) ! Canopy Radiation - allocate(bc_out%albd_parb(maxpatch_total,hlm_numSWb)) - allocate(bc_out%albi_parb(maxpatch_total,hlm_numSWb)) - allocate(bc_out%fabd_parb(maxpatch_total,hlm_numSWb)) - allocate(bc_out%fabi_parb(maxpatch_total,hlm_numSWb)) - allocate(bc_out%ftdd_parb(maxpatch_total,hlm_numSWb)) - allocate(bc_out%ftid_parb(maxpatch_total,hlm_numSWb)) - allocate(bc_out%ftii_parb(maxpatch_total,hlm_numSWb)) + allocate(bc_out%albd_parb(maxpatch_total,num_swb)) + allocate(bc_out%albi_parb(maxpatch_total,num_swb)) + allocate(bc_out%fabd_parb(maxpatch_total,num_swb)) + allocate(bc_out%fabi_parb(maxpatch_total,num_swb)) + allocate(bc_out%ftdd_parb(maxpatch_total,num_swb)) + allocate(bc_out%ftid_parb(maxpatch_total,num_swb)) + allocate(bc_out%ftii_parb(maxpatch_total,num_swb)) ! We allocate the boundary conditions to the BGC @@ -727,7 +751,7 @@ end subroutine set_bcs ! =================================================================================== - subroutine SetFatesGlobalElements1(use_fates,surf_numpft,surf_numcft) + subroutine SetFatesGlobalElements1(use_fates,surf_numpft,surf_numcft,param_reader) ! -------------------------------------------------------------------------------- ! @@ -741,13 +765,14 @@ subroutine SetFatesGlobalElements1(use_fates,surf_numpft,surf_numcft) logical, intent(in) :: use_fates ! Is fates turned on? integer, intent(in) :: surf_numpft ! Number of PFTs in surface dataset integer, intent(in) :: surf_numcft ! Number of CFTs in surface dataset + class(fates_param_reader_type), intent(in) :: param_reader ! HLM-provided param file reader integer :: fates_numpft ! Number of PFTs tracked in FATES if (use_fates) then ! Self explanatory, read the fates parameter file - call FatesReadParameters() + call FatesReadParameters(param_reader) fates_numpft = size(prt_params%wood_density,dim=1) @@ -757,8 +782,8 @@ subroutine SetFatesGlobalElements1(use_fates,surf_numpft,surf_numcft) ! to hold all PFTs. So create the same number of ! patches as the number of PFTs - maxpatch_primary = fates_numpft - maxpatch_secondary = 0 + maxpatches_by_landuse(primaryland) = fates_numpft + maxpatches_by_landuse(secondaryland:n_landuse_cats) = 0 maxpatch_total = fates_numpft ! If this is an SP run, we actually need enough patches on the @@ -773,13 +798,14 @@ subroutine SetFatesGlobalElements1(use_fates,surf_numpft,surf_numcft) else ! If we are using fixed biogeography or no-comp then we - ! can also apply those constraints to maxpatch_primary and secondary + ! can also apply those constraints to maxpatch_primaryland and secondary ! and that value will match fates_maxPatchesPerSite if(hlm_use_nocomp==itrue) then - maxpatch_primary = max(maxpatch_primary,fates_numpft) - maxpatch_total = maxpatch_primary + maxpatch_secondary + maxpatches_by_landuse(primaryland) = max(maxpatches_by_landuse(primaryland),fates_numpft) + maxpatch_total = sum(maxpatches_by_landuse(:)) + !if(maxpatch_primary maxSWb) then - write(fates_log(), *) 'FATES sets a maximum number of shortwave bands' - write(fates_log(), *) 'for some scratch-space, maxSWb' - write(fates_log(), *) 'it defaults to 2, but can be increased as needed' - write(fates_log(), *) 'your driver or host model is intending to drive' - write(fates_log(), *) 'FATES with:',hlm_numSWb,' bands.' - write(fates_log(), *) 'please increase maxSWb in EDTypes to match' - write(fates_log(), *) 'or exceed this value' + if(hlm_numSWb .ne. num_swb) then + write(fates_log(), *) 'FATES performs radiation scattering in the' + write(fates_log(), *) 'visible and near-infrared broad-bands for shortwave radiation.' + write(fates_log(), *) 'The host model has signaled to FATES that it is not tracking two' + write(fates_log(), *) 'bands.' + write(fates_log(), *) 'hlm_numSWb (HLM side):',hlm_numSWb + write(fates_log(), *) 'num_swb (FATES side): ',num_swb call endrun(msg=errMsg(sourcefile, __LINE__)) end if @@ -1486,6 +1520,16 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) call endrun(msg=errMsg(sourcefile, __LINE__)) end if + if ( (hlm_num_luh2_states .lt. 0) ) then + write(fates_log(), *) 'The FATES number of hlm luh state cats must be >= 0, exiting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if ( (hlm_num_luh2_transitions .lt. 0) ) then + write(fates_log(), *) 'The FATES number of hlm luh state transition cats must be >= 0, exiting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + if ( .not.((hlm_use_logging .eq.1).or.(hlm_use_logging.eq.0)) ) then write(fates_log(), *) 'The FATES namelist use_logging flag must be 0 or 1, exiting' call endrun(msg=errMsg(sourcefile, __LINE__)) @@ -1863,6 +1907,24 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) write(fates_log(),*) 'Transfering hlm_num_lu_harvest_cats= ',ival,' to FATES' end if + case('use_luh2') + hlm_use_luh = ival + if (fates_global_verbose()) then + write(fates_log(),*) 'Transfering hlm_use_luh = ',ival,' to FATES' + end if + + case('num_luh2_states') + hlm_num_luh2_states = ival + if (fates_global_verbose()) then + write(fates_log(),*) 'Transfering hlm_num_luh2_states= ',ival,' to FATES' + end if + + case('num_luh2_transitions') + hlm_num_luh2_transitions = ival + if (fates_global_verbose()) then + write(fates_log(),*) 'Transfering hlm_num_luh2_transitions= ',ival,' to FATES' + end if + case('use_cohort_age_tracking') hlm_use_cohort_age_tracking = ival if (fates_global_verbose()) then @@ -1968,7 +2030,7 @@ subroutine FatesReportParameters(masterproc) call FatesCheckParams(masterproc) ! Check general fates parameters call PRTCheckParams(masterproc) ! Check PARTEH parameters call SpitFireCheckParams(masterproc) - + call TransferRadParams() return @@ -2380,5 +2442,41 @@ subroutine DetermineGridCellNeighbors(neighbors,seeds,numg) call t_stopf('fates-seed-init-decomp') end subroutine DetermineGridCellNeighbors - - end module FatesInterfaceMod + +! ====================================================================================== + +!----------------------------------------------------------------------- +! TODO(jpalex): this belongs in FatesParametersInterface.F90, but would require +! untangling the dependencies of the *RegisterParams methods below. +subroutine FatesReadParameters(param_reader) + implicit none + + class(fates_param_reader_type), intent(in) :: param_reader ! HLM-provided param file reader + + character(len=32) :: subname = 'FatesReadParameters' + class(fates_parameters_type), allocatable :: fates_params + + if ( hlm_masterproc == itrue ) then + write(fates_log(), *) 'FatesParametersInterface.F90::'//trim(subname)//' :: CLM reading ED/FATES '//' parameters ' + end if + + allocate(fates_params) + call fates_params%Init() ! fates_params class, in FatesParameterInterfaceMod + call FatesRegisterParams(fates_params) !EDParamsMod, only operates on fates_params class + call SpitFireRegisterParams(fates_params) !SpitFire Mod, only operates of fates_params class + call PRTRegisterParams(fates_params) ! PRT mod, only operates on fates_params class + call FatesSynchronizedParamsInst%RegisterParams(fates_params) !Synchronized params class in Synchronized params mod, only operates on fates_params class + + call param_reader%Read(fates_params) + + call FatesReceiveParams(fates_params) + call SpitFireReceiveParams(fates_params) + call PRTReceiveParams(fates_params) + call FatesSynchronizedParamsInst%ReceiveParams(fates_params) + + call fates_params%Destroy() + deallocate(fates_params) + + end subroutine FatesReadParameters + +end module FatesInterfaceMod diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index 29a4ec2ba0..6e9779dcac 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -123,6 +123,10 @@ module FatesInterfaceTypesMod ! harvest_rates in dynHarvestMod ! bc_in%hlm_harvest_rates and bc_in%hlm_harvest_catnames + integer, public :: hlm_use_luh ! flag to signal whether or not to use luh2 drivers + integer, public :: hlm_num_luh2_states ! number of land use state types provided in LUH2 forcing dataset + + integer, public :: hlm_num_luh2_transitions ! number of land use transition types provided in LUH2 forcing dataset integer, public :: hlm_sf_nofire_def ! Definition of a no-fire case for hlm_spitfire_mode integer, public :: hlm_sf_scalar_lightning_def ! Definition of a scalar-lightning case for hlm_spitfire_mode @@ -258,10 +262,11 @@ module FatesInterfaceTypesMod real(r8), public, allocatable :: fates_hdim_levage(:) ! patch age lower bound dimension real(r8), public, allocatable :: fates_hdim_levheight(:) ! height lower bound dimension integer , public, allocatable :: fates_hdim_levpft(:) ! plant pft dimension + integer , public, allocatable :: fates_hdim_levlanduse(:) ! land use label dimension integer , public, allocatable :: fates_hdim_levfuel(:) ! fire fuel size class (fsc) dimension integer , public, allocatable :: fates_hdim_levcwdsc(:) ! cwd class dimension integer , public, allocatable :: fates_hdim_levcan(:) ! canopy-layer dimension - integer , public, allocatable :: fates_hdim_levleaf(:) ! leaf-layer dimension + real(r8), public, allocatable :: fates_hdim_levleaf(:) ! leaf-layer dimension, integrated VAI [m2/m2] integer , public, allocatable :: fates_hdim_levelem(:) ! element dimension integer , public, allocatable :: fates_hdim_canmap_levcnlf(:) ! canopy-layer map into the canopy-layer x leaf-layer dim integer , public, allocatable :: fates_hdim_lfmap_levcnlf(:) ! leaf-layer map into the can-layer x leaf-layer dimension @@ -543,8 +548,12 @@ module FatesInterfaceTypesMod ! Land use ! --------------------------------------------------------------------------------- real(r8),allocatable :: hlm_harvest_rates(:) ! annual harvest rate per cat from hlm for a site - character(len=64), allocatable :: hlm_harvest_catnames(:) ! names of hlm_harvest d1 + real(r8),allocatable :: hlm_luh_states(:) + character(len=64),allocatable :: hlm_luh_state_names(:) + real(r8),allocatable :: hlm_luh_transitions(:) + character(len=64),allocatable :: hlm_luh_transition_names(:) + integer :: hlm_harvest_units ! what units are the harvest rates specified in? [area vs carbon] diff --git a/main/FatesInventoryInitMod.F90 b/main/FatesInventoryInitMod.F90 index ec099860f1..61f77387f4 100644 --- a/main/FatesInventoryInitMod.F90 +++ b/main/FatesInventoryInitMod.F90 @@ -11,12 +11,15 @@ module FatesInventoryInitMod ! site, or a small collection of sparse/irregularly spaced group of sites ! ! Created: Ryan Knox June 2017 - ! This code borrows heavily in concept from what is done in ED2. We will also do our best to - ! maintain compatibility with the PSS/CSS file formats that were used in ED2. - ! See: https://github.com/EDmodel/ED2/blob/master/ED/src/io/ed_read_ed10_20_history.f90 + ! This code borrows heavily in concept from what is done in ED2. ! At the time of writing this ED2 is unlicensed, and only concepts were borrowed with no direct ! code copied. - !----------------------------------------------------------------------------------------------- + ! + ! + ! Update: Jessica Needham October 2023 + ! As discussed in FATES issue #1062 we decided to remove columns not used in FATES from the + ! PSS and CSS files. + !----------------------------------------------------------------------------------------------- ! CIME GLOBALS @@ -26,6 +29,7 @@ module FatesInventoryInitMod use FatesConstantsMod, only : r8 => fates_r8 use FatesConstantsMod, only : pi_const use FatesConstantsMod, only : itrue + use FatesConstantsMod, only : nearzero use FatesGlobals , only : endrun => fates_endrun use FatesGlobals , only : fates_log use EDParamsMod , only : regeneration_model @@ -33,7 +37,6 @@ module FatesInventoryInitMod use FatesInterfaceTypesMod, only : hlm_inventory_ctrl_file use FatesInterfaceTypesMod, only : nleafage use FatesInterfaceTypesMod, only : hlm_current_tod - use FatesInterfaceTypesMod, only : hlm_numSWb use FatesInterfaceTypesMod, only : numpft use FatesLitterMod , only : litter_type use EDTypesMod , only : ed_site_type @@ -67,12 +70,12 @@ module FatesInventoryInitMod use PRTGenericMod, only : nitrogen_element use PRTGenericMod, only : phosphorus_element use PRTGenericMod, only : SetState - use FatesConstantsMod, only : primaryforest + use FatesConstantsMod, only : primaryland use FatesRunningMeanMod, only : ema_lpa use PRTGenericMod, only : StorageNutrientTarget use FatesConstantsMod, only : fates_unset_int use EDCanopyStructureMod, only : canopy_summarization, canopy_structure - + use FatesRadiationMemMod, only : num_swb implicit none private @@ -164,7 +167,7 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) character(len=patchname_strlen), allocatable :: patch_name_vec(:) ! vector of patch ID strings real(r8) :: basal_area_postf ! basal area before fusion (m2/ha) real(r8) :: basal_area_pref ! basal area after fusion (m2/ha) - + ! I. Load the inventory list file, do some file handle checks ! ------------------------------------------------------------------------------------------ @@ -280,17 +283,16 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) age_init = 0.0_r8 area_init = 0.0_r8 allocate(newpatch) - call newpatch%Create(age_init, area_init, primaryforest, & - fates_unset_int, hlm_numSWb, numpft, sites(s)%nlevsoil, & + call newpatch%Create(age_init, area_init, primaryland, & + fates_unset_int, num_swb, numpft, sites(s)%nlevsoil, & hlm_current_tod, regeneration_model) newpatch%patchno = ipa newpatch%younger => null() newpatch%older => null() - if( inv_format_list(invsite) == 1 ) then - call set_inventory_edpatch_type1(newpatch,pss_file_unit,ipa,ios,patch_name) + call set_inventory_patch_type1(newpatch,pss_file_unit,ipa,ios,patch_name) end if ! Add it to the site's patch list @@ -363,6 +365,7 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) enddo end if + ! OPEN THE CSS FILE ! --------------------------------------------------------------------------------------- css_file_unit = shr_file_getUnit() @@ -379,7 +382,7 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) invcohortloop: do if ( inv_format_list(invsite) == 1 ) then - call set_inventory_edcohort_type1(sites(s),bc_in(s),css_file_unit, & + call set_inventory_cohort_type1(sites(s),bc_in(s),css_file_unit, & npatches, patch_pointer_vec,patch_name_vec, ios) end if if ( ios/=0 ) exit @@ -395,84 +398,6 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) deallocate(patch_pointer_vec,patch_name_vec) - ! now that we've read in the patch and cohort info, check to see if there is any real age info - if ( abs(sites(s)%youngest_patch%age - sites(s)%oldest_patch%age) <= nearzero .and. & - associated(sites(s)%youngest_patch%older) ) then - - ! so there are at least two patches and the oldest and youngest are the same age. - ! this means that sorting by age wasn't very useful. try sorting by total biomass instead - - ! first calculate the biomass in each patch. simplest way is to use the patch fusion criteria - currentpatch => sites(s)%youngest_patch - do while(associated(currentpatch)) - call patch_pft_size_profile(currentPatch) - currentPatch => currentpatch%older - enddo - - ! now we need to sort them. - ! first generate a new head of the linked list. - head_of_unsorted_patch_list => sites(s)%youngest_patch%older - - ! reset the site-level patch linked list, keeping only the youngest patch. - sites(s)%youngest_patch%older => null() - sites(s)%youngest_patch%younger => null() - sites(s)%oldest_patch => sites(s)%youngest_patch - - ! loop through each patch in the unsorted LL, peel it off, - ! and insert it into the new, sorted LL - do while(associated(head_of_unsorted_patch_list)) - - ! first keep track of the next patch in the old (unsorted) linked list - next_in_unsorted_patch_list => head_of_unsorted_patch_list%older - - ! check the two end-cases - - ! Youngest Patch - if(sum(head_of_unsorted_patch_list%pft_agb_profile(:,:)) <= & - sum(sites(s)%youngest_patch%pft_agb_profile(:,:)))then - head_of_unsorted_patch_list%older => sites(s)%youngest_patch - head_of_unsorted_patch_list%younger => null() - sites(s)%youngest_patch%younger => head_of_unsorted_patch_list - sites(s)%youngest_patch => head_of_unsorted_patch_list - - ! Oldest Patch - else if(sum(head_of_unsorted_patch_list%pft_agb_profile(:,:)) > & - sum(sites(s)%oldest_patch%pft_agb_profile(:,:)))then - head_of_unsorted_patch_list%older => null() - head_of_unsorted_patch_list%younger => sites(s)%oldest_patch - sites(s)%oldest_patch%older => head_of_unsorted_patch_list - sites(s)%oldest_patch => head_of_unsorted_patch_list - - ! Somewhere in the middle - else - currentpatch => sites(s)%youngest_patch - do while(associated(currentpatch)) - olderpatch => currentpatch%older - if(associated(currentpatch%older)) then - if(sum(head_of_unsorted_patch_list%pft_agb_profile(:,:)) >= & - sum(currentpatch%pft_agb_profile(:,:)) .and. & - sum(head_of_unsorted_patch_list%pft_agb_profile(:,:)) < & - sum(olderpatch%pft_agb_profile(:,:))) then - ! Set the new patches pointers - head_of_unsorted_patch_list%older => currentpatch%older - head_of_unsorted_patch_list%younger => currentpatch - ! Fix the patch's older pointer - currentpatch%older => head_of_unsorted_patch_list - ! Fix the older patch's younger pointer - olderpatch%younger => head_of_unsorted_patch_list - ! Exit the loop once head sorted to avoid later re-sort - exit - end if - end if - currentPatch => olderpatch - enddo - end if - - ! now work through to the next element in the unsorted linked list - head_of_unsorted_patch_list => next_in_unsorted_patch_list - end do - endif - ! Report Basal Area (as a check on if things were read in) ! ------------------------------------------------------------------------------ basal_area_pref = 0.0_r8 @@ -481,7 +406,7 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) currentcohort => currentpatch%tallest do while(associated(currentcohort)) basal_area_pref = basal_area_pref + & - currentcohort%n*0.25*((currentcohort%dbh/100.0_r8)**2.0_r8)*pi_const + currentcohort%n*0.25*((currentcohort%dbh/100.0_r8)**2.0_r8)*pi_const currentcohort => currentcohort%shorter end do currentPatch => currentpatch%older @@ -497,6 +422,7 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) ! ---------------------------------------------------------------------------------------- ipa=1 total_cohorts = 0 + currentpatch => sites(s)%youngest_patch do while(associated(currentpatch)) currentpatch%patchno = ipa @@ -616,8 +542,8 @@ subroutine assess_inventory_sites(sitelist_file_unit,nsites, inv_format_list, & ! ! type integer We will accomodate different file format with different ! field values as the need arises. format 1 will read in - ! datasets via "set_inventory_edpatch_type1()", - ! "set_inventory_edcohort_type1()" + ! datasets via "set_inventory_patch_type1()", + ! "set_inventory_cohort_type1()" ! ! latitude float The geographic latitude coordinate of the site ! longitude float The geogarphic longitude coordinate of the site @@ -729,7 +655,7 @@ end subroutine assess_inventory_sites ! ============================================================================================== - subroutine set_inventory_edpatch_type1(newpatch,pss_file_unit,ipa,ios,patch_name) + subroutine set_inventory_patch_type1(newpatch,pss_file_unit,ipa,ios,patch_name) ! -------------------------------------------------------------------------------------------- ! This subroutine reads in a line of an inventory patch file (pss) @@ -744,14 +670,6 @@ subroutine set_inventory_edpatch_type1(newpatch,pss_file_unit,ipa,ios,patch_name ! trk (integer) LU type index (0 non-forest, 1 secondary, 2 primary ! age (years) Time since this patch was disturbed (created) ! area (fraction) Fraction of the site occupied by this patch - ! water (NA) Water content of soil (NOT USED) - ! fsc (kg/m2) Fast Soil Carbon - ! stsc (kg/m2) Structural Soil Carbon - ! stsl (kg/m2) Structural Soil Lignin - ! ssc (kg/m2) Slow Soil Carbon - ! psc (NA) Passive Soil Carbon (NOT USED) - ! msn (kg/m2) Mineralized Soil Nitrogen - ! fsn (kg/m2) Fast Soil Nitrogen ! -------------------------------------------------------------------------------------------- use FatesSizeAgeTypeIndicesMod, only: get_age_class_index @@ -772,14 +690,6 @@ subroutine set_inventory_edpatch_type1(newpatch,pss_file_unit,ipa,ios,patch_name character(len=patchname_strlen) :: p_name ! unique string identifier of patch real(r8) :: p_age ! Patch age [years] real(r8) :: p_area ! Patch area [fraction] - real(r8) :: p_water ! Patch water (unused) - real(r8) :: p_fsc ! Patch fast soil carbon - real(r8) :: p_stsc ! Patch structural soil carbon - real(r8) :: p_stsl ! Patch structural soil lignins - real(r8) :: p_ssc ! Patch slow soil carbon - real(r8) :: p_psc ! Patch P soil carbon - real(r8) :: p_msn ! Patch mean soil nitrogen - real(r8) :: p_fsn ! Patch fast soil nitrogen integer :: icwd ! index for counting CWD pools integer :: ipft ! index for counting PFTs real(r8) :: pftfrac ! the inverse of the total number of PFTs @@ -788,9 +698,7 @@ subroutine set_inventory_edpatch_type1(newpatch,pss_file_unit,ipa,ios,patch_name '(F5.2,2X,A4,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2)' - read(pss_file_unit,fmt=*,iostat=ios) p_time, p_name, p_trk, p_age, p_area, & - p_water,p_fsc, p_stsc, p_stsl, p_ssc, & - p_psc, p_msn, p_fsn + read(pss_file_unit,fmt=*,iostat=ios) p_time, p_name, p_trk, p_age, p_area if (ios/=0) return @@ -798,9 +706,7 @@ subroutine set_inventory_edpatch_type1(newpatch,pss_file_unit,ipa,ios,patch_name if( debug_inv) then write(*,fmt=wr_fmt) & - p_time, p_name, p_trk, p_age, p_area, & - p_water,p_fsc, p_stsc, p_stsl, p_ssc, & - p_psc, p_msn, p_fsn + p_time, p_name, p_trk, p_age, p_area end if ! Fill in the patch's memory structures @@ -838,12 +744,12 @@ subroutine set_inventory_edpatch_type1(newpatch,pss_file_unit,ipa,ios,patch_name end do return - end subroutine set_inventory_edpatch_type1 + end subroutine set_inventory_patch_type1 ! ============================================================================================== - subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & + subroutine set_inventory_cohort_type1(csite,bc_in,css_file_unit,npatches, & patch_pointer_vec,patch_name_vec,ios) ! -------------------------------------------------------------------------------------------- @@ -857,14 +763,10 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & ! FILE FORMAT: ! time (year) year of measurement ! patch (string) patch id string associated with this cohort - ! index (integer) cohort index - ! dbh (cm) diameter at breast height - ! height (m) height of the tree - ! pft (integer) the plant functional type index (must be consistent with param file) + ! dbh (cm) diameter at breast height. Optional, set height to negative if used + ! height (m) height of vegetation in m. Optional, set dbh to negative if used + ! pft (integer) the plant functional type index (must be consistent with param file) ! n (/m2) The plant number density - ! bdead (kgC/plant)The dead biomass per indiv of this cohort (NOT USED) - ! balive (kgC/plant)The live biomass per indiv of this cohort (NOT USED) - ! avgRG (cm/yr?) Average Radial Growth (NOT USED) ! -------------------------------------------------------------------------------------------- use FatesAllometryMod , only : h_allom @@ -893,14 +795,10 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & class(prt_vartypes), pointer :: prt_obj real(r8) :: c_time ! Time patch was recorded character(len=patchname_strlen) :: p_name ! The patch associated with this cohort - character(len=cohortname_strlen) :: c_name ! cohort index real(r8) :: c_dbh ! diameter at breast height (cm) real(r8) :: c_height ! tree height (m) integer :: c_pft ! plant functional type index real(r8) :: c_nplant ! plant density (/m2) - real(r8) :: c_bdead ! dead biomass (kg) - real(r8) :: c_balive ! live biomass (kg) - real(r8) :: c_avgRG ! avg radial growth (NOT USED) real(r8) :: site_spread ! initial guess of site spread ! should be quickly re-calculated integer,parameter :: rstatus = 0 ! recruit status @@ -935,16 +833,16 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & real(r8), parameter :: abnormal_large_nplant = 1000.0_r8 ! Used to catch bad values real(r8), parameter :: abnormal_large_dbh = 500.0_r8 ! I've never heard of a tree > 3m + real(r8), parameter :: abnormal_large_height = 500.0_r8 ! I've never heard of a tree > 500m tall integer, parameter :: recruitstatus = 0 - read(css_file_unit,fmt=*,iostat=ios) c_time, p_name, c_name, c_dbh, c_height, & - c_pft, c_nplant, c_bdead, c_balive, c_avgRG + read(css_file_unit,fmt=*,iostat=ios) c_time, p_name, c_dbh, & + c_height, c_pft, c_nplant if( debug_inv) then write(*,fmt=wr_fmt) & - c_time, p_name, c_name, c_dbh, c_height, & - c_pft, c_nplant, c_bdead, c_balive, c_avgRG + c_time, p_name, c_dbh, c_height, c_pft, c_nplant end if if (ios/=0) return @@ -961,8 +859,7 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & if(.not.matched_patch)then write(fates_log(), *) 'could not match a cohort with a patch' write(fates_log(),fmt=wr_fmt) & - c_time, p_name, c_name, c_dbh, c_height, & - c_pft, c_nplant, c_bdead, c_balive, c_avgRG + c_time, p_name, c_dbh, c_height, c_pft, c_nplant call endrun(msg=errMsg(sourcefile, __LINE__)) end if @@ -983,18 +880,32 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & call endrun(msg=errMsg(sourcefile, __LINE__)) end if - if (c_dbh <=0 ) then + if (c_dbh < nearzero .and. c_height < nearzero) then write(fates_log(), *) 'inventory dbh: ', c_dbh - write(fates_log(), *) 'The inventory produced a cohort with <= 0 dbh' + write(fates_log(), *) 'and inventory height: ',c_height + write(fates_log(), *) 'are both zero or negative. One must be positive.' call endrun(msg=errMsg(sourcefile, __LINE__)) end if + if (c_dbh > nearzero .and. c_height > nearzero) then + write(fates_log(), *) 'inventory dbh: ', c_dbh + write(fates_log(), *) 'and inventory height: ',c_height + write(fates_log(), *) 'are both positive. One must be zero or negative.' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + if (c_dbh > abnormal_large_dbh ) then write(fates_log(), *) 'inventory dbh: ', c_nplant write(fates_log(), *) 'The inventory produced a cohort with very large diameter [cm]' call endrun(msg=errMsg(sourcefile, __LINE__)) end if + if (c_height > abnormal_large_height ) then + write(fates_log(), *) 'inventory height: ', c_height + write(fates_log(), *) 'The inventory produced a cohort with very large height [m]' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + if (c_nplant <=0 ) then write(fates_log(), *) 'inventory nplant: ', c_nplant write(fates_log(), *) 'The inventory produced a cohort with <= 0 density /m2' @@ -1030,10 +941,17 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & endif temp_cohort%n = c_nplant * cpatch%area / real(ncohorts_to_create,r8) - temp_cohort%dbh = c_dbh + temp_cohort%crowndamage = 1 ! assume undamaged - call h_allom(c_dbh,temp_cohort%pft,temp_cohort%height) + if( c_dbh> 0._r8)then + temp_cohort%dbh = c_dbh + call h_allom(c_dbh,temp_cohort%pft,temp_cohort%height) + else + temp_cohort%height = c_height + call h2d_allom(c_height,temp_cohort%pft,temp_cohort%dbh) + end if + temp_cohort%canopy_trim = 1.0_r8 ! Determine the phenology status and the elongation factors. @@ -1202,7 +1120,7 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & end do return - end subroutine set_inventory_edcohort_type1 + end subroutine set_inventory_cohort_type1 ! ==================================================================================== @@ -1210,11 +1128,10 @@ subroutine write_inventory_type1(currentSite) ! -------------------------------------------------------------------------------- ! This subroutine writes the cohort/patch inventory type files in the "type 1" - ! format. Note that for compatibility with ED2, we chose an old type that has - ! both extra unused fields and is missing fields from FATES. THis is not - ! a recommended file type for restarting a run. + ! format. ! The files will have a lat/long tag added to their name, and will be ! generated in the run folder. + ! JFN Oct 2023 - updated to get rid of unused ED columns ! -------------------------------------------------------------------------------- use shr_file_mod, only : shr_file_getUnit @@ -1256,9 +1173,9 @@ subroutine write_inventory_type1(currentSite) ilon_sign = 'W' end if - write(pss_name_out,'(A8,I2.2,A1,I5.5,A1,A1,I3.3,A1,I5.5,A1,A4)') & + write(pss_name_out,'(A8, I2.2, A1, I5.5, A1)') & 'pss_out_',ilat_int,'.',ilat_dec,ilat_sign,'_',ilon_int,'.',ilon_dec,ilon_sign,'.txt' - write(css_name_out,'(A8,I2.2,A1,I5.5,A1,A1,I3.3,A1,I5.5,A1,A4)') & + write(css_name_out,'(A8, I2.2, A1, A1, I3.3, A1)') & 'css_out_',ilat_int,'.',ilat_dec,ilat_sign,'_',ilon_int,'.',ilon_dec,ilon_sign,'.txt' pss_file_out = shr_file_getUnit() @@ -1267,8 +1184,8 @@ subroutine write_inventory_type1(currentSite) open(unit=pss_file_out,file=trim(pss_name_out), status='UNKNOWN',action='WRITE',form='FORMATTED') open(unit=css_file_out,file=trim(css_name_out), status='UNKNOWN',action='WRITE',form='FORMATTED') - write(pss_file_out,*) 'time patch trk age area water fsc stsc stsl ssc psc msn fsn' - write(css_file_out,*) 'time patch cohort dbh height pft nplant bdead alive Avgrg' + write(pss_file_out,*) 'time patch trk age area' + write(css_file_out,*) 'time patch dbh height pft nplant' ipatch=0 currentpatch => currentSite%youngest_patch @@ -1277,16 +1194,14 @@ subroutine write_inventory_type1(currentSite) write(patch_str,'(A7,i4.4,A)') '' - write(pss_file_out,*) '0000 ',trim(patch_str),' 2 ',currentPatch%age,currentPatch%area/AREA, & - '0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000' + write(pss_file_out,*) '0000 ',trim(patch_str),' 2 ',currentPatch%age,currentPatch%area/AREA icohort=0 currentcohort => currentpatch%tallest do while(associated(currentcohort)) icohort=icohort+1 - write(cohort_str,'(A7,i4.4,A)') '' - write(css_file_out,*) '0000 ',trim(patch_str),' ',trim(cohort_str), & - currentCohort%dbh,0.0,currentCohort%pft,currentCohort%n/currentPatch%area,0.0,0.0,0.0 + write(css_file_out,*) '0000 ',trim(patch_str), & + currentCohort%dbh,currentCohort%height,currentCohort%pft,currentCohort%n/currentPatch%area currentcohort => currentcohort%shorter end do diff --git a/main/FatesParametersInterface.F90 b/main/FatesParametersInterface.F90 index b19817a091..aa0ef85287 100644 --- a/main/FatesParametersInterface.F90 +++ b/main/FatesParametersInterface.F90 @@ -38,6 +38,7 @@ module FatesParametersInterface character(len=*), parameter, public :: dimension_name_hlm_pftno = 'fates_hlm_pftno' character(len=*), parameter, public :: dimension_name_history_damage_bins = 'fates_history_damage_bins' character(len=*), parameter, public :: dimension_name_damage = 'fates_damage_class' + character(len=*), parameter, public :: dimension_name_landuse = 'fates_landuseclass' ! Dimensions in the host namespace: character(len=*), parameter, public :: dimension_name_host_allpfts = 'allpfts' @@ -83,6 +84,35 @@ module FatesParametersInterface end type fates_parameters_type + ! Abstract class (to be implemented by host land models) to read in + ! parameter values. + type, abstract, public :: fates_param_reader_type + contains + ! Public functions + procedure(Read_interface), public, deferred :: Read + + end type fates_param_reader_type + + abstract interface + subroutine Read_interface(this, fates_params ) + ! + ! !DESCRIPTION: + ! Read 'fates_params' parameters from (HLM-provided) storage. Note this ignores + ! the legacy parameter_type.sync_with_host setting. + ! + ! USES + import :: fates_param_reader_type + import :: fates_parameters_type + ! !ARGUMENTS: + class(fates_param_reader_type) :: this + class(fates_parameters_type), intent(inout) :: fates_params + !----------------------------------------------------------------------- + + end subroutine Read_interface + + !----------------------------------------------------------------------- + end interface + contains !----------------------------------------------------------------------- diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 5d170dde68..a2e7089c76 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -1,31 +1,31 @@ module FatesRestartInterfaceMod - use FatesConstantsMod, only : r8 => fates_r8 - use FatesConstantsMod, only : fates_avg_flag_length - use FatesConstantsMod, only : fates_short_string_length - use FatesConstantsMod, only : fates_long_string_length - use FatesConstantsMod, only : itrue - use FatesConstantsMod, only : ifalse - use FatesConstantsMod, only : fates_unset_r8, fates_unset_int - use FatesConstantsMod, only : primaryforest - use FatesConstantsMod, only : nearzero - use FatesConstantsMod, only : default_regeneration - use FatesConstantsMod, only : TRS_regeneration + use FatesConstantsMod, only : r8 => fates_r8 + use FatesConstantsMod, only : fates_avg_flag_length + use FatesConstantsMod, only : fates_short_string_length + use FatesConstantsMod, only : fates_long_string_length + use FatesConstantsMod, only : itrue + use FatesConstantsMod, only : ifalse + use FatesConstantsMod, only : fates_unset_r8, fates_unset_int + use FatesConstantsMod, only : primaryland + use FatesConstantsMod, only : nearzero + use FatesConstantsMod, only : default_regeneration + use FatesConstantsMod, only : TRS_regeneration use FatesGlobals, only : fates_log use FatesGlobals, only : endrun => fates_endrun use FatesIODimensionsMod, only : fates_io_dimension_type use FatesIOVariableKindMod, only : fates_io_variable_kind_type use FatesRestartVariableMod, only : fates_restart_variable_type - use FatesInterfaceTypesMod, only : nlevcoage - use FatesInterfaceTypesMod, only : bc_in_type - use FatesInterfaceTypesMod, only : bc_out_type - use FatesInterfaceTypesMod, only : hlm_use_planthydro - use FatesInterfaceTypesMod, only : hlm_parteh_mode - use FatesInterfaceTypesMod, only : hlm_use_sp - use FatesInterfaceTypesMod, only : hlm_use_nocomp, hlm_use_fixed_biogeog - use FatesInterfaceTypesMod, only : fates_maxElementsPerSite - use FatesInterfaceTypesMod, only : hlm_use_tree_damage + use FatesInterfaceTypesMod, only : nlevcoage + use FatesInterfaceTypesMod, only : bc_in_type + use FatesInterfaceTypesMod, only : bc_out_type + use FatesInterfaceTypesMod, only : hlm_use_planthydro + use FatesInterfaceTypesMod, only : hlm_parteh_mode + use FatesInterfaceTypesMod, only : hlm_use_sp + use FatesInterfaceTypesMod, only : hlm_use_nocomp, hlm_use_fixed_biogeog + use FatesInterfaceTypesMod, only : fates_maxElementsPerSite + use FatesInterfaceTypesMod, only : hlm_use_tree_damage use FatesHydraulicsMemMod, only : nshell use FatesHydraulicsMemMod, only : n_hypool_ag use FatesHydraulicsMemMod, only : n_hypool_troot @@ -35,7 +35,7 @@ module FatesRestartInterfaceMod use PRTGenericMod, only : prt_cnp_flex_allom_hyp use EDCohortDynamicsMod, only : InitPRTObject use FatesPlantHydraulicsMod, only : InitHydrCohort - use FatesInterfaceTypesMod, only : nlevsclass + use FatesInterfaceTypesMod, only : nlevsclass use FatesInterfaceTypesMod, only : nlevdamage use FatesLitterMod, only : litter_type use FatesLitterMod, only : ncwd, nfsc @@ -46,7 +46,12 @@ module FatesRestartInterfaceMod use PRTGenericMod, only : num_elements use FatesRunningMeanMod, only : rmean_type use FatesRunningMeanMod, only : ema_lpa + use FatesRadiationMemMod, only : num_swb,norman_solver,twostr_solver + use TwoStreamMLPEMod, only : normalized_upper_boundary use EDParamsMod, only : regeneration_model + use EDParamsMod, only : radiation_model + use FatesConstantsMod, only : n_landuse_cats + use FatesConstantsMod, only : N_DIST_TYPES ! CIME GLOBALS use shr_log_mod , only : errMsg => shr_log_errMsg @@ -105,6 +110,8 @@ module FatesRestartInterfaceMod integer :: ir_canopy_trim_co integer :: ir_l2fr_co + integer :: ir_year_net_up_co + integer :: ir_cx_int_co integer :: ir_emadcxdt_co integer :: ir_cx0_co @@ -141,7 +148,8 @@ module FatesRestartInterfaceMod integer :: ir_treesai_co integer :: ir_canopy_layer_tlai_pa - + integer :: ir_nclp_pa + integer :: ir_zstar_pa !Logging integer :: ir_lmort_direct_co @@ -250,6 +258,8 @@ module FatesRestartInterfaceMod integer :: ir_abg_imort_flux_siscpf integer :: ir_abg_fmort_flux_siscpf + integer :: ir_disturbance_rates_siluludi + integer :: ir_cwdagin_flxdg integer :: ir_cwdbgin_flxdg integer :: ir_leaflittin_flxdg @@ -1014,6 +1024,12 @@ subroutine define_restart_vars(this, initialize_variables) hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_litter_moisture_pa_nfsc) end if + + call this%RegisterCohortVector(symbol_base='fates_year_net_up', vtype=cohort_r8, & + long_name_base='yearly net uptake at leaf layers', & + units='kg/m2/year', veclength=nlevleaf, flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_year_net_up_co ) + ! Site Level Diagnostics over multiple nutrients @@ -1124,25 +1140,35 @@ subroutine define_restart_vars(this, initialize_variables) ! Only register satellite phenology related restart variables if it is turned on! - if(hlm_use_sp .eq. itrue) then - call this%set_restart_var(vname='fates_cohort_area', vtype=cohort_r8, & - long_name='area of the fates cohort', & - units='m2', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_c_area_co ) - call this%set_restart_var(vname='fates_cohort_treelai', vtype=cohort_r8, & - long_name='leaf area index of fates cohort', & - units='m2/m2', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_treelai_co ) - call this%set_restart_var(vname='fates_cohort_treesai', vtype=cohort_r8, & - long_name='stem area index of fates cohort', & - units='m2/m2', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_treesai_co ) - call this%set_restart_var(vname='fates_canopy_layer_tlai_pa', vtype=cohort_r8, & + call this%set_restart_var(vname='fates_cohort_area', vtype=cohort_r8, & + long_name='area of the fates cohort', & + units='m2', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_c_area_co ) + call this%set_restart_var(vname='fates_cohort_treelai', vtype=cohort_r8, & + long_name='leaf area index of fates cohort', & + units='m2/m2', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_treelai_co ) + call this%set_restart_var(vname='fates_cohort_treesai', vtype=cohort_r8, & + long_name='stem area index of fates cohort', & + units='m2/m2', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_treesai_co ) + + if(hlm_use_sp .eq. itrue)then + call this%set_restart_var(vname='fates_canopy_layer_tlai_pa', vtype=cohort_r8, & long_name='total patch level leaf area index of each fates canopy layer', & units='m2/m2', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_canopy_layer_tlai_pa ) end if + call this%set_restart_var(vname='fates_nclp_pa', vtype=cohort_int, & + long_name='total number of canopy layers', & + units='-', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_nclp_pa ) + + call this%set_restart_var(vname='fates_zstar_pa', vtype=cohort_r8, & + long_name='patch zstar', & + units='-', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_zstar_pa ) ! Only register hydraulics restart variables if it is turned on! @@ -1482,6 +1508,10 @@ subroutine define_restart_vars(this, initialize_variables) long_name='24-hour patch veg temp', & units='K', initialize=initialize_variables,ivar=ivar, index = ir_tveg24_pa) + call this%DefineRMeanRestartVar(vname='fates_disturbance_rates',vtype=cohort_r8, & + long_name='disturbance rates by donor land-use type, receiver land-use type, and disturbance type', & + units='1/day', initialize=initialize_variables,ivar=ivar, index = ir_disturbance_rates_siluludi) + if ( regeneration_model == TRS_regeneration ) then call this%DefineRMeanRestartVar(vname='fates_seedling_layer_par24',vtype=cohort_r8, & @@ -1916,7 +1946,6 @@ subroutine set_restart_vectors(this,nc,nsites,sites) use EDTypesMod, only : ed_site_type use FatesCohortMod, only : fates_cohort_type use FatesPatchMod, only : fates_patch_type - use EDParamsMod, only : maxSWb use EDParamsMod, only : nclmax use EDTypesMod, only : numWaterMem use EDTypesMod, only : num_vegtemp_mem @@ -1962,6 +1991,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) integer :: io_idx_si_pft ! each site-pft index integer :: io_idx_si_vtmem ! indices for veg-temp memory at site integer :: io_idx_pa_ncl ! each canopy layer within each patch + integer :: io_idx_si_luludi ! site-level lu x lu x ndist index ! Some counters (for checking mostly) integer :: totalcohorts ! total cohort count on this thread (diagnostic) @@ -1984,6 +2014,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) integer :: i_cdam ! loop counter for damage integer :: icdi ! loop counter for damage integer :: icdj ! loop counter for damage + integer :: i_lu_donor, i_lu_receiver, i_dist ! loop counters for land use and disturbance type(fates_restart_variable_type) :: rvar type(fates_patch_type),pointer :: cpatch @@ -2094,6 +2125,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_abg_imort_flux_siscpf => this%rvars(ir_abg_imort_flux_siscpf)%r81d, & rio_abg_fmort_flux_siscpf => this%rvars(ir_abg_fmort_flux_siscpf)%r81d, & rio_abg_term_flux_siscpf => this%rvars(ir_abg_term_flux_siscpf)%r81d, & + rio_disturbance_rates_siluludi => this%rvars(ir_disturbance_rates_siluludi)%r81d, & rio_imortrate_sicdpf => this%rvars(ir_imortrate_sicdpf)%r81d, & rio_imortcflux_sicdsc => this%rvars(ir_imortcflux_sicdsc)%r81d, & @@ -2143,6 +2175,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) io_idx_si_cdpf = io_idx_co_1st io_idx_si_scpf = io_idx_co_1st io_idx_si_pft = io_idx_co_1st + io_idx_si_luludi = io_idx_co_1st ! recruitment rate do i_pft = 1,numpft @@ -2191,6 +2224,16 @@ subroutine set_restart_vectors(this,nc,nsites,sites) io_idx_si_pft = io_idx_si_pft + 1 end do + ! site-level disturbance rate diagnostic + do i_lu_donor = 1, n_landuse_cats + do i_lu_receiver = 1, n_landuse_cats + do i_dist = 1, n_dist_types + rio_disturbance_rates_siluludi(io_idx_si_luludi) = sites(s)%disturbance_rates(i_dist,i_lu_donor, i_lu_receiver) + io_idx_si_luludi = io_idx_si_luludi + 1 + end do + end do + end do + if(hlm_use_sp.eq.ifalse)then do el = 1, num_elements @@ -2278,6 +2321,8 @@ subroutine set_restart_vectors(this,nc,nsites,sites) end do end do + call this%SetCohortRealVector(ccohort%year_net_uptake,nlevleaf,ir_year_net_up_co,io_idx_co) + rio_l2fr_co(io_idx_co) = ccohort%l2fr if(hlm_parteh_mode .eq. prt_cnp_flex_allom_hyp) then @@ -2355,12 +2400,10 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_isnew_co(io_idx_co) = old_cohort endif - if (hlm_use_sp .eq. itrue) then - this%rvars(ir_c_area_co)%r81d(io_idx_co) = ccohort%c_area - this%rvars(ir_treelai_co)%r81d(io_idx_co) = ccohort%treelai - this%rvars(ir_treesai_co)%r81d(io_idx_co) = ccohort%treesai - end if - + this%rvars(ir_c_area_co)%r81d(io_idx_co) = ccohort%c_area + this%rvars(ir_treelai_co)%r81d(io_idx_co) = ccohort%treelai + this%rvars(ir_treesai_co)%r81d(io_idx_co) = ccohort%treesai + if ( debug ) then write(fates_log(),*) 'CLTV offsetNumCohorts II ',io_idx_co, & cohortsperpatch @@ -2380,7 +2423,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ! rio_livegrass_pa(io_idx_co_1st) = cpatch%livegrass rio_age_pa(io_idx_co_1st) = cpatch%age - rio_patchdistturbcat_pa(io_idx_co_1st) = cpatch%anthro_disturbance_label + rio_patchdistturbcat_pa(io_idx_co_1st) = cpatch%land_use_label rio_agesinceanthrodist_pa(io_idx_co_1st) = cpatch%age_since_anthro_disturbance rio_nocomp_pft_label_pa(io_idx_co_1st)= cpatch%nocomp_pft_label rio_area_pa(io_idx_co_1st) = cpatch%area @@ -2420,6 +2463,8 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ,io_idx_co,cohortsperpatch endif + this%rvars(ir_nclp_pa)%int1d(io_idx_co_1st) = cpatch%ncl_p + this%rvars(ir_zstar_pa)%r81d(io_idx_co_1st) = cpatch%zstar if(hlm_use_sp.eq.ifalse)then @@ -2485,7 +2530,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) end do end if - do i = 1,maxSWb + do i = 1,num_swb rio_gnd_alb_dif_pasb(io_idx_pa_ib) = cpatch%gnd_alb_dif(i) rio_gnd_alb_dir_pasb(io_idx_pa_ib) = cpatch%gnd_alb_dir(i) io_idx_pa_ib = io_idx_pa_ib + 1 @@ -2656,17 +2701,16 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in, bc_out) ! linked-list state structure. ! --------------------------------------------------------------------------------- - use EDTypesMod, only : ed_site_type - use FatesCohortMod, only : fates_cohort_type - use FatesPatchMod, only : fates_patch_type - use EDParamsMod, only : maxSWb, regeneration_model - use FatesInterfaceTypesMod, only : fates_maxElementsPerPatch - use FatesInterfaceTypesMod, only : hlm_current_tod, hlm_numSWb, numpft - - use EDTypesMod, only : area - use EDInitMod, only : zero_site - use EDInitMod, only : init_site_vars - use FatesAllometryMod, only : h2d_allom + use EDTypesMod, only : ed_site_type + use FatesCohortMod, only : fates_cohort_type + use FatesPatchMod, only : fates_patch_type + use EDParamsMod, only : regeneration_model + use FatesInterfaceTypesMod, only : fates_maxElementsPerPatch + use FatesInterfaceTypesMod, only : hlm_current_tod, numpft + use EDTypesMod, only : area + use EDInitMod, only : zero_site + use EDInitMod, only : init_site_vars + use FatesAllometryMod, only : h2d_allom ! !ARGUMENTS: @@ -2732,8 +2776,8 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in, bc_out) nocomp_pft = fates_unset_int ! the nocomp_pft label is set after patch creation has occured in 'get_restart_vectors' ! make new patch - call newp%Create(fates_unset_r8, fates_unset_r8, primaryforest, & - nocomp_pft, hlm_numSWb, numpft, sites(s)%nlevsoil, & + call newp%Create(fates_unset_r8, fates_unset_r8, primaryland, & + nocomp_pft, num_swb, numpft, sites(s)%nlevsoil, & hlm_current_tod, regeneration_model) ! Initialize the litter pools to zero, these @@ -2857,7 +2901,6 @@ subroutine get_restart_vectors(this, nc, nsites, sites) use EDTypesMod, only : ed_site_type use FatesCohortMod, only : fates_cohort_type use FatesPatchMod, only : fates_patch_type - use EDParamsMod, only : maxSWb use EDParamsMod, only : nclmax use FatesInterfaceTypesMod, only : numpft use FatesInterfaceTypesMod, only : fates_maxElementsPerPatch @@ -2912,6 +2955,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) integer :: io_idx_si_cdpf ! damage x size x pft within site integer :: io_idx_pa_ncl ! each canopy layer within each patch + integer :: io_idx_si_luludi ! site-level lu x lu x ndist index ! Some counters (for checking mostly) integer :: totalcohorts ! total cohort count on this thread (diagnostic) @@ -2931,6 +2975,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) integer :: i_cdam ! loop counter for damage class integer :: icdj ! loop counter for damage class integer :: icdi ! loop counter for damage class + integer :: i_lu_donor, i_lu_receiver, i_dist ! loop counters for land use and disturbance associate( rio_npatch_si => this%rvars(ir_npatch_si)%int1d, & rio_cd_status_si => this%rvars(ir_cd_status_si)%int1d, & @@ -3015,6 +3060,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) rio_imortrate_siscpf => this%rvars(ir_imortrate_siscpf)%r81d, & rio_fmortrate_crown_siscpf => this%rvars(ir_fmortrate_crown_siscpf)%r81d, & rio_fmortrate_cambi_siscpf => this%rvars(ir_fmortrate_cambi_siscpf)%r81d, & + rio_disturbance_rates_siluludi => this%rvars(ir_disturbance_rates_siluludi)%r81d, & rio_termnindiv_cano_siscpf => this%rvars(ir_termnindiv_cano_siscpf)%r81d, & rio_termnindiv_usto_siscpf => this%rvars(ir_termnindiv_usto_siscpf)%r81d, & rio_growflx_fusion_siscpf => this%rvars(ir_growflx_fusion_siscpf)%r81d, & @@ -3075,7 +3121,8 @@ subroutine get_restart_vectors(this, nc, nsites, sites) io_idx_si_cdpf = io_idx_co_1st io_idx_si_scpf = io_idx_co_1st io_idx_si_pft = io_idx_co_1st - + io_idx_si_luludi = io_idx_co_1st + ! read seed_bank info(site-level, but PFT-resolved) do i_pft = 1,numpft sites(s)%recruitment_rate(i_pft) = rio_recrate_sift(io_idx_co_1st+i_pft-1) @@ -3130,6 +3177,16 @@ subroutine get_restart_vectors(this, nc, nsites, sites) io_idx_si_pft = io_idx_si_pft + 1 end do + ! site-level disturbance rate diagnostic + do i_lu_donor = 1, n_landuse_cats + do i_lu_receiver = 1, n_landuse_cats + do i_dist = 1, n_dist_types + sites(s)%disturbance_rates(i_dist,i_lu_donor, i_lu_receiver) = rio_disturbance_rates_siluludi(io_idx_si_luludi) + io_idx_si_luludi = io_idx_si_luludi + 1 + end do + end do + end do + ! Mass balance and diagnostics across elements at the site level if(hlm_use_sp.eq.ifalse)then do el = 1, num_elements @@ -3214,6 +3271,8 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ccohort%canopy_trim = rio_canopy_trim_co(io_idx_co) ccohort%l2fr = rio_l2fr_co(io_idx_co) + call this%GetCohortRealVector(ccohort%year_net_uptake,nlevleaf,ir_year_net_up_co,io_idx_co) + if(hlm_parteh_mode .eq. prt_cnp_flex_allom_hyp) then ccohort%cx_int = this%rvars(ir_cx_int_co)%r81d(io_idx_co) ccohort%ema_dcxdt = this%rvars(ir_emadcxdt_co)%r81d(io_idx_co) @@ -3289,12 +3348,10 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ! (Keeping as an example) !call this%GetRMeanRestartVar(ccohort%tveg_lpa, ir_tveglpa_co, io_idx_co) - if (hlm_use_sp .eq. itrue) then - ccohort%c_area = this%rvars(ir_c_area_co)%r81d(io_idx_co) - ccohort%treelai = this%rvars(ir_treelai_co)%r81d(io_idx_co) - ccohort%treesai = this%rvars(ir_treesai_co)%r81d(io_idx_co) - end if - + ccohort%c_area = this%rvars(ir_c_area_co)%r81d(io_idx_co) + ccohort%treelai = this%rvars(ir_treelai_co)%r81d(io_idx_co) + ccohort%treesai = this%rvars(ir_treesai_co)%r81d(io_idx_co) + io_idx_co = io_idx_co + 1 ccohort => ccohort%taller @@ -3312,7 +3369,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ! cpatch%livegrass = rio_livegrass_pa(io_idx_co_1st) cpatch%age = rio_age_pa(io_idx_co_1st) - cpatch%anthro_disturbance_label = rio_patchdistturbcat_pa(io_idx_co_1st) + cpatch%land_use_label = rio_patchdistturbcat_pa(io_idx_co_1st) cpatch%age_since_anthro_disturbance = rio_agesinceanthrodist_pa(io_idx_co_1st) cpatch%nocomp_pft_label = rio_nocomp_pft_label_pa(io_idx_co_1st) cpatch%area = rio_area_pa(io_idx_co_1st) @@ -3323,6 +3380,8 @@ subroutine get_restart_vectors(this, nc, nsites, sites) cpatch%solar_zenith_flag = ( rio_solar_zenith_flag_pa(io_idx_co_1st) .eq. itrue ) cpatch%solar_zenith_angle = rio_solar_zenith_angle_pa(io_idx_co_1st) + cpatch%ncl_p = this%rvars(ir_nclp_pa)%int1d(io_idx_co_1st) + cpatch%zstar = this%rvars(ir_zstar_pa)%r81d(io_idx_co_1st) call this%GetRMeanRestartVar(cpatch%tveg24, ir_tveg24_pa, io_idx_co_1st) call this%GetRMeanRestartVar(cpatch%tveg_lpa, ir_tveglpa_pa, io_idx_co_1st) @@ -3414,7 +3473,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) end if - do i = 1,maxSWb + do i = 1,num_swb cpatch%gnd_alb_dif(i) = rio_gnd_alb_dif_pasb(io_idx_pa_ib) cpatch%gnd_alb_dir(i) = rio_gnd_alb_dir_pasb(io_idx_pa_ib) io_idx_pa_ib = io_idx_pa_ib + 1 @@ -3582,10 +3641,9 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) ! called upon restart reads. ! ------------------------------------------------------------------------- - use EDTypesMod, only : ed_site_type - use FatesPatchMod, only : fates_patch_type - use EDSurfaceRadiationMod, only : PatchNormanRadiation - use FatesInterfaceTypesMod, only : hlm_numSWb + use FatesNormanRadMod, only : PatchNormanRadiation + use EDTypesMod, only : ed_site_type + use FatesPatchMod, only : fates_patch_type ! !ARGUMENTS: class(fates_restart_interface_type) , intent(inout) :: this @@ -3618,9 +3676,9 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) ! zero diagnostic radiation profiles currentPatch%nrmlzd_parprof_pft_dir_z(:,:,:,:) = 0._r8 currentPatch%nrmlzd_parprof_pft_dif_z(:,:,:,:) = 0._r8 - currentPatch%nrmlzd_parprof_dir_z(:,:,:) = 0._r8 - currentPatch%nrmlzd_parprof_dif_z(:,:,:) = 0._r8 + currentPatch%rad_error(:) = 0._r8 + ! ----------------------------------------------------------- ! When calling norman radiation from the short-timestep ! we are passing in boundary conditions to set the following @@ -3644,7 +3702,7 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) ! no radiation is absorbed bc_out(s)%fabd_parb(ifp,:) = 0.0_r8 bc_out(s)%fabi_parb(ifp,:) = 0.0_r8 - do ib = 1,hlm_numSWb + do ib = 1,num_swb bc_out(s)%albd_parb(ifp,ib) = currentPatch%gnd_alb_dir(ib) bc_out(s)%albi_parb(ifp,ib) = currentPatch%gnd_alb_dif(ib) @@ -3654,15 +3712,51 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) enddo else - call PatchNormanRadiation (currentPatch, & - bc_out(s)%albd_parb(ifp,:), & - bc_out(s)%albi_parb(ifp,:), & - bc_out(s)%fabd_parb(ifp,:), & - bc_out(s)%fabi_parb(ifp,:), & - bc_out(s)%ftdd_parb(ifp,:), & - bc_out(s)%ftid_parb(ifp,:), & - bc_out(s)%ftii_parb(ifp,:)) - + select case(radiation_model) + case(norman_solver) + + call PatchNormanRadiation (currentPatch, & + bc_out(s)%albd_parb(ifp,:), & + bc_out(s)%albi_parb(ifp,:), & + bc_out(s)%fabd_parb(ifp,:), & + bc_out(s)%fabi_parb(ifp,:), & + bc_out(s)%ftdd_parb(ifp,:), & + bc_out(s)%ftid_parb(ifp,:), & + bc_out(s)%ftii_parb(ifp,:)) + + + case(twostr_solver) + associate( twostr => currentPatch%twostr) + + call twostr%CanopyPrep(currentPatch%fcansno) + call twostr%ZenithPrep(currentPatch%solar_zenith_angle) + + do ib = 1,num_swb + + twostr%band(ib)%albedo_grnd_diff = currentPatch%gnd_alb_dif(ib) + twostr%band(ib)%albedo_grnd_beam = currentPatch%gnd_alb_dir(ib) + + call twostr%Solve(ib, & ! in + normalized_upper_boundary, & ! in + 1.0_r8,1.0_r8, & ! in + sites(s)%taulambda_2str, & ! inout (scratch) + sites(s)%omega_2str, & ! inout (scratch) + sites(s)%ipiv_2str, & ! inout (scratch) + bc_out(s)%albd_parb(ifp,ib), & ! out + bc_out(s)%albi_parb(ifp,ib), & ! out + currentPatch%rad_error(ib), & ! out + bc_out(s)%fabd_parb(ifp,ib), & ! out + bc_out(s)%fabi_parb(ifp,ib), & ! out + bc_out(s)%ftdd_parb(ifp,ib), & ! out + bc_out(s)%ftid_parb(ifp,ib), & ! out + bc_out(s)%ftii_parb(ifp,ib)) + + end do + + end associate + + end select + endif ! is there vegetation? end if ! if the vegetation and zenith filter is active diff --git a/main/FatesUtilsMod.F90 b/main/FatesUtilsMod.F90 index 3310b5d6a4..4699a6aa60 100644 --- a/main/FatesUtilsMod.F90 +++ b/main/FatesUtilsMod.F90 @@ -13,6 +13,7 @@ module FatesUtilsMod public :: check_hlm_list public :: check_var_real public :: GetNeighborDistance + public :: FindIndex contains @@ -135,8 +136,6 @@ function GetNeighborDistance(gi,gj,latc,lonc) result(gcd) integer, intent(in) :: gi,gj ! indices of gridcells real(r8), intent(in) :: latc(:),lonc(:) ! lat/lon of gridcells real(r8) :: gcd - - ! write(fates_log(),*)'neighborhood: size ldomain latc/lonc: ', size(ldomain%latc), size(ldomain%lonc) gcd = GreatCircleDist(lonc(gi),lonc(gj), & latc(gi),latc(gj)) @@ -144,5 +143,39 @@ function GetNeighborDistance(gi,gj,latc,lonc) result(gcd) end function GetNeighborDistance ! ====================================================================================== + + function FindIndex(input_string_array,string_to_match) result(array_index) + + ! --------------------------------------------------------------------------------- + ! This simple function is a standin for the intrinsic FINDLOC which is not available + ! with some compilers such as NAG prior to v7.0. As with FINDLOC, the + ! function will return zero if a match is not found. + ! + ! Limitations compared to FINDLOC: + ! - Only takes one dimensional arrays + ! - Only take arrays of characters + ! - Does not allow masking + ! --------------------------------------------------------------------------------- + + ! Input and output + character(len=*), intent(in) :: input_string_array(:) + character(len=*), intent(in) :: string_to_match + integer :: array_index + + ! Locals + integer :: i + ! Initialize return index as zero + array_index = 0 + + ! Loop throught the array and compare strings + do i = 1, size(input_string_array) + if (trim(input_string_array(i)) .eq. trim(string_to_match)) then + array_index = i + end if + end do + + end function FindIndex + + ! ====================================================================================== end module FatesUtilsMod diff --git a/parameter_files/archive/api25.5.0_080923_fates_params_default.cdl b/parameter_files/archive/api25.5.0_080923_fates_params_default.cdl new file mode 100644 index 0000000000..f170fe2275 --- /dev/null +++ b/parameter_files/archive/api25.5.0_080923_fates_params_default.cdl @@ -0,0 +1,1735 @@ +netcdf fates_params_default { +dimensions: + fates_NCWD = 4 ; + fates_history_age_bins = 7 ; + fates_history_coage_bins = 2 ; + fates_history_damage_bins = 2 ; + fates_history_height_bins = 6 ; + fates_history_size_bins = 13 ; + fates_hlm_pftno = 14 ; + fates_hydr_organs = 4 ; + fates_leafage_class = 1 ; + fates_litterclass = 6 ; + fates_pft = 12 ; + fates_plant_organs = 4 ; + fates_string_length = 60 ; +variables: + double fates_history_ageclass_bin_edges(fates_history_age_bins) ; + fates_history_ageclass_bin_edges:units = "yr" ; + fates_history_ageclass_bin_edges:long_name = "Lower edges for age class bins used in age-resolved patch history output" ; + double fates_history_coageclass_bin_edges(fates_history_coage_bins) ; + fates_history_coageclass_bin_edges:units = "years" ; + fates_history_coageclass_bin_edges:long_name = "Lower edges for cohort age class bins used in cohort age resolved history output" ; + double fates_history_height_bin_edges(fates_history_height_bins) ; + fates_history_height_bin_edges:units = "m" ; + fates_history_height_bin_edges:long_name = "Lower edges for height bins used in height-resolved history output" ; + double fates_history_damage_bin_edges(fates_history_damage_bins) ; + fates_history_damage_bin_edges:units = "% crown loss" ; + fates_history_damage_bin_edges:long_name = "Lower edges for damage class bins used in cohort history output" ; + double fates_history_sizeclass_bin_edges(fates_history_size_bins) ; + fates_history_sizeclass_bin_edges:units = "cm" ; + fates_history_sizeclass_bin_edges:long_name = "Lower edges for DBH size class bins used in size-resolved cohort history output" ; + double fates_alloc_organ_id(fates_plant_organs) ; + fates_alloc_organ_id:units = "unitless" ; + fates_alloc_organ_id:long_name = "This is the global index that the organ in this file is associated with, values match those in parteh/PRTGenericMod.F90" ; + double fates_hydro_htftype_node(fates_hydr_organs) ; + fates_hydro_htftype_node:units = "unitless" ; + fates_hydro_htftype_node:long_name = "Switch that defines the hydraulic transfer functions for each organ." ; + char fates_pftname(fates_pft, fates_string_length) ; + fates_pftname:units = "unitless - string" ; + fates_pftname:long_name = "Description of plant type" ; + char fates_hydro_organ_name(fates_hydr_organs, fates_string_length) ; + fates_hydro_organ_name:units = "unitless - string" ; + fates_hydro_organ_name:long_name = "Name of plant hydraulics organs (DONT CHANGE, order matches media list in FatesHydraulicsMemMod.F90)" ; + char fates_alloc_organ_name(fates_plant_organs, fates_string_length) ; + fates_alloc_organ_name:units = "unitless - string" ; + fates_alloc_organ_name:long_name = "Name of plant organs (with alloc_organ_id, must match PRTGenericMod.F90)" ; + char fates_litterclass_name(fates_litterclass, fates_string_length) ; + fates_litterclass_name:units = "unitless - string" ; + fates_litterclass_name:long_name = "Name of the litter classes, for variables associated with dimension fates_litterclass" ; + double fates_alloc_organ_priority(fates_plant_organs, fates_pft) ; + fates_alloc_organ_priority:units = "index" ; + fates_alloc_organ_priority:long_name = "Priority level for allocation, 1: replaces turnover from storage, 2: same priority as storage use/replacement, 3: ascending in order of least importance" ; + double fates_alloc_storage_cushion(fates_pft) ; + fates_alloc_storage_cushion:units = "fraction" ; + fates_alloc_storage_cushion:long_name = "maximum size of storage C pool, relative to maximum size of leaf C pool" ; + double fates_alloc_store_priority_frac(fates_pft) ; + fates_alloc_store_priority_frac:units = "unitless" ; + fates_alloc_store_priority_frac:long_name = "for high-priority organs, the fraction of their turnover demand that is gauranteed to be replaced, and if need-be by storage" ; + double fates_allom_agb1(fates_pft) ; + fates_allom_agb1:units = "variable" ; + fates_allom_agb1:long_name = "Parameter 1 for agb allometry" ; + double fates_allom_agb2(fates_pft) ; + fates_allom_agb2:units = "variable" ; + fates_allom_agb2:long_name = "Parameter 2 for agb allometry" ; + double fates_allom_agb3(fates_pft) ; + fates_allom_agb3:units = "variable" ; + fates_allom_agb3:long_name = "Parameter 3 for agb allometry" ; + double fates_allom_agb4(fates_pft) ; + fates_allom_agb4:units = "variable" ; + fates_allom_agb4:long_name = "Parameter 4 for agb allometry" ; + double fates_allom_agb_frac(fates_pft) ; + fates_allom_agb_frac:units = "fraction" ; + fates_allom_agb_frac:long_name = "Fraction of woody biomass that is above ground" ; + double fates_allom_amode(fates_pft) ; + fates_allom_amode:units = "index" ; + fates_allom_amode:long_name = "AGB allometry function index." ; + double fates_allom_blca_expnt_diff(fates_pft) ; + fates_allom_blca_expnt_diff:units = "unitless" ; + fates_allom_blca_expnt_diff:long_name = "difference between allometric DBH:bleaf and DBH:crown area exponents" ; + double fates_allom_cmode(fates_pft) ; + fates_allom_cmode:units = "index" ; + fates_allom_cmode:long_name = "coarse root biomass allometry function index." ; + double fates_allom_crown_depth_frac(fates_pft) ; + fates_allom_crown_depth_frac:units = "fraction" ; + fates_allom_crown_depth_frac:long_name = "the depth of a cohort crown as a fraction of its height" ; + double fates_allom_d2bl1(fates_pft) ; + fates_allom_d2bl1:units = "variable" ; + fates_allom_d2bl1:long_name = "Parameter 1 for d2bl allometry" ; + double fates_allom_d2bl2(fates_pft) ; + fates_allom_d2bl2:units = "variable" ; + fates_allom_d2bl2:long_name = "Parameter 2 for d2bl allometry" ; + double fates_allom_d2bl3(fates_pft) ; + fates_allom_d2bl3:units = "unitless" ; + fates_allom_d2bl3:long_name = "Parameter 3 for d2bl allometry" ; + double fates_allom_d2ca_coefficient_max(fates_pft) ; + fates_allom_d2ca_coefficient_max:units = "m2 cm^(-1/beta)" ; + fates_allom_d2ca_coefficient_max:long_name = "max (savanna) dbh to area multiplier factor where: area = n*d2ca_coeff*dbh^beta" ; + double fates_allom_d2ca_coefficient_min(fates_pft) ; + fates_allom_d2ca_coefficient_min:units = "m2 cm^(-1/beta)" ; + fates_allom_d2ca_coefficient_min:long_name = "min (forest) dbh to area multiplier factor where: area = n*d2ca_coeff*dbh^beta" ; + double fates_allom_d2h1(fates_pft) ; + fates_allom_d2h1:units = "variable" ; + fates_allom_d2h1:long_name = "Parameter 1 for d2h allometry (intercept, or c)" ; + double fates_allom_d2h2(fates_pft) ; + fates_allom_d2h2:units = "variable" ; + fates_allom_d2h2:long_name = "Parameter 2 for d2h allometry (slope, or m)" ; + double fates_allom_d2h3(fates_pft) ; + fates_allom_d2h3:units = "variable" ; + fates_allom_d2h3:long_name = "Parameter 3 for d2h allometry (optional)" ; + double fates_allom_dbh_maxheight(fates_pft) ; + fates_allom_dbh_maxheight:units = "cm" ; + fates_allom_dbh_maxheight:long_name = "the diameter (if any) corresponding to maximum height, diameters may increase beyond this" ; + double fates_allom_fmode(fates_pft) ; + fates_allom_fmode:units = "index" ; + fates_allom_fmode:long_name = "fine root biomass allometry function index." ; + double fates_allom_fnrt_prof_a(fates_pft) ; + fates_allom_fnrt_prof_a:units = "unitless" ; + fates_allom_fnrt_prof_a:long_name = "Fine root profile function, parameter a" ; + double fates_allom_fnrt_prof_b(fates_pft) ; + fates_allom_fnrt_prof_b:units = "unitless" ; + fates_allom_fnrt_prof_b:long_name = "Fine root profile function, parameter b" ; + double fates_allom_fnrt_prof_mode(fates_pft) ; + fates_allom_fnrt_prof_mode:units = "index" ; + fates_allom_fnrt_prof_mode:long_name = "Index to select fine root profile function: 1) Jackson Beta, 2) 1-param exponential 3) 2-param exponential" ; + double fates_allom_frbstor_repro(fates_pft) ; + fates_allom_frbstor_repro:units = "fraction" ; + fates_allom_frbstor_repro:long_name = "fraction of bstore goes to reproduction after plant dies" ; + double fates_allom_hmode(fates_pft) ; + fates_allom_hmode:units = "index" ; + fates_allom_hmode:long_name = "height allometry function index." ; + double fates_allom_l2fr(fates_pft) ; + fates_allom_l2fr:units = "gC/gC" ; + fates_allom_l2fr:long_name = "Allocation parameter: fine root C per leaf C" ; + double fates_allom_la_per_sa_int(fates_pft) ; + fates_allom_la_per_sa_int:units = "m2/cm2" ; + fates_allom_la_per_sa_int:long_name = "Leaf area per sapwood area, intercept" ; + double fates_allom_la_per_sa_slp(fates_pft) ; + fates_allom_la_per_sa_slp:units = "m2/cm2/m" ; + fates_allom_la_per_sa_slp:long_name = "Leaf area per sapwood area rate of change with height, slope (optional)" ; + double fates_allom_lmode(fates_pft) ; + fates_allom_lmode:units = "index" ; + fates_allom_lmode:long_name = "leaf biomass allometry function index." ; + double fates_allom_sai_scaler(fates_pft) ; + fates_allom_sai_scaler:units = "m2/m2" ; + fates_allom_sai_scaler:long_name = "allometric ratio of SAI per LAI" ; + double fates_allom_smode(fates_pft) ; + fates_allom_smode:units = "index" ; + fates_allom_smode:long_name = "sapwood allometry function index." ; + double fates_allom_stmode(fates_pft) ; + fates_allom_stmode:units = "index" ; + fates_allom_stmode:long_name = "storage allometry function index: 1) Storage proportional to leaf biomass (with trimming), 2) Storage proportional to maximum leaf biomass (not trimmed)" ; + double fates_allom_zroot_k(fates_pft) ; + fates_allom_zroot_k:units = "unitless" ; + fates_allom_zroot_k:long_name = "scale coefficient of logistic rooting depth model" ; + double fates_allom_zroot_max_dbh(fates_pft) ; + fates_allom_zroot_max_dbh:units = "cm" ; + fates_allom_zroot_max_dbh:long_name = "dbh at which a plant reaches the maximum value for its maximum rooting depth" ; + double fates_allom_zroot_max_z(fates_pft) ; + fates_allom_zroot_max_z:units = "m" ; + fates_allom_zroot_max_z:long_name = "the maximum rooting depth defined at dbh = fates_allom_zroot_max_dbh. note: max_z=min_z=large, sets rooting depth to soil depth" ; + double fates_allom_zroot_min_dbh(fates_pft) ; + fates_allom_zroot_min_dbh:units = "cm" ; + fates_allom_zroot_min_dbh:long_name = "dbh at which the maximum rooting depth for a recruit is defined" ; + double fates_allom_zroot_min_z(fates_pft) ; + fates_allom_zroot_min_z:units = "m" ; + fates_allom_zroot_min_z:long_name = "the maximum rooting depth defined at dbh = fates_allom_zroot_min_dbh. note: max_z=min_z=large, sets rooting depth to soil depth" ; + double fates_c2b(fates_pft) ; + fates_c2b:units = "ratio" ; + fates_c2b:long_name = "Carbon to biomass multiplier of bulk structural tissues" ; + double fates_cnp_eca_alpha_ptase(fates_pft) ; + fates_cnp_eca_alpha_ptase:units = "g/m3" ; + fates_cnp_eca_alpha_ptase:long_name = "fraction of P from ptase activity sent directly to plant (ECA)" ; + double fates_cnp_eca_decompmicc(fates_pft) ; + fates_cnp_eca_decompmicc:units = "gC/m3" ; + fates_cnp_eca_decompmicc:long_name = "maximum soil microbial decomposer biomass found over depth (will be applied at a reference depth w/ exponential attenuation) (ECA)" ; + double fates_cnp_eca_km_nh4(fates_pft) ; + fates_cnp_eca_km_nh4:units = "gN/m3" ; + fates_cnp_eca_km_nh4:long_name = "half-saturation constant for plant nh4 uptake (ECA)" ; + double fates_cnp_eca_km_no3(fates_pft) ; + fates_cnp_eca_km_no3:units = "gN/m3" ; + fates_cnp_eca_km_no3:long_name = "half-saturation constant for plant no3 uptake (ECA)" ; + double fates_cnp_eca_km_p(fates_pft) ; + fates_cnp_eca_km_p:units = "gP/m3" ; + fates_cnp_eca_km_p:long_name = "half-saturation constant for plant p uptake (ECA)" ; + double fates_cnp_eca_km_ptase(fates_pft) ; + fates_cnp_eca_km_ptase:units = "gP/m3" ; + fates_cnp_eca_km_ptase:long_name = "half-saturation constant for biochemical P (ECA)" ; + double fates_cnp_eca_lambda_ptase(fates_pft) ; + fates_cnp_eca_lambda_ptase:units = "g/m3" ; + fates_cnp_eca_lambda_ptase:long_name = "critical value for biochemical production (ECA)" ; + double fates_cnp_eca_vmax_ptase(fates_pft) ; + fates_cnp_eca_vmax_ptase:units = "gP/m2/s" ; + fates_cnp_eca_vmax_ptase:long_name = "maximum production rate for biochemical P (per m2) (ECA)" ; + double fates_cnp_nfix1(fates_pft) ; + fates_cnp_nfix1:units = "fraction" ; + fates_cnp_nfix1:long_name = "fractional surcharge added to maintenance respiration that drives symbiotic fixation" ; + double fates_cnp_nitr_store_ratio(fates_pft) ; + fates_cnp_nitr_store_ratio:units = "(gN/gN)" ; + fates_cnp_nitr_store_ratio:long_name = "storeable (labile) N, as a ratio compared to the N bound in cell structures of other organs (see code)" ; + double fates_cnp_phos_store_ratio(fates_pft) ; + fates_cnp_phos_store_ratio:units = "(gP/gP)" ; + fates_cnp_phos_store_ratio:long_name = "storeable (labile) P, as a ratio compared to the P bound in cell structures of other organs (see code)" ; + double fates_cnp_pid_kd(fates_pft) ; + fates_cnp_pid_kd:units = "unknown" ; + fates_cnp_pid_kd:long_name = "derivative constant of the PID controller on adaptive fine-root biomass" ; + double fates_cnp_pid_ki(fates_pft) ; + fates_cnp_pid_ki:units = "unknown" ; + fates_cnp_pid_ki:long_name = "integral constant of the PID controller on adaptive fine-root biomass" ; + double fates_cnp_pid_kp(fates_pft) ; + fates_cnp_pid_kp:units = "unknown" ; + fates_cnp_pid_kp:long_name = "proportional constant of the PID controller on adaptive fine-root biomass" ; + double fates_cnp_prescribed_nuptake(fates_pft) ; + fates_cnp_prescribed_nuptake:units = "fraction" ; + fates_cnp_prescribed_nuptake:long_name = "Prescribed N uptake flux. 0=fully coupled simulation >0=prescribed (experimental)" ; + double fates_cnp_prescribed_puptake(fates_pft) ; + fates_cnp_prescribed_puptake:units = "fraction" ; + fates_cnp_prescribed_puptake:long_name = "Prescribed P uptake flux. 0=fully coupled simulation, >0=prescribed (experimental)" ; + double fates_cnp_store_ovrflw_frac(fates_pft) ; + fates_cnp_store_ovrflw_frac:units = "fraction" ; + fates_cnp_store_ovrflw_frac:long_name = "size of overflow storage (for excess C,N or P) as a fraction of storage target" ; + double fates_cnp_turnover_nitr_retrans(fates_plant_organs, fates_pft) ; + fates_cnp_turnover_nitr_retrans:units = "fraction" ; + fates_cnp_turnover_nitr_retrans:long_name = "retranslocation (reabsorbtion) fraction of nitrogen in turnover of scenescing tissues" ; + double fates_cnp_turnover_phos_retrans(fates_plant_organs, fates_pft) ; + fates_cnp_turnover_phos_retrans:units = "fraction" ; + fates_cnp_turnover_phos_retrans:long_name = "retranslocation (reabsorbtion) fraction of phosphorus in turnover of scenescing tissues" ; + double fates_cnp_vmax_nh4(fates_pft) ; + fates_cnp_vmax_nh4:units = "gN/gC/s" ; + fates_cnp_vmax_nh4:long_name = "maximum (potential) uptake rate of NH4 per gC of fineroot biomass (see main/EDPftvarcon.F90 vmax_nh4 for usage)" ; + double fates_cnp_vmax_no3(fates_pft) ; + fates_cnp_vmax_no3:units = "gN/gC/s" ; + fates_cnp_vmax_no3:long_name = "maximum (potential) uptake rate of NO3 per gC of fineroot biomass (see main/EDPftvarcon.F90 vmax_no3 for usage)" ; + double fates_cnp_vmax_p(fates_pft) ; + fates_cnp_vmax_p:units = "gP/gC/s" ; + fates_cnp_vmax_p:long_name = "maximum production rate for phosphorus (ECA and RD)" ; + double fates_damage_frac(fates_pft) ; + fates_damage_frac:units = "fraction" ; + fates_damage_frac:long_name = "fraction of cohort damaged in each damage event (event frequency specified in the is_it_damage_time subroutine)" ; + double fates_damage_mort_p1(fates_pft) ; + fates_damage_mort_p1:units = "fraction" ; + fates_damage_mort_p1:long_name = "inflection point of damage mortality function, a value of 0.8 means 50% mortality with 80% loss of crown, turn off with a large number" ; + double fates_damage_mort_p2(fates_pft) ; + fates_damage_mort_p2:units = "unitless" ; + fates_damage_mort_p2:long_name = "rate of mortality increase with damage" ; + double fates_damage_recovery_scalar(fates_pft) ; + fates_damage_recovery_scalar:units = "unitless" ; + fates_damage_recovery_scalar:long_name = "fraction of the cohort that recovers from damage" ; + double fates_dev_arbitrary_pft(fates_pft) ; + fates_dev_arbitrary_pft:units = "unknown" ; + fates_dev_arbitrary_pft:long_name = "Unassociated pft dimensioned free parameter that developers can use for testing arbitrary new hypotheses" ; + double fates_fire_alpha_SH(fates_pft) ; + fates_fire_alpha_SH:units = "m / (kw/m)**(2/3)" ; + fates_fire_alpha_SH:long_name = "spitfire parameter, alpha scorch height, Equation 16 Thonicke et al 2010" ; + double fates_fire_bark_scaler(fates_pft) ; + fates_fire_bark_scaler:units = "fraction" ; + fates_fire_bark_scaler:long_name = "the thickness of a cohorts bark as a fraction of its dbh" ; + double fates_fire_crown_kill(fates_pft) ; + fates_fire_crown_kill:units = "NA" ; + fates_fire_crown_kill:long_name = "fire parameter, see equation 22 in Thonicke et al 2010" ; + double fates_frag_fnrt_fcel(fates_pft) ; + fates_frag_fnrt_fcel:units = "fraction" ; + fates_frag_fnrt_fcel:long_name = "Fine root litter cellulose fraction" ; + double fates_frag_fnrt_flab(fates_pft) ; + fates_frag_fnrt_flab:units = "fraction" ; + fates_frag_fnrt_flab:long_name = "Fine root litter labile fraction" ; + double fates_frag_fnrt_flig(fates_pft) ; + fates_frag_fnrt_flig:units = "fraction" ; + fates_frag_fnrt_flig:long_name = "Fine root litter lignin fraction" ; + double fates_frag_leaf_fcel(fates_pft) ; + fates_frag_leaf_fcel:units = "fraction" ; + fates_frag_leaf_fcel:long_name = "Leaf litter cellulose fraction" ; + double fates_frag_leaf_flab(fates_pft) ; + fates_frag_leaf_flab:units = "fraction" ; + fates_frag_leaf_flab:long_name = "Leaf litter labile fraction" ; + double fates_frag_leaf_flig(fates_pft) ; + fates_frag_leaf_flig:units = "fraction" ; + fates_frag_leaf_flig:long_name = "Leaf litter lignin fraction" ; + double fates_frag_seed_decay_rate(fates_pft) ; + fates_frag_seed_decay_rate:units = "yr-1" ; + fates_frag_seed_decay_rate:long_name = "fraction of seeds that decay per year" ; + double fates_grperc(fates_pft) ; + fates_grperc:units = "unitless" ; + fates_grperc:long_name = "Growth respiration factor" ; + double fates_hydro_avuln_gs(fates_pft) ; + fates_hydro_avuln_gs:units = "unitless" ; + fates_hydro_avuln_gs:long_name = "shape parameter for stomatal control of water vapor exiting leaf" ; + double fates_hydro_avuln_node(fates_hydr_organs, fates_pft) ; + fates_hydro_avuln_node:units = "unitless" ; + fates_hydro_avuln_node:long_name = "xylem vulnerability curve shape parameter" ; + double fates_hydro_epsil_node(fates_hydr_organs, fates_pft) ; + fates_hydro_epsil_node:units = "MPa" ; + fates_hydro_epsil_node:long_name = "bulk elastic modulus" ; + double fates_hydro_fcap_node(fates_hydr_organs, fates_pft) ; + fates_hydro_fcap_node:units = "unitless" ; + fates_hydro_fcap_node:long_name = "fraction of non-residual water that is capillary in source" ; + double fates_hydro_k_lwp(fates_pft) ; + fates_hydro_k_lwp:units = "unitless" ; + fates_hydro_k_lwp:long_name = "inner leaf humidity scaling coefficient" ; + double fates_hydro_kmax_node(fates_hydr_organs, fates_pft) ; + fates_hydro_kmax_node:units = "kg/MPa/m/s" ; + fates_hydro_kmax_node:long_name = "maximum xylem conductivity per unit conducting xylem area" ; + double fates_hydro_p50_gs(fates_pft) ; + fates_hydro_p50_gs:units = "MPa" ; + fates_hydro_p50_gs:long_name = "water potential at 50% loss of stomatal conductance" ; + double fates_hydro_p50_node(fates_hydr_organs, fates_pft) ; + fates_hydro_p50_node:units = "MPa" ; + fates_hydro_p50_node:long_name = "xylem water potential at 50% loss of conductivity" ; + double fates_hydro_p_taper(fates_pft) ; + fates_hydro_p_taper:units = "unitless" ; + fates_hydro_p_taper:long_name = "xylem taper exponent" ; + double fates_hydro_pinot_node(fates_hydr_organs, fates_pft) ; + fates_hydro_pinot_node:units = "MPa" ; + fates_hydro_pinot_node:long_name = "osmotic potential at full turgor" ; + double fates_hydro_pitlp_node(fates_hydr_organs, fates_pft) ; + fates_hydro_pitlp_node:units = "MPa" ; + fates_hydro_pitlp_node:long_name = "turgor loss point" ; + double fates_hydro_resid_node(fates_hydr_organs, fates_pft) ; + fates_hydro_resid_node:units = "cm3/cm3" ; + fates_hydro_resid_node:long_name = "residual water conent" ; + double fates_hydro_rfrac_stem(fates_pft) ; + fates_hydro_rfrac_stem:units = "fraction" ; + fates_hydro_rfrac_stem:long_name = "fraction of total tree resistance from troot to canopy" ; + double fates_hydro_rs2(fates_pft) ; + fates_hydro_rs2:units = "m" ; + fates_hydro_rs2:long_name = "absorbing root radius" ; + double fates_hydro_srl(fates_pft) ; + fates_hydro_srl:units = "m g-1" ; + fates_hydro_srl:long_name = "specific root length" ; + double fates_hydro_thetas_node(fates_hydr_organs, fates_pft) ; + fates_hydro_thetas_node:units = "cm3/cm3" ; + fates_hydro_thetas_node:long_name = "saturated water content" ; + double fates_hydro_vg_alpha_node(fates_hydr_organs, fates_pft) ; + fates_hydro_vg_alpha_node:units = "MPa-1" ; + fates_hydro_vg_alpha_node:long_name = "(used if hydr_htftype_node = 2), capillary length parameter in van Genuchten model" ; + double fates_hydro_vg_m_node(fates_hydr_organs, fates_pft) ; + fates_hydro_vg_m_node:units = "unitless" ; + fates_hydro_vg_m_node:long_name = "(used if hydr_htftype_node = 2),m in van Genuchten 1980 model, 2nd pore size distribution parameter" ; + double fates_hydro_vg_n_node(fates_hydr_organs, fates_pft) ; + fates_hydro_vg_n_node:units = "unitless" ; + fates_hydro_vg_n_node:long_name = "(used if hydr_htftype_node = 2),n in van Genuchten 1980 model, pore size distribution parameter" ; + double fates_leaf_c3psn(fates_pft) ; + fates_leaf_c3psn:units = "flag" ; + fates_leaf_c3psn:long_name = "Photosynthetic pathway (1=c3, 0=c4)" ; + double fates_leaf_jmaxha(fates_pft) ; + fates_leaf_jmaxha:units = "J/mol" ; + fates_leaf_jmaxha:long_name = "activation energy for jmax. NOTE: if fates_leaf_photo_tempsens_model=2 then these values are NOT USED" ; + double fates_leaf_jmaxhd(fates_pft) ; + fates_leaf_jmaxhd:units = "J/mol" ; + fates_leaf_jmaxhd:long_name = "deactivation energy for jmax. NOTE: if fates_leaf_photo_tempsens_model=2 then these values are NOT USED" ; + double fates_leaf_jmaxse(fates_pft) ; + fates_leaf_jmaxse:units = "J/mol/K" ; + fates_leaf_jmaxse:long_name = "entropy term for jmax. NOTE: if fates_leaf_photo_tempsens_model=2 then these values are NOT USED" ; + double fates_leaf_slamax(fates_pft) ; + fates_leaf_slamax:units = "m^2/gC" ; + fates_leaf_slamax:long_name = "Maximum Specific Leaf Area (SLA), even if under a dense canopy" ; + double fates_leaf_slatop(fates_pft) ; + fates_leaf_slatop:units = "m^2/gC" ; + fates_leaf_slatop:long_name = "Specific Leaf Area (SLA) at top of canopy, projected area basis" ; + double fates_leaf_stomatal_intercept(fates_pft) ; + fates_leaf_stomatal_intercept:units = "umol H2O/m**2/s" ; + fates_leaf_stomatal_intercept:long_name = "Minimum unstressed stomatal conductance for Ball-Berry model and Medlyn model" ; + double fates_leaf_stomatal_slope_ballberry(fates_pft) ; + fates_leaf_stomatal_slope_ballberry:units = "unitless" ; + fates_leaf_stomatal_slope_ballberry:long_name = "stomatal slope parameter, as per Ball-Berry" ; + double fates_leaf_stomatal_slope_medlyn(fates_pft) ; + fates_leaf_stomatal_slope_medlyn:units = "KPa**0.5" ; + fates_leaf_stomatal_slope_medlyn:long_name = "stomatal slope parameter, as per Medlyn" ; + double fates_leaf_vcmax25top(fates_leafage_class, fates_pft) ; + fates_leaf_vcmax25top:units = "umol CO2/m^2/s" ; + fates_leaf_vcmax25top:long_name = "maximum carboxylation rate of Rub. at 25C, canopy top" ; + double fates_leaf_vcmaxha(fates_pft) ; + fates_leaf_vcmaxha:units = "J/mol" ; + fates_leaf_vcmaxha:long_name = "activation energy for vcmax. NOTE: if fates_leaf_photo_tempsens_model=2 then these values are NOT USED" ; + double fates_leaf_vcmaxhd(fates_pft) ; + fates_leaf_vcmaxhd:units = "J/mol" ; + fates_leaf_vcmaxhd:long_name = "deactivation energy for vcmax. NOTE: if fates_leaf_photo_tempsens_model=2 then these values are NOT USED" ; + double fates_leaf_vcmaxse(fates_pft) ; + fates_leaf_vcmaxse:units = "J/mol/K" ; + fates_leaf_vcmaxse:long_name = "entropy term for vcmax. NOTE: if fates_leaf_photo_tempsens_model=2 then these values are NOT USED" ; + double fates_maintresp_leaf_atkin2017_baserate(fates_pft) ; + fates_maintresp_leaf_atkin2017_baserate:units = "umol CO2/m^2/s" ; + fates_maintresp_leaf_atkin2017_baserate:long_name = "Leaf maintenance respiration base rate parameter (r0) per Atkin et al 2017" ; + double fates_maintresp_leaf_ryan1991_baserate(fates_pft) ; + fates_maintresp_leaf_ryan1991_baserate:units = "gC/gN/s" ; + fates_maintresp_leaf_ryan1991_baserate:long_name = "Leaf maintenance respiration base rate per Ryan et al 1991" ; + double fates_maintresp_reduction_curvature(fates_pft) ; + fates_maintresp_reduction_curvature:units = "unitless (0-1)" ; + fates_maintresp_reduction_curvature:long_name = "curvature of MR reduction as f(carbon storage), 1=linear, 0=very curved" ; + double fates_maintresp_reduction_intercept(fates_pft) ; + fates_maintresp_reduction_intercept:units = "unitless (0-1)" ; + fates_maintresp_reduction_intercept:long_name = "intercept of MR reduction as f(carbon storage), 0=no throttling, 1=max throttling" ; + double fates_maintresp_reduction_upthresh(fates_pft) ; + fates_maintresp_reduction_upthresh:units = "unitless (0-1)" ; + fates_maintresp_reduction_upthresh:long_name = "upper threshold for storage biomass (relative to leaf biomass) above which MR is not reduced" ; + double fates_mort_bmort(fates_pft) ; + fates_mort_bmort:units = "1/yr" ; + fates_mort_bmort:long_name = "background mortality rate" ; + double fates_mort_freezetol(fates_pft) ; + fates_mort_freezetol:units = "degrees C" ; + fates_mort_freezetol:long_name = "minimum temperature tolerance" ; + double fates_mort_hf_flc_threshold(fates_pft) ; + fates_mort_hf_flc_threshold:units = "fraction" ; + fates_mort_hf_flc_threshold:long_name = "plant fractional loss of conductivity at which drought mortality begins for hydraulic model" ; + double fates_mort_hf_sm_threshold(fates_pft) ; + fates_mort_hf_sm_threshold:units = "unitless" ; + fates_mort_hf_sm_threshold:long_name = "soil moisture (btran units) at which drought mortality begins for non-hydraulic model" ; + double fates_mort_ip_age_senescence(fates_pft) ; + fates_mort_ip_age_senescence:units = "years" ; + fates_mort_ip_age_senescence:long_name = "Mortality cohort age senescence inflection point. If _ this mortality term is off. Setting this value turns on age dependent mortality. " ; + double fates_mort_ip_size_senescence(fates_pft) ; + fates_mort_ip_size_senescence:units = "dbh cm" ; + fates_mort_ip_size_senescence:long_name = "Mortality dbh senescence inflection point. If _ this mortality term is off. Setting this value turns on size dependent mortality" ; + double fates_mort_prescribed_canopy(fates_pft) ; + fates_mort_prescribed_canopy:units = "1/yr" ; + fates_mort_prescribed_canopy:long_name = "mortality rate of canopy trees for prescribed physiology mode" ; + double fates_mort_prescribed_understory(fates_pft) ; + fates_mort_prescribed_understory:units = "1/yr" ; + fates_mort_prescribed_understory:long_name = "mortality rate of understory trees for prescribed physiology mode" ; + double fates_mort_r_age_senescence(fates_pft) ; + fates_mort_r_age_senescence:units = "mortality rate year^-1" ; + fates_mort_r_age_senescence:long_name = "Mortality age senescence rate of change. Sensible range is around 0.03-0.06. Larger values givesteeper mortality curves." ; + double fates_mort_r_size_senescence(fates_pft) ; + fates_mort_r_size_senescence:units = "mortality rate dbh^-1" ; + fates_mort_r_size_senescence:long_name = "Mortality dbh senescence rate of change. Sensible range is around 0.03-0.06. Larger values give steeper mortality curves." ; + double fates_mort_scalar_coldstress(fates_pft) ; + fates_mort_scalar_coldstress:units = "1/yr" ; + fates_mort_scalar_coldstress:long_name = "maximum mortality rate from cold stress" ; + double fates_mort_scalar_cstarvation(fates_pft) ; + fates_mort_scalar_cstarvation:units = "1/yr" ; + fates_mort_scalar_cstarvation:long_name = "maximum mortality rate from carbon starvation" ; + double fates_mort_scalar_hydrfailure(fates_pft) ; + fates_mort_scalar_hydrfailure:units = "1/yr" ; + fates_mort_scalar_hydrfailure:long_name = "maximum mortality rate from hydraulic failure" ; + double fates_mort_upthresh_cstarvation(fates_pft) ; + fates_mort_upthresh_cstarvation:units = "unitless" ; + fates_mort_upthresh_cstarvation:long_name = "threshold for storage biomass (relative to target leaf biomass) above which carbon starvation is zero" ; + double fates_nonhydro_smpsc(fates_pft) ; + fates_nonhydro_smpsc:units = "mm" ; + fates_nonhydro_smpsc:long_name = "Soil water potential at full stomatal closure" ; + double fates_nonhydro_smpso(fates_pft) ; + fates_nonhydro_smpso:units = "mm" ; + fates_nonhydro_smpso:long_name = "Soil water potential at full stomatal opening" ; + double fates_phen_cold_size_threshold(fates_pft) ; + fates_phen_cold_size_threshold:units = "cm" ; + fates_phen_cold_size_threshold:long_name = "the dbh size above which will lead to phenology-related stem and leaf drop" ; + double fates_phen_drought_threshold(fates_pft) ; + fates_phen_drought_threshold:units = "m3/m3 or mm" ; + fates_phen_drought_threshold:long_name = "threshold for drought phenology (or lower threshold for semi-deciduous PFTs); the quantity depends on the sign: if positive, the threshold is volumetric soil moisture (m3/m3). If negative, the threshold is soil matric potentical (mm)" ; + double fates_phen_evergreen(fates_pft) ; + fates_phen_evergreen:units = "logical flag" ; + fates_phen_evergreen:long_name = "Binary flag for evergreen leaf habit" ; + double fates_phen_flush_fraction(fates_pft) ; + fates_phen_flush_fraction:units = "fraction" ; + fates_phen_flush_fraction:long_name = "Upon bud-burst, the maximum fraction of storage carbon used for flushing leaves" ; + double fates_phen_fnrt_drop_fraction(fates_pft) ; + fates_phen_fnrt_drop_fraction:units = "fraction" ; + fates_phen_fnrt_drop_fraction:long_name = "fraction of fine roots to drop during drought/cold" ; + double fates_phen_mindaysoff(fates_pft) ; + fates_phen_mindaysoff:units = "days" ; + fates_phen_mindaysoff:long_name = "day threshold compared against days since leaves abscised (shed)" ; + double fates_phen_moist_threshold(fates_pft) ; + fates_phen_moist_threshold:units = "m3/m3 or mm" ; + fates_phen_moist_threshold:long_name = "upper threshold for drought phenology (only for drought semi-deciduous PFTs); the quantity depends on the sign: if positive, the threshold is volumetric soil moisture (m3/m3). If negative, the threshold is soil matric potentical (mm)" ; + double fates_phen_season_decid(fates_pft) ; + fates_phen_season_decid:units = "logical flag" ; + fates_phen_season_decid:long_name = "Binary flag for seasonal-deciduous leaf habit" ; + double fates_phen_stem_drop_fraction(fates_pft) ; + fates_phen_stem_drop_fraction:units = "fraction" ; + fates_phen_stem_drop_fraction:long_name = "fraction of stems to drop for non-woody species during drought/cold" ; + double fates_phen_stress_decid(fates_pft) ; + fates_phen_stress_decid:units = "logical flag" ; + fates_phen_stress_decid:long_name = "Binary flag for stress-deciduous leaf habit" ; + double fates_prescribed_npp_canopy(fates_pft) ; + fates_prescribed_npp_canopy:units = "kgC / m^2 / yr" ; + fates_prescribed_npp_canopy:long_name = "NPP per unit crown area of canopy trees for prescribed physiology mode" ; + double fates_prescribed_npp_understory(fates_pft) ; + 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_rad_leaf_clumping_index(fates_pft) ; + fates_rad_leaf_clumping_index:units = "fraction (0-1)" ; + fates_rad_leaf_clumping_index:long_name = "factor describing how much self-occlusion of leaf scattering elements decreases light interception" ; + double fates_rad_leaf_rhonir(fates_pft) ; + fates_rad_leaf_rhonir:units = "fraction" ; + fates_rad_leaf_rhonir:long_name = "Leaf reflectance: near-IR" ; + double fates_rad_leaf_rhovis(fates_pft) ; + fates_rad_leaf_rhovis:units = "fraction" ; + fates_rad_leaf_rhovis:long_name = "Leaf reflectance: visible" ; + double fates_rad_leaf_taunir(fates_pft) ; + fates_rad_leaf_taunir:units = "fraction" ; + fates_rad_leaf_taunir:long_name = "Leaf transmittance: near-IR" ; + double fates_rad_leaf_tauvis(fates_pft) ; + fates_rad_leaf_tauvis:units = "fraction" ; + fates_rad_leaf_tauvis:long_name = "Leaf transmittance: visible" ; + double fates_rad_leaf_xl(fates_pft) ; + fates_rad_leaf_xl:units = "unitless" ; + fates_rad_leaf_xl:long_name = "Leaf/stem orientation index" ; + double fates_rad_stem_rhonir(fates_pft) ; + fates_rad_stem_rhonir:units = "fraction" ; + fates_rad_stem_rhonir:long_name = "Stem reflectance: near-IR" ; + double fates_rad_stem_rhovis(fates_pft) ; + fates_rad_stem_rhovis:units = "fraction" ; + fates_rad_stem_rhovis:long_name = "Stem reflectance: visible" ; + double fates_rad_stem_taunir(fates_pft) ; + fates_rad_stem_taunir:units = "fraction" ; + fates_rad_stem_taunir:long_name = "Stem transmittance: near-IR" ; + double fates_rad_stem_tauvis(fates_pft) ; + fates_rad_stem_tauvis:units = "fraction" ; + fates_rad_stem_tauvis:long_name = "Stem transmittance: visible" ; + double fates_recruit_height_min(fates_pft) ; + fates_recruit_height_min:units = "m" ; + fates_recruit_height_min:long_name = "the minimum height (ie starting height) of a newly recruited plant" ; + double fates_recruit_init_density(fates_pft) ; + fates_recruit_init_density:units = "stems/m2" ; + fates_recruit_init_density:long_name = "initial seedling density for a cold-start near-bare-ground simulation. If negative sets initial tree dbh - only to be used in nocomp mode" ; + double fates_recruit_prescribed_rate(fates_pft) ; + fates_recruit_prescribed_rate:units = "n/yr" ; + fates_recruit_prescribed_rate:long_name = "recruitment rate for prescribed physiology mode" ; + double fates_recruit_seed_alloc(fates_pft) ; + fates_recruit_seed_alloc:units = "fraction" ; + fates_recruit_seed_alloc:long_name = "fraction of available carbon balance allocated to seeds" ; + double fates_recruit_seed_alloc_mature(fates_pft) ; + fates_recruit_seed_alloc_mature:units = "fraction" ; + fates_recruit_seed_alloc_mature:long_name = "fraction of available carbon balance allocated to seeds in mature plants (adds to fates_seed_alloc)" ; + double fates_recruit_seed_dbh_repro_threshold(fates_pft) ; + fates_recruit_seed_dbh_repro_threshold:units = "cm" ; + fates_recruit_seed_dbh_repro_threshold:long_name = "the diameter where the plant will increase allocation to the seed pool by fraction: fates_recruit_seed_alloc_mature" ; + double fates_recruit_seed_germination_rate(fates_pft) ; + fates_recruit_seed_germination_rate:units = "yr-1" ; + fates_recruit_seed_germination_rate:long_name = "fraction of seeds that germinate per year" ; + double fates_recruit_seed_supplement(fates_pft) ; + fates_recruit_seed_supplement:units = "KgC/m2/yr" ; + fates_recruit_seed_supplement:long_name = "Supplemental external seed rain source term (non-mass conserving)" ; + double fates_seed_dispersal_fraction(fates_pft) ; + fates_seed_dispersal_fraction:units = "fraction" ; + fates_seed_dispersal_fraction:long_name = "fraction of seed rain to be dispersed to other grid cells" ; + double fates_seed_dispersal_max_dist(fates_pft) ; + fates_seed_dispersal_max_dist:units = "m" ; + fates_seed_dispersal_max_dist:long_name = "maximum seed dispersal distance for a given pft" ; + double fates_seed_dispersal_pdf_scale(fates_pft) ; + fates_seed_dispersal_pdf_scale:units = "unitless" ; + fates_seed_dispersal_pdf_scale:long_name = "seed dispersal probability density function scale parameter, A, Table 1 Bullock et al 2016" ; + double fates_seed_dispersal_pdf_shape(fates_pft) ; + fates_seed_dispersal_pdf_shape:units = "unitless" ; + fates_seed_dispersal_pdf_shape:long_name = "seed dispersal probability density function shape parameter, B, Table 1 Bullock et al 2016" ; + double fates_stoich_nitr(fates_plant_organs, fates_pft) ; + fates_stoich_nitr:units = "gN/gC" ; + fates_stoich_nitr:long_name = "target nitrogen concentration (ratio with carbon) of organs" ; + double fates_stoich_phos(fates_plant_organs, fates_pft) ; + fates_stoich_phos:units = "gP/gC" ; + fates_stoich_phos:long_name = "target phosphorus concentration (ratio with carbon) of organs" ; + double fates_trim_inc(fates_pft) ; + fates_trim_inc:units = "m2/m2" ; + fates_trim_inc:long_name = "Arbitrary incremental change in trimming function." ; + double fates_trim_limit(fates_pft) ; + fates_trim_limit:units = "m2/m2" ; + fates_trim_limit:long_name = "Arbitrary limit to reductions in leaf area with stress" ; + double fates_trs_repro_alloc_a(fates_pft) ; + fates_trs_repro_alloc_a:units = "fraction" ; + fates_trs_repro_alloc_a:long_name = "shape parameter for sigmoidal function relating dbh to reproductive allocation" ; + double fates_trs_repro_alloc_b(fates_pft) ; + fates_trs_repro_alloc_b:units = "fraction" ; + fates_trs_repro_alloc_b:long_name = "intercept parameter for sigmoidal function relating dbh to reproductive allocation" ; + double fates_trs_repro_frac_seed(fates_pft) ; + fates_trs_repro_frac_seed:units = "fraction" ; + fates_trs_repro_frac_seed:long_name = "fraction of reproductive mass that is seed" ; + double fates_trs_seedling_a_emerg(fates_pft) ; + fates_trs_seedling_a_emerg:units = "day -1" ; + fates_trs_seedling_a_emerg:long_name = "mean fraction of seed bank emerging" ; + double fates_trs_seedling_b_emerg(fates_pft) ; + fates_trs_seedling_b_emerg:units = "day -1" ; + fates_trs_seedling_b_emerg:long_name = "seedling emergence sensitivity to soil moisture" ; + double fates_trs_seedling_background_mort(fates_pft) ; + fates_trs_seedling_background_mort:units = "yr-1" ; + fates_trs_seedling_background_mort:long_name = "background seedling mortality rate" ; + double fates_trs_seedling_h2o_mort_a(fates_pft) ; + fates_trs_seedling_h2o_mort_a:units = "-" ; + fates_trs_seedling_h2o_mort_a:long_name = "coefficient in moisture-based seedling mortality" ; + double fates_trs_seedling_h2o_mort_b(fates_pft) ; + fates_trs_seedling_h2o_mort_b:units = "-" ; + fates_trs_seedling_h2o_mort_b:long_name = "coefficient in moisture-based seedling mortality" ; + double fates_trs_seedling_h2o_mort_c(fates_pft) ; + fates_trs_seedling_h2o_mort_c:units = "-" ; + fates_trs_seedling_h2o_mort_c:long_name = "coefficient in moisture-based seedling mortality" ; + double fates_trs_seedling_light_mort_a(fates_pft) ; + fates_trs_seedling_light_mort_a:units = "-" ; + fates_trs_seedling_light_mort_a:long_name = "light-based seedling mortality coefficient" ; + double fates_trs_seedling_light_mort_b(fates_pft) ; + fates_trs_seedling_light_mort_b:units = "-" ; + fates_trs_seedling_light_mort_b:long_name = "light-based seedling mortality coefficient" ; + double fates_trs_seedling_light_rec_a(fates_pft) ; + fates_trs_seedling_light_rec_a:units = "-" ; + fates_trs_seedling_light_rec_a:long_name = "coefficient in light-based seedling to sapling transition" ; + double fates_trs_seedling_light_rec_b(fates_pft) ; + fates_trs_seedling_light_rec_b:units = "-" ; + fates_trs_seedling_light_rec_b:long_name = "coefficient in light-based seedling to sapling transition" ; + double fates_trs_seedling_mdd_crit(fates_pft) ; + fates_trs_seedling_mdd_crit:units = "mm H2O day" ; + fates_trs_seedling_mdd_crit:long_name = "critical moisture deficit (suction) day accumulation for seedling moisture-based seedling mortality to begin" ; + double fates_trs_seedling_par_crit_germ(fates_pft) ; + fates_trs_seedling_par_crit_germ:units = "MJ m-2 day-1" ; + fates_trs_seedling_par_crit_germ:long_name = "critical light level for germination" ; + double fates_trs_seedling_psi_crit(fates_pft) ; + fates_trs_seedling_psi_crit:units = "mm H2O" ; + fates_trs_seedling_psi_crit:long_name = "critical soil moisture (suction) for seedling stress" ; + double fates_trs_seedling_psi_emerg(fates_pft) ; + fates_trs_seedling_psi_emerg:units = "mm h20 suction" ; + fates_trs_seedling_psi_emerg:long_name = "critical soil moisture for seedling emergence" ; + double fates_trs_seedling_root_depth(fates_pft) ; + fates_trs_seedling_root_depth:units = "m" ; + fates_trs_seedling_root_depth:long_name = "rooting depth of seedlings" ; + double fates_turb_displar(fates_pft) ; + fates_turb_displar:units = "unitless" ; + fates_turb_displar:long_name = "Ratio of displacement height to canopy top height" ; + double fates_turb_leaf_diameter(fates_pft) ; + fates_turb_leaf_diameter:units = "m" ; + fates_turb_leaf_diameter:long_name = "Characteristic leaf dimension" ; + double fates_turb_z0mr(fates_pft) ; + fates_turb_z0mr:units = "unitless" ; + fates_turb_z0mr:long_name = "Ratio of momentum roughness length to canopy top height" ; + double fates_turnover_branch(fates_pft) ; + fates_turnover_branch:units = "yr" ; + fates_turnover_branch:long_name = "turnover time of branches" ; + double fates_turnover_fnrt(fates_pft) ; + fates_turnover_fnrt:units = "yr" ; + fates_turnover_fnrt:long_name = "root longevity (alternatively, turnover time)" ; + double fates_turnover_leaf(fates_leafage_class, fates_pft) ; + fates_turnover_leaf:units = "yr" ; + fates_turnover_leaf:long_name = "Leaf longevity (ie turnover timescale). For drought-deciduous PFTs, this also indicates the maximum length of the growing (i.e., leaves on) season." ; + double fates_turnover_senleaf_fdrought(fates_pft) ; + fates_turnover_senleaf_fdrought:units = "unitless[0-1]" ; + fates_turnover_senleaf_fdrought:long_name = "multiplication factor for leaf longevity of senescent leaves during drought" ; + double fates_wood_density(fates_pft) ; + fates_wood_density:units = "g/cm3" ; + fates_wood_density:long_name = "mean density of woody tissue in plant" ; + double fates_woody(fates_pft) ; + fates_woody:units = "logical flag" ; + fates_woody:long_name = "Binary woody lifeform flag" ; + double fates_hlm_pft_map(fates_hlm_pftno, fates_pft) ; + fates_hlm_pft_map:units = "area fraction" ; + fates_hlm_pft_map:long_name = "In fixed biogeog mode, fraction of HLM area associated with each FATES PFT" ; + double fates_fire_FBD(fates_litterclass) ; + fates_fire_FBD:units = "kg Biomass/m3" ; + fates_fire_FBD:long_name = "fuel bulk density" ; + double fates_fire_low_moisture_Coeff(fates_litterclass) ; + fates_fire_low_moisture_Coeff:units = "NA" ; + fates_fire_low_moisture_Coeff:long_name = "spitfire parameter, equation B1 Thonicke et al 2010" ; + double fates_fire_low_moisture_Slope(fates_litterclass) ; + fates_fire_low_moisture_Slope:units = "NA" ; + fates_fire_low_moisture_Slope:long_name = "spitfire parameter, equation B1 Thonicke et al 2010" ; + double fates_fire_mid_moisture(fates_litterclass) ; + fates_fire_mid_moisture:units = "NA" ; + fates_fire_mid_moisture:long_name = "spitfire litter moisture threshold to be considered medium dry" ; + double fates_fire_mid_moisture_Coeff(fates_litterclass) ; + fates_fire_mid_moisture_Coeff:units = "NA" ; + fates_fire_mid_moisture_Coeff:long_name = "spitfire parameter, equation B1 Thonicke et al 2010" ; + double fates_fire_mid_moisture_Slope(fates_litterclass) ; + fates_fire_mid_moisture_Slope:units = "NA" ; + fates_fire_mid_moisture_Slope:long_name = "spitfire parameter, equation B1 Thonicke et al 2010" ; + double fates_fire_min_moisture(fates_litterclass) ; + fates_fire_min_moisture:units = "NA" ; + fates_fire_min_moisture:long_name = "spitfire litter moisture threshold to be considered very dry" ; + double fates_fire_SAV(fates_litterclass) ; + fates_fire_SAV:units = "cm-1" ; + fates_fire_SAV:long_name = "fuel surface area to volume ratio" ; + double fates_frag_maxdecomp(fates_litterclass) ; + fates_frag_maxdecomp:units = "yr-1" ; + fates_frag_maxdecomp:long_name = "maximum rate of litter & CWD transfer from non-decomposing class into decomposing class" ; + double fates_frag_cwd_frac(fates_NCWD) ; + fates_frag_cwd_frac:units = "fraction" ; + fates_frag_cwd_frac:long_name = "fraction of woody (bdead+bsw) biomass destined for CWD pool" ; + double fates_canopy_closure_thresh ; + fates_canopy_closure_thresh:units = "unitless" ; + fates_canopy_closure_thresh:long_name = "tree canopy coverage at which crown area allometry changes from savanna to forest value" ; + double fates_cnp_eca_plant_escalar ; + fates_cnp_eca_plant_escalar:units = "" ; + fates_cnp_eca_plant_escalar:long_name = "scaling factor for plant fine root biomass to calculate nutrient carrier enzyme abundance (ECA)" ; + double fates_cohort_age_fusion_tol ; + fates_cohort_age_fusion_tol:units = "unitless" ; + fates_cohort_age_fusion_tol:long_name = "minimum fraction in differece in cohort age between cohorts." ; + double fates_cohort_size_fusion_tol ; + fates_cohort_size_fusion_tol:units = "unitless" ; + fates_cohort_size_fusion_tol:long_name = "minimum fraction in difference in dbh between cohorts" ; + double fates_comp_excln ; + fates_comp_excln:units = "none" ; + fates_comp_excln:long_name = "IF POSITIVE: weighting factor (exponent on dbh) for canopy layer exclusion and promotion, IF NEGATIVE: switch to use deterministic height sorting" ; + double fates_damage_canopy_layer_code ; + fates_damage_canopy_layer_code:units = "unitless" ; + fates_damage_canopy_layer_code:long_name = "Integer code that decides whether damage affects canopy trees (1), understory trees (2)" ; + double fates_damage_event_code ; + fates_damage_event_code:units = "unitless" ; + fates_damage_event_code:long_name = "Integer code that options how damage events are structured" ; + double fates_dev_arbitrary ; + fates_dev_arbitrary:units = "unknown" ; + fates_dev_arbitrary:long_name = "Unassociated free parameter that developers can use for testing arbitrary new hypotheses" ; + double fates_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" ; + double fates_fire_cg_strikes ; + fates_fire_cg_strikes:units = "fraction (0-1)" ; + fates_fire_cg_strikes:long_name = "fraction of cloud to ground lightning strikes" ; + double fates_fire_drying_ratio ; + fates_fire_drying_ratio:units = "NA" ; + fates_fire_drying_ratio:long_name = "spitfire parameter, fire drying ratio for fuel moisture, alpha_FMC EQ 6 Thonicke et al 2010" ; + double fates_fire_durat_slope ; + fates_fire_durat_slope:units = "NA" ; + fates_fire_durat_slope:long_name = "spitfire parameter, fire max duration slope, Equation 14 Thonicke et al 2010" ; + double fates_fire_fdi_a ; + fates_fire_fdi_a:units = "NA" ; + fates_fire_fdi_a:long_name = "spitfire parameter, fire danger index, EQ 5 Thonicke et al 2010" ; + double fates_fire_fdi_alpha ; + fates_fire_fdi_alpha:units = "NA" ; + fates_fire_fdi_alpha:long_name = "spitfire parameter, EQ 7 Venevsky et al. GCB 2002,(modified EQ 8 Thonicke et al. 2010) " ; + double fates_fire_fdi_b ; + fates_fire_fdi_b:units = "NA" ; + fates_fire_fdi_b:long_name = "spitfire parameter, fire danger index, EQ 5 Thonicke et al 2010 " ; + double fates_fire_fuel_energy ; + fates_fire_fuel_energy:units = "kJ/kg" ; + fates_fire_fuel_energy:long_name = "spitfire parameter, heat content of fuel" ; + double fates_fire_max_durat ; + fates_fire_max_durat:units = "minutes" ; + fates_fire_max_durat:long_name = "spitfire parameter, fire maximum duration, Equation 14 Thonicke et al 2010" ; + double fates_fire_miner_damp ; + fates_fire_miner_damp:units = "NA" ; + fates_fire_miner_damp:long_name = "spitfire parameter, mineral-dampening coefficient EQ A1 Thonicke et al 2010 " ; + double fates_fire_miner_total ; + fates_fire_miner_total:units = "fraction" ; + fates_fire_miner_total:long_name = "spitfire parameter, total mineral content, Table A1 Thonicke et al 2010" ; + double fates_fire_nignitions ; + fates_fire_nignitions:units = "ignitions per year per km2" ; + fates_fire_nignitions:long_name = "number of annual ignitions per square km" ; + double fates_fire_part_dens ; + fates_fire_part_dens:units = "kg/m2" ; + fates_fire_part_dens:long_name = "spitfire parameter, oven dry particle density, Table A1 Thonicke et al 2010" ; + double fates_fire_threshold ; + fates_fire_threshold:units = "kW/m" ; + fates_fire_threshold:long_name = "spitfire parameter, fire intensity threshold for tracking fires that spread" ; + double fates_frag_cwd_fcel ; + fates_frag_cwd_fcel:units = "unitless" ; + fates_frag_cwd_fcel:long_name = "Cellulose fraction for CWD" ; + double fates_frag_cwd_flig ; + fates_frag_cwd_flig:units = "unitless" ; + fates_frag_cwd_flig:long_name = "Lignin fraction of coarse woody debris" ; + double fates_hydro_kmax_rsurf1 ; + fates_hydro_kmax_rsurf1:units = "kg water/m2 root area/Mpa/s" ; + fates_hydro_kmax_rsurf1:long_name = "maximum conducitivity for unit root surface (into root)" ; + double fates_hydro_kmax_rsurf2 ; + fates_hydro_kmax_rsurf2:units = "kg water/m2 root area/Mpa/s" ; + fates_hydro_kmax_rsurf2:long_name = "maximum conducitivity for unit root surface (out of root)" ; + double fates_hydro_psi0 ; + fates_hydro_psi0:units = "MPa" ; + fates_hydro_psi0:long_name = "sapwood water potential at saturation" ; + double fates_hydro_psicap ; + fates_hydro_psicap:units = "MPa" ; + fates_hydro_psicap:long_name = "sapwood water potential at which capillary reserves exhausted" ; + double fates_hydro_solver ; + fates_hydro_solver:units = "unitless" ; + fates_hydro_solver:long_name = "switch designating which numerical solver for plant hydraulics, 1 = 1D taylor, 2 = 2D Picard, 3 = 2D Newton (deprecated)" ; + double fates_landuse_logging_coll_under_frac ; + fates_landuse_logging_coll_under_frac:units = "fraction" ; + fates_landuse_logging_coll_under_frac:long_name = "Fraction of stems killed in the understory when logging generates disturbance" ; + double fates_landuse_logging_collateral_frac ; + fates_landuse_logging_collateral_frac:units = "fraction" ; + fates_landuse_logging_collateral_frac:long_name = "Fraction of large stems in upperstory that die from logging collateral damage" ; + double fates_landuse_logging_dbhmax ; + fates_landuse_logging_dbhmax:units = "cm" ; + fates_landuse_logging_dbhmax:long_name = "Maximum dbh below which logging is applied (unset values flag this to be unused)" ; + double fates_landuse_logging_dbhmax_infra ; + fates_landuse_logging_dbhmax_infra:units = "cm" ; + fates_landuse_logging_dbhmax_infra:long_name = "Tree diameter, above which infrastructure from logging does not impact damage or mortality." ; + double fates_landuse_logging_dbhmin ; + fates_landuse_logging_dbhmin:units = "cm" ; + fates_landuse_logging_dbhmin:long_name = "Minimum dbh at which logging is applied" ; + double fates_landuse_logging_direct_frac ; + fates_landuse_logging_direct_frac:units = "fraction" ; + fates_landuse_logging_direct_frac:long_name = "Fraction of stems logged directly per event" ; + double fates_landuse_logging_event_code ; + fates_landuse_logging_event_code:units = "unitless" ; + fates_landuse_logging_event_code:long_name = "Integer code that options how logging events are structured" ; + double fates_landuse_logging_export_frac ; + fates_landuse_logging_export_frac:units = "fraction" ; + fates_landuse_logging_export_frac:long_name = "fraction of trunk product being shipped offsite, the leftovers will be left onsite as large CWD" ; + double fates_landuse_logging_mechanical_frac ; + fates_landuse_logging_mechanical_frac:units = "fraction" ; + fates_landuse_logging_mechanical_frac:long_name = "Fraction of stems killed due infrastructure an other mechanical means" ; + double fates_landuse_pprodharv10_forest_mean ; + fates_landuse_pprodharv10_forest_mean:units = "fraction" ; + fates_landuse_pprodharv10_forest_mean:long_name = "mean harvest mortality proportion of deadstem to 10-yr product (pprodharv10) of all woody PFT types" ; + double fates_leaf_photo_temp_acclim_thome_time ; + fates_leaf_photo_temp_acclim_thome_time:units = "years" ; + fates_leaf_photo_temp_acclim_thome_time:long_name = "Length of the window for the long-term (i.e. T_home in Kumarathunge et al 2019) exponential moving average (ema) of vegetation temperature used in photosynthesis temperature acclimation (used if fates_leaf_photo_tempsens_model = 2)" ; + double fates_leaf_photo_temp_acclim_timescale ; + fates_leaf_photo_temp_acclim_timescale:units = "days" ; + fates_leaf_photo_temp_acclim_timescale:long_name = "Length of the window for the exponential moving average (ema) of vegetation temperature used in photosynthesis temperature acclimation (used if fates_maintresp_leaf_model=2 or fates_leaf_photo_tempsens_model = 2)" ; + double fates_leaf_photo_tempsens_model ; + fates_leaf_photo_tempsens_model:units = "unitless" ; + fates_leaf_photo_tempsens_model:long_name = "switch for choosing the model that defines the temperature sensitivity of photosynthetic parameters (vcmax, jmax). 1=non-acclimating; 2=Kumarathunge et al 2019" ; + double fates_leaf_stomatal_assim_model ; + fates_leaf_stomatal_assim_model:units = "unitless" ; + fates_leaf_stomatal_assim_model:long_name = "a switch designating whether to use net (1) or gross (2) assimilation in the stomatal model" ; + double fates_leaf_stomatal_model ; + fates_leaf_stomatal_model:units = "unitless" ; + fates_leaf_stomatal_model:long_name = "switch for choosing between Ball-Berry (1) stomatal conductance model and Medlyn (2) model" ; + double fates_leaf_theta_cj_c3 ; + fates_leaf_theta_cj_c3:units = "unitless" ; + fates_leaf_theta_cj_c3:long_name = "Empirical curvature parameter for ac, aj photosynthesis co-limitation in c3 plants" ; + double fates_leaf_theta_cj_c4 ; + fates_leaf_theta_cj_c4:units = "unitless" ; + fates_leaf_theta_cj_c4:long_name = "Empirical curvature parameter for ac, aj photosynthesis co-limitation in c4 plants" ; + double fates_maintresp_leaf_model ; + fates_maintresp_leaf_model:units = "unitless" ; + fates_maintresp_leaf_model:long_name = "switch for choosing between maintenance respiration models. 1=Ryan (1991), 2=Atkin et al., (2017)" ; + double fates_maintresp_nonleaf_baserate ; + fates_maintresp_nonleaf_baserate:units = "gC/gN/s" ; + fates_maintresp_nonleaf_baserate:long_name = "Base maintenance respiration rate for plant tissues, using Ryan 1991" ; + double fates_maxcohort ; + fates_maxcohort:units = "count" ; + fates_maxcohort:long_name = "maximum number of cohorts per patch. Actual number of cohorts also depend on cohort fusion tolerances" ; + double fates_maxpatch_primary ; + fates_maxpatch_primary:units = "count" ; + fates_maxpatch_primary:long_name = "maximum number of primary vegetation patches per site" ; + double fates_maxpatch_secondary ; + fates_maxpatch_secondary:units = "count" ; + fates_maxpatch_secondary:long_name = "maximum number of secondary vegetation patches per site" ; + double fates_mort_disturb_frac ; + fates_mort_disturb_frac:units = "fraction" ; + fates_mort_disturb_frac:long_name = "fraction of canopy mortality that results in disturbance (i.e. transfer of area from new to old patch)" ; + double fates_mort_understorey_death ; + fates_mort_understorey_death:units = "fraction" ; + fates_mort_understorey_death:long_name = "fraction of plants in understorey cohort impacted by overstorey tree-fall" ; + double fates_patch_fusion_tol ; + fates_patch_fusion_tol:units = "unitless" ; + fates_patch_fusion_tol:long_name = "minimum fraction in difference in profiles between patches" ; + double fates_phen_chilltemp ; + fates_phen_chilltemp:units = "degrees C" ; + fates_phen_chilltemp:long_name = "chilling day counting threshold for vegetation" ; + double fates_phen_coldtemp ; + fates_phen_coldtemp:units = "degrees C" ; + fates_phen_coldtemp:long_name = "vegetation temperature exceedance that flags a cold-day for leaf-drop" ; + double fates_phen_gddthresh_a ; + fates_phen_gddthresh_a:units = "none" ; + fates_phen_gddthresh_a:long_name = "GDD accumulation function, intercept parameter: gdd_thesh = a + b exp(c*ncd)" ; + double fates_phen_gddthresh_b ; + fates_phen_gddthresh_b:units = "none" ; + fates_phen_gddthresh_b:long_name = "GDD accumulation function, multiplier parameter: gdd_thesh = a + b exp(c*ncd)" ; + double fates_phen_gddthresh_c ; + fates_phen_gddthresh_c:units = "none" ; + fates_phen_gddthresh_c:long_name = "GDD accumulation function, exponent parameter: gdd_thesh = a + b exp(c*ncd)" ; + double fates_phen_mindayson ; + fates_phen_mindayson:units = "days" ; + fates_phen_mindayson:long_name = "day threshold compared against days since leaves became on-allometry" ; + double fates_phen_ncolddayslim ; + fates_phen_ncolddayslim:units = "days" ; + fates_phen_ncolddayslim:long_name = "day threshold exceedance for temperature leaf-drop" ; + double fates_q10_froz ; + fates_q10_froz:units = "unitless" ; + fates_q10_froz:long_name = "Q10 for frozen-soil respiration rates" ; + double fates_q10_mr ; + fates_q10_mr:units = "unitless" ; + fates_q10_mr:long_name = "Q10 for maintenance respiration" ; + double fates_rad_model ; + fates_rad_model:units = "unitless" ; + fates_rad_model:long_name = "switch designating the model for canopy radiation, 1 = Norman, 2 = Two-stream (experimental)" ; + double fates_regeneration_model ; + fates_regeneration_model:units = "-" ; + fates_regeneration_model:long_name = "switch for choosing between FATES\'s: 1) default regeneration scheme , 2) the Tree Recruitment Scheme (Hanbury-Brown et al., 2022), or (3) the Tree Recruitment Scheme without seedling dynamics" ; + double fates_soil_salinity ; + fates_soil_salinity:units = "ppt" ; + fates_soil_salinity:long_name = "soil salinity used for model when not coupled to dynamic soil salinity" ; + double fates_trs_seedling2sap_par_timescale ; + fates_trs_seedling2sap_par_timescale:units = "days" ; + fates_trs_seedling2sap_par_timescale:long_name = "Length of the window for the exponential moving average of par at the seedling layer used to calculate seedling to sapling transition rates" ; + double fates_trs_seedling_emerg_h2o_timescale ; + fates_trs_seedling_emerg_h2o_timescale:units = "days" ; + fates_trs_seedling_emerg_h2o_timescale:long_name = "Length of the window for the exponential moving average of smp used to calculate seedling emergence" ; + double fates_trs_seedling_mdd_timescale ; + fates_trs_seedling_mdd_timescale:units = "days" ; + fates_trs_seedling_mdd_timescale:long_name = "Length of the window for the exponential moving average of moisture deficit days used to calculate seedling mortality" ; + double fates_trs_seedling_mort_par_timescale ; + fates_trs_seedling_mort_par_timescale:units = "days" ; + fates_trs_seedling_mort_par_timescale:long_name = "Length of the window for the exponential moving average of par at the seedling layer used to calculate seedling mortality" ; + double fates_vai_top_bin_width ; + fates_vai_top_bin_width:units = "m2/m2" ; + fates_vai_top_bin_width:long_name = "width in VAI units of uppermost leaf+stem layer scattering element in each canopy layer" ; + double fates_vai_width_increase_factor ; + fates_vai_width_increase_factor:units = "unitless" ; + fates_vai_width_increase_factor:long_name = "factor by which each leaf+stem scattering element increases in VAI width (1 = uniform spacing)" ; + +// global attributes: + :history = "This file was generated by BatchPatchParams.py:\nCDL Base File = archive/api24.1.0_101722_fates_params_default.cdl\nXML patch file = archive/api24.1.0_101722_patch_params.xml" ; +data: + + fates_history_ageclass_bin_edges = 0, 1, 2, 5, 10, 20, 50 ; + + fates_history_coageclass_bin_edges = 0, 5 ; + + fates_history_height_bin_edges = 0, 0.1, 0.3, 1, 3, 10 ; + + fates_history_damage_bin_edges = 0, 80 ; + + fates_history_sizeclass_bin_edges = 0, 5, 10, 15, 20, 30, 40, 50, 60, 70, + 80, 90, 100 ; + + fates_alloc_organ_id = 1, 2, 3, 6 ; + + fates_hydro_htftype_node = 1, 1, 1, 1 ; + + fates_pftname = + "broadleaf_evergreen_tropical_tree ", + "needleleaf_evergreen_extratrop_tree ", + "needleleaf_colddecid_extratrop_tree ", + "broadleaf_evergreen_extratrop_tree ", + "broadleaf_hydrodecid_tropical_tree ", + "broadleaf_colddecid_extratrop_tree ", + "broadleaf_evergreen_extratrop_shrub ", + "broadleaf_hydrodecid_extratrop_shrub ", + "broadleaf_colddecid_extratrop_shrub ", + "arctic_c3_grass ", + "cool_c3_grass ", + "c4_grass " ; + + fates_hydro_organ_name = + "leaf ", + "stem ", + "transporting root ", + "absorbing root " ; + + fates_alloc_organ_name = + "leaf", + "fine root", + "sapwood", + "structure" ; + + fates_litterclass_name = + "twig ", + "small branch ", + "large branch ", + "trunk ", + "dead leaves ", + "live grass " ; + + fates_alloc_organ_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, + 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4 ; + + fates_alloc_storage_cushion = 1.2, 1.2, 1.2, 1.2, 2.4, 1.2, 1.2, 2.4, 1.2, + 1.2, 1.2, 1.2 ; + + fates_alloc_store_priority_frac = 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, + 0.8, 0.8, 0.8, 0.8 ; + + fates_allom_agb1 = 0.06896, 0.06896, 0.06896, 0.06896, 0.06896, 0.06896, + 0.06896, 0.06896, 0.06896, 0.01, 0.01, 0.01 ; + + fates_allom_agb2 = 0.572, 0.572, 0.572, 0.572, 0.572, 0.572, 0.572, 0.572, + 0.572, 0.572, 0.572, 0.572 ; + + fates_allom_agb3 = 1.94, 1.94, 1.94, 1.94, 1.94, 1.94, 1.94, 1.94, 1.94, + 1.94, 1.94, 1.94 ; + + fates_allom_agb4 = 0.931, 0.931, 0.931, 0.931, 0.931, 0.931, 0.931, 0.931, + 0.931, 0.931, 0.931, 0.931 ; + + fates_allom_agb_frac = 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, + 0.6, 0.6 ; + + fates_allom_amode = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; + + fates_allom_blca_expnt_diff = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; + + fates_allom_cmode = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; + + fates_allom_crown_depth_frac = 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.95, 0.95, + 0.95, 1, 1, 1 ; + + fates_allom_d2bl1 = 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, + 0.07, 0.07, 0.07 ; + + fates_allom_d2bl2 = 1.3, 1.3, 1.3, 1.3, 1.3, 1.3, 1.3, 1.3, 1.3, 1.3, 1.3, + 1.3 ; + + fates_allom_d2bl3 = 0.55, 0.55, 0.55, 0.55, 0.55, 0.55, 0.55, 0.55, 0.55, + 0.55, 0.55, 0.55 ; + + fates_allom_d2ca_coefficient_max = 0.6568464, 0.6568464, 0.6568464, + 0.6568464, 0.6568464, 0.6568464, 0.6568464, 0.6568464, 0.6568464, + 0.6568464, 0.6568464, 0.6568464 ; + + fates_allom_d2ca_coefficient_min = 0.3381119, 0.3381119, 0.3381119, + 0.3381119, 0.3381119, 0.3381119, 0.3381119, 0.3381119, 0.3381119, + 0.3381119, 0.3381119, 0.3381119 ; + + fates_allom_d2h1 = 0.64, 0.64, 0.64, 0.64, 0.64, 0.64, 0.64, 0.64, 0.64, + 0.64, 0.64, 0.64 ; + + fates_allom_d2h2 = 0.37, 0.37, 0.37, 0.37, 0.37, 0.37, 0.37, 0.37, 0.37, + 0.37, 0.37, 0.37 ; + + fates_allom_d2h3 = -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, + -999.9, -999.9, -999.9, -999.9, -999.9 ; + + fates_allom_dbh_maxheight = 90, 80, 80, 80, 90, 80, 3, 3, 2, 0.35, 0.35, 0.35 ; + + fates_allom_fmode = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; + + fates_allom_fnrt_prof_a = 7, 7, 7, 7, 6, 6, 7, 7, 7, 11, 11, 11 ; + + fates_allom_fnrt_prof_b = 1, 2, 2, 1, 2, 2, 1.5, 1.5, 1.5, 2, 2, 2 ; + + fates_allom_fnrt_prof_mode = 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3 ; + + fates_allom_frbstor_repro = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; + + fates_allom_hmode = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; + + fates_allom_l2fr = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; + + fates_allom_la_per_sa_int = 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, + 0.8, 0.8, 0.8 ; + + fates_allom_la_per_sa_slp = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; + + fates_allom_lmode = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; + + fates_allom_sai_scaler = 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, + 0.1, 0.1 ; + + fates_allom_smode = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; + + fates_allom_stmode = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; + + fates_allom_zroot_k = 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10 ; + + fates_allom_zroot_max_dbh = 100, 100, 100, 100, 100, 100, 2, 2, 2, 2, 2, 2 ; + + fates_allom_zroot_max_z = 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, + 100, 100 ; + + fates_allom_zroot_min_dbh = 1, 1, 1, 2.5, 2.5, 2.5, 0.1, 0.1, 0.1, 0.1, 0.1, + 0.1 ; + + fates_allom_zroot_min_z = 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, + 100, 100 ; + + fates_c2b = 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2 ; + + fates_cnp_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_cnp_eca_decompmicc = 280, 280, 280, 280, 280, 280, 280, 280, 280, 280, + 280, 280 ; + + fates_cnp_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_cnp_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_cnp_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_cnp_eca_km_ptase = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; + + fates_cnp_eca_lambda_ptase = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; + + fates_cnp_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_cnp_nfix1 = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; + + fates_cnp_nitr_store_ratio = 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, + 1.5, 1.5, 1.5 ; + + fates_cnp_phos_store_ratio = 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, + 1.5, 1.5, 1.5 ; + + fates_cnp_pid_kd = 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_cnp_pid_ki = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; + + fates_cnp_pid_kp = 0.0005, 0.0005, 0.0005, 0.0005, 0.0005, 0.0005, 0.0005, + 0.0005, 0.0005, 0.0005, 0.0005, 0.0005 ; + + fates_cnp_prescribed_nuptake = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; + + fates_cnp_prescribed_puptake = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; + + fates_cnp_store_ovrflw_frac = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; + + fates_cnp_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 ; + + fates_cnp_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 ; + + fates_cnp_vmax_nh4 = 2.5e-09, 2.5e-09, 2.5e-09, 2.5e-09, 2.5e-09, 2.5e-09, + 2.5e-09, 2.5e-09, 2.5e-09, 2.5e-09, 2.5e-09, 2.5e-09 ; + + fates_cnp_vmax_no3 = 2.5e-09, 2.5e-09, 2.5e-09, 2.5e-09, 2.5e-09, 2.5e-09, + 2.5e-09, 2.5e-09, 2.5e-09, 2.5e-09, 2.5e-09, 2.5e-09 ; + + fates_cnp_vmax_p = 5e-10, 5e-10, 5e-10, 5e-10, 5e-10, 5e-10, 5e-10, 5e-10, + 5e-10, 5e-10, 5e-10, 5e-10 ; + + fates_damage_frac = 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, + 0.01, 0.01, 0.01 ; + + fates_damage_mort_p1 = 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9 ; + + fates_damage_mort_p2 = 5.5, 5.5, 5.5, 5.5, 5.5, 5.5, 5.5, 5.5, 5.5, 5.5, + 5.5, 5.5 ; + + fates_damage_recovery_scalar = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; + + fates_dev_arbitrary_pft = _, _, _, _, _, _, _, _, _, _, _, _ ; + + fates_fire_alpha_SH = 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, + 0.2 ; + + fates_fire_bark_scaler = 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, + 0.07, 0.07, 0.07, 0.07 ; + + fates_fire_crown_kill = 0.775, 0.775, 0.775, 0.775, 0.775, 0.775, 0.775, + 0.775, 0.775, 0.775, 0.775, 0.775 ; + + fates_frag_fnrt_fcel = 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, + 0.5, 0.5 ; + + fates_frag_fnrt_flab = 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, + 0.25, 0.25, 0.25 ; + + fates_frag_fnrt_flig = 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, + 0.25, 0.25, 0.25 ; + + fates_frag_leaf_fcel = 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, + 0.5, 0.5 ; + + fates_frag_leaf_flab = 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, + 0.25, 0.25, 0.25 ; + + fates_frag_leaf_flig = 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, + 0.25, 0.25, 0.25 ; + + fates_frag_seed_decay_rate = 0.51, 0.51, 0.51, 0.51, 0.51, 0.51, 0.51, 0.51, + 0.51, 0.51, 0.51, 0.51 ; + + fates_grperc = 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, + 0.11, 0.11 ; + + fates_hydro_avuln_gs = 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, + 2.5, 2.5 ; + + fates_hydro_avuln_node = + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2 ; + + fates_hydro_epsil_node = + 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, + 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, + 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, + 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8 ; + + fates_hydro_fcap_node = + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, + 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; + + fates_hydro_k_lwp = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; + + fates_hydro_kmax_node = + -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, + 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, + -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, + -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999 ; + + fates_hydro_p50_gs = -1.5, -1.5, -1.5, -1.5, -1.5, -1.5, -1.5, -1.5, -1.5, + -1.5, -1.5, -1.5 ; + + fates_hydro_p50_node = + -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, + -2.25, -2.25, + -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, + -2.25, -2.25, + -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, + -2.25, -2.25, + -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, + -2.25, -2.25 ; + + fates_hydro_p_taper = 0.333, 0.333, 0.333, 0.333, 0.333, 0.333, 0.333, + 0.333, 0.333, 0.333, 0.333, 0.333 ; + + fates_hydro_pinot_node = + -1.465984, -1.465984, -1.465984, -1.465984, -1.465984, -1.465984, + -1.465984, -1.465984, -1.465984, -1.465984, -1.465984, -1.465984, + -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, + -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, + -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, + -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, + -1.043478, -1.043478, -1.043478, -1.043478, -1.043478, -1.043478, + -1.043478, -1.043478, -1.043478, -1.043478, -1.043478, -1.043478 ; + + fates_hydro_pitlp_node = + -1.67, -1.67, -1.67, -1.67, -1.67, -1.67, -1.67, -1.67, -1.67, -1.67, + -1.67, -1.67, + -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, + -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, + -1.2, -1.2, -1.2, -1.2, -1.2, -1.2, -1.2, -1.2, -1.2, -1.2, -1.2, -1.2 ; + + fates_hydro_resid_node = + 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, + 0.21, 0.21, 0.21, 0.21, 0.21, 0.21, 0.21, 0.21, 0.21, 0.21, 0.21, 0.21, + 0.21, 0.21, 0.21, 0.21, 0.21, 0.21, 0.21, 0.21, 0.21, 0.21, 0.21, 0.21, + 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11 ; + + fates_hydro_rfrac_stem = 0.625, 0.625, 0.625, 0.625, 0.625, 0.625, 0.625, + 0.625, 0.625, 0.625, 0.625, 0.625 ; + + fates_hydro_rs2 = 0.0001, 0.0001, 0.0001, 0.0001, 0.0001, 0.0001, 0.0001, + 0.0001, 0.0001, 0.0001, 0.0001, 0.0001 ; + + fates_hydro_srl = 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25 ; + + fates_hydro_thetas_node = + 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, + 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, + 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, + 0.75, 0.75, 0.75, 0.75, 0.75, 0.75, 0.75, 0.75, 0.75, 0.75, 0.75, 0.75 ; + + fates_hydro_vg_alpha_node = + 0.0005, 0.0005, 0.0005, 0.0005, 0.0005, 0.005, 0.005, 0.005, 0.005, 0.005, + 0.005, 0.005, + 0.0005, 0.0005, 0.0005, 0.0005, 0.0005, 0.005, 0.005, 0.005, 0.005, 0.005, + 0.005, 0.005, + 0.0005, 0.0005, 0.0005, 0.0005, 0.0005, 0.005, 0.005, 0.005, 0.005, 0.005, + 0.005, 0.005, + 0.0005, 0.0005, 0.0005, 0.0005, 0.0005, 0.005, 0.005, 0.005, 0.005, 0.005, + 0.005, 0.005 ; + + fates_hydro_vg_m_node = + 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, + 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, + 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, + 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5 ; + + fates_hydro_vg_n_node = + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2 ; + + fates_leaf_c3psn = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0 ; + + fates_leaf_jmaxha = 43540, 43540, 43540, 43540, 43540, 43540, 43540, 43540, + 43540, 43540, 43540, 43540 ; + + fates_leaf_jmaxhd = 152040, 152040, 152040, 152040, 152040, 152040, 152040, + 152040, 152040, 152040, 152040, 152040 ; + + fates_leaf_jmaxse = 495, 495, 495, 495, 495, 495, 495, 495, 495, 495, 495, + 495 ; + + fates_leaf_slamax = 0.0954, 0.0954, 0.0954, 0.0954, 0.0954, 0.0954, 0.012, + 0.03, 0.03, 0.03, 0.03, 0.03 ; + + fates_leaf_slatop = 0.012, 0.005, 0.024, 0.009, 0.03, 0.03, 0.012, 0.03, + 0.03, 0.03, 0.03, 0.03 ; + + fates_leaf_stomatal_intercept = 10000, 10000, 10000, 10000, 10000, 10000, + 10000, 10000, 10000, 10000, 10000, 40000 ; + + fates_leaf_stomatal_slope_ballberry = 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8 ; + + fates_leaf_stomatal_slope_medlyn = 4.1, 2.3, 2.3, 4.1, 4.4, 4.4, 4.7, 4.7, + 4.7, 2.2, 5.3, 1.6 ; + + fates_leaf_vcmax25top = + 50, 62, 39, 61, 58, 58, 62, 54, 54, 78, 78, 78 ; + + fates_leaf_vcmaxha = 65330, 65330, 65330, 65330, 65330, 65330, 65330, 65330, + 65330, 65330, 65330, 65330 ; + + fates_leaf_vcmaxhd = 149250, 149250, 149250, 149250, 149250, 149250, 149250, + 149250, 149250, 149250, 149250, 149250 ; + + fates_leaf_vcmaxse = 485, 485, 485, 485, 485, 485, 485, 485, 485, 485, 485, + 485 ; + + fates_maintresp_leaf_atkin2017_baserate = 1.756, 1.4995, 1.4995, 1.756, + 1.756, 1.756, 2.0749, 2.0749, 2.0749, 2.1956, 2.1956, 2.1956 ; + + fates_maintresp_leaf_ryan1991_baserate = 2.525e-06, 2.525e-06, 2.525e-06, + 2.525e-06, 2.525e-06, 2.525e-06, 2.525e-06, 2.525e-06, 2.525e-06, + 2.525e-06, 2.525e-06, 2.525e-06 ; + + fates_maintresp_reduction_curvature = 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, + 0.01, 0.01, 0.01, 0.01, 0.01, 0.01 ; + + fates_maintresp_reduction_intercept = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; + + fates_maintresp_reduction_upthresh = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; + + fates_mort_bmort = 0.014, 0.014, 0.014, 0.014, 0.014, 0.014, 0.014, 0.014, + 0.014, 0.014, 0.014, 0.014 ; + + fates_mort_freezetol = 2.5, -55, -80, -30, 2.5, -80, -60, -10, -80, -80, + -20, 2.5 ; + + fates_mort_hf_flc_threshold = 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, + 0.5, 0.5, 0.5 ; + + fates_mort_hf_sm_threshold = 1e-06, 1e-06, 1e-06, 1e-06, 1e-06, 1e-06, + 1e-06, 1e-06, 1e-06, 1e-06, 1e-06, 1e-06 ; + + fates_mort_ip_age_senescence = _, _, _, _, _, _, _, _, _, _, _, _ ; + + fates_mort_ip_size_senescence = _, _, _, _, _, _, _, _, _, _, _, _ ; + + fates_mort_prescribed_canopy = 0.0194, 0.0194, 0.0194, 0.0194, 0.0194, + 0.0194, 0.0194, 0.0194, 0.0194, 0.0194, 0.0194, 0.0194 ; + + fates_mort_prescribed_understory = 0.025, 0.025, 0.025, 0.025, 0.025, 0.025, + 0.025, 0.025, 0.025, 0.025, 0.025, 0.025 ; + + fates_mort_r_age_senescence = _, _, _, _, _, _, _, _, _, _, _, _ ; + + fates_mort_r_size_senescence = _, _, _, _, _, _, _, _, _, _, _, _ ; + + fates_mort_scalar_coldstress = 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3 ; + + fates_mort_scalar_cstarvation = 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, + 0.6, 0.6, 0.6 ; + + fates_mort_scalar_hydrfailure = 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, + 0.6, 0.6, 0.6 ; + + fates_mort_upthresh_cstarvation = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; + + fates_nonhydro_smpsc = -255000, -255000, -255000, -255000, -255000, -255000, + -255000, -255000, -255000, -255000, -255000, -255000 ; + + fates_nonhydro_smpso = -66000, -66000, -66000, -66000, -66000, -66000, + -66000, -66000, -66000, -66000, -66000, -66000 ; + + fates_phen_cold_size_threshold = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; + + fates_phen_drought_threshold = -152957.4, -152957.4, -152957.4, -152957.4, + -152957.4, -152957.4, -152957.4, -152957.4, -152957.4, -152957.4, + -152957.4, -152957.4 ; + + fates_phen_evergreen = 1, 1, 0, 1, 0, 0, 1, 0, 0, 0, 0, 0 ; + + fates_phen_flush_fraction = _, _, 0.5, _, 0.5, 0.5, _, 0.5, 0.5, 0.5, 0.5, + 0.5 ; + + fates_phen_fnrt_drop_fraction = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; + + fates_phen_mindaysoff = 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, + 100, 100 ; + + fates_phen_moist_threshold = -122365.9, -122365.9, -122365.9, -122365.9, + -122365.9, -122365.9, -122365.9, -122365.9, -122365.9, -122365.9, + -122365.9, -122365.9 ; + + fates_phen_season_decid = 0, 0, 1, 0, 0, 1, 0, 0, 1, 1, 0, 0 ; + + fates_phen_stem_drop_fraction = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; + + fates_phen_stress_decid = 0, 0, 0, 0, 1, 0, 0, 1, 0, 0, 1, 1 ; + + fates_prescribed_npp_canopy = 0.4, 0.4, 0.4, 0.4, 0.4, 0.4, 0.4, 0.4, 0.4, + 0.4, 0.4, 0.4 ; + + fates_prescribed_npp_understory = 0.03125, 0.03125, 0.03125, 0.03125, + 0.03125, 0.03125, 0.03125, 0.03125, 0.03125, 0.03125, 0.03125, 0.03125 ; + + fates_rad_leaf_clumping_index = 0.85, 0.85, 0.8, 0.85, 0.85, 0.9, 0.85, 0.9, + 0.9, 0.75, 0.75, 0.75 ; + + fates_rad_leaf_rhonir = 0.46, 0.41, 0.39, 0.46, 0.41, 0.41, 0.46, 0.41, + 0.41, 0.28, 0.28, 0.28 ; + + fates_rad_leaf_rhovis = 0.11, 0.09, 0.08, 0.11, 0.08, 0.08, 0.11, 0.08, + 0.08, 0.05, 0.05, 0.05 ; + + fates_rad_leaf_taunir = 0.33, 0.32, 0.42, 0.33, 0.43, 0.43, 0.33, 0.43, + 0.43, 0.4, 0.4, 0.4 ; + + fates_rad_leaf_tauvis = 0.06, 0.04, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, + 0.06, 0.05, 0.05, 0.05 ; + + fates_rad_leaf_xl = 0.32, 0.01, 0.01, 0.32, 0.2, 0.59, 0.32, 0.59, 0.59, + -0.23, -0.23, -0.23 ; + + fates_rad_stem_rhonir = 0.49, 0.36, 0.36, 0.49, 0.49, 0.49, 0.49, 0.49, + 0.49, 0.53, 0.53, 0.53 ; + + fates_rad_stem_rhovis = 0.21, 0.12, 0.12, 0.21, 0.21, 0.21, 0.21, 0.21, + 0.21, 0.31, 0.31, 0.31 ; + + fates_rad_stem_taunir = 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, + 0.001, 0.001, 0.25, 0.25, 0.25 ; + + fates_rad_stem_tauvis = 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, + 0.001, 0.001, 0.12, 0.12, 0.12 ; + + fates_recruit_height_min = 1.3, 1.3, 1.3, 1.3, 1.3, 1.3, 0.2, 0.2, 0.2, + 0.125, 0.125, 0.125 ; + + fates_recruit_init_density = 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, + 0.2, 0.2, 0.2 ; + + fates_recruit_prescribed_rate = 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_recruit_seed_alloc = 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_recruit_seed_alloc_mature = 0, 0, 0, 0, 0, 0, 0.9, 0.9, 0.9, 0.9, 0.9, + 0.9 ; + + fates_recruit_seed_dbh_repro_threshold = 90, 80, 80, 80, 90, 80, 3, 3, 2, + 0.35, 0.35, 0.35 ; + + fates_recruit_seed_germination_rate = 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, + 0.5, 0.5, 0.5, 0.5, 0.5 ; + + fates_recruit_seed_supplement = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; + + fates_seed_dispersal_fraction = _, _, _, _, _, _, _, _, _, _, _, _ ; + + fates_seed_dispersal_max_dist = _, _, _, _, _, _, _, _, _, _, _, _ ; + + fates_seed_dispersal_pdf_scale = _, _, _, _, _, _, _, _, _, _, _, _ ; + + fates_seed_dispersal_pdf_shape = _, _, _, _, _, _, _, _, _, _, _, _ ; + + fates_stoich_nitr = + 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, + 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_stoich_phos = + 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, + 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_trim_inc = 0.03, 0.03, 0.03, 0.03, 0.03, 0.03, 0.03, 0.03, 0.03, 0.03, + 0.03, 0.03 ; + + fates_trim_limit = 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3 ; + + fates_trs_repro_alloc_a = 0.0049, 0.0049, 0.0049, 0.0049, 0.0049, 0.0049, + 0.0049, 0.0049, 0.0049, 0.0049, 0.0049, 0.0049 ; + + fates_trs_repro_alloc_b = -2.6171, -2.6171, -2.6171, -2.6171, -2.6171, + -2.6171, -2.6171, -2.6171, -2.6171, -2.6171, -2.6171, -2.6171 ; + + fates_trs_repro_frac_seed = 0.24, 0.24, 0.24, 0.24, 0.24, 0.24, 0.24, 0.24, + 0.24, 0.24, 0.24, 0.24 ; + + fates_trs_seedling_a_emerg = 0.0003, 0.0003, 0.0003, 0.0003, 0.0003, 0.0003, + 0.0003, 0.0003, 0.0003, 0.0003, 0.0003, 0.0003 ; + + fates_trs_seedling_b_emerg = 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, + 1.2, 1.2, 1.2 ; + + fates_trs_seedling_background_mort = 0.1085371, 0.1085371, 0.1085371, + 0.1085371, 0.1085371, 0.1085371, 0.1085371, 0.1085371, 0.1085371, + 0.1085371, 0.1085371, 0.1085371 ; + + fates_trs_seedling_h2o_mort_a = 4.070565e-17, 4.070565e-17, 4.070565e-17, + 4.070565e-17, 4.070565e-17, 4.070565e-17, 4.070565e-17, 4.070565e-17, + 4.070565e-17, 4.070565e-17, 4.070565e-17, 4.070565e-17 ; + + fates_trs_seedling_h2o_mort_b = -6.390757e-11, -6.390757e-11, -6.390757e-11, + -6.390757e-11, -6.390757e-11, -6.390757e-11, -6.390757e-11, + -6.390757e-11, -6.390757e-11, -6.390757e-11, -6.390757e-11, -6.390757e-11 ; + + fates_trs_seedling_h2o_mort_c = 1.268992e-05, 1.268992e-05, 1.268992e-05, + 1.268992e-05, 1.268992e-05, 1.268992e-05, 1.268992e-05, 1.268992e-05, + 1.268992e-05, 1.268992e-05, 1.268992e-05, 1.268992e-05 ; + + fates_trs_seedling_light_mort_a = -0.009897694, -0.009897694, -0.009897694, + -0.009897694, -0.009897694, -0.009897694, -0.009897694, -0.009897694, + -0.009897694, -0.009897694, -0.009897694, -0.009897694 ; + + fates_trs_seedling_light_mort_b = -7.154063, -7.154063, -7.154063, + -7.154063, -7.154063, -7.154063, -7.154063, -7.154063, -7.154063, + -7.154063, -7.154063, -7.154063 ; + + fates_trs_seedling_light_rec_a = 0.007, 0.007, 0.007, 0.007, 0.007, 0.007, + 0.007, 0.007, 0.007, 0.007, 0.007, 0.007 ; + + fates_trs_seedling_light_rec_b = 0.8615, 0.8615, 0.8615, 0.8615, 0.8615, + 0.8615, 0.8615, 0.8615, 0.8615, 0.8615, 0.8615, 0.8615 ; + + fates_trs_seedling_mdd_crit = 1400000, 1400000, 1400000, 1400000, 1400000, + 1400000, 1400000, 1400000, 1400000, 1400000, 1400000, 1400000 ; + + fates_trs_seedling_par_crit_germ = 0.656, 0.656, 0.656, 0.656, 0.656, 0.656, + 0.656, 0.656, 0.656, 0.656, 0.656, 0.656 ; + + fates_trs_seedling_psi_crit = -251995.7, -251995.7, -251995.7, -251995.7, + -251995.7, -251995.7, -251995.7, -251995.7, -251995.7, -251995.7, + -251995.7, -251995.7 ; + + fates_trs_seedling_psi_emerg = -15744.65, -15744.65, -15744.65, -15744.65, + -15744.65, -15744.65, -15744.65, -15744.65, -15744.65, -15744.65, + -15744.65, -15744.65 ; + + fates_trs_seedling_root_depth = 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, + 0.06, 0.06, 0.06, 0.06, 0.06 ; + + fates_turb_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_turb_leaf_diameter = 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, + 0.04, 0.04, 0.04, 0.04 ; + + fates_turb_z0mr = 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, + 0.055, 0.055, 0.055, 0.055 ; + + fates_turnover_branch = 150, 150, 150, 150, 150, 150, 150, 150, 150, 0, 0, 0 ; + + fates_turnover_fnrt = 1, 2, 1, 1.5, 1, 1, 1.5, 1, 1, 1, 1, 1 ; + + fates_turnover_leaf = + 1.5, 4, 1, 1.5, 1, 1, 1.5, 1, 1, 1, 1, 1 ; + + fates_turnover_senleaf_fdrought = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; + + fates_wood_density = 0.7, 0.4, 0.7, 0.53, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, + 0.7 ; + + fates_woody = 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0 ; + + fates_hlm_pft_map = + 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1 ; + + fates_fire_FBD = 15.4, 16.8, 19.6, 999, 4, 4 ; + + fates_fire_low_moisture_Coeff = 1.12, 1.09, 0.98, 0.8, 1.15, 1.15 ; + + fates_fire_low_moisture_Slope = 0.62, 0.72, 0.85, 0.8, 0.62, 0.62 ; + + fates_fire_mid_moisture = 0.72, 0.51, 0.38, 1, 0.8, 0.8 ; + + fates_fire_mid_moisture_Coeff = 2.35, 1.47, 1.06, 0.8, 3.2, 3.2 ; + + fates_fire_mid_moisture_Slope = 2.35, 1.47, 1.06, 0.8, 3.2, 3.2 ; + + fates_fire_min_moisture = 0.18, 0.12, 0, 0, 0.24, 0.24 ; + + fates_fire_SAV = 13, 3.58, 0.98, 0.2, 66, 66 ; + + fates_frag_maxdecomp = 0.52, 0.383, 0.383, 0.19, 1, 999 ; + + fates_frag_cwd_frac = 0.045, 0.075, 0.21, 0.67 ; + + fates_canopy_closure_thresh = 0.8 ; + + fates_cnp_eca_plant_escalar = 1.25e-05 ; + + fates_cohort_age_fusion_tol = 0.08 ; + + fates_cohort_size_fusion_tol = 0.08 ; + + fates_comp_excln = 3 ; + + fates_damage_canopy_layer_code = 1 ; + + fates_damage_event_code = 1 ; + + fates_dev_arbitrary = _ ; + + fates_fire_active_crown_fire = 0 ; + + fates_fire_cg_strikes = 0.2 ; + + fates_fire_drying_ratio = 66000 ; + + fates_fire_durat_slope = -11.06 ; + + fates_fire_fdi_a = 17.62 ; + + fates_fire_fdi_alpha = 0.00037 ; + + fates_fire_fdi_b = 243.12 ; + + fates_fire_fuel_energy = 18000 ; + + fates_fire_max_durat = 240 ; + + fates_fire_miner_damp = 0.41739 ; + + fates_fire_miner_total = 0.055 ; + + fates_fire_nignitions = 15 ; + + fates_fire_part_dens = 513 ; + + fates_fire_threshold = 50 ; + + fates_frag_cwd_fcel = 0.76 ; + + fates_frag_cwd_flig = 0.24 ; + + fates_hydro_kmax_rsurf1 = 20 ; + + fates_hydro_kmax_rsurf2 = 0.0001 ; + + fates_hydro_psi0 = 0 ; + + fates_hydro_psicap = -0.6 ; + + fates_hydro_solver = 1 ; + + fates_landuse_logging_coll_under_frac = 0.55983 ; + + fates_landuse_logging_collateral_frac = 0.05 ; + + fates_landuse_logging_dbhmax = _ ; + + fates_landuse_logging_dbhmax_infra = 35 ; + + fates_landuse_logging_dbhmin = 50 ; + + fates_landuse_logging_direct_frac = 0.15 ; + + fates_landuse_logging_event_code = -30 ; + + fates_landuse_logging_export_frac = 0.8 ; + + fates_landuse_logging_mechanical_frac = 0.05 ; + + fates_landuse_pprodharv10_forest_mean = 0.8125 ; + + fates_leaf_photo_temp_acclim_thome_time = 30 ; + + fates_leaf_photo_temp_acclim_timescale = 30 ; + + fates_leaf_photo_tempsens_model = 1 ; + + fates_leaf_stomatal_assim_model = 1 ; + + fates_leaf_stomatal_model = 1 ; + + fates_leaf_theta_cj_c3 = 0.999 ; + + fates_leaf_theta_cj_c4 = 0.999 ; + + fates_maintresp_leaf_model = 1 ; + + fates_maintresp_nonleaf_baserate = 2.525e-06 ; + + fates_maxcohort = 100 ; + + fates_maxpatch_primary = 10 ; + + fates_maxpatch_secondary = 4 ; + + fates_mort_disturb_frac = 1 ; + + fates_mort_understorey_death = 0.55983 ; + + fates_patch_fusion_tol = 0.05 ; + + fates_phen_chilltemp = 5 ; + + fates_phen_coldtemp = 7.5 ; + + fates_phen_gddthresh_a = -68 ; + + fates_phen_gddthresh_b = 638 ; + + fates_phen_gddthresh_c = -0.01 ; + + fates_phen_mindayson = 90 ; + + fates_phen_ncolddayslim = 5 ; + + fates_q10_froz = 1.5 ; + + fates_q10_mr = 1.5 ; + + fates_rad_model = 1 ; + + fates_regeneration_model = 1 ; + + fates_soil_salinity = 0.4 ; + + fates_trs_seedling2sap_par_timescale = 32 ; + + fates_trs_seedling_emerg_h2o_timescale = 7 ; + + fates_trs_seedling_mdd_timescale = 126 ; + + fates_trs_seedling_mort_par_timescale = 32 ; + + fates_vai_top_bin_width = 1 ; + + fates_vai_width_increase_factor = 1 ; +} diff --git a/parameter_files/archive/api32.0.0_231215_luh2.xml b/parameter_files/archive/api32.0.0_231215_luh2.xml new file mode 100644 index 0000000000..ab0e8f33db --- /dev/null +++ b/parameter_files/archive/api32.0.0_231215_luh2.xml @@ -0,0 +1,54 @@ + + + + + + + + + + + + + + + + + + + archive/api25.5.0_080923_fates_params_default.cdl + fates_params_default.cdl + 1,2,3,4,5,6,7,8,9,10,11,12 + + + fates_maxpatch_primary + + + fates_maxpatch_secondary + + + fates_landuseclass + 5 + + + fates_maxpatches_by_landuse + fates_landuseclass + count + maximum number of patches per site on each land use type + 9, 4, 1, 1, 1 + + + fates_landuseclass_name + fates_landuseclass, fates_string_length + unitless - string + Name of the land use classes, for variables associated with dimension fates_landuseclass + primaryland, secondaryland, rangeland, pastureland, cropland + + + diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index f170fe2275..99bdaed02e 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -13,6 +13,7 @@ dimensions: fates_pft = 12 ; fates_plant_organs = 4 ; fates_string_length = 60 ; + fates_landuseclass = 5 ; variables: double fates_history_ageclass_bin_edges(fates_history_age_bins) ; fates_history_ageclass_bin_edges:units = "yr" ; @@ -44,6 +45,9 @@ variables: char fates_alloc_organ_name(fates_plant_organs, fates_string_length) ; fates_alloc_organ_name:units = "unitless - string" ; fates_alloc_organ_name:long_name = "Name of plant organs (with alloc_organ_id, must match PRTGenericMod.F90)" ; + char fates_landuseclass_name(fates_landuseclass, fates_string_length) ; + fates_landuseclass_name:units = "unitless - string" ; + fates_landuseclass_name:long_name = "Name of the land use classes, for variables associated with dimension fates_landuseclass" ; char fates_litterclass_name(fates_litterclass, fates_string_length) ; fates_litterclass_name:units = "unitless - string" ; fates_litterclass_name:long_name = "Name of the litter classes, for variables associated with dimension fates_litterclass" ; @@ -469,7 +473,7 @@ variables: fates_phen_stem_drop_fraction:long_name = "fraction of stems to drop for non-woody species during drought/cold" ; double fates_phen_stress_decid(fates_pft) ; fates_phen_stress_decid:units = "logical flag" ; - fates_phen_stress_decid:long_name = "Binary flag for stress-deciduous leaf habit" ; + fates_phen_stress_decid:long_name = "Flag for stress/drought-deciduous leaf habit. 0 - not stress deciduous; 1 - default drought deciduous (two target states only, fully flushed or fully abscised); 2 - semi-deciduous" ; double fates_prescribed_npp_canopy(fates_pft) ; fates_prescribed_npp_canopy:units = "kgC / m^2 / yr" ; fates_prescribed_npp_canopy:long_name = "NPP per unit crown area of canopy trees for prescribed physiology mode" ; @@ -668,6 +672,9 @@ variables: double fates_frag_cwd_frac(fates_NCWD) ; fates_frag_cwd_frac:units = "fraction" ; fates_frag_cwd_frac:long_name = "fraction of woody (bdead+bsw) biomass destined for CWD pool" ; + double fates_maxpatches_by_landuse(fates_landuseclass) ; + fates_maxpatches_by_landuse:units = "count" ; + fates_maxpatches_by_landuse:long_name = "maximum number of patches per site on each land use type" ; double fates_canopy_closure_thresh ; fates_canopy_closure_thresh:units = "unitless" ; fates_canopy_closure_thresh:long_name = "tree canopy coverage at which crown area allometry changes from savanna to forest value" ; @@ -815,12 +822,6 @@ variables: double fates_maxcohort ; fates_maxcohort:units = "count" ; fates_maxcohort:long_name = "maximum number of cohorts per patch. Actual number of cohorts also depend on cohort fusion tolerances" ; - double fates_maxpatch_primary ; - fates_maxpatch_primary:units = "count" ; - fates_maxpatch_primary:long_name = "maximum number of primary vegetation patches per site" ; - double fates_maxpatch_secondary ; - fates_maxpatch_secondary:units = "count" ; - fates_maxpatch_secondary:long_name = "maximum number of secondary vegetation patches per site" ; double fates_mort_disturb_frac ; fates_mort_disturb_frac:units = "fraction" ; fates_mort_disturb_frac:long_name = "fraction of canopy mortality that results in disturbance (i.e. transfer of area from new to old patch)" ; @@ -930,6 +931,13 @@ data: "sapwood", "structure" ; + fates_landuseclass_name = + "primaryland", + "secondaryland", + "rangeland", + "pastureland", + "cropland" ; + fates_litterclass_name = "twig ", "small branch ", @@ -1589,6 +1597,8 @@ data: fates_frag_cwd_frac = 0.045, 0.075, 0.21, 0.67 ; + fates_maxpatches_by_landuse = 9, 4, 1, 1, 1 ; + fates_canopy_closure_thresh = 0.8 ; fates_cnp_eca_plant_escalar = 1.25e-05 ; @@ -1687,10 +1697,6 @@ data: fates_maxcohort = 100 ; - fates_maxpatch_primary = 10 ; - - fates_maxpatch_secondary = 4 ; - fates_mort_disturb_frac = 1 ; fates_mort_understorey_death = 0.55983 ; diff --git a/parameter_files/patch_default_bciopt224.xml b/parameter_files/patch_default_bciopt224.xml index 8ab504ed31..b1ec419f64 100644 --- a/parameter_files/patch_default_bciopt224.xml +++ b/parameter_files/patch_default_bciopt224.xml @@ -2,7 +2,7 @@ This parameter dataset was created by Ryan Knox rgknox@lbl.gov. Please contact if using in published work. The calibration uses the following datasets: [1] Ely et al. 2019. Leaf mass area, Panama. NGEE-Tropics data collection.http://dx.doi.org/10.15486/ngt/1411973 and [2] Condit et al. 2019. Complete data from the Barro Colorado 50-ha plot. https://doi.org/10.15146/5xcp-0d46. [3] Koven et al. 2019. Benchmarking and parameter sensitivity of physiological and vegetation dynamics using the functionally assembled terrestrial ecosystem simulator. Biogeosciences. The ECA nutrient aquisition parmeters are unconstrained, the file output naming convention vmn6phi is shorthand for vmax for nitrogen uptake is order e-6 and for phosphorus is excessively high. These parameters were calibrated with the special fates modification in main/EDTypesMod.F90: nclmax = 3 fates_params_default.cdl - fates_params_opt224_040822_api25.cdl + fates_params_opt224_092023_api26.cdl 1 diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/radiation/FatesNormanRadMod.F90 similarity index 72% rename from biogeophys/EDSurfaceAlbedoMod.F90 rename to radiation/FatesNormanRadMod.F90 index 18c7e7866e..24cf38fbb7 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/radiation/FatesNormanRadMod.F90 @@ -1,4 +1,4 @@ -module EDSurfaceRadiationMod +module FatesNormanRadMod !------------------------------------------------------------------------------------- ! EDSurfaceRadiation @@ -10,30 +10,26 @@ module EDSurfaceRadiationMod #include "shr_assert.h" - use EDTypesMod , only : ed_site_type - use FatesPatchMod, only : fates_patch_type - use EDParamsMod, only : maxpft - use FatesConstantsMod , only : r8 => fates_r8 - use FatesConstantsMod , only : itrue - use FatesConstantsMod , only : pi_const - use FatesConstantsMod , only : nocomp_bareground + use EDTypesMod , only : ed_site_type + use FatesPatchMod , only : fates_patch_type + use EDParamsMod , only : maxpft + use FatesConstantsMod , only : r8 => fates_r8 + use FatesConstantsMod , only : itrue + use FatesConstantsMod , only : pi_const + use FatesConstantsMod , only : nocomp_bareground use FatesInterfaceTypesMod , only : bc_in_type use FatesInterfaceTypesMod , only : bc_out_type - use FatesInterfaceTypesMod , only : hlm_numSWb use FatesInterfaceTypesMod , only : numpft - use EDParamsMod , only : maxSWb - use EDParamsMod , only : nclmax - use EDParamsMod , only : nlevleaf - use EDTypesMod , only : n_rad_stream_types - use EDTypesMod , only : idiffuse - use EDTypesMod , only : idirect - use EDParamsMod , only : ivis - use EDParamsMod , only : inir - use EDParamsMod , only : ipar - use EDCanopyStructureMod, only: calc_areaindex - use FatesGlobals , only : fates_log - use FatesGlobals, only : endrun => fates_endrun - use EDPftvarcon, only : EDPftvarcon_inst + use EDParamsMod , only : nclmax + use EDParamsMod , only : nlevleaf + use FatesRadiationMemMod , only : num_swb + use FatesRadiationMemMod , only : num_rad_stream_types + use FatesRadiationmemMod , only : idirect, idiffuse + use FatesRadiationMemMod , only : ivis, inir, ipar + use EDCanopyStructureMod , only : calc_areaindex + use FatesGlobals , only : fates_log + use FatesGlobals , only : endrun => fates_endrun + use EDPftvarcon , only : EDPftvarcon_inst ! CIME globals use shr_log_mod , only : errMsg => shr_log_errMsg @@ -41,15 +37,13 @@ module EDSurfaceRadiationMod implicit none private - public :: ED_Norman_Radiation ! Surface albedo and two-stream fluxes public :: PatchNormanRadiation - public :: ED_SunShadeFracs logical :: debug = .false. ! for debugging this module character(len=*), parameter, private :: sourcefile = & __FILE__ - ! real(r8), public :: albice(maxSWb) = & ! albedo land ice by waveband (1=vis, 2=nir) + ! real(r8), public :: albice(num_swb) = & ! albedo land ice by waveband (1=vis, 2=nir) ! (/ 0.80_r8, 0.55_r8 /) !parameters of canopy snow reflectance model. @@ -57,124 +51,14 @@ module EDSurfaceRadiationMod ! and so they are stored here for now in common with the ice parameters above. ! in principle these could be moved to the parameter file. - real(r8), public :: albice(maxSWb) = & ! albedo land ice by waveband (1=vis, 2=nir) + real(r8), public :: albice(num_swb) = & ! albedo land ice by waveband (1=vis, 2=nir) (/ 0.80_r8, 0.55_r8 /) - real(r8), public :: rho_snow(maxSWb) = & ! albedo land ice by waveband (1=vis, 2=nir) + real(r8), public :: rho_snow(num_swb) = & ! albedo land ice by waveband (1=vis, 2=nir) (/ 0.80_r8, 0.55_r8 /) - real(r8), public :: tau_snow(maxSWb) = & ! albedo land ice by waveband (1=vis, 2=nir) + real(r8), public :: tau_snow(num_swb) = & ! albedo land ice by waveband (1=vis, 2=nir) (/ 0.01_r8, 0.01_r8 /) contains - subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) - ! - ! - - ! !ARGUMENTS: - - integer, intent(in) :: nsites - type(ed_site_type), intent(inout), target :: sites(nsites) ! FATES site vector - type(bc_in_type), intent(in) :: bc_in(nsites) - type(bc_out_type), intent(inout) :: bc_out(nsites) - - - ! !LOCAL VARIABLES: - integer :: s ! site loop counter - integer :: ifp ! patch loop counter - integer :: ib ! radiation broad band counter - type(fates_patch_type), pointer :: currentPatch ! patch pointer - - !----------------------------------------------------------------------- - ! ------------------------------------------------------------------------------- - ! TODO (mv, 2014-10-29) the filter here is different than below - ! this is needed to have the VOC's be bfb - this needs to be - ! re-examined int he future - ! RGK,2016-08-06: FATES is still incompatible with VOC emission module - ! ------------------------------------------------------------------------------- - - - do s = 1, nsites - - ifp = 0 - currentpatch => sites(s)%oldest_patch - do while (associated(currentpatch)) - if(currentpatch%nocomp_pft_label.ne.nocomp_bareground)then - ! do not do albedo calculations for bare ground patch in SP mode - ! and (more impotantly) do not iterate ifp or it will mess up the indexing wherein - ! ifp=1 is the first vegetated patch. - ifp = ifp+1 - - currentPatch%f_sun (:,:,:) = 0._r8 - currentPatch%fabd_sun_z (:,:,:) = 0._r8 - currentPatch%fabd_sha_z (:,:,:) = 0._r8 - currentPatch%fabi_sun_z (:,:,:) = 0._r8 - currentPatch%fabi_sha_z (:,:,:) = 0._r8 - currentPatch%fabd (:) = 0._r8 - currentPatch%fabi (:) = 0._r8 - - ! zero diagnostic radiation profiles - currentPatch%nrmlzd_parprof_pft_dir_z(:,:,:,:) = 0._r8 - currentPatch%nrmlzd_parprof_pft_dif_z(:,:,:,:) = 0._r8 - currentPatch%nrmlzd_parprof_dir_z(:,:,:) = 0._r8 - currentPatch%nrmlzd_parprof_dif_z(:,:,:) = 0._r8 - - currentPatch%solar_zenith_flag = bc_in(s)%filter_vegzen_pa(ifp) - currentPatch%solar_zenith_angle = bc_in(s)%coszen_pa(ifp) - currentPatch%gnd_alb_dif(1:hlm_numSWb) = bc_in(s)%albgr_dif_rb(1:hlm_numSWb) - currentPatch%gnd_alb_dir(1:hlm_numSWb) = bc_in(s)%albgr_dir_rb(1:hlm_numSWb) - currentPatch%fcansno = bc_in(s)%fcansno_pa(ifp) - - if(currentPatch%solar_zenith_flag )then - - bc_out(s)%albd_parb(ifp,:) = 0._r8 ! output HLM - bc_out(s)%albi_parb(ifp,:) = 0._r8 ! output HLM - bc_out(s)%fabi_parb(ifp,:) = 0._r8 ! output HLM - bc_out(s)%fabd_parb(ifp,:) = 0._r8 ! output HLM - bc_out(s)%ftdd_parb(ifp,:) = 1._r8 ! output HLM - bc_out(s)%ftid_parb(ifp,:) = 1._r8 ! output HLM - bc_out(s)%ftii_parb(ifp,:) = 1._r8 ! output HLM - - if (maxval(currentPatch%nrad(1,:))==0)then - !there are no leaf layers in this patch. it is effectively bare ground. - ! no radiation is absorbed - bc_out(s)%fabd_parb(ifp,:) = 0.0_r8 - bc_out(s)%fabi_parb(ifp,:) = 0.0_r8 - currentPatch%radiation_error = 0.0_r8 - - do ib = 1,hlm_numSWb - bc_out(s)%albd_parb(ifp,ib) = bc_in(s)%albgr_dir_rb(ib) - bc_out(s)%albi_parb(ifp,ib) = bc_in(s)%albgr_dif_rb(ib) - bc_out(s)%ftdd_parb(ifp,ib)= 1.0_r8 - !bc_out(s)%ftid_parb(ifp,ib)= 1.0_r8 - bc_out(s)%ftid_parb(ifp,ib)= 0.0_r8 - bc_out(s)%ftii_parb(ifp,ib)= 1.0_r8 - enddo - - else - - call PatchNormanRadiation (currentPatch, & - bc_out(s)%albd_parb(ifp,:), & - bc_out(s)%albi_parb(ifp,:), & - bc_out(s)%fabd_parb(ifp,:), & - bc_out(s)%fabi_parb(ifp,:), & - bc_out(s)%ftdd_parb(ifp,:), & - bc_out(s)%ftid_parb(ifp,:), & - bc_out(s)%ftii_parb(ifp,:)) - - - endif ! is there vegetation? - - end if ! if the vegetation and zenith filter is active - endif ! not bare ground - currentPatch => currentPatch%younger - end do ! Loop linked-list patches - enddo ! Loop Sites - - return - end subroutine ED_Norman_Radiation - - - ! ====================================================================================== - subroutine PatchNormanRadiation (currentPatch, & albd_parb_out, & ! (ifp,ib) albi_parb_out, & ! (ifp,ib) @@ -195,13 +79,13 @@ subroutine PatchNormanRadiation (currentPatch, & ! ----------------------------------------------------------------------------------- type(fates_patch_type), intent(inout), target :: currentPatch - real(r8), intent(inout) :: albd_parb_out(hlm_numSWb) - real(r8), intent(inout) :: albi_parb_out(hlm_numSWb) - real(r8), intent(inout) :: fabd_parb_out(hlm_numSWb) - real(r8), intent(inout) :: fabi_parb_out(hlm_numSWb) - real(r8), intent(inout) :: ftdd_parb_out(hlm_numSWb) - real(r8), intent(inout) :: ftid_parb_out(hlm_numSWb) - real(r8), intent(inout) :: ftii_parb_out(hlm_numSWb) + real(r8), intent(inout) :: albd_parb_out(num_swb) + real(r8), intent(inout) :: albi_parb_out(num_swb) + real(r8), intent(inout) :: fabd_parb_out(num_swb) + real(r8), intent(inout) :: fabi_parb_out(num_swb) + real(r8), intent(inout) :: ftdd_parb_out(num_swb) + real(r8), intent(inout) :: ftid_parb_out(num_swb) + real(r8), intent(inout) :: ftii_parb_out(num_swb) ! Locals ! ----------------------------------------------------------------------------------- @@ -218,25 +102,25 @@ subroutine PatchNormanRadiation (currentPatch, & real(r8) :: tr_dif_z(nclmax,maxpft,nlevleaf) ! Exponential transmittance of diffuse radiation through a single layer real(r8) :: weighted_dir_tr(nclmax) real(r8) :: weighted_fsun(nclmax) - real(r8) :: weighted_dif_ratio(nclmax,maxSWb) + real(r8) :: weighted_dif_ratio(nclmax,num_swb) real(r8) :: weighted_dif_down(nclmax) real(r8) :: weighted_dif_up(nclmax) - real(r8) :: refl_dif(nclmax,maxpft,nlevleaf,maxSWb) ! Term for diffuse radiation reflected by laye - real(r8) :: tran_dif(nclmax,maxpft,nlevleaf,maxSWb) ! Term for diffuse radiation transmitted by layer - real(r8) :: dif_ratio(nclmax,maxpft,nlevleaf,maxSWb) ! Ratio of upward to forward diffuse fluxes + real(r8) :: refl_dif(nclmax,maxpft,nlevleaf,num_swb) ! Term for diffuse radiation reflected by laye + real(r8) :: tran_dif(nclmax,maxpft,nlevleaf,num_swb) ! Term for diffuse radiation transmitted by layer + real(r8) :: dif_ratio(nclmax,maxpft,nlevleaf,num_swb) ! Ratio of upward to forward diffuse fluxes real(r8) :: Dif_dn(nclmax,maxpft,nlevleaf) ! Forward diffuse flux onto canopy layer J (W/m**2 ground area) real(r8) :: Dif_up(nclmax,maxpft,nlevleaf) ! Upward diffuse flux above canopy layer J (W/m**2 ground area) real(r8) :: lai_change(nclmax,maxpft,nlevleaf) ! Forward diffuse flux onto canopy layer J (W/m**2 ground area) real(r8) :: frac_lai ! Fraction of lai in each layer real(r8) :: frac_sai ! Fraction of sai in each layer - real(r8) :: f_abs(nclmax,maxpft,nlevleaf,maxSWb) ! Fraction of light absorbed by surfaces. - real(r8) :: rho_layer(nclmax,maxpft,nlevleaf,maxSWb)! Weighted verage reflectance of layer - real(r8) :: tau_layer(nclmax,maxpft,nlevleaf,maxSWb)! Weighted average transmittance of layer - real(r8) :: f_abs_leaf(nclmax,maxpft,nlevleaf,maxSWb) + real(r8) :: f_abs(nclmax,maxpft,nlevleaf,num_swb) ! Fraction of light absorbed by surfaces. + real(r8) :: rho_layer(nclmax,maxpft,nlevleaf,num_swb)! Weighted verage reflectance of layer + real(r8) :: tau_layer(nclmax,maxpft,nlevleaf,num_swb)! Weighted average transmittance of layer + real(r8) :: f_abs_leaf(nclmax,maxpft,nlevleaf,num_swb) real(r8) :: Abs_dir_z(maxpft,nlevleaf) real(r8) :: Abs_dif_z(maxpft,nlevleaf) - real(r8) :: abs_rad(maxSWb) !radiation absorbed by soil + real(r8) :: abs_rad(num_swb) !radiation absorbed by soil real(r8) :: tr_soili ! Radiation transmitted to the soil surface. real(r8) :: tr_soild ! Radiation transmitted to the soil surface. real(r8) :: phi1b(maxpft) ! Radiation transmitted to the soil surface. @@ -259,8 +143,8 @@ subroutine PatchNormanRadiation (currentPatch, & real(r8) :: gdir - real(r8), parameter :: forc_dir(n_rad_stream_types) = (/ 1.0_r8, 0.0_r8 /) ! These are binary switches used - real(r8), parameter :: forc_dif(n_rad_stream_types) = (/ 0.0_r8, 1.0_r8 /) ! to turn off and on radiation streams + real(r8), parameter :: forc_dir(num_rad_stream_types) = (/ 1.0_r8, 0.0_r8 /) ! These are binary switches used + real(r8), parameter :: forc_dif(num_rad_stream_types) = (/ 0.0_r8, 1.0_r8 /) ! to turn off and on radiation streams @@ -292,13 +176,13 @@ subroutine PatchNormanRadiation (currentPatch, & ! Initialize the ouput arrays ! --------------------------------------------------------------------------------- - albd_parb_out(1:hlm_numSWb) = 0.0_r8 - albi_parb_out(1:hlm_numSWb) = 0.0_r8 - fabd_parb_out(1:hlm_numSWb) = 0.0_r8 - fabi_parb_out(1:hlm_numSWb) = 0.0_r8 - ftdd_parb_out(1:hlm_numSWb) = 1.0_r8 - ftid_parb_out(1:hlm_numSWb) = 1.0_r8 - ftii_parb_out(1:hlm_numSWb) = 1.0_r8 + albd_parb_out(1:num_swb) = 0.0_r8 + albi_parb_out(1:num_swb) = 0.0_r8 + fabd_parb_out(1:num_swb) = 0.0_r8 + fabi_parb_out(1:num_swb) = 0.0_r8 + ftdd_parb_out(1:num_swb) = 1.0_r8 + ftid_parb_out(1:num_swb) = 1.0_r8 + ftii_parb_out(1:num_swb) = 1.0_r8 ! Is this pft/canopy layer combination present in this patch? rho_layer(:,:,:,:)=0.0_r8 @@ -322,7 +206,7 @@ subroutine PatchNormanRadiation (currentPatch, & frac_sai = 1.0_r8 - frac_lai ! layer level reflectance qualities - do ib = 1,hlm_numSWb !vis, nir + do ib = 1,num_swb !vis, nir rho_layer(L,ft,iv,ib)=frac_lai*rhol(ft,ib)+frac_sai*rhos(ft,ib) tau_layer(L,ft,iv,ib)=frac_lai*taul(ft,ib)+frac_sai*taus(ft,ib) @@ -364,7 +248,7 @@ subroutine PatchNormanRadiation (currentPatch, & !do this once for one unit of diffuse, and once for one unit of direct radiation - do radtype = 1, n_rad_stream_types + do radtype = 1, num_rad_stream_types ! Extract information that needs to be provided by ED into local array. ! RGK: NOT SURE WHY WE NEED FTWEIGHT ... @@ -393,7 +277,7 @@ subroutine PatchNormanRadiation (currentPatch, & weighted_dir_tr(L) = 0.0_r8 weighted_fsun(L) = 0._r8 - weighted_dif_ratio(L,1:hlm_numSWb) = 0._r8 + weighted_dif_ratio(L,1:num_swb) = 0._r8 !Each canopy layer (canopy, understorey) has multiple 'parallel' pft's @@ -544,7 +428,7 @@ subroutine PatchNormanRadiation (currentPatch, & ! Iterative solution do scattering !==============================================================================! - do ib = 1,hlm_numSWb !vis, nir + do ib = 1,num_swb !vis, nir !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! ! Leaf scattering coefficient and terms do diffuse radiation reflected ! and transmitted by a layer @@ -584,15 +468,15 @@ subroutine PatchNormanRadiation (currentPatch, & weighted_dif_ratio(L,ib) = weighted_dif_ratio(L,ib) + & dif_ratio(L,ft,1,ib) * ftweight(L,ft,1) !instance where the first layer ftweight is used a proxy for the whole column. FTWA - end do!hlm_numSWb + end do!num_swb endif ! currentPatch%canopy_mask end do!ft end do!L - ! Zero out the radiation error for the current patch before conducting the conservation check - currentPatch%radiation_error = 0.0_r8 + do ib = 1,num_swb - do ib = 1,hlm_numSWb + currentPatch%rad_error(ib) = 0._r8 + Dif_dn(:,:,:) = 0.00_r8 Dif_up(:,:,:) = 0.00_r8 do L = 1, currentPatch%NCL_p !work down from the top of the canopy. @@ -919,15 +803,6 @@ subroutine PatchNormanRadiation (currentPatch, & forc_dir(radtype) * tr_dir_z(L,ft,iv) currentPatch%nrmlzd_parprof_pft_dif_z(radtype,L,ft,iv) = & Dif_dn(L,ft,iv) + Dif_up(L,ft,iv) - ! - currentPatch%nrmlzd_parprof_dir_z(radtype,L,iv) = & - currentPatch%nrmlzd_parprof_dir_z(radtype,L,iv) + & - (forc_dir(radtype) * tr_dir_z(L,ft,iv)) * & - (ftweight(L,ft,iv) / sum(ftweight(L,1:numpft,iv))) - currentPatch%nrmlzd_parprof_dif_z(radtype,L,iv) = & - currentPatch%nrmlzd_parprof_dif_z(radtype,L,iv) + & - (Dif_dn(L,ft,iv) + Dif_up(L,ft,iv)) * & - (ftweight(L,ft,iv) / sum(ftweight(L,1:numpft,iv))) end do end if ! ib = visible end if ! present @@ -1011,8 +886,9 @@ subroutine PatchNormanRadiation (currentPatch, & if ( (currentPatch%total_canopy_area / currentPatch%area) .gt. tolerance ) then ! normalize rad error by the veg-covered fraction of the patch because that is ! the only part that this code applies to - currentPatch%radiation_error = currentPatch%radiation_error + error & + currentPatch%rad_error(ib) = currentPatch%rad_error(ib) + error & * currentPatch%total_canopy_area / currentPatch%area + endif lai_reduction(:) = 0.0_r8 @@ -1094,7 +970,7 @@ subroutine PatchNormanRadiation (currentPatch, & end if end if - end do !hlm_numSWb + end do !num_swb enddo ! rad-type @@ -1103,222 +979,5 @@ subroutine PatchNormanRadiation (currentPatch, & return end subroutine PatchNormanRadiation -! ====================================================================================== - -subroutine ED_SunShadeFracs(nsites, sites,bc_in,bc_out) - - implicit none - - ! Arguments - integer,intent(in) :: nsites - type(ed_site_type),intent(inout),target :: sites(nsites) - type(bc_in_type),intent(in) :: bc_in(nsites) - type(bc_out_type),intent(inout) :: bc_out(nsites) - - - ! locals - type (fates_patch_type),pointer :: cpatch ! c"urrent" patch - real(r8) :: sunlai - real(r8) :: shalai - real(r8) :: elai - integer :: CL - integer :: FT - integer :: iv - integer :: s - integer :: ifp - - - do s = 1,nsites - - ifp = 0 - cpatch => sites(s)%oldest_patch - - do while (associated(cpatch)) - if(cpatch%nocomp_pft_label.ne.nocomp_bareground)then !only for veg patches - ! do not do albedo calculations for bare ground patch in SP mode - ! and (more impotantly) do not iterate ifp or it will mess up the indexing wherein - ! ifp=1 is the first vegetated patch. - ifp=ifp+1 - - if( debug ) write(fates_log(),*) 'edsurfRad_5600',ifp,s,cpatch%NCL_p,numpft - - ! zero out various datas - cpatch%ed_parsun_z(:,:,:) = 0._r8 - cpatch%ed_parsha_z(:,:,:) = 0._r8 - cpatch%ed_laisun_z(:,:,:) = 0._r8 - cpatch%ed_laisha_z(:,:,:) = 0._r8 - - bc_out(s)%fsun_pa(ifp) = 0._r8 - - sunlai = 0._r8 - shalai = 0._r8 - - cpatch%parprof_pft_dir_z(:,:,:) = 0._r8 - cpatch%parprof_pft_dif_z(:,:,:) = 0._r8 - cpatch%parprof_dir_z(:,:) = 0._r8 - cpatch%parprof_dif_z(:,:) = 0._r8 - - ! Loop over patches to calculate laisun_z and laisha_z for each layer. - ! Derive canopy laisun, laisha, and fsun from layer sums. - ! If sun/shade big leaf code, nrad=1 and fsun_z(p,1) and tlai_z(p,1) from - ! SurfaceAlbedo is canopy integrated so that layer value equals canopy value. - - ! cpatch%f_sun is calculated in the surface_albedo routine... - - do CL = 1, cpatch%NCL_p - do FT = 1,numpft - - if( debug ) write(fates_log(),*) 'edsurfRad_5601',CL,FT,cpatch%nrad(CL,ft) - - do iv = 1, cpatch%nrad(CL,ft) !NORMAL CASE. - - ! FIX(SPM,040114) - existing comment - ! ** Should this be elai or tlai? Surely we only do radiation for elai? - - cpatch%ed_laisun_z(CL,ft,iv) = cpatch%elai_profile(CL,ft,iv) * & - cpatch%f_sun(CL,ft,iv) - - if ( debug ) write(fates_log(),*) 'edsurfRad 570 ',cpatch%elai_profile(CL,ft,iv) - if ( debug ) write(fates_log(),*) 'edsurfRad 571 ',cpatch%f_sun(CL,ft,iv) - - cpatch%ed_laisha_z(CL,ft,iv) = cpatch%elai_profile(CL,ft,iv) * & - (1._r8 - cpatch%f_sun(CL,ft,iv)) - - end do - - !needed for the VOC emissions, etc. - sunlai = sunlai + sum(cpatch%ed_laisun_z(CL,ft,1:cpatch%nrad(CL,ft))) - shalai = shalai + sum(cpatch%ed_laisha_z(CL,ft,1:cpatch%nrad(CL,ft))) - - end do - end do - - if(sunlai+shalai > 0._r8)then - bc_out(s)%fsun_pa(ifp) = sunlai / (sunlai+shalai) - else - bc_out(s)%fsun_pa(ifp) = 0._r8 - endif - - if(debug)then - if(bc_out(s)%fsun_pa(ifp) > 1._r8)then - write(fates_log(),*) 'too much leaf area in profile', bc_out(s)%fsun_pa(ifp), & - sunlai,shalai - endif - end if - - elai = calc_areaindex(cpatch,'elai') - - bc_out(s)%laisun_pa(ifp) = elai*bc_out(s)%fsun_pa(ifp) - bc_out(s)%laisha_pa(ifp) = elai*(1.0_r8-bc_out(s)%fsun_pa(ifp)) - - ! Absorbed PAR profile through canopy - ! If sun/shade big leaf code, nrad=1 and fluxes from SurfaceAlbedo - ! are canopy integrated so that layer values equal big leaf values. - - if ( debug ) write(fates_log(),*) 'edsurfRad 645 ',cpatch%NCL_p,numpft - - do CL = 1, cpatch%NCL_p - do FT = 1,numpft - - if ( debug ) write(fates_log(),*) 'edsurfRad 649 ',cpatch%nrad(CL,ft) - - do iv = 1, cpatch%nrad(CL,ft) - - if ( debug ) then - write(fates_log(),*) 'edsurfRad 653 ', cpatch%ed_parsun_z(CL,ft,iv) - write(fates_log(),*) 'edsurfRad 654 ', bc_in(s)%solad_parb(ifp,ipar) - write(fates_log(),*) 'edsurfRad 655 ', bc_in(s)%solai_parb(ifp,ipar) - write(fates_log(),*) 'edsurfRad 656 ', cpatch%fabd_sun_z(CL,ft,iv) - write(fates_log(),*) 'edsurfRad 657 ', cpatch%fabi_sun_z(CL,ft,iv) - endif - - cpatch%ed_parsun_z(CL,ft,iv) = & - bc_in(s)%solad_parb(ifp,ipar)*cpatch%fabd_sun_z(CL,ft,iv) + & - bc_in(s)%solai_parb(ifp,ipar)*cpatch%fabi_sun_z(CL,ft,iv) - - if ( debug )write(fates_log(),*) 'edsurfRad 663 ', cpatch%ed_parsun_z(CL,ft,iv) - - cpatch%ed_parsha_z(CL,ft,iv) = & - bc_in(s)%solad_parb(ifp,ipar)*cpatch%fabd_sha_z(CL,ft,iv) + & - bc_in(s)%solai_parb(ifp,ipar)*cpatch%fabi_sha_z(CL,ft,iv) - - if ( debug ) write(fates_log(),*) 'edsurfRad 669 ', cpatch%ed_parsha_z(CL,ft,iv) - - end do !iv - end do !FT - end do !CL - - ! Convert normalized radiation error units from fraction of radiation to W/m2 - cpatch%radiation_error = cpatch%radiation_error * (bc_in(s)%solad_parb(ifp,ipar) + & - bc_in(s)%solai_parb(ifp,ipar)) - - ! output the actual PAR profiles through the canopy for diagnostic purposes - do CL = 1, cpatch%NCL_p - do FT = 1,numpft - do iv = 1, cpatch%nrad(CL,ft) - cpatch%parprof_pft_dir_z(CL,FT,iv) = (bc_in(s)%solad_parb(ifp,ipar) * & - cpatch%nrmlzd_parprof_pft_dir_z(idirect,CL,FT,iv)) + & - (bc_in(s)%solai_parb(ifp,ipar) * & - cpatch%nrmlzd_parprof_pft_dir_z(idiffuse,CL,FT,iv)) - cpatch%parprof_pft_dif_z(CL,FT,iv) = (bc_in(s)%solad_parb(ifp,ipar) * & - cpatch%nrmlzd_parprof_pft_dif_z(idirect,CL,FT,iv)) + & - (bc_in(s)%solai_parb(ifp,ipar) * & - cpatch%nrmlzd_parprof_pft_dif_z(idiffuse,CL,FT,iv)) - end do ! iv - end do ! FT - end do ! CL - - do CL = 1, cpatch%NCL_p - do iv = 1, maxval(cpatch%nrad(CL,:)) - cpatch%parprof_dir_z(CL,iv) = (bc_in(s)%solad_parb(ifp,ipar) * & - cpatch%nrmlzd_parprof_dir_z(idirect,CL,iv)) + & - (bc_in(s)%solai_parb(ifp,ipar) * & - cpatch%nrmlzd_parprof_dir_z(idiffuse,CL,iv)) - cpatch%parprof_dif_z(CL,iv) = (bc_in(s)%solad_parb(ifp,ipar) * & - cpatch%nrmlzd_parprof_dif_z(idirect,CL,iv)) + & - (bc_in(s)%solai_parb(ifp,ipar) * & - cpatch%nrmlzd_parprof_dif_z(idiffuse,CL,iv)) - end do ! iv - end do ! CL - endif ! not bareground patch - cpatch => cpatch%younger - enddo - - - enddo - return - -end subroutine ED_SunShadeFracs - - -! ! MOVE TO THE INTERFACE -! subroutine ED_CheckSolarBalance(g,filter_nourbanp,num_nourbanp,fsa,fsr,forc_solad,forc_solai) - - -! implicit none -! integer,intent(in),dimension(:) :: gridcell ! => gridcell index -! integer,intent(in),dimension(:) :: filter_nourbanp ! => patch filter for non-urban points -! integer, intent(in) :: num_nourbanp ! number of patches in non-urban points in patch filter -! real(r8),intent(in),dimension(:,:) :: forc_solad ! => atm2lnd_inst%forc_solad_grc, direct radiation (W/m**2 -! real(r8),intent(in),dimension(:,:) :: forc_solai ! => atm2lnd_inst%forc_solai_grc, diffuse radiation (W/m**2) -! real(r8),intent(in),dimension(:,:) :: fsa ! => solarabs_inst%fsa_patch, solar radiation absorbed (total) (W/m**2) -! real(r8),intent(in),dimension(:,:) :: fsr ! => solarabs_inst%fsr_patch, solar radiation reflected (W/m**2) - -! integer :: p -! integer :: fp -! integer :: g -! real(r8) :: errsol - -! do fp = 1,num_nourbanp -! p = filter_nourbanp(fp) -! g = gridcell(p) -! errsol = (fsa(p) + fsr(p) - (forc_solad(g,1) + forc_solad(g,2) + forc_solai(g,1) + forc_solai(g,2))) -! if(abs(errsol) > 0.1_r8)then -! write(fates_log(),*) 'sol error in surf rad',p,g, errsol -! endif -! end do -! return -! end subroutine ED_CheckSolarBalance - -end module EDSurfaceRadiationMod +end module FatesNormanRadMod diff --git a/radiation/FatesRadiationDriveMod.F90 b/radiation/FatesRadiationDriveMod.F90 new file mode 100644 index 0000000000..cb642c1289 --- /dev/null +++ b/radiation/FatesRadiationDriveMod.F90 @@ -0,0 +1,504 @@ +module FatesRadiationDriveMod + + !------------------------------------------------------------------------------------- + ! EDSurfaceRadiation + ! + ! This module contains function and type definitions for all things related + ! to radiative transfer in ED modules at the land surface. + ! + !------------------------------------------------------------------------------------- + +#include "shr_assert.h" + + use EDTypesMod , only : ed_site_type + use FatesPatchMod, only : fates_patch_type + use EDParamsMod, only : maxpft + use FatesConstantsMod , only : r8 => fates_r8 + use FatesConstantsMod , only : fates_unset_r8 + use FatesConstantsMod , only : itrue + use FatesConstantsMod , only : pi_const + use FatesConstantsMod , only : nocomp_bareground + use FatesConstantsMod , only : nearzero + use FatesInterfaceTypesMod , only : bc_in_type + use FatesInterfaceTypesMod , only : bc_out_type + use FatesInterfaceTypesMod , only : numpft + use FatesRadiationMemMod, only : num_rad_stream_types + use FatesRadiationMemMod, only : idirect, idiffuse + use FatesRadiationMemMod, only : num_swb, ivis, inir, ipar + use FatesRadiationMemMod, only : alb_ice, rho_snow, tau_snow + use FatesRadiationMemMod, only : norman_solver + use FatesRadiationMemMod, only : twostr_solver + use EDParamsMod, only : radiation_model + use TwoStreamMLPEMod, only : normalized_upper_boundary + use FatesTwoStreamUtilsMod, only : FatesPatchFSun + use FatesTwoStreamUtilsMod, only : CheckPatchRadiationBalance + use FatesInterfaceTypesMod , only : hlm_hio_ignore_val + use EDParamsMod , only : dinc_vai,dlower_vai + use EDParamsMod , only : nclmax + use EDParamsMod , only : nlevleaf + use EDCanopyStructureMod, only: calc_areaindex + use FatesGlobals , only : fates_log + use FatesGlobals, only : endrun => fates_endrun + use EDPftvarcon, only : EDPftvarcon_inst + use FatesNormanRadMod, only : PatchNormanRadiation + + ! CIME globals + use shr_log_mod , only : errMsg => shr_log_errMsg + + implicit none + + private + public :: FatesNormalizedCanopyRadiation ! Surface albedo and two-stream fluxes + public :: FatesSunShadeFracs + + logical :: debug = .false. ! for debugging this module + character(len=*), parameter, private :: sourcefile = & + __FILE__ + + logical :: preserve_b4b = .true. + +contains + + subroutine FatesNormalizedCanopyRadiation(nsites, sites, bc_in, bc_out ) + + ! Perform normalized (ie per unit downwelling radiative forcing) radiation + ! scattering of the vegetation canopy. + ! This call is normalized because the host wants an albedo for the next time + ! step, but it does not have the absolute beam and diffuse forcing for the + ! next step yet. + ! However, with both Norman and Two stream, we save normalized scattering + ! and absorption profiles amonst the vegetation, and that can + ! be scaled by the forcing when we perform diagnostics, calculate heating + ! rates (HLM side), and calculate absorbed leaf PAR for photosynthesis. + + ! + + ! !ARGUMENTS: + + integer, intent(in) :: nsites + type(ed_site_type), intent(inout), target :: sites(nsites) ! FATES site vector + type(bc_in_type), intent(in) :: bc_in(nsites) + type(bc_out_type), intent(inout) :: bc_out(nsites) + + ! !LOCAL VARIABLES: + integer :: s ! site loop counter + integer :: ifp ! patch loop counter + integer :: ib ! radiation broad band counter + type(fates_patch_type), pointer :: currentPatch ! patch pointer + + !----------------------------------------------------------------------- + ! ------------------------------------------------------------------------------- + ! TODO (mv, 2014-10-29) the filter here is different than below + ! this is needed to have the VOC's be bfb - this needs to be + ! re-examined int he future + ! RGK,2016-08-06: FATES is still incompatible with VOC emission module + ! ------------------------------------------------------------------------------- + + + do s = 1, nsites + + ifp = 0 + currentpatch => sites(s)%oldest_patch + do while (associated(currentpatch)) + + ! do not do albedo calculations for bare ground patch in SP mode + ! and (more impotantly) do not iterate ifp or it will mess up the indexing wherein + ! ifp=1 is the first vegetated patch. + + if_notbareground: if(currentpatch%nocomp_pft_label.ne.nocomp_bareground)then + + ifp = ifp+1 + + ! Zero diagnostics + currentPatch%f_sun (:,:,:) = 0._r8 + currentPatch%fabd_sun_z (:,:,:) = 0._r8 + currentPatch%fabd_sha_z (:,:,:) = 0._r8 + currentPatch%fabi_sun_z (:,:,:) = 0._r8 + currentPatch%fabi_sha_z (:,:,:) = 0._r8 + currentPatch%fabd (:) = 0._r8 + currentPatch%fabi (:) = 0._r8 + currentPatch%nrmlzd_parprof_pft_dir_z(:,:,:,:) = 0._r8 + currentPatch%nrmlzd_parprof_pft_dif_z(:,:,:,:) = 0._r8 + + currentPatch%rad_error(:) = hlm_hio_ignore_val + + currentPatch%solar_zenith_flag = bc_in(s)%filter_vegzen_pa(ifp) + currentPatch%solar_zenith_angle = bc_in(s)%coszen_pa(ifp) + currentPatch%gnd_alb_dif(1:num_swb) = bc_in(s)%albgr_dif_rb(1:num_swb) + currentPatch%gnd_alb_dir(1:num_swb) = bc_in(s)%albgr_dir_rb(1:num_swb) + currentPatch%fcansno = bc_in(s)%fcansno_pa(ifp) + + if(radiation_model.eq.twostr_solver) then + call currentPatch%twostr%CanopyPrep(bc_in(s)%fcansno_pa(ifp)) + call currentPatch%twostr%ZenithPrep(bc_in(s)%coszen_pa(ifp)) + end if + + if_zenith_flag: if(.not.currentPatch%solar_zenith_flag )then + + ! Sun below horizon, trivial solution + ! Note (RGK-MLO): Investigate twilight mechanics for + ! non-zero diffuse radiation when cosz<=0 + + ! Temporarily turn off to preserve b4b + ! preserve_b4b will be removed soon. This is kept here to prevent + ! round off errors in the baseline tests for the two-stream code (RGK 12-27-23) + if (.not.preserve_b4b) then + bc_out(s)%albd_parb(ifp,:) = 1._r8 + bc_out(s)%albi_parb(ifp,:) = 1._r8 + bc_out(s)%fabi_parb(ifp,:) = 0._r8 + bc_out(s)%fabd_parb(ifp,:) = 0._r8 + bc_out(s)%ftdd_parb(ifp,:) = 0._r8 + bc_out(s)%ftid_parb(ifp,:) = 0._r8 + bc_out(s)%ftii_parb(ifp,:) = 0._r8 + end if + else + + bc_out(s)%albd_parb(ifp,:) = 0._r8 ! output HLM + bc_out(s)%albi_parb(ifp,:) = 0._r8 ! output HLM + bc_out(s)%fabi_parb(ifp,:) = 0._r8 ! output HLM + bc_out(s)%fabd_parb(ifp,:) = 0._r8 ! output HLM + bc_out(s)%ftdd_parb(ifp,:) = 1._r8 ! output HLM + bc_out(s)%ftid_parb(ifp,:) = 1._r8 ! output HLM + bc_out(s)%ftii_parb(ifp,:) = 1._r8 ! output HLM + + if_nrad: if (maxval(currentPatch%nrad(1,:))==0)then + ! there are no leaf layers in this patch. it is effectively bare ground. + bc_out(s)%fabd_parb(ifp,:) = 0.0_r8 + bc_out(s)%fabi_parb(ifp,:) = 0.0_r8 + currentPatch%rad_error(:) = 0.0_r8 + + do ib = 1,num_swb + bc_out(s)%albd_parb(ifp,ib) = bc_in(s)%albgr_dir_rb(ib) + bc_out(s)%albi_parb(ifp,ib) = bc_in(s)%albgr_dif_rb(ib) + bc_out(s)%ftdd_parb(ifp,ib) = 1.0_r8 + bc_out(s)%ftid_parb(ifp,ib) = 0.0_r8 + bc_out(s)%ftii_parb(ifp,ib) = 1.0_r8 + enddo + + else + + select case(radiation_model) + case(norman_solver) + + call PatchNormanRadiation (currentPatch, & + bc_out(s)%albd_parb(ifp,:), & ! Surface Albedo direct + bc_out(s)%albi_parb(ifp,:), & ! Surface Albedo (indirect) diffuse + bc_out(s)%fabd_parb(ifp,:), & ! Fraction direct absorbed by canopy per unit incident + bc_out(s)%fabi_parb(ifp,:), & ! Fraction diffuse absorbed by canopy per unit incident + bc_out(s)%ftdd_parb(ifp,:), & ! Down direct flux below canopy per unit direct at top + bc_out(s)%ftid_parb(ifp,:), & ! Down diffuse flux below canopy per unit direct at top + bc_out(s)%ftii_parb(ifp,:)) ! Down diffuse flux below canopy per unit diffuse at top + + case(twostr_solver) + + associate( twostr => currentPatch%twostr) + + !call twostr%CanopyPrep(bc_in(s)%fcansno_pa(ifp)) + !call twostr%ZenithPrep(bc_in(s)%coszen_pa(ifp)) + + do ib = 1,num_swb + + twostr%band(ib)%albedo_grnd_diff = bc_in(s)%albgr_dif_rb(ib) + twostr%band(ib)%albedo_grnd_beam = bc_in(s)%albgr_dir_rb(ib) + + call twostr%Solve(ib, & ! in + normalized_upper_boundary, & ! in + 1.0_r8,1.0_r8, & ! in + sites(s)%taulambda_2str, & ! inout (scratch) + sites(s)%omega_2str, & ! inout (scratch) + sites(s)%ipiv_2str, & ! inout (scratch) + bc_out(s)%albd_parb(ifp,ib), & ! out + bc_out(s)%albi_parb(ifp,ib), & ! out + currentPatch%rad_error(ib), & ! out + bc_out(s)%fabd_parb(ifp,ib), & ! out + bc_out(s)%fabi_parb(ifp,ib), & ! out + bc_out(s)%ftdd_parb(ifp,ib), & ! out + bc_out(s)%ftid_parb(ifp,ib), & ! out + bc_out(s)%ftii_parb(ifp,ib)) + + if(debug) then + currentPatch%twostr%band(ib)%Rbeam_atm = 1._r8 + currentPatch%twostr%band(ib)%Rdiff_atm = 1._r8 + call CheckPatchRadiationBalance(currentPatch, sites(s)%snow_depth, & + ib, bc_out(s)%fabd_parb(ifp,ib),bc_out(s)%fabi_parb(ifp,ib)) + currentPatch%twostr%band(ib)%Rbeam_atm = fates_unset_r8 + currentPatch%twostr%band(ib)%Rdiff_atm = fates_unset_r8 + + if(bc_out(s)%fabi_parb(ifp,ib)>1.0 .or. bc_out(s)%fabd_parb(ifp,ib)>1.0)then + write(fates_log(),*) 'absorbed fraction > 1.0?' + write(fates_log(),*) ifp,ib,bc_out(s)%fabi_parb(ifp,ib),bc_out(s)%fabd_parb(ifp,ib) + call twostr%Dump(ib,lat=sites(s)%lat,lon=sites(s)%lon) + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + end do + end associate + + end select + + end if if_nrad + + endif if_zenith_flag + end if if_notbareground + + currentPatch => currentPatch%younger + end do ! Loop linked-list patches + enddo ! Loop Sites + + return + end subroutine FatesNormalizedCanopyRadiation + + ! ====================================================================================== + + subroutine FatesSunShadeFracs(nsites, sites,bc_in,bc_out) + + implicit none + + ! Arguments + integer,intent(in) :: nsites + type(ed_site_type),intent(inout),target :: sites(nsites) + type(bc_in_type),intent(in) :: bc_in(nsites) + type(bc_out_type),intent(inout) :: bc_out(nsites) + + ! locals + type (fates_patch_type),pointer :: cpatch ! c"urrent" patch + real(r8) :: sunlai + real(r8) :: shalai + real(r8) :: elai + integer :: cl,ft + integer :: iv,ib + integer :: s + integer :: ifp + integer :: nv + integer :: icol + ! Fraction of the canopy area associated with each pft and layer + ! (used for weighting diagnostics) + real(r8) :: area_vlpfcl(nlevleaf,maxpft,nclmax) + real(r8) :: vai_top,vai_bot + real(r8) :: area_frac + real(r8) :: Rb_abs,Rd_abs,Rd_abs_leaf,Rb_abs_leaf,R_abs_stem,R_abs_snow,leaf_sun_frac + real(r8) :: vai + + do s = 1,nsites + + ifp = 0 + cpatch => sites(s)%oldest_patch + + do while (associated(cpatch)) + + if_notbareground:if(cpatch%nocomp_pft_label.ne.nocomp_bareground)then !only for veg patches + ! do not do albedo calculations for bare ground patch in SP mode + ! and (more impotantly) do not iterate ifp or it will mess up the indexing wherein + ! ifp=1 is the first vegetated patch. + ifp=ifp+1 + + ! Initialize diagnostics + cpatch%ed_parsun_z(:,:,:) = 0._r8 + cpatch%ed_parsha_z(:,:,:) = 0._r8 + cpatch%ed_laisun_z(:,:,:) = 0._r8 + cpatch%ed_laisha_z(:,:,:) = 0._r8 + cpatch%parprof_pft_dir_z(:,:,:) = 0._r8 + cpatch%parprof_pft_dif_z(:,:,:) = 0._r8 + + bc_out(s)%fsun_pa(ifp) = 0._r8 + + ! preserve_b4b will be removed soon. This is kept here to prevent + ! round off errors in the baseline tests for the two-stream code (RGK 12-27-23) + if(.not.preserve_b4b)then + bc_out(s)%laisun_pa(ifp) = 0._r8 + bc_out(s)%laisha_pa(ifp) = calc_areaindex(cpatch,'elai') + end if + + sunlai = 0._r8 + shalai = 0._r8 + if_norm_twostr: if (radiation_model.eq.norman_solver) then + + ! Loop over patches to calculate laisun_z and laisha_z for each layer. + ! Derive canopy laisun, laisha, and fsun from layer sums. + ! If sun/shade big leaf code, nrad=1 and fsun_z(p,1) and tlai_z(p,1) from + ! SurfaceAlbedo is canopy integrated so that layer value equals canopy value. + + ! cpatch%f_sun is calculated in the surface_albedo routine... + + do cl = 1, cpatch%ncl_p + do ft = 1,numpft + ! preserve_b4b will be removed soon. This is kept here to prevent + ! round off errors in the baseline tests for the two-stream code (RGK 12-27-23) + if(.not.preserve_b4b) then + sunlai = sunlai + sum(cpatch%elai_profile(cl,ft,1:cpatch%nrad(cl,ft)) * & + cpatch%f_sun(cl,ft,1:cpatch%nrad(cl,ft))) + shalai = shalai + sum(cpatch%elai_profile(cl,ft,1:cpatch%nrad(cl,ft))) + else + do iv = 1,cpatch%nrad(cl,ft) + cpatch%ed_laisun_z(CL,ft,iv) = cpatch%elai_profile(CL,ft,iv) * & + cpatch%f_sun(CL,ft,iv) + + cpatch%ed_laisha_z(CL,ft,iv) = cpatch%elai_profile(CL,ft,iv) * & + (1._r8 - cpatch%f_sun(CL,ft,iv)) + + end do + + !needed for the VOC emissions, etc. + sunlai = sunlai + sum(cpatch%ed_laisun_z(CL,ft,1:cpatch%nrad(CL,ft))) + shalai = shalai + sum(cpatch%ed_laisha_z(CL,ft,1:cpatch%nrad(CL,ft))) + + end if + end do + end do + ! preserve_b4b will be removed soon. This is kept here to prevent + ! round off errors in the baseline tests for the two-stream code (RGK 12-27-23) + if(.not.preserve_b4b)then + shalai = shalai-sunlai + end if + + if(sunlai+shalai > 0._r8)then + bc_out(s)%fsun_pa(ifp) = sunlai / (sunlai+shalai) + else + bc_out(s)%fsun_pa(ifp) = 0._r8 + endif + + if(debug)then + if(bc_out(s)%fsun_pa(ifp) > 1._r8)then + write(fates_log(),*) 'too much leaf area in profile', bc_out(s)%fsun_pa(ifp), & + sunlai,shalai + endif + end if + + elai = calc_areaindex(cpatch,'elai') + + bc_out(s)%laisun_pa(ifp) = elai*bc_out(s)%fsun_pa(ifp) + bc_out(s)%laisha_pa(ifp) = elai*(1.0_r8-bc_out(s)%fsun_pa(ifp)) + + ! Absorbed PAR profile through canopy + ! If sun/shade big leaf code, nrad=1 and fluxes from SurfaceAlbedo + ! are canopy integrated so that layer values equal big leaf values. + + do cl = 1, cpatch%ncl_p + do ft = 1,numpft + do iv = 1, cpatch%nrad(cl,ft) + + cpatch%ed_parsun_z(cl,ft,iv) = & + bc_in(s)%solad_parb(ifp,ipar)*cpatch%fabd_sun_z(cl,ft,iv) + & + bc_in(s)%solai_parb(ifp,ipar)*cpatch%fabi_sun_z(cl,ft,iv) + + cpatch%ed_parsha_z(cl,ft,iv) = & + bc_in(s)%solad_parb(ifp,ipar)*cpatch%fabd_sha_z(cl,ft,iv) + & + bc_in(s)%solai_parb(ifp,ipar)*cpatch%fabi_sha_z(cl,ft,iv) + + end do !iv + end do !ft + end do !cl + + ! Convert normalized radiation error units from fraction of radiation to W/m2 + do ib = 1,num_swb + cpatch%rad_error(ib) = cpatch%rad_error(ib) * & + (bc_in(s)%solad_parb(ifp,ib) + bc_in(s)%solai_parb(ifp,ib)) + end do + + ! output the actual PAR profiles through the canopy for diagnostic purposes + do cl = 1, cpatch%ncl_p + do ft = 1,numpft + do iv = 1, cpatch%nrad(cl,ft) + cpatch%parprof_pft_dir_z(cl,ft,iv) = (bc_in(s)%solad_parb(ifp,ipar) * & + cpatch%nrmlzd_parprof_pft_dir_z(idirect,cl,ft,iv)) + & + (bc_in(s)%solai_parb(ifp,ipar) * & + cpatch%nrmlzd_parprof_pft_dir_z(idiffuse,cl,ft,iv)) + + cpatch%parprof_pft_dif_z(cl,ft,iv) = (bc_in(s)%solad_parb(ifp,ipar) * & + cpatch%nrmlzd_parprof_pft_dif_z(idirect,cl,ft,iv)) + & + (bc_in(s)%solai_parb(ifp,ipar) * & + cpatch%nrmlzd_parprof_pft_dif_z(idiffuse,cl,ft,iv)) + + end do ! iv + end do ! ft + end do ! cl + + else + + ! If there is no sun out, we have a trivial solution + if_zenithflag: if(cpatch%solar_zenith_flag ) then + + ! Two-stream + ! ----------------------------------------------------------- + do ib = 1,num_swb + cpatch%twostr%band(ib)%Rbeam_atm = bc_in(s)%solad_parb(ifp,ib) + cpatch%twostr%band(ib)%Rdiff_atm = bc_in(s)%solai_parb(ifp,ib) + end do + + area_vlpfcl(:,:,:) = 0._r8 + cpatch%f_sun(:,:,:) = 0._r8 + + call FatesPatchFSun(cpatch, & + bc_out(s)%fsun_pa(ifp), & + bc_out(s)%laisun_pa(ifp), & + bc_out(s)%laisha_pa(ifp)) + + associate(twostr => cpatch%twostr) + + do_cl: do cl = 1,twostr%n_lyr + do_icol: do icol = 1,twostr%n_col(cl) + + ft = twostr%scelg(cl,icol)%pft + if_notair: if (ft>0) then + area_frac = twostr%scelg(cl,icol)%area + vai = twostr%scelg(cl,icol)%sai+twostr%scelg(cl,icol)%lai + nv = minloc(dlower_vai, DIM=1, MASK=(dlower_vai>vai)) + do iv = 1, nv + + vai_top = dlower_vai(iv)-dinc_vai(iv) + vai_bot = min(dlower_vai(iv),twostr%scelg(cl,icol)%sai+twostr%scelg(cl,icol)%lai) + + cpatch%parprof_pft_dir_z(cl,ft,iv) = cpatch%parprof_pft_dir_z(cl,ft,iv) + & + area_frac*twostr%GetRb(cl,icol,ivis,vai_top) + cpatch%parprof_pft_dif_z(cl,ft,iv) = cpatch%parprof_pft_dif_z(cl,ft,iv) + & + area_frac*twostr%GetRdDn(cl,icol,ivis,vai_top) + & + area_frac*twostr%GetRdUp(cl,icol,ivis,vai_top) + + call twostr%GetAbsRad(cl,icol,ipar,vai_top,vai_bot, & + Rb_abs,Rd_abs,Rd_abs_leaf,Rb_abs_leaf,R_abs_stem,R_abs_snow,leaf_sun_frac) + + cpatch%f_sun(cl,ft,iv) = cpatch%f_sun(cl,ft,iv) + & + area_frac*leaf_sun_frac + cpatch%ed_parsun_z(cl,ft,iv) = cpatch%ed_parsun_z(cl,ft,iv) + & + area_frac*(rd_abs_leaf*leaf_sun_frac + rb_abs_leaf) + cpatch%ed_parsha_z(cl,ft,iv) = cpatch%ed_parsha_z(cl,ft,iv) + & + area_frac*rd_abs_leaf*(1._r8-leaf_sun_frac) + + area_vlpfcl(iv,ft,cl) = area_vlpfcl(iv,ft,cl) + area_frac + end do + end if if_notair + end do do_icol + + do ft = 1,numpft + do_iv: do iv = 1, nlevleaf + if(area_vlpfcl(iv,ft,cl) cpatch%younger + enddo + + + enddo + return + + end subroutine FatesSunShadeFracs + +end module FatesRadiationDriveMod diff --git a/radiation/FatesRadiationMemMod.F90 b/radiation/FatesRadiationMemMod.F90 new file mode 100644 index 0000000000..6927c6bf3c --- /dev/null +++ b/radiation/FatesRadiationMemMod.F90 @@ -0,0 +1,61 @@ +Module FatesRadiationMemMod + + ! --------------------------------------------------------------------------- + ! This module is a space that holds data that defines how + ! FATES in particular uses its radiation schemes. + ! + ! Alternatively, the TwoStreamMLPEMod is more agnostic. + ! For instance, TwoStreamMLPEMod makes no assumptions about + ! which or how many broad bands are used + ! + ! For now, this module also holds relevant data for Norman radiation + ! --------------------------------------------------------------------------- + + use FatesConstantsMod, only : r8 => fates_r8 + + integer, parameter, public :: norman_solver = 1 + integer, parameter, public :: twostr_solver = 2 + + integer, parameter, public :: num_rad_stream_types = 2 ! The number of radiation streams used (direct/diffuse) + + integer, parameter, public :: idirect = 1 ! This is the array index for direct radiation + integer, parameter, public :: idiffuse = 2 ! This is the array index for diffuse radiation + + + ! TODO: we use this cp_maxSWb only because we have a static array q(size=2) of + ! land-ice abledo for vis and nir. This should be a parameter, which would + ! get us on track to start using multi-spectral or hyper-spectral (RGK 02-2017) + + integer, parameter, public :: num_swb = 2 ! Number of shortwave bands we use + ! This needs to match what is used in the host model + ! This is visible (1) and near-infrared (2) + + integer, parameter, public :: ivis = 1 ! This is the array index for short-wave + ! radiation in the visible spectrum, as expected + ! in boundary condition files and parameter + ! files. This will be compared with + ! the HLM's expectation in FatesInterfaceMod + + integer, parameter, public :: inir = 2 ! This is the array index for short-wave + ! radiation in the near-infrared spectrum, as expected + ! in boundary condition files and parameter + ! files. This will be compared with + ! the HLM's expectation in FatesInterfaceMod + + integer, parameter, public :: ipar = ivis ! The photosynthetically active band + ! can be approximated to be equal to the visible band + + ! albedo land ice by waveband (1=vis, 2=nir) + real(r8), public :: alb_ice(num_swb) = (/ 0.80_r8, 0.55_r8 /) + + ! albedo land ice by waveband (1=vis, 2=nir) + real(r8), public :: rho_snow(num_swb) = (/ 0.80_r8, 0.55_r8 /) + + ! albedo land ice by waveband (1=vis, 2=nir) + real(r8), public :: tau_snow(num_swb) = (/ 0.01_r8, 0.01_r8 /) + + + + + +end Module FatesRadiationMemMod diff --git a/radiation/FatesTwoStreamUtilsMod.F90 b/radiation/FatesTwoStreamUtilsMod.F90 new file mode 100644 index 0000000000..5a87ff24b0 --- /dev/null +++ b/radiation/FatesTwoStreamUtilsMod.F90 @@ -0,0 +1,534 @@ +Module FatesTwoStreamUtilsMod + + ! This module holds routines that are specific to connecting FATES with + ! the two-stream radiation module. These routines are used to + ! describe the scattering elements from cohort and patch data, and are + ! used to decompose the scattering elements to return values + ! at the cohort, or patch-pft scale. + use FatesConstantsMod , only : r8 => fates_r8 + use FatesConstantsMod , only : ifalse + use FatesConstantsMod , only : itrue + 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 shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + use FatesInterfaceTypesMod, only : numpft + use FatesRadiationMemMod , only : num_swb + use FatesRadiationMemMod , only : ivis, inir + use FatesRadiationMemMod , only : rho_snow,tau_snow + use TwoStreamMLPEMod , only : air_ft, AllocateRadParams, rad_params + use FatesCohortMod , only : fates_cohort_type + use FatesPatchMod , only : fates_patch_type + use EDTypesMod , only : ed_site_type + use EDParamsMod , only : nclmax + use TwoStreamMLPEMod , only : twostream_type + use TwoStreamMLPEMod , only : RadParamPrep + use TwoStreamMLPEMod , only : AllocateRadParams + use TwoStreamMLPEMod , only : rel_err_thresh,area_err_thresh + use EDPftvarcon , only : EDPftvarcon_inst + use FatesAllometryMod , only : VegAreaLayer + + implicit none + + logical, parameter :: debug = .false. ! local debug flag + character(len=*), parameter, private :: sourcefile = & + __FILE__ + + + public :: FatesConstructRadElements + public :: FatesGetCohortAbsRad + public :: FatesPatchFSun + public :: CheckPatchRadiationBalance + +contains + + + subroutine FatesConstructRadElements(site,fcansno_pa,coszen_pa) + + type(ed_site_type) :: site + type(fates_patch_type),pointer :: patch + real(r8) :: fcansno_pa(:) + real(r8) :: coszen_pa(:) + + type(fates_cohort_type), pointer :: cohort + integer :: n_col(nclmax) ! Number of parallel column elements per layer + integer :: ican,ft,icol + type(twostream_type), pointer :: twostr + + + ! DO NOT MAKE CANOPY_OPEN_FRAC >0 UNTIL LAI COMPRESSION + ! HAS BEEN THOUGHT THROUGH. WE CANT JUST DECREASE THE + ! AREA WITHOUT CONSERVING TOTAL LEAF AND STEM AREA + real(r8), parameter :: canopy_open_frac = 0.00_r8 + + integer :: maxcol + real(r8) :: canopy_frac(5) + integer :: ifp + ! Area indices for the cohort [m2 media / m2 crown footprint] + real(r8) :: elai_cohort,tlai_cohort,esai_cohort,tsai_cohort + real(r8) :: vai_top,vai_bot ! veg area index at top and bottom of cohort (dummy vars) + + real(r8) :: area_ratio ! If elements are over 100% of available + ! canopy area, this is how much we squeeze + ! the area down by, as a ratio. This is also + ! applied to increase LAI and SAI in the cohorts + ! and elements as well (to preserve mass and volume). + + integer :: max_elements ! Maximum number of scattering elements on the site + integer :: n_scr ! The size of the scratch arrays + logical :: allocate_scratch ! Whether to re-allocate the scratch arrays + + ! These parameters are not used yet + !real(r8) :: max_vai_diff_per_elem ! The maximum vai difference in any element + ! ! between the least and most vai of constituting + ! ! cohorts. THe objective is to reduce this. + !integer, parameter :: max_el_per_layer = 10 + !real(r8), parameter :: init_max_vai_diff_per_elem = 0.2_r8 + !type(fates_cohort_type), pointer :: elem_co_ptrs(ncl*max_el_per_layer,100) + + + + + max_elements = -1 + ifp=0 + patch => site%oldest_patch + do while (associated(patch)) + ifp=ifp+1 + associate(twostr => patch%twostr) + + ! Identify how many elements we need, and possibly consolidate + ! cohorts into elements where they are very similar (LAI and PFT) + ! ------------------------------------------------------------------------------------------- + + !max_vai_diff_per_elem = init_max_vai_diff_per_elem + !iterate_count_do: do while(iterate_element_count)then + + ! Identify how many elements we need + n_col(1:nclmax) = 0 + cohort => patch%tallest + do while (associated(cohort)) + ft = cohort%pft + ican = cohort%canopy_layer + n_col(ican) = n_col(ican) + 1 + cohort => cohort%shorter + enddo + + ! If there is only one layer, then we don't + ! need to add an air element to the only + ! layer. This is because all non-veg + ! area will be attributed to a ground patch + ! But if there is more than one layer, then + ! an air element is needed for all the non + ! occupied space, even if the canopy_open_frac + ! is zero. + + if(patch%total_canopy_area>nearzero)then + canopy_frac(:) = 0._r8 + cohort => patch%tallest + do while (associated(cohort)) + ican = cohort%canopy_layer + canopy_frac(ican) = canopy_frac(ican) + cohort%c_area/patch%total_canopy_area + cohort => cohort%shorter + enddo + else + canopy_frac(:) = 0._r8 + end if + + do ican = 1,patch%ncl_p + if( (1._r8-canopy_frac(ican))>area_err_thresh ) then + n_col(ican) = n_col(ican) + 1 + end if + end do + + + ! Handle memory + ! If the two-stream object is not large enough + ! or if it is way larger than what is needed + ! re-allocate the object + ! ------------------------------------------------------------------------------------------- + + maxcol = 0 + do ican = 1,patch%ncl_p + if (n_col(ican)>maxcol) maxcol=n_col(ican) + end do + + if(.not.associated(twostr%scelg)) then + + call twostr%AllocInitTwoStream((/ivis,inir/),patch%ncl_p,maxcol+2) + + else + + if(ubound(twostr%scelg,2) < maxcol .or. & + ubound(twostr%scelg,2) > (maxcol+4) .or. & + ubound(twostr%scelg,1) < patch%ncl_p ) then + + call twostr%DeallocTwoStream() + + ! Add a little more space than necessary so + ! we don't have to keep allocating/deallocating + call twostr%AllocInitTwoStream((/ivis,inir/),patch%ncl_p,maxcol+2) + + end if + + end if + + + ! Fill the elements with their basic data and + ! reference the cohort to the elements + ! ------------------------------------------------------------------------------------------- + + n_col(1:nclmax) = 0 + cohort => patch%tallest + do while (associated(cohort)) + + ft = cohort%pft + ican = cohort%canopy_layer + + patch%canopy_mask(ican,ft) = 1 + + ! Every cohort gets its own element right now + n_col(ican) = n_col(ican)+1 + + ! If we pass layer index 0 to this routine + ! it will return the total plant LAIs and SAIs + call VegAreaLayer(cohort%treelai, & + cohort%treesai, & + cohort%height, & + 0, & + cohort%nv, & + cohort%pft, & + site%snow_depth, & + vai_top, vai_bot, & + elai_cohort,esai_cohort) + + ! Its possible that this layer is covered by snow + ! if so, then just consider it an air layer + if((elai_cohort+esai_cohort)>nearzero)then + twostr%scelg(ican,n_col(ican))%pft = ft + else + twostr%scelg(ican,n_col(ican))%pft = air_ft + end if + + twostr%scelg(ican,n_col(ican))%area = cohort%c_area/patch%total_canopy_area + twostr%scelg(ican,n_col(ican))%lai = elai_cohort + twostr%scelg(ican,n_col(ican))%sai = esai_cohort + + ! Cohort needs to know which column its in + cohort%twostr_col = n_col(ican) + + cohort => cohort%shorter + enddo + + + do ican = 1,patch%ncl_p + + ! If the canopy is not full, add an air element + if( (1._r8-canopy_frac(ican))>area_err_thresh ) then + n_col(ican) = n_col(ican) + 1 + twostr%scelg(ican,n_col(ican))%pft = air_ft + twostr%scelg(ican,n_col(ican))%area = 1._r8-canopy_frac(ican) + twostr%scelg(ican,n_col(ican))%lai = 0._r8 + twostr%scelg(ican,n_col(ican))%sai = 0._r8 + end if + + ! If the layer is overfull, remove some from area from + ! the first element that is 10x larger than the threshold + + if_overfull: if( (canopy_frac(ican)-1._r8)>area_err_thresh ) then + do icol = 1,n_col(ican) + if(twostr%scelg(ican,icol)%area > 10._r8*(canopy_frac(ican)-1._r8))then + area_ratio = (twostr%scelg(ican,icol)%area + (1._r8-canopy_frac(ican)))/twostr%scelg(ican,icol)%area + twostr%scelg(ican,icol)%area = twostr%scelg(ican,icol)%area * area_ratio + twostr%scelg(ican,icol)%lai = twostr%scelg(ican,icol)%lai / area_ratio + twostr%scelg(ican,icol)%sai = twostr%scelg(ican,icol)%sai / area_ratio + canopy_frac(ican) = 1.0_r8 + exit if_overfull + end if + end do + + !write(fates_log(),*) 'overfull areas' + !twostr%cosz = coszen_pa(ifp) + ! call twostr%Dump(1,lat=site%lat,lon=site%lon) + ! call endrun(msg=errMsg(sourcefile, __LINE__)) + end if if_overfull + + end do + + twostr%n_col(1:patch%ncl_p) = n_col(1:patch%ncl_p) + + ! Set up some non-element parameters + ! ------------------------------------------------------------------------------------------- + + twostr%n_lyr = patch%ncl_p ! Number of layers + + call twostr%GetNSCel() ! Total number of elements + + max_elements = max(max_elements,twostr%n_scel) + + twostr%force_prep = .true. ! This signals that two-stream scattering coefficients + + ! that are dependent on geometry need to be updated + call twostr%CanopyPrep(fcansno_pa(ifp)) + call twostr%ZenithPrep(coszen_pa(ifp)) + + end associate + + patch => patch%younger + end do + + ! Re-evaluate the scratch space used for solving two-stream radiation + ! The scratch space needs to be 2x the number of computational elements + ! for the patch with the most elements. + + if(allocated(site%taulambda_2str) .and. max_elements>0 )then + n_scr = ubound(site%taulambda_2str,dim=1) + allocate_scratch = .false. + if(2*max_elements > n_scr) then + allocate_scratch = .true. + deallocate(site%taulambda_2str,site%ipiv_2str,site%omega_2str) + elseif(2*max_elements < (n_scr-24)) then + allocate_scratch = .true. + deallocate(site%taulambda_2str,site%ipiv_2str,site%omega_2str) + end if + else + allocate_scratch = .true. + end if + + if(allocate_scratch)then + ! Twice as many spaces as there are elements, plus some + ! extra to prevent allocating/deallocating on the next step + n_scr = 2*max_elements+8 + allocate(site%taulambda_2str(n_scr)) + allocate(site%omega_2str(n_scr,n_scr)) + allocate(site%ipiv_2str(n_scr)) + end if + + return + end subroutine FatesConstructRadElements + + ! ============================================================================================= + + subroutine FatesPatchFSun(patch,fsun,laisun,laisha) + + type(fates_patch_type) :: patch + real(r8) :: fsun ! Patch average sunlit fraction + real(r8) :: laisun ! Patch average LAI of leaves in sun + real(r8) :: laisha ! Patch average LAI of leaves in shade + + integer :: ican, icol ! Canopy vertical and horizontal element index + + ! Dummy variables + real(r8) :: Rb_abs,Rd_abs,Rd_abs_leaf,Rb_abs_leaf,R_abs_stem,R_abs_snow + + real(r8) :: leaf_sun_frac ! Element specific sunlit fraction of leaf + real(r8) :: in_fab + + laisun = 0._r8 + laisha = 0._r8 + + associate(twostr => patch%twostr) + + + do ican = 1,twostr%n_lyr + do icol = 1,twostr%n_col(ican) + + associate(scelg => patch%twostr%scelg(ican,icol)) + + call twostr%GetAbsRad(ican,icol,ivis,0._r8,scelg%lai+scelg%sai, & + Rb_abs,Rd_abs,Rd_abs_leaf,Rb_abs_leaf,R_abs_stem,R_abs_snow,leaf_sun_frac) + + laisun = laisun + scelg%area*scelg%lai*leaf_sun_frac + laisha = laisha + scelg%area*scelg%lai*(1._r8-leaf_sun_frac) + end associate + end do + end do + + if((laisun+laisha)>nearzero)then + fsun = laisun / (laisun+laisha) + else + fsun = 0.5_r8 ! Nominal value, should not affect results if no leaves or light! + end if + + end associate + return + end subroutine FatesPatchFSun + + ! ============================================================================================ + + subroutine CheckPatchRadiationBalance(patch, snow_depth, ib, fabd, fabi) + + ! Loop through the cohorts in the patch, get the + ! absorbed radiation, then compare the amount absorbed + ! to the fraction the solver calculated + + type(fates_patch_type) :: patch + integer :: ib ! broadband index + real(r8) :: snow_depth + real(r8) :: fabd ! Fraction of absorbed direct radiation by vegetation + real(r8) :: fabi ! Fraction of absorbed indirect radiation by vegetation + + type(fates_cohort_type), pointer :: cohort + integer :: iv,ican,icol + real(r8),dimension(50) :: cohort_vaitop + real(r8),dimension(50) :: cohort_vaibot + real(r8),dimension(50) :: cohort_layer_elai + real(r8),dimension(50) :: cohort_layer_esai + real(r8) :: cohort_elai + real(r8) :: cohort_esai + real(r8) :: rb_abs,rd_abs,rb_abs_leaf,rd_abs_leaf,leaf_sun_frac,check_fab,in_fab + + associate(twostr => patch%twostr) + + check_fab = 0._r8 + + cohort => patch%tallest + do while (associated(cohort)) + + do iv = 1,cohort%nv + call VegAreaLayer(cohort%treelai, & + cohort%treesai, & + cohort%height, & + iv, & + cohort%nv, & + cohort%pft, & + snow_depth, & + cohort_vaitop(iv), & + cohort_vaibot(iv), & + cohort_layer_elai(iv), & + cohort_layer_esai(iv)) + end do + + cohort_elai = sum(cohort_layer_elai(1:cohort%nv)) + cohort_esai = sum(cohort_layer_esai(1:cohort%nv)) + + do iv = 1,cohort%nv + + ican = cohort%canopy_layer + icol = cohort%twostr_col + + call FatesGetCohortAbsRad(patch,cohort,ib,cohort_vaitop(iv),cohort_vaibot(iv), & + cohort_elai,cohort_esai,rb_abs,rd_abs,rb_abs_leaf,rd_abs_leaf,leaf_sun_frac ) + + check_fab = check_fab + (Rb_abs+Rd_abs) * cohort%c_area/patch%total_canopy_area + + end do + cohort => cohort%shorter + enddo + + in_fab = fabd*twostr%band(ib)%Rbeam_atm + fabi*twostr%band(ib)%Rdiff_atm + + if( abs(check_fab-in_fab) > in_fab*10._r8*rel_err_thresh ) then + write(fates_log(),*)'Absorbed radiation didnt balance after cohort sum' + write(fates_log(),*) ib,in_fab,check_fab,snow_depth + call twostr%Dump(ib,patch%solar_zenith_angle) + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + + end associate + + return + end subroutine CheckPatchRadiationBalance + + ! ============================================================================================= + + subroutine FatesGetCohortAbsRad(patch,cohort,ib,vaitop,vaibot,cohort_elai,cohort_esai, & + rb_abs,rd_abs,rb_abs_leaf,rd_abs_leaf,leaf_sun_frac ) + + ! This subroutine retrieves the absorbed radiation on + ! leaves and stems, as well as the leaf sunlit fraction + ! over a specified interval of VAI (vegetation area index) + ! VAI is exposed leaf + stem area index + + type(fates_patch_type) :: patch + type(fates_cohort_type) :: cohort + integer,intent(in) :: ib + real(r8),intent(in) :: vaitop + real(r8),intent(in) :: vaibot + real(r8),intent(in) :: cohort_elai + real(r8),intent(in) :: cohort_esai + real(r8),intent(out) :: rb_abs + real(r8),intent(out) :: rd_abs + real(r8),intent(out) :: rb_abs_leaf + real(r8),intent(out) :: rd_abs_leaf + real(r8),intent(out) :: leaf_sun_frac + + real(r8) :: rd_abs_el,rb_abs_el + real(r8) :: vai_top_el + real(r8) :: vai_bot_el + real(r8) :: rd_abs_leaf_el + real(r8) :: rb_abs_leaf_el + real(r8) :: r_abs_stem_el + real(r8) :: r_abs_snow_el + real(r8) :: diff_wt_leaf,diff_wt_elem + real(r8) :: beam_wt_leaf,beam_wt_elem + real(r8) :: evai_cvai ! element VAI / cohort VAI + + associate(scelg => patch%twostr%scelg(cohort%canopy_layer,cohort%twostr_col), & + scelb => patch%twostr%band(ib)%scelb(cohort%canopy_layer,cohort%twostr_col) ) + + if((cohort_elai+cohort_esai) shr_log_errMsg + use shr_sys_mod , only: shr_sys_abort + use FatesConstantsMod, only : r8 => fates_r8 + use shr_infnan_mod, only : shr_infnan_isnan + + implicit none + private + + real(r8),parameter :: nearzero = 1.e-20_r8 + logical, parameter :: debug=.true. + real(r8), parameter :: unset_r8 = 1.e-36_r8 + real(r8), parameter :: unset_int = -999 + integer, parameter :: twostr_vis = 1 ! Named index of visible shortwave radiation + integer, parameter :: twostr_nir = 2 ! Named index for near infrared shortwave radiation + + + ! Allowable error, as a fraction of total incident for total canopy + ! radiation balance checks + + real(r8), public, parameter :: rel_err_thresh = 1.e-6_r8 + real(r8), public, parameter :: area_err_thresh = rel_err_thresh*0.1_r8 + + ! These are the codes for how the upper boundary is specified, normalized or absolute + integer,public, parameter :: normalized_upper_boundary = 1 + integer,public, parameter :: absolute_upper_boundary = 2 + + integer :: log_unit ! fortran output unit for logging + + ! These are parameter constants, ie things that are specific to the plant material + ! and radiation band. Not all of these need to be used. 2-stream ultimately wants + ! optical depth, scattering coefficient and backscatter fractions for diffuse and + ! direct light. So there are various ways to get to these parameters, depending + ! on the host model's available parameters. The rho,tau,xl and clumping parameters + ! are standard elm/clm parameters, and provided as a convenience. + + + ! Snow optical parameter constants for visible (index=1) and NIR (index=2) + + real(r8), parameter :: betad_snow(1:2) = (/0.5, 0.5/) ! Diffuse backscatter fraction (CLM50 Tech Man) + real(r8), parameter :: betab_snow(1:2) = (/0.5, 0.5/) ! Beam backscatter fraction (CLM50 Tech Man) + real(r8), parameter :: om_snow(1:2) = (/0.8, 0.4/) ! Scattering coefficient for snow (CLM50 Tech Man) + !real(r8), parameter :: om_snow(1:2) = (/0.85, 0.75/) ! Tarboton 95 + + ! Cap the maximum optical depth. After 30 or so, its + ! so close to zero, if the values get too large, then + ! it will blow up the exponents and cause math problems + + real(r8), parameter :: kb_max = 30._r8 + + + ! For air, use a nominal values to prevent div0s + ! the key is that vai = 0 + + real(r8), parameter :: k_air = 0.5_r8 + real(r8), parameter :: om_air = 0.5_r8 + real(r8), parameter :: beta_air = 0.5_r8 + integer, public, parameter :: air_ft = 0 + + type, public :: rad_params_type + + ! From the parameter file + real(r8), allocatable :: rhol(:,:) ! leaf material reflectance: (band x pft) + real(r8), allocatable :: rhos(:,:) ! stem material reflectance: (band x pft) + real(r8), allocatable :: taul(:,:) ! leaf material transmittance: (band x pft) + real(r8), allocatable :: taus(:,:) ! stem material transmittance: (band x pft) + real(r8), allocatable :: xl(:) ! leaf/stem orientation (pft) + real(r8), allocatable :: clumping_index(:) ! clumping index 0-1, when + ! leaves stick together (pft) + + ! Derived parameters + real(r8), allocatable :: phi1(:) ! intermediate term for kd and kb + real(r8), allocatable :: phi2(:) ! intermediate term for kd and kb + real(r8), allocatable :: avmu(:) ! average "av" inverse optical depth "mu" per unit leaf and stem area + real(r8), allocatable :: kd_leaf(:) ! Mean optical depth per unit area leaves in diffuse + real(r8), allocatable :: kd_stem(:) ! Mean optical depth per unit area stems in diffuse + real(r8), allocatable :: om_leaf(:,:) ! Leaf scattering coefficient (band x pft) + real(r8), allocatable :: om_stem(:,:) ! Stem scattering coefficient (band x pft) + end type rad_params_type + + type(rad_params_type),public :: rad_params + + + ! Information describing the scattering elements + ! that is based on "g"eometry, and independent of wavelength + + type scelg_type + integer :: pft ! pft index + real(r8) :: area ! m2 col/m2 ground + real(r8) :: lai ! m2 of leaf area / m2 col + real(r8) :: sai ! m2 of stem area / m2 col + real(r8) :: Kb ! Optical depth of beam radiation + real(r8) :: Kb_leaf ! Optical depth of just leaves in beam radiation + real(r8) :: Kd ! Optical depth of diffuse radiation + real(r8) :: area_squeeze ! This is the ratio of the element area to the + ! the area of its constituents. Ideally this + ! should be 1.0, but if the host model does not + ! do a good job of filling up a canopy with 100% space, + ! and instead is fractionally more than 100%, we must + ! squeeze the area of 1 or more elements to get an exact + ! space usage. + end type scelg_type + + + ! Information describing the scattering elemnets that + ! is dependent on wavelengths, ie "b"ands (this is allocated for each broad band) + + type scelb_type + + ! Terms used in the final solution, also used for decomposing solution + real(r8) :: Au ! Compound intercept term + real(r8) :: Ad ! Compound intercept term + real(r8) :: B1 ! Compound term w/ lambdas (operates on e^{av}) + real(r8) :: B2 ! Compound term w/ lambdas (operates on e^{-av}) + real(r8) :: lambda1_diff ! Compount term w/ B for diffuse forcing + real(r8) :: lambda2_diff ! Compound term w/ B for diffuse forcing + real(r8) :: lambda1_beam ! Compount term w/ B for beam forcing + real(r8) :: lambda2_beam ! Compound term w/ B for beam forcing + + real(r8) :: a ! Complex term operating on veg area index + real(r8) :: om ! scattering coefficient for media as a whole + real(r8) :: betad ! backscatter fraction of diffuse radiation for media as a whole + real(r8) :: betab ! backscatter fraction of beam radiation for media as a whole + real(r8) :: Rbeam0 ! Normalized downwelling beam radiation at + ! top of the element (relative to downwelling atmospheric beam) [-] + + end type scelb_type + + + type band_type + + type(scelb_type), pointer :: scelb(:,:) ! array of scattering coefficients (layer, column) + ! can be sparse, will only solve indices up to + integer :: ib ! band index, should be consistent with rad_params + real(r8) :: Rbeam_atm ! Downwelling beam radiation from atmosphere [W/m2 ground] + real(r8) :: Rdiff_atm ! Downwelling diffuse radiation from atmosphere [W/m2 ground] + real(r8) :: albedo_grnd_diff ! Ground albedo diffuse + real(r8) :: albedo_grnd_beam ! Ground albedo direct + + end type band_type + + + ! This type contains the pre-processed scattering coefficients + ! and routines. This is the parent type that holds almost everything + ! in the two-stream solver. + ! The scelg structure describes the scattering elements, these are values + ! that need to be defined by the ecosystem model, somewhat of + ! an input to the solver. Since this is a Perfect Plasticity Approximation + ! enabled system, we partition the scattering media into "columns" and "layers" + ! Layers are canopy layers, think understory, mid-story and upper canopy. Columns + ! are divisions of horizontal space, ie literal columns of space. The current + ! implementation limits this space to media that has uniform scattering coefficients. + ! So there could not be different PFTs in the same column, because they would undoubtedly + ! have different joint scattering coefficients at different height levels in + ! the column. Therefore, every column is connected with a PFT. + + + type, public :: twostream_type + + type(scelg_type), pointer :: scelg(:,:) ! array of scattering elements (layer, column) + ! can be sparse, will only solve indices up to + ! n_lyr,n_col(n_lyr). This is for band (wavelength) + ! independent information + + type(band_type), pointer :: band(:) ! Holds scattering coefficients for each band + ! vis,nir,etc (nothing that emits though, no thermal) + + integer :: n_bands ! number of bands (allocation size of band(:)) + integer :: n_lyr ! number of (vertical) scattering element layers + integer, allocatable :: n_col(:) ! number of (horizontal) scattering element columns per layer + integer :: n_scel ! total number of scattering elements + logical :: force_prep ! Some coefficients are only updated + ! when the canopy composition changes, ie + ! changes in leaf, stem or snow structure. + ! If so, this sets to true, signalling that diffuse + ! scattering coefficients should be updated. + ! Otherwise, we only updated zenith dependent + ! parameters on short sub-daily timesteps + real(r8) :: frac_snow ! Current mean snow-fraction of the canopy + real(r8) :: frac_snow_old ! Previous mean snow-fraction of the canopy + real(r8) :: cosz ! Current cosine of the zenith angle + + contains + + procedure :: ZenithPrep ! Update coefficients as zenith changes + procedure :: CanopyPrep ! Update coefficients as canopy changes + procedure :: Solve ! Perform the scattering solution + procedure :: Dump ! Dump out (print out) the site of interest + procedure :: GetNSCel + procedure :: AllocInitTwoStream + procedure :: DeallocTwoStream + + procedure :: GetRdUp + procedure :: GetRdDn + procedure :: GetRb + procedure :: GetAbsRad + + + end type twostream_type + + public :: RadParamPrep + public :: AllocateRadParams + public :: TwoStreamLogInit + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + + +contains + + subroutine TwoStreamLogInit(log_unit_in) + integer,intent(in) :: log_unit_in + + log_unit = log_unit_in + + end subroutine TwoStreamLogInit + + subroutine endrun(msg) + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Abort the model for abnormal termination + ! This subroutine was derived from CLM's + ! endrun_vanilla() in abortutils.F90 + ! + ! + ! !ARGUMENTS: + implicit none + character(len=*), intent(in) :: msg ! string to be printed + !----------------------------------------------------------------------- + + write(log_unit,*)'ENDRUN:', msg + call shr_sys_abort() + + end subroutine endrun + + + ! =============================================================================================== + + subroutine AllocInitTwoStream(this,band_indices,ncan,ncol) + + class(twostream_type) :: this + integer :: band_indices(:) + integer :: ncan + integer :: ncol + + integer :: nbands + integer :: ib + + nbands = ubound(band_indices,1) + + allocate(this%n_col(ncan)) + allocate(this%scelg(ncan,ncol)) + allocate(this%band(nbands)) + + this%n_col(1:ncan) = unset_int + this%n_bands = nbands + this%n_lyr = ncan + this%frac_snow = unset_r8 + this%frac_snow_old = unset_r8 + + do ib = 1,nbands + + allocate(this%band(ib)%scelb(ncan,ncol)) + this%band(ib)%albedo_grnd_diff = unset_r8 + this%band(ib)%albedo_grnd_beam = unset_r8 + this%band(ib)%ib = band_indices(ib) + + end do + + + + return + end subroutine AllocInitTwoStream + + ! =============================================================================================== + + subroutine DeallocTwoStream(this) + + class(twostream_type) :: this + + integer :: nbands + integer :: ib + + nbands = ubound(this%band,1) + + deallocate(this%scelg) + deallocate(this%n_col) + do ib = 1,nbands + deallocate(this%band(ib)%scelb) + end do + deallocate(this%band) + + return + end subroutine DeallocTwoStream + + ! =============================================================================================== + + subroutine AllocateRadParams(n_pft,n_bands) + + integer,intent(in) :: n_pft + integer,intent(in) :: n_bands + + ! Include the zeroth pft index for air + + allocate(rad_params%rhol(n_bands,n_pft)) + allocate(rad_params%rhos(n_bands,n_pft)) + allocate(rad_params%taul(n_bands,n_pft)) + allocate(rad_params%taus(n_bands,n_pft)) + allocate(rad_params%xl(n_pft)) + allocate(rad_params%clumping_index(n_pft)) + + allocate(rad_params%phi1(n_pft)) + allocate(rad_params%phi2(n_pft)) + allocate(rad_params%avmu(n_pft)) + allocate(rad_params%kd_leaf(n_pft)) + allocate(rad_params%kd_stem(n_pft)) + allocate(rad_params%om_leaf(n_bands,n_pft)) + allocate(rad_params%om_stem(n_bands,n_pft)) + + end subroutine AllocateRadParams + + ! ================================================================================================ + + function GetRdDn(this,ican,icol,ib,vai) result(r_diff_dn) + + class(twostream_type) :: this + real(r8),intent(in) :: vai + integer,intent(in) :: ican + integer,intent(in) :: icol + integer,intent(in) :: ib + real(r8) :: r_diff_dn + + ! Rdn = Ad e−(Kbv) + Re + λ1 B2 e^(av) + λ2 B1 e^(−av) + + associate(scelb => this%band(ib)%scelb(ican,icol), & + scelg => this%scelg(ican,icol) ) + + r_diff_dn = this%band(ib)%Rbeam_atm*( & + scelb%Ad*exp(-scelg%Kb*vai) + & + scelb%B2*scelb%lambda1_beam*exp(scelb%a*vai) + & + scelb%B1*scelb%lambda2_beam*exp(-scelb%a*vai)) + & + this%band(ib)%Rdiff_atm*( & + scelb%B2*scelb%lambda1_diff*exp(scelb%a*vai) + & + scelb%B1*scelb%lambda2_diff*exp(-scelb%a*vai)) + + if(debug)then + ! if(isnan(r_diff_dn))then !RGK: NVHPC HAS A BUG IN THIS INTRINSIC (01-2024) + ! if(r_diff_dn /= r_diff_dn) then + if(shr_infnan_isnan(r_diff_dn)) then + write(log_unit,*)"GETRDN" + write(log_unit,*)scelg%Kb + write(log_unit,*)scelb%a + write(log_unit,*)vai + write(log_unit,*)scelb%Ad + write(log_unit,*)scelb%B1,scelb%B2 + write(log_unit,*)scelb%lambda1_beam,scelb%lambda2_beam + write(log_unit,*)scelb%lambda1_diff,scelb%lambda2_diff + write(log_unit,*)this%band(ib)%Rbeam_atm + write(log_unit,*)this%band(ib)%Rdiff_atm + write(log_unit,*)exp(-scelg%Kb*vai) + write(log_unit,*)exp(scelb%a*vai) + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + end associate + end function GetRdDn + + function GetRdUp(this,ican,icol,ib,vai) result(r_diff_up) + + class(twostream_type) :: this + real(r8),intent(in) :: vai + integer,intent(in) :: ican + integer,intent(in) :: icol + integer,intent(in) :: ib + real(r8) :: r_diff_up + + ! Rup = Au e−(Kbv) + Re + λ1 B1 e^(av) + λ2 B2 e^(−av) + + associate(scelb => this%band(ib)%scelb(ican,icol), & + scelg => this%scelg(ican,icol) ) + + r_diff_up = this%band(ib)%Rbeam_atm*( & + scelb%Au*exp(-scelg%Kb*vai) + & + scelb%B1*scelb%lambda1_beam*exp(scelb%a*vai) + & + scelb%B2*scelb%lambda2_beam*exp(-scelb%a*vai)) + & + this%band(ib)%Rdiff_atm*( & + scelb%B1*scelb%lambda1_diff*exp(scelb%a*vai) + & + scelb%B2*scelb%lambda2_diff*exp(-scelb%a*vai)) + + end associate + end function GetRdUp + + function GetRb(this,ican,icol,ib,vai) result(r_beam_dn) + + class(twostream_type) :: this + real(r8),intent(in) :: vai + integer,intent(in) :: ican + integer,intent(in) :: icol + integer,intent(in) :: ib + real(r8) :: r_beam_dn + + r_beam_dn = this%band(ib)%Rbeam_atm * & + this%band(ib)%scelb(ican,icol)%Rbeam0*exp(-this%scelg(ican,icol)%Kb*vai) + + end function GetRb + + subroutine GetAbsRad(this,ican,icol,ib,vai_top,vai_bot, & + Rb_abs,Rd_abs,Rd_abs_leaf,Rb_abs_leaf,R_abs_stem,R_abs_snow,leaf_sun_frac) + + ! This routine is used to help decompose radiation scattering + ! and return the amount of absorbed radiation. The canopy layer and column + ! index identify the element of interest. The other arguments are the upper and + ! lower bounds within the element over which to evaluate absorbed radiation. + ! The assumption is that the vegetation area index is zero at the top of the + ! element, and increases going downwards. As with all assumptions in this + ! module, the scattering parameters are uniform within the element itself, + ! which includes an assumption of the leaf/stem proportionality. + ! --------------------------------------------------------------------------- + ! Solution for radiative intensity of diffuse up and down at tai=v + ! Rup = Au e−(Kbv) + Re + λ1 B1 e^(av) + λ2 B2 e^(−av) + ! Rdn = Ad e−(Kbv) + Re + λ1 B2 e^(av) + λ2 B1 e^(−av) + ! --------------------------------------------------------------------------- + + ! Arguments + class(twostream_type) :: this + integer,intent(in) :: ican + integer,intent(in) :: icol + integer, intent(in) :: ib ! broad band index + real(r8), intent(in) :: vai_top ! veg area index (from the top of element) to start + real(r8), intent(in) :: vai_bot ! veg area index (from the top of element) to finish + real(r8), intent(out) :: Rb_abs ! total absorbed beam radiation [W/m2 ground] + real(r8), intent(out) :: Rd_abs ! total absorbed diffuse radiation [W/m2 ground] + real(r8), intent(out) :: Rb_abs_leaf ! Absorbed beam radiation from leaves [W/m2 ground] + real(r8), intent(out) :: Rd_abs_leaf ! Absorbed diff radiation from leaves [W/m2 ground] + real(r8), intent(out) :: R_abs_stem ! Absorbed beam+diff radiation stems [W/m2 ground] + real(r8), intent(out) :: R_abs_snow ! Absorbed beam+diff radiation snow [W/m2 ground] + real(r8), intent(out) :: leaf_sun_frac ! Fraction of leaves in the interval exposed + ! to sunlight + + real(r8) :: dvai,dlai ! Amount of VAI and LAI in this interval [m2/m2] + real(r8) :: Rd_net ! Difference in diffuse radiation at upper and lower boundaries [W/m2] + real(r8) :: Rb_net ! Difference in beam radiation at upper and lower boundaries [W/m2] + real(r8) :: vai_max ! total integrated (leaf+stem) area index of the current element + real(r8) :: frac_abs_snow ! fraction of radiation absorbed by snow + real(r8) :: diff_wt_leaf ! diffuse absorption weighting for leaves + real(r8) :: diff_wt_stem ! diffuse absorption weighting for stems + real(r8) :: beam_wt_leaf ! beam absorption weighting for leaves + real(r8) :: beam_wt_stem ! beam absorption weighting for stems + real(r8) :: lai_bot,lai_top + + associate(scelb => this%band(ib)%scelb(ican,icol), & + scelg => this%scelg(ican,icol), & + ft => this%scelg(ican,icol)%pft ) + + ! If this is air, trivial solutions + if(ft==air_ft) then + Rb_abs = 0._r8 + Rd_abs = 0._r8 + Rb_abs_leaf = 0._r8 + Rd_abs_leaf = 0._r8 + R_abs_stem = 0._r8 + R_abs_snow = 0._r8 + leaf_sun_frac = 0._r8 + return + end if + + ! The total vegetation area index of the element + vai_max = scelg%lai + scelg%sai + + dvai = vai_bot - vai_top + + lai_top = vai_top*scelg%lai/( scelg%lai+ scelg%sai) + lai_bot = vai_bot*scelg%lai/( scelg%lai+ scelg%sai) + dlai = dvai * scelg%lai/( scelg%lai+ scelg%sai) + + + if(dlai>nearzero)then + leaf_sun_frac = max(0.001_r8,min(0.999_r8,scelb%Rbeam0/(dlai*scelg%Kb_leaf/rad_params%clumping_index(ft)) & + *(exp(-scelg%Kb_leaf*lai_top) - exp(-scelg%Kb_leaf*lai_bot)))) + else + leaf_sun_frac = 0001._r8 + end if + + !leaf_sun_frac = max(0.001_r8,min(0.999_r8,scelb%Rbeam0/(dvai*scelg%Kb/rad_params%clumping_index(ft)) & + ! *(exp(-scelg%Kb*vai_top) - exp(-scelg%Kb*vai_bot)))) + + + if(debug) then + if(leaf_sun_frac>1.0_r8 .or. leaf_sun_frac<0._r8) then + write(log_unit,*)"impossible leaf sun fraction" + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + ! We have to disentangle the absorption between leaves and stems, we give them both + ! a weighting fraction of total absorption of area*K*(1-om) + + frac_abs_snow = this%frac_snow*(1._r8-om_snow(ib)) / (1._r8-scelb%om) + + diff_wt_leaf = scelg%lai*(1._r8-rad_params%om_leaf(ib,ft))*rad_params%Kd_leaf(ft) + diff_wt_stem = scelg%sai*(1._r8-rad_params%om_stem(ib,ft))*rad_params%Kd_stem(ft) + + beam_wt_leaf = scelg%lai*(1._r8-rad_params%om_leaf(ib,ft))*scelg%Kb_leaf + beam_wt_stem = scelg%sai*(1._r8-rad_params%om_stem(ib,ft))*1._r8 + + ! Mean element transmission coefficients adding snow scattering + + if(debug) then + if( (vai_bot-vai_max)>rel_err_thresh)then + write(log_unit,*)"During decomposition of the 2-stream radiation solution" + write(log_unit,*)"A vegetation area index (VAI) was requested in GetAbsRad()" + write(log_unit,*)"that is larger than the total integrated VAI of the " + write(log_unit,*)"computation element of interest." + write(log_unit,*)"vai_max: ",vai_max + write(log_unit,*)"vai_bot: ",vai_bot + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + if( (vai_bot-vai_top)<-rel_err_thresh ) then + write(log_unit,*)"During decomposition of the 2-stream radiation solution" + write(log_unit,*)"the vegetation area index at the lower position was set" + write(log_unit,*)"as greater than the value at the upper position." + write(log_unit,*)"vai_max: ",vai_max + write(log_unit,*)"vai_bot: ",vai_bot + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + ! Amount of absorbed radiation is retrieved by doing an energy + ! balance on this boundaries over the depth of interest (ie net) + ! Result is Watts / m2 of the element's area footprint NOT + ! per m2 of tissue (at least not in this step) + + Rb_net = this%GetRb(ican,icol,ib,vai_top)-this%GetRb(ican,icol,ib,vai_bot) + + Rd_net = (this%GetRdDn(ican,icol,ib,vai_top) - this%GetRdDn(ican,icol,ib,vai_bot)) + & + (this%GetRdUp(ican,icol,ib,vai_bot) - this%GetRdUp(ican,icol,ib,vai_top)) + + ! The net beam radiation includes that which is absorbed, but also, + ! that which is re-scattered, the re-scattered acts as a source + ! to the net diffuse balance and adds to the absorbed, and a sink + ! on the beam absorbed term. + + Rb_abs = Rb_net * (1._r8-this%band(ib)%scelb(ican,icol)%om) + Rd_abs = Rd_net + Rb_net * this%band(ib)%scelb(ican,icol)%om + + + Rb_abs_leaf = (1._r8-frac_abs_snow)*Rb_abs * beam_wt_leaf / (beam_wt_leaf+beam_wt_stem) + Rd_abs_leaf = (1._r8-frac_abs_snow)*Rd_abs * diff_wt_leaf / (diff_wt_leaf+diff_wt_stem) + + R_abs_snow = (Rb_abs+Rd_abs)*frac_abs_snow + + R_abs_stem = (1._r8-frac_abs_snow)* & + (Rb_abs*beam_wt_stem / (beam_wt_leaf+beam_wt_stem) + & + Rd_abs*diff_wt_stem / (diff_wt_leaf+diff_wt_stem)) + + + + + end associate + return + end subroutine GetAbsRad + + ! ================================================================================================ + + subroutine Dump(this,ib,lat,lon) + + ! Dump out everything we know about these two-stream elements + + class(twostream_type) :: this + integer,intent(in) :: ib + real(r8),optional,intent(in) :: lat + real(r8),optional,intent(in) :: lon + integer :: ican + integer :: icol + + write(log_unit,*) 'Dumping Two-stream elements for band ', ib + write(log_unit,*) + write(log_unit,*) 'rbeam atm: ',this%band(ib)%Rbeam_atm + write(log_unit,*) 'rdiff_atm: ',this%band(ib)%Rdiff_atm + write(log_unit,*) 'alb grnd diff: ',this%band(ib)%albedo_grnd_diff + write(log_unit,*) 'alb grnd beam: ',this%band(ib)%albedo_grnd_beam + write(log_unit,*) 'cosz: ',this%cosz + write(log_unit,*) 'snow fraction: ',this%frac_snow + if(present(lat)) write(log_unit,*) 'lat: ',lat + if(present(lon)) write(log_unit,*) 'lon: ',lon + + do_can: do ican = 1,this%n_lyr + do_col: do icol = 1,this%n_col(ican) + associate(scelg => this%scelg(ican,icol), & + scelb => this%band(ib)%scelb(ican,icol)) + write(log_unit,*) '--',ican,icol,'--' + write(log_unit,*) 'pft:',scelg%pft + write(log_unit,*) 'area: ',scelg%area + write(log_unit,*) 'lai,sai: ',scelg%lai,scelg%sai + write(log_unit,*) 'Kb: ',scelg%Kb + write(log_unit,*) 'Kb leaf: ',scelg%Kb_leaf + write(log_unit,*) 'Kd: ',scelg%Kd + write(log_unit,*) 'Rb0: ',scelb%Rbeam0 + write(log_unit,*) 'om: ',scelb%om + write(log_unit,*) 'betad: ',scelb%betad + write(log_unit,*) 'betab:',scelb%betab + write(log_unit,*) 'a: ',scelb%a + this%band(ib)%Rbeam_atm = 1.0_r8 + this%band(ib)%Rdiff_atm = 1.0_r8 + write(log_unit,*)'RDiff Down @ bottom: ',this%GetRdDn(ican,icol,ib,scelg%lai+scelg%sai) + write(log_unit,*)'RDiff Up @ bottom: ',this%GetRdUp(ican,icol,ib,scelg%lai+scelg%sai) + write(log_unit,*)'Rbeam @ bottom: ',this%GetRb(ican,icol,ib,scelg%lai+scelg%sai) + end associate + end do do_col + end do do_can + + end subroutine Dump + + + ! ================================================================================================ + + subroutine RadParamPrep() + + integer :: ft + integer :: nbands + integer :: numpft + integer :: ib + + numpft = ubound(rad_params%om_leaf,2) + nbands = ubound(rad_params%om_leaf,1) + + do ft = 1,numpft + + ! The non-band specific parameters here will be re-derived for each + ! band, which is inefficient, however this is an incredibly cheap + ! routine to begin with, its only called during initialization, so + ! just let it go, dont worry about it. + + if(rad_params%xl(ft)<-0.4_r8 .or. rad_params%xl(ft)>0.6_r8) then + write(log_unit,*)"Leaf orientation factors (xl) should be between -0.4 and 0.6" + write(log_unit,*)"ft: ",ft,"xl: ",rad_params%xl(ft) + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + ! There is a singularity of leaf orientation is exactly 0 + ! phi1 = 0.5 + ! phi2 = 0.0 + ! avmu = 1/0 (1 - 0.5/0 * ln(0.5/0.5) ) but the limit approaches 1 + ! a value of 0.0001 does not break numerics and generates an avmu of nearly 1 + + if( abs(rad_params%xl(ft)) <0.0001) rad_params%xl(ft)=0.0001_r8 + + ! There must be protections on xl to prevent div0 and other weirdness + rad_params%phi1(ft) = 0.5_r8 - 0.633_r8*rad_params%xl(ft) - 0.330_r8*rad_params%xl(ft)*rad_params%xl(ft) + rad_params%phi2(ft) = 0.877_r8 * (1._r8 - 2._r8*rad_params%phi1(ft)) !0 = horiz leaves, 1 - vert leaves. + + ! Eq. 3.4 CLM50 Tech Man + rad_params%avmu(ft) = (1._r8/rad_params%phi2(ft))* & + (1._r8-(rad_params%phi1(ft)/rad_params%phi2(ft))* & + log((rad_params%phi2(ft)+rad_params%phi1(ft))/rad_params%phi1(ft))) + + do ib = 1, nbands + rad_params%Kd_leaf(ft) = rad_params%clumping_index(ft)/rad_params%avmu(ft) + rad_params%Kd_stem(ft) = 1._r8 + + rad_params%om_leaf(ib,ft) = rad_params%rhol(ib,ft) + rad_params%taul(ib,ft) + rad_params%om_stem(ib,ft) = rad_params%rhos(ib,ft) + rad_params%taus(ib,ft) + + if( rad_params%om_leaf(ib,ft) > 0.99_r8 ) then + write(log_unit,*) "In: TwoStreamMLPEMod.F90:RadParamPrep()" + write(log_unit,*) "An extremely high leaf scattering coefficient was generated:" + write(log_unit,*) "om = tau + rho" + write(log_unit,*) "band = ",ib + write(log_unit,*) "pft = ",ft + write(log_unit,*) "om_leaf = ",rad_params%om_leaf(ib,ft) + write(log_unit,*) "rhol = ",rad_params%rhol(ib,ft) + write(log_unit,*) "taul = ",rad_params%taul(ib,ft) + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + if( rad_params%om_stem(ib,ft) > 0.99_r8 ) then + write(log_unit,*) "In: TwoStreamMLPEMod.F90:RadParamPrep()" + write(log_unit,*) "An extremely high stem scattering coefficient was generated:" + write(log_unit,*) "om = tau + rho" + write(log_unit,*) "band = ",ib + write(log_unit,*) "pft = ",ft + write(log_unit,*) "om_stem = ",rad_params%om_stem(ib,ft) + write(log_unit,*) "rhos = ",rad_params%rhos(ib,ft) + write(log_unit,*) "taus = ",rad_params%taus(ib,ft) + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + end do + + end do + + return + end subroutine RadParamPrep + + ! ================================================================================================ + + + ! ================================================================================================ + + subroutine CanopyPrep(this,frac_snow) + + ! Pre-process things that change with canopy-geometry or snow cover + ! We try to only run this when necessary. For instance we only + ! run this when the canopy vegetation composition changes, or + ! when the amount of snow-cover changes. + + class(twostream_type) :: this + + real(r8) :: frac_snow ! The fraction (in terms of vegetation area index) + ! of vegetation covered with snow + + ! But we check if the snow conditions + ! change during the high frequency calls + ! as well. + integer :: ib ! The band of interest + integer :: ican ! scattering element canopy layer index (top down) + integer :: icol ! scattering element column + real(r8) :: rho ! element mean material reflectance + real(r8) :: tau ! element mean material transmittance + real(r8) :: vai ! vegetation area index lai+sai + real(r8) :: om_veg ! scattering coefficient for vegetation (no snow) + real(r8) :: betad_veg ! diffuse backscatter for vegetation (no snow) + real(r8) :: betad_om ! multiplication of diffuse backscatter and reflectance + real(r8) :: area_check ! Checks to make sure each layer has 100% coverage + real(r8) :: a2 ! The "a" term squared + + this%frac_snow = frac_snow + + if(.not.this%force_prep) then + if(abs(this%frac_snow-this%frac_snow_old) this%scelg(ican,icol)%lai, & + sai => this%scelg(ican,icol)%sai, & + ft => this%scelg(ican,icol)%pft, & + scelg => this%scelg(ican,icol)) + + vai = lai + sai + + ! Mean element transmission coefficients w/o snow effects + + if(ft==air_ft) then + scelg%Kd = k_air + else + if(debug)then + if(vai this%band(ib)%scelb(ican,icol)) + + if (ft==air_ft) then + + scelb%om = om_air + scelb%betad = beta_air + + else + + ! Material reflectance (weighted average of leaf stem and snow) + + ! Eq. 3.11 and 3.12 ClM5.0 Tech Man + om_veg = (lai*rad_params%om_leaf(ib,ft) + & + sai*rad_params%om_stem(ib,ft))/vai + + ! Eq. 3.5 ClM5.0 Tech Man + scelb%om = this%frac_snow*om_snow(ib) + (1._r8-this%frac_snow)*om_veg + + ! Diffuse backscatter, taken from G. Bonan's code + + rho = (lai * rad_params%rhol(ib,ft) + & + sai * rad_params%rhos(ib,ft))/vai + tau = (lai * rad_params%taul(ib,ft) + & + sai * rad_params%taus(ib,ft))/vai + + ! Eq 3.13 from CLM5.0 Tech Man + betad_veg = 0.5_r8 / scelb%om * & + ( scelb%om + (rho-tau) * ((1._r8+rad_params%xl(ft))/2._r8)**2._r8 ) + + ! Eq. 3.6 from CLM5.0 Tech Man + betad_om = betad_veg*om_veg*(1._r8-this%frac_snow) + & + om_snow(ib)*betad_snow(ib)*this%frac_snow + + scelb%betad = betad_om / scelb%om + + if(debug)then + !if(isnan(scelb%betad))then !RGK: NVHPC HAS A BUG IN THIS INTRINSIC (01-2024) + !if(scelb%betad /= scelb%betad) then + if(shr_infnan_isnan(scelb%betad))then + write(log_unit,*)"nans in canopy prep" + write(log_unit,*) ib,ican,icol,ft + write(log_unit,*) scelb%betad,scelb%om,lai,sai + write(log_unit,*) this%frac_snow,om_snow(ib),vai,om_veg + write(log_unit,*)"TwoStreamMLPEMod.F90:CanopyPrep" + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + end if + + a2 = scelg%Kd*scelg%Kd*(1._r8-scelb%om)*(1._r8-scelb%om+2._r8*scelb%om*scelb%betad) + if(a2<0._r8) then + write(log_unit,*)'a^2 is less than zero' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + ! We also have to avoid singularities, see Ad and Au below, + ! where a^2-Kb^2 is in the denominator + + scelb%a = sqrt(a2) + + end associate + end do do_bands + end associate + end do do_col + + ! RE-ENABLE THIS CHECK WHEN FATES IS BETTER AT CONSERVING AREA!! + if(.false.)then + !if( abs(area_check-1._r8) > 10._r8*area_err_thresh )then + write(log_unit,*)"Only a partial canopy was specified" + write(log_unit,*)"Scattering elements must constitute 100% of the ground cover." + write(log_unit,*)"for open spaces, create an air element with the respective area." + write(log_unit,*)"total area (out of 1): ",area_check,ican + write(log_unit,*)"layer: ",ican," of: ",this%n_lyr + do icol = 1,this%n_col(ican) + write(log_unit,*)this%scelg(ican,icol)%area,this%scelg(ican,icol)%pft + end do + write(log_unit,*)"TwoStreamMLPEMod.F90:CanopyPrep" + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + end do do_can + + return + end subroutine CanopyPrep + + ! ================================================================================================ + + subroutine ZenithPrep(this,cosz_in) + + ! Pre-process things that change with the zenith angle + ! i.e. the beam optical properties + + ! Important !!!! + ! This should always be called after CanopyPrep() has been + ! called. This routine relies on the results of that routine + ! notably the scattering coefficient "om". + + class(twostream_type) :: this + integer :: ib ! band index, matches indexing of rad_params + real(r8),intent(in) :: cosz_in ! Un-protected cosine of the zenith angle + + real(r8) :: cosz ! the near-zero protected cosz + integer :: ican ! scattering element canopy layer index (top down) + integer :: icol ! scattering element column + real(r8) :: asu ! single scattering albedo + real(r8) :: gdir + real(r8) :: tmp0,tmp1,tmp2 + real(r8) :: betab_veg ! beam backscatter for vegetation (no snow) + real(r8) :: betab_om ! multiplication of beam backscatter and reflectance + real(r8) :: om_veg ! scattering coefficient for vegetation (no snow) + real(r8) :: Kb_sing ! the KB_leaf that would generate a singularity + ! with the scelb%a parameter + real(r8) :: Kb_stem ! actual optical depth of stem with not planar geometry effects + ! usually the base value + real(r8), parameter :: Kb_stem_base = 1.0_r8 + real(r8), parameter :: sing_tol = 0.01_r8 ! allowable difference between + ! the Kb_leaf that creates + ! a singularity and the actual + + if( (cosz_in-1.0) > nearzero ) then + write(log_unit,*)"The cosine of the zenith angle cannot exceed 1" + write(log_unit,*)"cosz: ",cosz + write(log_unit,*)"TwoStreamMLPEMod.F90:ZenithPrep" + call endrun(msg=errMsg(sourcefile, __LINE__)) + elseif(cosz_in<0._r8)then + write(log_unit,*)"The cosine of the zenith angle should not be less than zero" + write(log_unit,*)"It can be exactly zero, but not less than" + write(log_unit,*)"cosz: ",cosz + write(log_unit,*)"TwoStreamMLPEMod.F90:ZenithPrep" + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + cosz = max(0.001,cosz_in) + + this%cosz = cosz + + do_ican: do ican = 1,this%n_lyr + do_ical: do icol = 1,this%n_col(ican) + + associate(ft => this%scelg(ican,icol)%pft, & + scelg => this%scelg(ican,icol)) + + if(ft==air_ft)then + ! Simple provisions for a ghost element (air) + scelg%Kb_leaf = k_air + scelg%Kb = k_air + else + gdir = rad_params%phi1(ft) + rad_params%phi2(ft) * cosz + + Kb_stem = Kb_stem_base + + !how much direct light penetrates a singleunit of lai? + scelg%Kb_leaf = min(kb_max,rad_params%clumping_index(ft) * gdir / cosz) + + ! To avoid singularities, we need to make sure that Kb =/ a + ! If they are too similar, it will create a very large + ! term in the linear solution and generate solution errors + ! Lets identify the Kb_leaf that gives a singularity. + ! We don't need to include the min() function + ! a will never be that large. + ! + ! kb = a = (lai*kb_leaf + sai*kb_stem)/(lai+sai) + ! (a*(lai+sai) - sai*kb_stem)/lai = Kb_sing + ! or.. adjust stem Kb? + ! (a*(lai+sai) - lai*kb_leaf)/sai = kb_stem_sing + if(scelg%lai>nearzero) then + do ib = 1,this%n_bands + Kb_sing = (this%band(ib)%scelb(ican,icol)%a*(scelg%lai+scelg%sai) - scelg%sai*Kb_stem)/scelg%lai + if(abs(scelg%Kb_leaf - Kb_sing) this%band(ib)%scelb(ican,icol) ) + + if(ft==air_ft)then + + ! Simple provisions for a ghost element (air) + scelb%betab = beta_air + + else + + ! betab - upscatter parameter for direct beam radiation, from G. Bonan + ! Eq. 3.16 CLM50 Tech Man + ! asu is the single scattering albedo per om_veg (material reflectance) + + asu = 0.5_r8 * gdir / tmp0 * tmp2 + + betab_veg = (1._r8 + rad_params%avmu(ft)*scelg%Kb) / (rad_params%avmu(ft)*scelg%Kb) * asu + + om_veg = (scelg%lai*rad_params%om_leaf(ib,ft) + & + scelg%sai*rad_params%om_stem(ib,ft))/(scelg%lai+scelg%sai) + + ! Eq. 3.7 CLM50 Tech Man + betab_om = betab_veg*om_veg*(1._r8-this%frac_snow) + & + om_snow(ib)*betab_snow(ib)*this%frac_snow + + scelb%betab = betab_om / scelb%om + + if(debug)then + if( .not.(scelb%betab==scelb%betab))then + write(log_unit,*)"Beam backscatter fraction is NaN" + write(log_unit,*) betab_om,scelb%om,om_veg,this%frac_snow,betab_veg,asu,rad_params%avmu(ft),scelg%Kb + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + end if + + end associate + end do do_ib + end associate + end do do_ical + end do do_ican + + return + end subroutine ZenithPrep + + ! ================================================================================================ + + subroutine GetNSCel(this) + + ! Simply return the total number + ! of scattering elements from the + ! multi-layer scattering element array + + class(twostream_type) :: this + integer :: ican + + this%n_scel = 0 + do ican = 1,this%n_lyr + this%n_scel = this%n_scel + this%n_col(ican) + end do + return + end subroutine GetNSCel + + ! =============================================================== + + subroutine Solve(this, ib, & + upper_boundary_type, & + Rbeam_atm, & + Rdiff_atm, & + taulamb, & + omega, & + ipiv, & + albedo_beam, & + albedo_diff, & + consv_err, & + frac_abs_can_beam, & + frac_abs_can_diff, & + frac_beam_grnd_beam, & + frac_diff_grnd_beam, & + frac_diff_grnd_diff) + + ! Find the scattering coefficients for two-stream radiation in the canopy. + + ! Note that these scattering coefficients are separated for scattering + ! generated by a beam radiation boundary condition, and a diffuse radiation + ! boundary conditions. Thus, we need not provide the magnitude of the forcing + ! for this step. If the user provides values of 1 for the Rbeam_atm and Rdiff_atm + ! boundary condition. It is assumed this is a normalized solution. If values + ! other than 1 are passed, we assume that it is not a normalized solution, + ! and we update the data structure values this%band(ib)%Rbeam_atm and + ! this%band(ib)%Rdiff_atm. In a normalized solution, we will leave this + ! as unset. + ! In ELM and CLM, the land-model requests an albedo and other + ! normalized output from from this algorithm for the NEXT STEP. This is + ! due to the atmospheric model needing an albedo to calculate the downwelling + ! radiation on the next step. THus, the asynchronous nature of things. That is + ! why we allow a normalized solution here. When actual absorption or flux values are + ! desired, the scattering coefficients that were determined during the normalized + ! solution are still valid when the magnitude of the downwelling beam and diffuse + ! radiation boundary conditions to the vegetation canopy are known. + + + class(twostream_type) :: this + integer :: ib ! Band of interest, matches indexing of rad_params + integer :: upper_boundary_type ! Is this a normalized(1) or absolute(2) solution? + + real(r8) :: Rbeam_atm ! Intensity of beam radiation at top of canopy [W/m2 ground] + real(r8) :: Rdiff_atm ! Intensity of diffuse radiation at top of canopy [W/m2 ground] + ! + real(r8) :: taulamb(:) ! both the coefficient vector and constant side of the linear equation + real(r8) :: omega(:,:) ! the square matrix to be inverted + integer :: ipiv(:) ! pivot indices for LAPACK (not optional output, we don't use) + + real(r8) :: albedo_beam ! Mean albedo at canopy top generated from beam radiation [-] + real(r8) :: albedo_diff ! Mean albedo at canopy top generated from downwelling diffuse [-] + + real(r8) :: temp_err ! Used to build the other error terms, a temp + real(r8) :: consv_err ! radiation canopy balance conservation + ! error, fraction of incident + + real(r8) :: frac_abs_can_beam ! Fraction of incident beam radiation absorbed by the vegetation [-] + real(r8) :: frac_abs_can_diff ! Fraction of incident diffuse radiation absorbed by the vegetation [-] + real(r8) :: frac_beam_grnd_beam ! fraction of beam radiation at ground resulting from of beam at canopy top [-] + real(r8) :: frac_diff_grnd_beam ! fraction of down diffuse radiation at ground resulting from beam at canopy top + real(r8) :: frac_diff_grnd_diff ! fraction of down diffuse radiation at ground resulting from down diffuse at canopy top [-] + + ! These arrays are only used if we run in debug mode, and are + ! looking to report the error on the linear solution e = TAU - OMEGA*LAMBDA + real(r8),allocatable :: tau_temp(:) + real(r8),allocatable :: omega_temp(:,:) + + ! Two stream solution arrays + ! Each of these are given generic names, because + ! they are assemblages of many terms. But generally + ! they fit the linear algebra formulation: + ! + ! TAU(:) = OMEGA(:,:) * LAMBDA(:) + ! + ! Where, we invert to solve for the coefficients LAMBDA + + integer :: isol ! Solution index loop (beam, beam+diff) + integer :: ican ! Loop index for canopy layers + integer :: ibot ! layer index for top side of layer divide + integer :: itop ! layer index for bottom side of layer divide + integer :: icol ! Loop index for canopy columns + integer :: jcol ! Another loop index for canopy columns + integer :: ilem ! Index for scattering elements + integer :: k1,k2 ! Indices for the lambda terms in the OMEGA and LAMBDA array + integer :: qp ! Equation position index + integer :: n_eq ! Total number of equations + + integer :: ilem_off ! Offset, or total number of elements above layer of interest + real(r8) :: b1,b2,nu_sqrd ! intermediate terms, see documentation + real(r8) :: Rbeam_top ! Mean beam radiation at top of layer [W/m2] + real(r8) :: Rbeam_bot ! Mean beam radiation at bottom of layer [W/m2] + real(r8) :: vai ! Vegetation area index [m2 vegetation / m2 ground] + real(r8) :: rb_abs ! beam absorbed over an element [W/m2 ground] + real(r8) :: rd_abs ! diffuse absorbed over an element [W/m2 ground] + real(r8) :: rd_abs_leaf ! diffuse absorbed over leaves (dummy) + real(r8) :: rb_abs_leaf ! beam absorbed by leaves (dummy) + real(r8) :: r_abs_stem ! total absorbed by stems (dummy) + real(r8) :: r_abs_snow ! total absorbed by snow (dummy) + real(r8) :: leaf_sun_frac ! sunlit fraction of leaves (dummy) + + + real(r8) :: beam_err,diff_err ! error partitioned by beam and diffuse + type(scelg_type),pointer :: scelgp ! Pointer to the scelg data structure + type(scelb_type),pointer :: scelbp ! Pointer to the scelb data structure + + ! Parameters for solving via LAPACK DGESV() and DGESVXX() + integer :: info ! Procedure diagnostic ouput + + ! Testing switch + ! If true, then allow elements + ! of different layers, but same row, to have priority + ! flux into the other element, instead of a mix + logical, parameter :: continuity_on = .true. + + logical, parameter :: albedo_corr = .true. + + ! ------------------------------------------------------------------------------------ + ! Example system of equations for 2 parallel columns in each of two canopy + ! layers. Each line is one of the balanc equations. And the x's are + ! the unknown coefficients used in those equations. 2 coefficients + ! map to each element, and read left to right. + ! EL1 is the element in top layer left column. + ! EL2 is the element in the top layer, right column + ! EL3 is the element in the bottom layer, left column + ! EL4 is the element in the bottom layer, right column + ! + ! EL1 EL2 EL3 EL4 + ! EQ: Idn balance with upper BC can1, col 1: x x + ! EQ: Idn balance with upper BC can1, col 2: x x + ! EQ: Idn balance between upper & lower x x x x x x + ! EQ: Idn balance between upper & lower x x x x x x + ! EQ: Iup balance between lower & upper x x x x x x x x + ! EQ: Iup balance between lower & upper x x x x x x x x + ! EQ: Iup/Idn balance with ground, 1st col: x x + ! EQ: Iup/Idn Balance with ground, 2nd lower col: x x + ! + ! Note: The Iup balance between layers requires ALL + ! terms, because light comes out of both + ! upper canopy elements and reflects off soil + ! AND, light upwells from both lower elements. + ! + ! -------------------------------------------------------------------------- + + ! -------------------------------------------------------------------------- + ! Beam Scattering + ! First do the direct beam stuff. It is a trivial solution + ! and is required as a boundary condition to the diffuse solver + ! All parallel layers recieve downwelling form the + ! atmosphere. + ! Rbeam0 is the upper boundary condition provided by data or another + ! model. + ! Rbeam() is the incident beam radiation at the top of each layer + ! upper canopy. + ! -------------------------------------------------------------------------- + + if((Rbeam_atm+Rdiff_atm) this%scelg(ican,icol) + scelbp => this%band(ib)%scelb(ican,icol) + scelbp%Rbeam0 = Rbeam_top + Rbeam_bot = Rbeam_bot + & + Rbeam_top*scelgp%area*exp(-scelgp%Kb*(scelgp%lai+scelgp%sai)) + end do + Rbeam_top = Rbeam_bot + end do + + ! Calculate element-level intermediate terms to the solve + ! These are dependent on leaf level scattering and beam scattering + ! These values will be used to populate the matrix solve + ! ===================================================================== + + do ican = 1,this%n_lyr + do icol = 1,this%n_col(ican) + + scelgp => this%scelg(ican,icol) + scelbp => this%band(ib)%scelb(ican,icol) + + b2 = -(scelgp%Kd*(1._r8-scelbp%om)*(1._r8-2._r8*scelbp%betab)+scelgp%Kb) * & + scelbp%om*scelgp%Kb*scelbp%Rbeam0 + + b1 = -(scelgp%Kd*(1._r8-scelbp%om+2._r8*scelbp%om*scelbp%betad) + & + (1._r8-2._r8*scelbp%betab)*scelgp%Kb) * & + scelbp%om*scelgp%Kb*scelbp%Rbeam0 + + nu_sqrd = (1._r8-scelbp%om)/(1._r8-scelbp%om+2._r8*scelbp%om*scelbp%betad) + + if(nu_sqrd<0._r8)then + write(log_unit,*)'nu_sqrd is less than zero' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + ! B_1 term from documentation: + scelbp%B1 = 0.5_r8*(1._r8+sqrt(nu_sqrd)) + + ! B_2 term from documentation + scelbp%B2 = 0.5_r8*(1._r8-sqrt(nu_sqrd)) + + ! A_2 term from documentation + scelbp%Ad = -0.5_r8*(b1+b2)/(scelbp%a*scelbp%a-scelgp%Kb*scelgp%Kb) ! aka half b2 minus b1 + + ! A_1 term from documentation + scelbp%Au = -0.5_r8*(b1-b2)/(scelbp%a*scelbp%a-scelgp%Kb*scelgp%Kb) ! aka half b1 plus b2 + + end do + end do + + ! ===================================================================== + ! Set up the linear systems solver + ! + ! [TAU] = [OMEGA]*[LAMBDA] + ! OMEGA(n_equations,n_coefficients) + ! TAU(n_equations) + ! LAMBDA (n_coefficients) (the solution) + ! + ! Indexing Variables + ! ilem : element position + ! k1 : coefficient 1 position + ! k2 : coefficient 2 position + ! qp : equation position, this continues to increment + ! ===================================================================== + + n_eq = 2*this%n_scel + + ! TO-DO: MAKE THIS SCRATCH SPACE AT THE SITE LEVEL? + !!allocate(OMEGA(2*this%n_scel,2*this%n_scel),stat=alloc_err) + !!allocate(TAU(2*this%n_scel),stat=alloc_err) + !!allocate(LAMBDA(2*this%n_scel),stat=alloc_err) + + ! We come up with two solutions: + ! First: we run with now diffuse downwelling + ! radiation, this allows us to calculate + ! the canopy top albedo for beam radiation only + ! which is useful for coupling with the atmosphere + ! Second: we run with bot simultaneously, and + ! use that solution to understand everything + ! else, including the absorbed radiation + + do_isol: do isol = 1,2 + + + ! This is temporary (these need to be set + ! because this routine makes a call to get normalized + ! absorbtions to get total noramalized canopy absorbtion) + ! We will set it back to unknown following that call + + if(isol==1)then + this%band(ib)%Rbeam_atm = 1.0_r8 + this%band(ib)%Rdiff_atm = 0.0_r8 + else + this%band(ib)%Rbeam_atm = 0.0_r8 + this%band(ib)%Rdiff_atm = 1.0_r8 + end if + + omega(1:n_eq,1:n_eq) = 0._r8 + taulamb(1:n_eq) = 0._r8 + + ! -------------------------------------------------------------------- + ! I. Flux equations with the atmospheric boundary + ! These balance with all elements in the upper + ! canopy, only. The upper canopy is layer 1. + ! -------------------------------------------------------------------- + + qp = 0 ! e"Q"uation "P"osition + do icol = 1,this%n_col(1) + scelgp => this%scelg(1,icol) + scelbp => this%band(ib)%scelb(1,icol) + ilem = icol + qp = qp + 1 + k1 = 2*(ilem-1)+1 + k2 = k1+1 + taulamb(qp) = this%band(ib)%Rdiff_atm - this%band(ib)%Rbeam_atm*scelbp%Ad + omega(qp,k1) = scelbp%B2 + omega(qp,k2) = scelbp%B1 + end do + + + if_understory: if(this%n_lyr>1) then + + + ! ------------------------------------------------------------------- + ! II. Flux equations between canopy layers, DOWNWELLING + ! We only perform flux balancing between layers + ! if we have any understory, this is true if ican>1 + ! ------------------------------------------------------------------- + ! Refer to Equation X in technical document + ! ------------------------------------------------------------ + + ! This is the index offset for the layer above the + ! current layer of interest. We start by evaluating + ! Layer 2, so the offset refers to layer 1, and a + ! value of 0 + + ilem_off = 0 + do_dn_ican: do ican = 2,this%n_lyr + + itop = ican-1 ! Top layer of the balance + ibot = ican ! Bottom layer of the balance + + ! Downwelling, includes all members from top for + ! each independant member below + + do jcol = 1,this%n_col(ibot) + + qp = qp + 1 + ilem = ilem_off + this%n_col(itop) + jcol + k1 = 2*(ilem-1)+1 + k2 = k1 + 1 + + ! Include the self terms for the current element + ! This term is at v=0 + + taulamb(qp) = this%band(ib)%Rbeam_atm*this%band(ib)%scelb(ibot,jcol)%Ad + omega(qp,k1) = omega(qp,k1) - this%band(ib)%scelb(ibot,jcol)%B2 + omega(qp,k2) = omega(qp,k2) - this%band(ib)%scelb(ibot,jcol)%B1 + + ! We need to include the terms from + ! all elements above the current element of interest + ! (this can be moved out of jcol loop for efficiency) + do icol = 1,this%n_col(itop) + + ilem = ilem_off + icol + k1 = 2*(ilem-1)+1 + k2 = k1 + 1 + + scelgp => this%scelg(itop,icol) + scelbp => this%band(ib)%scelb(itop,icol) + + vai = scelgp%lai + scelgp%sai + + taulamb(qp) = taulamb(qp) - scelgp%area * this%band(ib)%Rbeam_atm*scelbp%Ad *exp(-scelgp%Kb*vai) + omega(qp,k1) = omega(qp,k1) + scelgp%area * scelbp%B2*exp(scelbp%a*vai) + omega(qp,k2) = omega(qp,k2) + scelgp%area * scelbp%B1*exp(-scelbp%a*vai) + + end do + + end do + + ilem_off = ilem_off + this%n_col(itop) + + end do do_dn_ican + + + ! ------------------------------------------------------------------- + ! III. Flux equations between canopy layers, UPWELLING + ! ------------------------------------------------------------------- + ! Refer to equation X in the technical documentation. + ! Note the upwelling balance is performed on the upper layer, + ! one equation for each element in the upper layer. + ! Note that since we use "ghost elements" or air elements + ! we don't have to factor in reflections from exposed ground. + ! These effects will be mediated through the ghost elements + ! ------------------------------------------------------------------- + + ilem_off = 0 + + do_up_ican: do ican = 2,this%n_lyr + + itop = ican-1 + ibot = ican + + do icol = 1,this%n_col(itop) + + qp = qp + 1 + + ! Self terms (ie the upwelling evaluated at the bottom edge of each top element) + ilem = ilem_off + icol + k1 = 2*(ilem-1)+1 + k2 = k1 + 1 + scelgp => this%scelg(itop,icol) + scelbp => this%band(ib)%scelb(itop,icol) + + vai = scelgp%lai + scelgp%sai + taulamb(qp) = this%band(ib)%Rbeam_atm*scelbp%Au*exp(-scelgp%Kb*vai) + omega(qp,k1) = omega(qp,k1) - scelbp%B1*exp(scelbp%a*vai) + omega(qp,k2) = omega(qp,k2) - scelbp%B2*exp(-scelbp%a*vai) + + ! Terms for mean diffuse exiting lower elements (move out of this loop for efficiency) + do jcol = 1,this%n_col(ibot) + ilem = ilem_off + this%n_col(itop) + jcol + k1 = 2*(ilem-1)+1 + k2 = k1 + 1 + scelgp => this%scelg(ibot,jcol) + scelbp => this%band(ib)%scelb(ibot,jcol) + + taulamb(qp) = taulamb(qp) - this%band(ib)%Rbeam_atm*scelgp%area*scelbp%Au + omega(qp,k1) = omega(qp,k1) + scelgp%area*scelbp%B1 + omega(qp,k2) = omega(qp,k2) + scelgp%area*scelbp%B2 + end do + + end do + + ilem_off = ilem_off + this%n_col(itop) + end do do_up_ican + + + end if if_understory + + + ! Flux balance equations between the understory elements, and + ! the ground below them + ilem_off = 0 + do ican=1,this%n_lyr-1 + ilem_off = ilem_off + this%n_col(ican) + end do + + do jcol = 1,this%n_col(this%n_lyr) + + ilem = ilem_off + jcol + qp = qp + 1 + k1 = 2*(ilem-1)+1 + k2 = k1 + 1 + + scelgp => this%scelg(this%n_lyr,jcol) + scelbp => this%band(ib)%scelb(this%n_lyr,jcol) + + vai = scelgp%lai + scelgp%sai + + taulamb(qp) = this%band(ib)%Rbeam_atm*(scelbp%Au*exp(-scelgp%Kb*vai) & + - this%band(ib)%albedo_grnd_diff*scelbp%Ad*exp(-scelgp%Kb*vai) & + - this%band(ib)%albedo_grnd_beam*scelbp%Rbeam0*exp(-scelgp%Kb*vai)) + + omega(qp,k1) = omega(qp,k1) - scelbp%B1*exp(scelbp%a*vai) + omega(qp,k2) = omega(qp,k2) - scelbp%B2*exp(-scelbp%a*vai) + + omega(qp,k1) = omega(qp,k1) + this%band(ib)%albedo_grnd_diff*scelbp%B2*exp(scelbp%a*vai) + omega(qp,k2) = omega(qp,k2) + this%band(ib)%albedo_grnd_diff*scelbp%B1*exp(-scelbp%a*vai) + + end do + + ! dgesv will overwrite TAU with LAMBDA + ! ie, left side of TAU = OMEGA*LAMBDA + ! lets dave it temporarily + + if(debug)then + allocate(tau_temp(n_eq),omega_temp(n_eq,n_eq)) + tau_temp(1:n_eq) = taulamb(1:n_eq) + omega_temp(1:n_eq,1:n_eq) = omega(1:n_eq,1:n_eq) + end if + + ! the desired precision of the iterative algorithm is: + ! RNRM < SQRT(N)*XNRM*ANRM*EPS + ! eps is the machine precision of the real number type + ! ANRM is the "infinity-norm", ie the infinity norm is the abs() maximum row sum + ! XNRM is the abs() maximum value in that column + + ! Find the solution + call dgesv(n_eq, 1, omega(1:n_eq,1:n_eq), n_eq, ipiv(1:n_eq), taulamb(1:n_eq), n_eq, info) + + if(info.ne.0)then + write(log_unit,*) 'Could not find a solution via dgesv' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + ! Perform a forward check on the solution error + do ilem = 1,n_eq + temp_err = tau_temp(ilem) - sum(taulamb(1:n_eq)*omega_temp(ilem,1:n_eq)) + if(abs(temp_err)>rel_err_thresh)then + write(log_unit,*) 'Poor forward solution on two-stream solver' + write(log_unit,*) 'isol (1=beam or 2=diff): ',isol + write(log_unit,*) 'i (equation): ',ilem + write(log_unit,*) 'band index (1=vis,2=nir): ',ib + write(log_unit,*) 'error (tau(i) - omega(i,:)*lambda(:)) ',temp_err + this%band(ib)%Rbeam_atm = 1._r8 + this%band(ib)%Rdiff_atm = 1._r8 + call this%Dump(ib) + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end do + deallocate(tau_temp,omega_temp) + + + ! Save the solution terms + + ilem_off = 0 + if(isol==1)then !Beam + do ican = 1,this%n_lyr + do icol = 1,this%n_col(ican) + ilem = ilem_off + icol + k1 = 2*(ilem-1)+1 + k2 = k1 + 1 + scelgp => this%scelg(ican,icol) + scelbp => this%band(ib)%scelb(ican,icol) + scelbp%lambda1_beam = taulamb(k1) + scelbp%lambda2_beam = taulamb(k2) + ! The lambda diff terms will be + ! multiplied by zero before we use them + ! but, we dont want things like nan's + ! or weird math, so we set them to zero too + scelbp%lambda1_diff = 0._r8 + scelbp%lambda2_diff = 0._r8 + end do + ilem_off = ilem_off + this%n_col(ican) + end do + else + do ican = 1,this%n_lyr + do icol = 1,this%n_col(ican) + ilem = ilem_off + icol + k1 = 2*(ilem-1)+1 + k2 = k1 + 1 + scelgp => this%scelg(ican,icol) + scelbp => this%band(ib)%scelb(ican,icol) + scelbp%lambda1_diff = taulamb(k1) + scelbp%lambda2_diff = taulamb(k2) + end do + ilem_off = ilem_off + this%n_col(ican) + end do + end if + + ! Process the total canopy absorbed radiation in the + ! two types of radiation, as well as the downwelling + ! flux at the ground interface + ! -------------------------------------------------------------------------------- + + if_beam: if(isol==1)then + + ican = 1 + albedo_beam = 0._r8 + do icol = 1,this%n_col(ican) + scelgp => this%scelg(ican,icol) + scelbp => this%band(ib)%scelb(ican,icol) + albedo_beam = albedo_beam + & + scelgp%area * this%GetRdUp(ican,icol,ib,0._r8) + end do + + frac_diff_grnd_beam = 0._r8 + frac_beam_grnd_beam = 0._r8 + ican = this%n_lyr + do icol = 1,this%n_col(ican) + scelgp => this%scelg(ican,icol) + scelbp => this%band(ib)%scelb(ican,icol) + frac_diff_grnd_beam = frac_diff_grnd_beam + & + scelgp%area*this%GetRdDn(ican,icol,ib,scelgp%lai+scelgp%sai) + frac_beam_grnd_beam = frac_beam_grnd_beam + & + scelgp%area*scelbp%Rbeam0*exp(-scelgp%Kb*(scelgp%lai+scelgp%sai)) + end do + + + frac_abs_can_beam = 0._r8 + do ican = 1,this%n_lyr + do icol = 1,this%n_col(ican) + scelgp => this%scelg(ican,icol) + scelbp => this%band(ib)%scelb(ican,icol) + call this%GetAbsRad(ican,icol,ib, 0._r8,scelgp%lai+scelgp%sai, & + rb_abs,rd_abs,rd_abs_leaf,rb_abs_leaf,r_abs_stem,r_abs_snow,leaf_sun_frac) + frac_abs_can_beam = frac_abs_can_beam + scelgp%area*(rb_abs+rd_abs) + end do + end do + + else ! Diffuse + + albedo_diff = 0._r8 + do icol = 1,this%n_col(1) + scelgp => this%scelg(1,icol) + scelbp => this%band(ib)%scelb(1,icol) + albedo_diff = albedo_diff + & + scelgp%area * this%GetRdUp(1,icol,ib,0._r8) + end do + + frac_abs_can_diff = 0._r8 + + do ican = 1,this%n_lyr + do icol = 1,this%n_col(ican) + scelgp => this%scelg(ican,icol) + scelbp => this%band(ib)%scelb(ican,icol) + call this%GetAbsRad(ican,icol,ib,0._r8,scelgp%lai+scelgp%sai, & + rb_abs,rd_abs,rd_abs_leaf,rb_abs_leaf,r_abs_stem,r_abs_snow,leaf_sun_frac) + frac_abs_can_diff = frac_abs_can_diff + scelgp%area*rd_abs + end do + end do + + frac_diff_grnd_diff = 0._r8 + ican = this%n_lyr + do icol = 1,this%n_col(ican) + scelgp => this%scelg(ican,icol) + scelbp => this%band(ib)%scelb(ican,icol) + frac_diff_grnd_diff = frac_diff_grnd_diff + & + scelgp%area*this%GetRdDn(ican,icol,ib,scelgp%lai+scelgp%sai) + end do + + end if if_beam + + end do do_isol + + + ! Check the error balance + ! --------------------------------------------------------------------------------------------- + + ! Source = upwelling + canopy absorbed + ground absorbed + + consv_err = ((Rbeam_atm + Rdiff_atm) - & + (albedo_diff + albedo_beam ) - & + (frac_abs_can_diff + frac_abs_can_beam) - & + ((frac_diff_grnd_diff+frac_diff_grnd_beam)*(1._r8-this%band(ib)%albedo_grnd_diff)) - & + (frac_beam_grnd_beam*(1._r8-this%band(ib)%albedo_grnd_beam)) ) / (Rbeam_atm + Rdiff_atm) + + ! This is an error magnitude, not a bias + consv_err = abs(consv_err) + + beam_err = Rbeam_atm - (albedo_beam + frac_abs_can_beam + & + frac_diff_grnd_beam*(1._r8-this%band(ib)%albedo_grnd_diff) + & + frac_beam_grnd_beam*(1._r8-this%band(ib)%albedo_grnd_beam)) + + diff_err = Rdiff_atm - (albedo_diff + frac_abs_can_diff + & + frac_diff_grnd_diff*(1._r8-this%band(ib)%albedo_grnd_diff)) + + if( consv_err > rel_err_thresh ) then + write(log_unit,*)"Total canopy flux balance not closing in TwoStrteamMLPEMod:Solve" + write(log_unit,*)"Relative Error, delta/(Rbeam_atm+Rdiff_atm) :",consv_err + write(log_unit,*)"Max Error: ",rel_err_thresh + write(log_unit,*)"ib: ",ib + write(log_unit,*)"scattering coeff: ",(2*rad_params%om_leaf(ib,1)+0.5*rad_params%om_stem(ib,1))/2.5 + write(log_unit,*)"Breakdown:",this%n_lyr + do ican = 1,this%n_lyr + do icol = 1,this%n_col(ican) + scelgp => this%scelg(ican,icol) + scelbp => this%band(ib)%scelb(ican,icol) + write(log_unit,*)" ",ican,icol + write(log_unit,*)" ",scelgp%lai+scelgp%sai,scelgp%pft,scelgp%area + write(log_unit,*)" ",scelbp%om,scelgp%Kb,scelgp%Kd,scelbp%betab,scelbp%betad + write(log_unit,*)" ",scelbp%om*(1.0-scelbp%betad) + write(log_unit,*)" ",scelbp%lambda1_beam,scelbp%lambda2_beam + write(log_unit,*)" ",scelbp%lambda1_diff,scelbp%lambda2_diff + write(log_unit,*)"AB TERMS: ",scelbp%Ad,scelbp%Au,scelbp%B1,scelbp%B2,scelbp%a + write(log_unit,*)"LAMBDA TERMS: ",scelbp%lambda1_diff,scelbp%lambda2_diff,scelbp%lambda1_beam,scelbp%lambda2_beam + end do + end do + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + ! Re-cast the abledos so they are direct result of the components. + ! CESM and E3SM have higher tolerances. We close to 1e-6 but they + ! close to 1e-8, which is just very difficult when the canopies + ! get complex + if(albedo_corr)then + + albedo_beam = Rbeam_atm - (frac_abs_can_beam + & + frac_diff_grnd_beam*(1._r8-this%band(ib)%albedo_grnd_diff) + & + frac_beam_grnd_beam*(1._r8-this%band(ib)%albedo_grnd_beam)) + + albedo_diff = Rdiff_atm - (frac_abs_can_diff + & + frac_diff_grnd_diff*(1._r8-this%band(ib)%albedo_grnd_diff)) + + end if + + ! Set the boundary conditions back to unknown for a normalized solution + ! This prevents us from calling the absorption and flux query routines incorrectly. + ! For non-normalized, set it to the actual input boundary conditions + + if(upper_boundary_type.eq.normalized_upper_boundary) then + this%band(ib)%Rbeam_atm = unset_r8 + this%band(ib)%Rdiff_atm = unset_r8 + else + this%band(ib)%Rbeam_atm = Rbeam_atm + this%band(ib)%Rdiff_atm = Rdiff_atm + end if + + + return + end subroutine Solve + + +end Module TwoStreamMLPEMod diff --git a/tools/BatchPatchParams.py b/tools/BatchPatchParams.py index 99a6f6bd76..cd3e934632 100755 --- a/tools/BatchPatchParams.py +++ b/tools/BatchPatchParams.py @@ -7,9 +7,15 @@ import os import argparse import code # For development: code.interact(local=dict(globals(), **locals())) -from scipy.io import netcdf import xml.etree.ElementTree as et - +# Newer versions of scipy have dropped the netcdf module and +# netcdf functions are part of the io parent module +try: + from scipy import io as nc + +except ImportError: + from scipy.io import netcdf as nc + debug = True # --------------------------------------------------------------------------------------- @@ -105,15 +111,18 @@ def main(): base_nc = os.popen('mktemp').read().rstrip('\n') gencmd = "ncgen -o "+base_nc+" "+base_cdl os.system(gencmd) - + # Generate a temp output file name new_nc = os.popen('mktemp').read().rstrip('\n') + os.system("ls "+base_nc) + os.system("ls "+new_nc) + # Use FatesPFTIndexSwapper.py to prune out unwanted PFTs pft_trim_list = xmlroot.find('pft_trim_list').text.replace(" ","") swapcmd="../tools/FatesPFTIndexSwapper.py --pft-indices="+pft_trim_list+" --fin="+base_nc+" --fout="+new_nc+" --nohist" #+" 1>/dev/null" os.system(swapcmd) - + # On subsequent parameters, overwrite the file paramroot = xmlroot.find('parameters') @@ -173,7 +182,7 @@ def main(): # Append history - fp_nc = netcdf.netcdf_file(new_nc, 'a') + fp_nc = nc.netcdf_file(new_nc, 'a') fp_nc.history = "This file was generated by BatchPatchParams.py:\n"\ "CDL Base File = {}\n"\ "XML patch file = {}"\ diff --git a/tools/FatesPFTIndexSwapper.py b/tools/FatesPFTIndexSwapper.py index 99e258bdc6..c63f8891b7 100755 --- a/tools/FatesPFTIndexSwapper.py +++ b/tools/FatesPFTIndexSwapper.py @@ -15,9 +15,14 @@ import getopt import code # For development: code.interact(local=locals()) from datetime import datetime -from scipy.io import netcdf -#import matplotlib.pyplot as plt +# import matplotlib.pyplot as plt +# Newer versions of scipy have dropped the netcdf module and +# netcdf functions are part of the io parent module +try: + from scipy import io as nc +except ImportError: + from scipy.io import netcdf as nc # ======================================================================================= # Parameters @@ -28,6 +33,7 @@ hydro_dim_name = 'fates_hydr_organs' litt_dim_name = 'fates_litterclass' string_dim_name = 'fates_string_length' +landuse_dim_name = 'fates_landuseclass' class timetype: @@ -147,9 +153,9 @@ def main(argv): num_pft_out = len(donor_pft_indices) # Open the netcdf files - fp_out = netcdf.netcdf_file(output_fname, 'w') + fp_out = nc.netcdf_file(output_fname, 'w') - fp_in = netcdf.netcdf_file(input_fname, 'r') + fp_in = nc.netcdf_file(input_fname, 'r') for key, value in sorted(fp_in.dimensions.items()): if(key==pft_dim_name): @@ -165,14 +171,14 @@ def main(argv): in_var = fp_in.variables.get(key) - - + # Idenfity if this variable has pft dimension - pft_dim_found = -1 - prt_dim_found = -1 - hydro_dim_found = -1 - litt_dim_found = -1 - string_dim_found = -1 + pft_dim_found = -1 + prt_dim_found = -1 + hydro_dim_found = -1 + litt_dim_found = -1 + string_dim_found = -1 + landuse_dim_found = -1 pft_dim_len = len(fp_in.variables.get(key).dimensions) for idim, name in enumerate(fp_in.variables.get(key).dimensions): @@ -188,13 +194,18 @@ def main(argv): hydro_dim_found = idim if(name==string_dim_name): string_dim_found = idim - + if(name==landuse_dim_name): + landuse_dim_found = idim + + + + # Copy over the input data # Tedious, but I have to permute through all combinations of dimension position if( pft_dim_len == 0 ): out_var = fp_out.createVariable(key,'d',(fp_in.variables.get(key).dimensions)) out_var.assignValue(float(fp_in.variables.get(key).data)) - elif( (pft_dim_found==-1) & (prt_dim_found==-1) & (litt_dim_found==-1) & (hydro_dim_found==-1) ): + elif( (pft_dim_found==-1) & (prt_dim_found==-1) & (litt_dim_found==-1) & (hydro_dim_found==-1) & (landuse_dim_found==-1) ): out_var = fp_out.createVariable(key,'d',(fp_in.variables.get(key).dimensions)) out_var[:] = in_var[:] elif( (pft_dim_found==0) & (pft_dim_len==1) ): # 1D fates_pft @@ -231,6 +242,10 @@ def main(argv): out_var[:] = in_var[:] elif( (litt_dim_found==0) & (string_dim_found>=0) ): + out_var = fp_out.createVariable(key,'c',(fp_in.variables.get(key).dimensions)) + out_var[:] = in_var[:] + + elif( (landuse_dim_found==0) & (string_dim_found>=0) ): out_var = fp_out.createVariable(key,'c',(fp_in.variables.get(key).dimensions)) out_var[:] = in_var[:] @@ -241,6 +256,9 @@ def main(argv): elif( litt_dim_found==0 ): out_var = fp_out.createVariable(key,'d',(fp_in.variables.get(key).dimensions)) out_var[:] = in_var[:] + elif( landuse_dim_found==0 ): + out_var = fp_out.createVariable(key,'d',(fp_in.variables.get(key).dimensions)) + out_var[:] = in_var[:] elif( hydro_dim_found==0): out_var = fp_out.createVariable(key,'d',(fp_in.variables.get(key).dimensions)) out_var[:] = in_var[:] diff --git a/tools/UpdateParamAPI.py b/tools/UpdateParamAPI.py index f23ef5d24c..cc9ffa1faa 100755 --- a/tools/UpdateParamAPI.py +++ b/tools/UpdateParamAPI.py @@ -12,10 +12,17 @@ import os import argparse import code # For development: code.interact(local=dict(globals(), **locals())) -from scipy.io import netcdf import xml.etree.ElementTree as et import numpy as np +# Newer versions of scipy have dropped the netcdf module and +# netcdf functions are part of the io parent module +try: + from scipy import io as nc + +except ImportError: + from scipy.io import netcdf as nc + # ======================================================================================= def load_xml(xmlfile): @@ -157,10 +164,10 @@ def removevar(base_nc,varname): # The trick here, is to copy the whole file, minus the variable of interest # into a temp file. Then completely remove the old file, and - fp_base = netcdf.netcdf_file(base_nc, 'r',mmap=False) + fp_base = nc.netcdf_file(base_nc, 'r',mmap=False) new_nc = os.popen('mktemp').read().rstrip('\n') - fp_new = netcdf.netcdf_file(new_nc, 'w',mmap=False) + fp_new = nc.netcdf_file(new_nc, 'w',mmap=False) found = False for key, value in sorted(fp_base.dimensions.items()): @@ -248,7 +255,7 @@ def main(): print("The dimension size should be a scalar") exit(2) - ncfile = netcdf.netcdf_file(base_nc,"a",mmap=False) + ncfile = nc.netcdf_file(base_nc,"a",mmap=False) ncfile.createDimension(dimname, values[0]) ncfile.flush() ncfile.close() @@ -264,7 +271,7 @@ def main(): exit(2) # Find which parameters use this dimension - ncfile = netcdf.netcdf_file(base_nc,"r",mmap=False) + ncfile = nc.netcdf_file(base_nc,"r",mmap=False) found = False for key, value in sorted(ncfile.dimensions.items()): if(key==dimname): @@ -298,47 +305,51 @@ def main(): # print("no data type (dt), exiting");exit(2) try: + # print("trying dimnames: {}".format(paramname)) dimnames = tuple(mod.find('di').text.replace(" ","").split(',')) except: print("no data type (di), exiting");exit(2) try: + # print("trying units: {}".format(paramname)) units = mod.find('un').text.strip() except: print("no units (un), exiting");exit(2) try: + # print("trying ln: {}".format(paramname)) longname = mod.find('ln').text.strip() except: print("no long-name (ln), exiting");exit(2) - ncfile = netcdf.netcdf_file(base_nc,"a",mmap=False) + ncfile = nc.netcdf_file(base_nc,"a",mmap=False) try: - values = str2fvec(mod.find('val').text.strip()) - except: - # try: - if(isinstance(mod.find('val').text,type(None))): - # values = mod.find('val').text.strip() - # except: + # print("trying val: {}".format(paramname)) + valstring = mod.find('val').text.strip() + values = str2fvec(valstring) + except Exception as emsg: + # print("type: {}".format(type(valstring))) + if(isinstance(valstring,type(None))): print("Warning: no values (val). Setting undefined (i.e. '_'): {}\n".format(paramname)) sel_values = ncfile.variables['fates_dev_arbitrary_pft'].data dcode = "d" - else: - print("unknown values (val), exiting");exit(2) + elif(isinstance(valstring,str)): + dcode = "c" + values = valstring.split(',') + for i,val in enumerate(values): + values[i] = val.strip() + print("value: {},{}".format(i,values[i])) + sel_values = selectvalues(ncfile,list(dimnames),ipft_list,values,dcode) + else: + print("exception, unknown values (val), exiting: {}".format(emsg));exit(2) #print("no values (val), exiting");exit(2) else: #code.interact(local=dict(globals(), **locals())) if(dimnames[0]=='scalar' or dimnames[0]=='none' or dimnames[0]==''): dimnames = () - - if(isinstance(values[0],str)): - dcode = "c" - values = values.split(',') - for i,val in enumerate(values): - values[i] = val.strip() elif(isinstance(values[0],float)): dcode = "d" else: @@ -371,7 +382,7 @@ def main(): print("to change a parameter, the field must have a name attribute") exit(2) - ncfile = netcdf.netcdf_file(base_nc,"a",mmap=False) + ncfile = nc.netcdf_file(base_nc,"a",mmap=False) ncvar_o = ncfile.variables[paramname_o] # dims_o = ncvar_o.dimensions dtype_o = ncvar_o.typecode() diff --git a/tools/ed2_to_fates_inventory_init.py b/tools/ed2_to_fates_inventory_init.py new file mode 100644 index 0000000000..b258341a08 --- /dev/null +++ b/tools/ed2_to_fates_inventory_init.py @@ -0,0 +1,49 @@ +#!/usr/bin/env python + +### This script takes a ED2 style inventory init file and converts it to a file compatible with FATES. +# It accepts the following flags: +# --fin : input filename + +import argparse +import pandas as pd +import sys + +def main(): + parser = argparse.ArgumentParser(description='Parse command line arguments to this script.') + # + parser.add_argument('--fin', dest='fnamein', type=str, help="Input filename. Required.", required=True) + + args = parser.parse_args() + + # is it a pss or css file? + filetype = args.fnamein.split('.')[1] + + # make the new file name + base_filename = args.fnamein.split('.')[0] + output_filename = f"{base_filename}_{'fates'}.{filetype}" + + # open the input data + dsin = pd.read_csv(args.fnamein, delim_whitespace=True) + + # if patch file delete unnecessary patch columns + if filetype == 'pss' : + keep_col = ['time', 'patch', 'trk', 'age', 'area'] + newds = dsin[keep_col] + + + # if cohort file delete unnecessary cohort columns + elif filetype == 'css' : + keep_col = ['time', 'patch', 'dbh', 'height', 'pft', 'nplant'] + newds = dsin[keep_col] + + else : + print("file type must be one of patch (pss) or cohort (css)") + + + newds.to_csv(output_filename, index=False, sep=' ') +# ======================================================================================================== +# This is the actual call to main + +if __name__ == "__main__": + main() + diff --git a/tools/luh2/luh2.py b/tools/luh2/luh2.py index d0cd91afec..ec111c88f6 100644 --- a/tools/luh2/luh2.py +++ b/tools/luh2/luh2.py @@ -59,10 +59,12 @@ def main(): # Add additional required variables for the host land model # Add 'YEAR' as a variable. - # This is an old requirement of the HLM and should simply be a copy of the `time` dimension # If we are merging, we might not need to do this, so check to see if its there already + # This is a requirement of the HLM dyn_subgrid module and should be the actual year. + # Note that the time variable from the LUH2 data is 'years since ...' so we need to + # add the input data year if (not "YEAR" in list(regrid_luh2.variables)): - regrid_luh2["YEAR"] = regrid_luh2.time + regrid_luh2["YEAR"] = regrid_luh2.time + ds_luh2.timesince regrid_luh2["LONGXY"] = ds_regrid_target["LONGXY"] # TO DO: double check if this is strictly necessary regrid_luh2["LATIXY"] = ds_regrid_target["LATIXY"] # TO DO: double check if this is strictly necessary @@ -70,6 +72,12 @@ def main(): if (not 'lsmlat' in list(regrid_luh2.dims)): regrid_luh2 = regrid_luh2.rename_dims({'lat':'lsmlat','lon':'lsmlon'}) + # Reapply the coordinate attributes. This is a workaround for an xarray bug (#8047) + # Currently only need time + regrid_luh2.time.attrs = ds_luh2.time.attrs + regrid_luh2.lat.attrs = ds_luh2.lat.attrs + regrid_luh2.lon.attrs = ds_luh2.lon.attrs + # Merge existing regrided luh2 file with merge input target # TO DO: check that the grid resolution # We could do this with an append during the write phase instead of the merge diff --git a/tools/luh2/luh2mod.py b/tools/luh2/luh2mod.py index c8534d42a9..801baa96fc 100644 --- a/tools/luh2/luh2mod.py +++ b/tools/luh2/luh2mod.py @@ -30,7 +30,7 @@ def PrepDataset(input_dataset,start=None,stop=None,merge_flag=False): # 'years since' style format. if(not(dstype in ('static','regrid'))): - if (dstype == 'LUH2'): + if ('LUH2' in dstype): # Get the units to determine the file time # It is expected that the units of time is 'years since ...' time_since_array = input_dataset.time.units.split() @@ -66,6 +66,9 @@ def PrepDataset(input_dataset,start=None,stop=None,merge_flag=False): # the start/stop is out of range input_dataset = input_dataset.sel(time=slice(years_since_start,years_since_stop)) + # Save the timesince as a variable for future use + input_dataset["timesince"] = time_since + # Correct the necessary variables for both datasets # We don't need to Prep the incoming dataset if it's being opened to merge if(not merge_flag): @@ -77,7 +80,7 @@ def PrepDataset(input_dataset,start=None,stop=None,merge_flag=False): def PrepDataset_ESMF(input_dataset,dsflag,dstype): if (dsflag): - if(dstype == "LUH2"): + if("LUH2" in dstype): print("PrepDataset: LUH2") input_dataset = BoundsVariableFixLUH2(input_dataset) elif(dstype == "surface"): @@ -138,16 +141,19 @@ def CheckDataset(input_dataset): dsflag = False dsvars = list(input_dataset.variables) - if('primf' in dsvars or - 'primf_to_secdn' in dsvars or + if(any('primf' in subname for subname in dsvars) or any('irrig' in subname for subname in dsvars)): - dstype = 'LUH2' + if ('primf_to_secdn' in dsvars): + dstype = 'LUH2_transitions' + else: + dstype = 'LUH2' + dsflag = True - print("LUH2") + # print("LUH2") elif('natpft' in dsvars): dstype = 'surface' dsflag = True - print("Surface") + # print("Surface") elif('icwtr' in dsvars): dstype = 'static' dsflag = True @@ -199,7 +205,7 @@ def RegridLoop(ds_to_regrid, regridder): for i in range(varlen-1): # Skip time variable - if (ds_varnames[i] != "time"): + if (not "time" in ds_varnames[i]): # Only regrid variables that match the lat/lon shape. if (ds_to_regrid[ds_varnames[i]][0].shape == (ds_to_regrid.lat.shape[0], ds_to_regrid.lon.shape[0])): diff --git a/tools/modify_fates_paramfile.py b/tools/modify_fates_paramfile.py index adacb2457b..1b25ae7171 100755 --- a/tools/modify_fates_paramfile.py +++ b/tools/modify_fates_paramfile.py @@ -17,7 +17,6 @@ # ======================================================================================= import os -from scipy.io import netcdf as nc import argparse import shutil import tempfile @@ -27,6 +26,16 @@ import numpy as np import code # For development: code.interact(local=dict(globals(), **locals())) +# Newer versions of scipy have dropped the netcdf module and +# netcdf functions are part of the io parent module +try: + from scipy import io as nc + +except ImportError: + from scipy.io import netcdf as nc + + + # ======================================================================================== # ======================================================================================== # Main @@ -141,7 +150,7 @@ def main(): 'fates_history_damage_bins', 'fates_NCWD','fates_litterclass','fates_leafage_class', \ 'fates_plant_organs','fates_hydr_organs','fates_hlm_pftno', \ - 'fates_leafage_class']: + 'fates_leafage_class','fates_landuse_class']: otherdimpresent = True otherdimname = var.dimensions[i] otherdimlength = var.shape[i] diff --git a/tools/ncvarsort.py b/tools/ncvarsort.py index 327dd84a96..6583700ae3 100755 --- a/tools/ncvarsort.py +++ b/tools/ncvarsort.py @@ -30,7 +30,7 @@ def main(): # make empty lists to hold the variable names in. the first of these is a list of sub-lists, # one for each type of variable (based on dimensionality). # the second is the master list that will contain all variables. - varnames_list = [[],[],[],[],[],[],[],[],[],[],[],[],[]] + varnames_list = [[],[],[],[],[],[],[],[],[],[],[],[],[],[]] varnames_list_sorted = [] # # sort the variables by dimensionality, but mix the PFT x other dimension in with the regular PFT-indexed variables @@ -48,6 +48,7 @@ def main(): (u'fates_prt_organs', u'fates_string_length'):7, (u'fates_plant_organs', u'fates_string_length'):7, (u'fates_litterclass', u'fates_string_length'):7, + (u'fates_landuseclass', u'fates_string_length'):7, (u'fates_pft',):8, (u'fates_hydr_organs', u'fates_pft'):8, (u'fates_leafage_class', u'fates_pft'):8, @@ -56,7 +57,9 @@ def main(): (u'fates_hlm_pftno', u'fates_pft'):9, (u'fates_litterclass',):10, (u'fates_NCWD',):11, - ():12} + (u'fates_landuseclass',):12, + (u'fates_landuseclass', u'fates_pft'):12, + ():13} # # go through each of the variables and assign it to one of the sub-lists based on its dimensionality for v_name, varin in dsin.variables.items():