Skip to content

Commit

Permalink
Merge pull request ESCOMP#262 from rgknox/rgknox-interface-dynamics-n…
Browse files Browse the repository at this point in the history 
…umpft

dynamic numpft, dimension interface, removal of edecophyscon
  • Loading branch information
@rgknox
rgknox authored Aug 17, 2017
2 parents cdd1f73 + 59c7c8d commit 0115fbc
Show file tree
Hide file tree
Showing 21 changed files with 544 additions and 821 deletions.
56 changes: 27 additions & 29 deletions biogeochem/EDCanopyStructureMod.F90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -7,16 +7,16 @@ module EDCanopyStructureMod

use FatesConstantsMod , only : r8 => fates_r8
use FatesGlobals , only : fates_log
use EDPftvarcon , only : EDPftvarcon_inst
use EDPftvarcon , only : EDPftvarcon_inst
use EDGrowthFunctionsMod , only : c_area
use EDCohortDynamicsMod , only : copy_cohort, terminate_cohorts, fuse_cohorts
use EDtypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type, ncwd
use EDTypesMod , only : nclmax
use EDTypesMod , only : nlevleaf
use EDTypesMod , only : numpft_ed
use EDtypesMod , only : AREA
use FatesGlobals , only : endrun => fates_endrun
use FatesInterfaceMod , only : hlm_days_per_year
use FatesInterfaceMod , only : numpft

! CIME Globals
use shr_log_mod , only : errMsg => shr_log_errMsg
Expand Down Expand Up @@ -825,7 +825,6 @@ subroutine canopy_summarization( nsites, sites, bc_in )
use EDPatchDynamicsMod , only : set_root_fraction
use EDTypesMod , only : sizetype_class_index
use EDGrowthFunctionsMod , only : tree_lai, c_area
use EDEcophysConType , only : EDecophyscon
use EDtypesMod , only : area
use EDPftvarcon , only : EDPftvarcon_inst

Expand Down Expand Up @@ -941,7 +940,6 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si)

use EDGrowthFunctionsMod , only : tree_lai, tree_sai, c_area
use EDtypesMod , only : area, dinc_ed, hitemax, n_hite_bins
use EDEcophysConType , only : EDecophyscon

!
! !ARGUMENTS
Expand Down Expand Up @@ -1051,19 +1049,19 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si)
currentCohort => currentPatch%shortest
do while(associated(currentCohort))
ft = currentCohort%pft
min_chite = currentCohort%hite - currentCohort%hite * EDecophyscon%crown(ft)
min_chite = currentCohort%hite - currentCohort%hite * EDPftvarcon_inst%crown(ft)
max_chite = currentCohort%hite
do iv = 1,N_HITE_BINS
frac_canopy(iv) = 0.0_r8
! this layer is in the middle of the canopy
if(max_chite > maxh(iv).and.min_chite < minh(iv))then
frac_canopy(iv)= min(1.0_r8,dh / (currentCohort%hite*EDecophyscon%crown(ft)))
frac_canopy(iv)= min(1.0_r8,dh / (currentCohort%hite*EDPftvarcon_inst%crown(ft)))
! this is the layer with the bottom of the canopy in it.
elseif(min_chite < maxh(iv).and.min_chite > minh(iv).and.max_chite > maxh(iv))then
frac_canopy(iv) = (maxh(iv) -min_chite ) / (currentCohort%hite*EDecophyscon%crown(ft))
frac_canopy(iv) = (maxh(iv) -min_chite ) / (currentCohort%hite*EDPftvarcon_inst%crown(ft))
! this is the layer with the top of the canopy in it.
elseif(max_chite > minh(iv).and.max_chite < maxh(iv).and.min_chite < minh(iv))then
frac_canopy(iv) = (max_chite - minh(iv)) / (currentCohort%hite*EDecophyscon%crown(ft))
frac_canopy(iv) = (max_chite - minh(iv)) / (currentCohort%hite*EDPftvarcon_inst%crown(ft))
elseif(max_chite < maxh(iv).and.min_chite > minh(iv))then !the whole cohort is within this layer.
frac_canopy(iv) = 1.0_r8
endif
Expand Down Expand Up @@ -1111,7 +1109,7 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si)
currentCohort => currentCohort%taller
enddo !currentCohort
lai = 0.0_r8
do ft = 1,numpft_ed
do ft = 1,numpft
lai = lai+ sum(currentPatch%tlai_profile(1,ft,:))
enddo

Expand Down Expand Up @@ -1159,9 +1157,9 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si)
! what is the height of this layer? (for snow burial purposes...)
! EDPftvarcon_inst%vertical_canopy_frac(ft))! fudge - this should be pft specific but i cant get it to compile.
layer_top_hite = currentCohort%hite-((iv/currentCohort%NV) * currentCohort%hite * &
EDecophyscon%crown(currentCohort%pft) )
EDPftvarcon_inst%crown(currentCohort%pft) )
layer_bottom_hite = currentCohort%hite-(((iv+1)/currentCohort%NV) * currentCohort%hite * &
EDecophyscon%crown(currentCohort%pft)) ! EDPftvarcon_inst%vertical_canopy_frac(ft))
EDPftvarcon_inst%crown(currentCohort%pft)) ! EDPftvarcon_inst%vertical_canopy_frac(ft))

fraction_exposed =1.0_r8

Expand Down Expand Up @@ -1192,10 +1190,10 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si)
iv = currentCohort%NV
! EDPftvarcon_inst%vertical_canopy_frac(ft))! fudge - this should be pft specific but i cant get it to compile.
layer_top_hite = currentCohort%hite-((iv/currentCohort%NV) * currentCohort%hite * &
EDecophyscon%crown(currentCohort%pft) )
EDPftvarcon_inst%crown(currentCohort%pft) )
! EDPftvarcon_inst%vertical_canopy_frac(ft))
layer_bottom_hite = currentCohort%hite-(((iv+1)/currentCohort%NV) * currentCohort%hite * &
EDecophyscon%crown(currentCohort%pft))
EDPftvarcon_inst%crown(currentCohort%pft))

fraction_exposed = 1.0_r8 !default.
snow_depth_avg = snow_depth_si * frac_sno_eff_si
Expand Down Expand Up @@ -1251,7 +1249,7 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si)
enddo !cohort

do L = 1,currentPatch%NCL_p
do ft = 1,numpft_ed
do ft = 1,numpft
do iv = 1,currentPatch%nrad(L,ft)
!account for total canopy area
currentPatch%tlai_profile(L,ft,iv) = currentPatch%tlai_profile(L,ft,iv) / &
Expand Down Expand Up @@ -1279,7 +1277,7 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si)

currentPatch%nrad = currentPatch%ncan
do L = 1,currentPatch%NCL_p
do ft = 1,numpft_ed
do ft = 1,numpft
if(currentPatch%nrad(L,ft) > 30)then
write(fates_log(), *) 'ED: issue w/ nrad'
endif
Expand All @@ -1291,24 +1289,24 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si)
end do !iv
enddo !ft

if ( L == 1 .and. abs(sum(currentPatch%canopy_area_profile(1,1:numpft_ed,1))) < 0.99999 &
if ( L == 1 .and. abs(sum(currentPatch%canopy_area_profile(1,1:numpft,1))) < 0.99999 &
.and. currentPatch%NCL_p > 1 ) then
write(fates_log(), *) 'ED: canopy area too small',sum(currentPatch%canopy_area_profile(1,1:numpft_ed,1))
write(fates_log(), *) 'ED: cohort areas', currentPatch%canopy_area_profile(1,1:numpft_ed,:)
write(fates_log(), *) 'ED: canopy area too small',sum(currentPatch%canopy_area_profile(1,1:numpft,1))
write(fates_log(), *) 'ED: cohort areas', currentPatch%canopy_area_profile(1,1:numpft,:)
endif

if (L == 1 .and. currentPatch%NCL_p > 1 .and. &
abs(sum(currentPatch%canopy_area_profile(1,1:numpft_ed,1))) < 0.99999) then
abs(sum(currentPatch%canopy_area_profile(1,1:numpft,1))) < 0.99999) then
write(fates_log(), *) 'ED: not enough area in the top canopy', &
sum(currentPatch%canopy_area_profile(L,1:numpft_ed,1)), &
currentPatch%canopy_area_profile(L,1:numpft_ed,1)
sum(currentPatch%canopy_area_profile(L,1:numpft,1)), &
currentPatch%canopy_area_profile(L,1:numpft,1)
endif

if(abs(sum(currentPatch%canopy_area_profile(L,1:numpft_ed,1))) > 1.00001)then
if(abs(sum(currentPatch%canopy_area_profile(L,1:numpft,1))) > 1.00001)then
write(fates_log(), *) 'ED: canopy-area-profile wrong', &
sum(currentPatch%canopy_area_profile(L,1:numpft_ed,1)), &
sum(currentPatch%canopy_area_profile(L,1:numpft,1)), &
currentPatch%patchno, L
write(fates_log(), *) 'ED: areas',currentPatch%canopy_area_profile(L,1:numpft_ed,1),currentPatch%patchno
write(fates_log(), *) 'ED: areas',currentPatch%canopy_area_profile(L,1:numpft,1),currentPatch%patchno

currentCohort => currentPatch%shortest

Expand All @@ -1328,7 +1326,7 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si)
enddo ! loop over L

do L = 1,currentPatch%NCL_p
do ft = 1,numpft_ed
do ft = 1,numpft
if(currentPatch%present(L,FT) > 1)then
write(fates_log(), *) 'ED: present issue',L,ft,currentPatch%present(L,FT)
currentPatch%present(L,ft) = 1
Expand Down Expand Up @@ -1500,28 +1498,28 @@ function calc_areaindex(cpatch,ai_type) result(ai)
ai = 0._r8
if (trim(ai_type) == 'elai') then
do cl = 1,cpatch%NCL_p
do ft = 1,numpft_ed
do ft = 1,numpft
ai = ai + sum(cpatch%canopy_area_profile(cl,ft,1:cpatch%nrad(cl,ft)) * &
cpatch%elai_profile(cl,ft,1:cpatch%nrad(cl,ft)))
enddo
enddo
elseif (trim(ai_type) == 'tlai') then
do cl = 1,cpatch%NCL_p
do ft = 1,numpft_ed
do ft = 1,numpft
ai = ai + sum(cpatch%canopy_area_profile(cl,ft,1:cpatch%nrad(cl,ft)) * &
cpatch%tlai_profile(cl,ft,1:cpatch%nrad(cl,ft)))
enddo
enddo
elseif (trim(ai_type) == 'esai') then
do cl = 1,cpatch%NCL_p
do ft = 1,numpft_ed
do ft = 1,numpft
ai = ai + sum(cpatch%canopy_area_profile(cl,ft,1:cpatch%nrad(cl,ft)) * &
cpatch%esai_profile(cl,ft,1:cpatch%nrad(cl,ft)))
enddo
enddo
elseif (trim(ai_type) == 'tsai') then
do cl = 1,cpatch%NCL_p
do ft = 1,numpft_ed
do ft = 1,numpft
ai = ai + sum(cpatch%canopy_area_profile(cl,ft,1:cpatch%nrad(cl,ft)) * &
cpatch%tsai_profile(cl,ft,1:cpatch%nrad(cl,ft)))
enddo
Expand Down
5 changes: 2 additions & 3 deletions biogeochem/EDCohortDynamicsMod.F90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -13,7 +13,6 @@ module EDCohortDynamicsMod
use FatesConstantsMod , only : itrue
use FatesInterfaceMod , only : hlm_days_per_year
use EDPftvarcon , only : EDPftvarcon_inst
use EDEcophysContype , only : EDecophyscon
use EDGrowthFunctionsMod , only : c_area, tree_lai
use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type
use EDTypesMod , only : nclmax
Expand Down Expand Up @@ -676,8 +675,8 @@ subroutine fuse_cohorts(patchptr, bc_in)
type (ed_cohort_type) , pointer :: currentCohort, nextc, nextnextc
integer :: i
integer :: fusion_took_place
integer :: maxcohorts !maximum total no of cohorts. Needs to be >numpft_edx2
integer :: iterate !do we need to keep fusing to get below maxcohorts?
integer :: maxcohorts ! maximum total no of cohorts.
integer :: iterate ! do we need to keep fusing to get below maxcohorts?
integer :: nocohorts
real(r8) :: newn
real(r8) :: diff
Expand Down
37 changes: 17 additions & 20 deletions biogeochem/EDPatchDynamicsMod.F90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -8,17 +8,18 @@ module EDPatchDynamicsMod
use EDPftvarcon , only : EDPftvarcon_inst
use EDCohortDynamicsMod , only : fuse_cohorts, sort_cohorts, insert_cohort
use EDtypesMod , only : ncwd, n_dbh_bins, ntol, area, dbhmax
use EDTypesMod , only : numpft_ed
use EDTypesMod , only : maxPatchesPerSite
use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type
use EDTypesMod , only : min_patch_area
use EDTypesMod , only : nclmax
use EDTypesMod , only : maxpft
use FatesInterfaceMod , only : hlm_use_planthydro
use FatesInterfaceMod , only : hlm_numlevgrnd
use FatesInterfaceMod , only : hlm_numlevsoil
use FatesInterfaceMod , only : hlm_numSWb
use FatesInterfaceMod , only : bc_in_type
use FatesInterfaceMod , only : hlm_days_per_year
use FatesInterfaceMod , only : numpft
use FatesGlobals , only : endrun => fates_endrun
use FatesConstantsMod , only : r8 => fates_r8
use FatesConstantsMod , only : itrue
Expand Down Expand Up @@ -206,8 +207,8 @@ subroutine spawn_patches( currentSite, bc_in)
real(r8) :: age ! notional age of this patch in years
integer :: tnull ! is there a tallest cohort?
integer :: snull ! is there a shortest cohort?
real(r8) :: root_litter_local(numpft_ed) ! initial value of root litter. KgC/m2
real(r8) :: leaf_litter_local(numpft_ed) ! initial value of leaf litter. KgC/m2
real(r8) :: root_litter_local(maxpft) ! initial value of root litter. KgC/m2
real(r8) :: leaf_litter_local(maxpft) ! initial value of leaf litter. KgC/m2
real(r8) :: cwd_ag_local(ncwd) ! initial value of above ground coarse woody debris. KgC/m2
real(r8) :: cwd_bg_local(ncwd) ! initial value of below ground coarse woody debris. KgC/m2
real(r8) :: spread_local(nclmax) ! initial value of canopy spread parameter.no units
Expand Down Expand Up @@ -523,7 +524,7 @@ subroutine average_patch_properties( currentPatch, newPatch, patch_site_areadis
newPatch%cwd_bg(c) = newPatch%cwd_bg(c) + currentPatch%cwd_bg(c) * patch_site_areadis/newPatch%area
enddo

do p = 1,numpft_ed !move litter pool en mass into the new patch
do p = 1,numpft !move litter pool en mass into the new patch
newPatch%root_litter(p) = newPatch%root_litter(p) + currentPatch%root_litter(p) * patch_site_areadis/newPatch%area
newPatch%leaf_litter(p) = newPatch%leaf_litter(p) + currentPatch%leaf_litter(p) * patch_site_areadis/newPatch%area

Expand Down Expand Up @@ -589,7 +590,7 @@ subroutine fire_litter_fluxes(currentSite, cp_target, new_patch_target, patch_si
currentSite%total_burn_flux_to_atm = currentSite%total_burn_flux_to_atm + burned_litter * new_patch%area !kG/site/day
enddo

do p = 1,numpft_ed
do p = 1,numpft
burned_litter = new_patch%leaf_litter(p) * patch_site_areadis/new_patch%area * currentPatch%burnt_frac_litter(dl_sf)
new_patch%leaf_litter(p) = new_patch%leaf_litter(p) - burned_litter
currentSite%flux_out = currentSite%flux_out + burned_litter * new_patch%area !kG/site/day
Expand Down Expand Up @@ -684,7 +685,7 @@ subroutine fire_litter_fluxes(currentSite, cp_target, new_patch_target, patch_si
enddo

!burned leaves.
do p = 1,numpft_ed
do p = 1,numpft

currentSite%leaf_litter_burned(p) = currentSite%leaf_litter_burned(p) + &
dead_tree_density * currentCohort%bl * currentCohort%cfa
Expand Down Expand Up @@ -763,8 +764,8 @@ subroutine mortality_litter_fluxes(currentSite, cp_target, new_patch_target, pat
real(r8) :: np_mult !Fraction of the new patch which came from the current patch (and so needs the same litter)
integer :: p,c
real(r8) :: canopy_mortality_woody_litter ! flux of wood litter in to litter pool: KgC/m2/day
real(r8) :: canopy_mortality_leaf_litter(numpft_ed) ! flux in to leaf litter from tree death: KgC/m2/day
real(r8) :: canopy_mortality_root_litter(numpft_ed) ! flux in to froot litter from tree death: KgC/m2/day
real(r8) :: canopy_mortality_leaf_litter(maxpft) ! flux in to leaf litter from tree death: KgC/m2/day
real(r8) :: canopy_mortality_root_litter(maxpft) ! flux in to froot litter from tree death: KgC/m2/day
real(r8) :: mean_agb_frac ! mean fraction of AGB to total woody biomass (stand mean)
!---------------------------------------------------------------------

Expand Down Expand Up @@ -830,7 +831,7 @@ subroutine mortality_litter_fluxes(currentSite, cp_target, new_patch_target, pat
! For the new patch, only some fraction of its land area (patch_areadis/np%area) is derived from the current patch
! so we need to multiply by patch_areadis/np%area

mean_agb_frac = sum(EDPftvarcon_inst%allom_agb_frac(1:numpft_ed))/dble(numpft_ed)
mean_agb_frac = sum(EDPftvarcon_inst%allom_agb_frac(1:numpft))/dble(numpft)

do c = 1,ncwd

Expand All @@ -848,7 +849,7 @@ subroutine mortality_litter_fluxes(currentSite, cp_target, new_patch_target, pat
SF_val_CWD_frac(c) * canopy_mortality_woody_litter * hlm_days_per_year * (1.0_r8 - mean_agb_frac) / AREA
enddo

do p = 1,numpft_ed
do p = 1,numpft

new_patch%leaf_litter(p) = new_patch%leaf_litter(p) + canopy_mortality_leaf_litter(p) / litter_area * np_mult
new_patch%root_litter(p) = new_patch%root_litter(p) + canopy_mortality_root_litter(p) / litter_area * np_mult
Expand Down Expand Up @@ -897,8 +898,8 @@ subroutine create_patch(currentSite, new_patch, age, areap, spread_local,cwd_ag_
allocate(new_patch%fabi(hlm_numSWb))
allocate(new_patch%sabs_dir(hlm_numSWb))
allocate(new_patch%sabs_dif(hlm_numSWb))
allocate(new_patch%rootfr_ft(numpft_ed,hlm_numlevgrnd))
allocate(new_patch%rootr_ft(numpft_ed,hlm_numlevgrnd))
allocate(new_patch%rootfr_ft(numpft,hlm_numlevgrnd))
allocate(new_patch%rootr_ft(numpft,hlm_numlevgrnd))

call zero_patch(new_patch) !The nan value in here is not working??

Expand Down Expand Up @@ -1152,7 +1153,7 @@ subroutine fuse_patches( csite, bc_in )
!---------------------------------------------------------------------!
! Calculate the difference criteria for each pft and dbh class !
!---------------------------------------------------------------------!
do ft = 1,numpft_ed ! loop over pfts
do ft = 1,numpft ! loop over pfts
do z = 1,n_dbh_bins ! loop over hgt bins
!is there biomass in this category?
if(currentPatch%pft_agb_profile(ft,z) > 0.0_r8.or.tpp%pft_agb_profile(ft,z) > 0.0_r8)then
Expand Down Expand Up @@ -1268,7 +1269,7 @@ subroutine fuse_2_patches(dp, rp)
rp%cwd_bg(c) = (dp%cwd_bg(c)*dp%area + rp%cwd_bg(c)*rp%area) * inv_sum_area
enddo

do p = 1,numpft_ed
do p = 1,numpft
rp%seeds_in(p) = (rp%seeds_in(p)*rp%area + dp%seeds_in(p)*dp%area) * inv_sum_area
rp%seed_decay(p) = (rp%seed_decay(p)*rp%area + dp%seed_decay(p)*dp%area) * inv_sum_area
rp%seed_germination(p) = (rp%seed_germination(p)*rp%area + dp%seed_germination(p)*dp%area) * inv_sum_area
Expand Down Expand Up @@ -1531,11 +1532,7 @@ subroutine patch_pft_size_profile(cp_pnt)

delta_dbh = (DBHMAX/N_DBH_BINS)

do p = 1,numpft_ed
do j = 1,N_DBH_BINS
currentPatch%pft_agb_profile(p,j) = 0.0_r8
enddo
enddo
currentPatch%pft_agb_profile(:,:) = 0.0_r8

do j = 1,N_DBH_BINS
if (j == 1) then
Expand Down Expand Up @@ -1617,7 +1614,7 @@ subroutine set_root_fraction( cpatch , zi )
integer :: lev,p,c,ft
!----------------------------------------------------------------------

do ft = 1,numpft_ed
do ft = 1,numpft
do lev = 1, hlm_numlevgrnd
cpatch%rootfr_ft(ft,lev) = 0._r8
enddo
Expand Down
Loading

0 comments on commit 0115fbc

Please sign in to comment.