From d9f2ca0a6fa77ce9666c4e8c0617159ab4ac3736 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 30 Apr 2020 02:22:45 -0600 Subject: [PATCH 001/209] roll back snow burial change --- biogeochem/EDCanopyStructureMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 4bdb462b04..acf7a9edd0 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1592,7 +1592,7 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) if(snow_depth_avg>= minh(iv).and.snow_depth_avg <= maxh(iv))then !only partly hidden... fraction_exposed = max(0._r8,(min(1.0_r8,(snow_depth_avg-minh(iv))/dh))) endif - ! fraction_exposed = 1.0_r8 + fraction_exposed = 1.0_r8 ! no m2 of leaf per m2 of ground in each height class ! FIX(SPM,032414) these should be uncommented this and double check From 3fc6a942ee3e9934f5f562acb27b47e6176f1ec1 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 30 Apr 2020 03:59:14 -0600 Subject: [PATCH 002/209] initial set of nocomp changes. doesn't work yet --- biogeochem/EDPatchDynamicsMod.F90 | 31 ++++++++++++++++++++++++++----- main/EDInitMod.F90 | 17 +++++++++++++++-- main/EDTypesMod.F90 | 2 +- main/FatesRestartInterfaceMod.F90 | 9 +++++++++ 4 files changed, 51 insertions(+), 8 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index c57b8b3d6a..5016891812 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -42,6 +42,7 @@ module EDPatchDynamicsMod use FatesInterfaceMod , only : bc_in_type use FatesInterfaceMod , only : hlm_days_per_year use FatesInterfaceMod , only : numpft + use FatesInterfaceMod , only : hlm_use_nocomp use FatesGlobals , only : endrun => fates_endrun use FatesConstantsMod , only : r8 => fates_r8 use FatesConstantsMod , only : itrue, ifalse @@ -395,6 +396,7 @@ subroutine spawn_patches( currentSite, bc_in) 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) :: patch_site_areadis ! total area disturbed in m2 per patch per day + real(r8) :: site_areadis_pft(numpft) ! total area disturbed per PFT class when nocomp mode is on. m2 per patch per day real(r8) :: age ! notional age of this patch in years integer :: el ! element loop index integer :: tnull ! is there a tallest cohort? @@ -409,6 +411,7 @@ subroutine spawn_patches( currentSite, bc_in) real(r8) :: leaf_burn_frac ! fraction of leaves burned in fire ! for both woody and grass species real(r8) :: leaf_m ! leaf mass during partial burn calculations + integer :: nocomp_pft ! where nocomp mode is on, PFT label !--------------------------------------------------------------------- storesmallcohort => null() ! storage of the smallest cohort for insertion routine @@ -419,6 +422,7 @@ subroutine spawn_patches( currentSite, bc_in) site_areadis_primary = 0.0_r8 site_areadis_secondary = 0.0_r8 + site_areadis_pft(1:numpft)=0.0_r8 do while(associated(currentPatch)) @@ -448,7 +452,12 @@ subroutine spawn_patches( currentSite, bc_in) else site_areadis_secondary = site_areadis_secondary + currentPatch%area * currentPatch%disturbance_rate endif - + + ! accumulate PFT specific disturbance rates in nocomp mode + if(hlm_use_nocomp.eq.itrue)then + site_areadis_pft(currentPatch%nocomp_pft_label) = site_areadis_pft(currentPatch%nocomp_pft_label) & + + currentPatch%area * currentPatch%disturbance_rate + end if end if currentPatch => currentPatch%older @@ -465,7 +474,7 @@ subroutine spawn_patches( currentSite, bc_in) allocate(new_patch_primary) call create_patch(currentSite, new_patch_primary, age, & - site_areadis_primary, primaryforest) + site_areadis_primary, primaryforest,nocomp_pft) ! Initialize the litter pools to zero, these ! pools will be populated by looping over the existing patches @@ -488,7 +497,7 @@ subroutine spawn_patches( currentSite, bc_in) if ( site_areadis_secondary .gt. nearzero) then allocate(new_patch_secondary) call create_patch(currentSite, new_patch_secondary, age, & - site_areadis_secondary, secondaryforest) + site_areadis_secondary, secondaryforest,nocomp_pft) ! Initialize the litter pools to zero, these ! pools will be populated by looping over the existing patches @@ -1821,7 +1830,7 @@ end subroutine mortality_litter_fluxes ! ============================================================================ - subroutine create_patch(currentSite, new_patch, age, areap, label) + subroutine create_patch(currentSite, new_patch, age, areap, label,nocomp_pft) ! ! !DESCRIPTION: @@ -1835,7 +1844,7 @@ subroutine create_patch(currentSite, new_patch, age, areap, label) real(r8), intent(in) :: age ! notional age of this patch in years real(r8), intent(in) :: areap ! initial area of this patch in m2. integer, intent(in) :: label ! anthropogenic disturbance label - + integer, intent(in) :: nocomp_pft ! sets PFT of patch only where nocomp is active ! !LOCAL VARIABLES: !--------------------------------------------------------------------- integer :: el ! element loop index @@ -1881,6 +1890,10 @@ subroutine create_patch(currentSite, new_patch, age, areap, label) ! assign anthropgenic disturbance category and label new_patch%anthro_disturbance_label = label + + ! where nocomp is active, set PFT of patch + new_patch%nocomp_pft_label = nocomp_pft + if (label .eq. secondaryforest) then new_patch%age_since_anthro_disturbance = age else @@ -2023,6 +2036,9 @@ subroutine zero_patch(cp_p) currentPatch%gnd_alb_dir(:) = nan currentPatch%gnd_alb_dif(:) = nan + ! special modes + currentPatch%nocomp_pft_label = fates_unset_int + end subroutine zero_patch ! ============================================================================ @@ -2183,6 +2199,11 @@ subroutine fuse_patches( csite, bc_in ) endif ! sum(biomass(:,:) .gt. force_patchfuse_min_biomass endif ! maxage + ! Do not fuse patches that have different PFT labels in nocomp mode + if(hlm_use_nocomp.eq.itrue.and. & + tpp%nocomp_pft_label.ne.currentPatch%nocomp_pft_label)then + fuse_flag = 0 + end if !-------------------------------------------------------------------------! ! Call the patch fusion routine if there is not a meaningful difference ! ! any of the pft x height categories ! diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index d820181c78..c2a20ec36a 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -39,6 +39,7 @@ module EDInitMod use FatesInterfaceMod , only : hlm_use_planthydro use FatesInterfaceMod , only : hlm_use_inventory_init use FatesInterfaceMod , only : hlm_use_fixed_biogeog + use FatesInterfaceMod , only : hlm_use_nocomp use FatesInterfaceMod , only : numpft use FatesInterfaceMod , only : nleafage use FatesInterfaceMod , only : nlevsclass @@ -391,6 +392,14 @@ subroutine init_patches( nsites, sites, bc_in) ! have smaller spread factors than bare ground (they are crowded) sites(s)%spread = init_spread_near_bare_ground + if(hlm_use_nocomp.eq.itrue)then + no_new_patches = numpft + else + no_new_patches = 1 + end if + + do n = 1, no_new_patches + allocate(newp) newp%patchno = 1 @@ -403,7 +412,7 @@ subroutine init_patches( nsites, sites, bc_in) ! make new patch... - call create_patch(sites(s), newp, age, area, primaryforest) + call create_patch(sites(s), newp, age, area, primaryforest, nocomp_pft) ! Initialize the litter pools to zero, these ! pools will be populated by looping over the existing patches @@ -419,6 +428,8 @@ subroutine init_patches( nsites, sites, bc_in) sitep => sites(s) call init_cohorts(sitep, newp, bc_in(s)) + + end do !no new patches ! For carbon balance checks, we need to initialize the ! total carbon stock @@ -426,7 +437,9 @@ 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 - enddo + + + enddo !s end if diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 819fadd830..5902b47be0 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -386,7 +386,7 @@ module EDTypesMod integer :: ncl_p ! Number of occupied canopy layers integer :: anthro_disturbance_label ! patch label for anthropogenic disturbance classification real(r8) :: age_since_anthro_disturbance ! average age for secondary forest since last anthropogenic disturbance - + integer :: nocomp_pft_label ! where nocomp is active, use this label for patch ID. ! LEAF ORGANIZATION real(r8) :: pft_agb_profile(maxpft,n_dbh_bins) ! binned above ground biomass, for patch fusion: KgC/m2 real(r8) :: canopy_layer_tlai(nclmax) ! total leaf area index of each canopy layer diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 5ea5c615a9..0f677ed9c6 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -143,6 +143,7 @@ module FatesRestartInterfaceMod integer :: ir_area_pa integer :: ir_agesinceanthrodist_pa integer :: ir_patchdistturbcat_pa + integer :: ir_nocomp_pft_label_pa ! Site level @@ -824,6 +825,10 @@ subroutine define_restart_vars(this, initialize_variables) long_name='Disturbance label of patch', units='yr', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_patchdistturbcat_pa ) + call this%set_restart_var(vname='fates_nocomp_pft_label', vtype=cohort_int, & + long_name='PFT label of patch in nocomp mode', units='none', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_nocomp_pft_label_pa ) + call this%set_restart_var(vname='fates_area', vtype=cohort_r8, & long_name='are of the ED patch', units='m2', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_area_pa ) @@ -1540,6 +1545,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_age_pa => this%rvars(ir_age_pa)%r81d, & rio_patchdistturbcat_pa => this%rvars(ir_patchdistturbcat_pa)%int1d, & rio_agesinceanthrodist_pa => this%rvars(ir_agesinceanthrodist_pa)%r81d, & + rio_nocomp_pft_label_pa => this%rvars(ir_nocomp_pft_label_pa)%int1d, & rio_area_pa => this%rvars(ir_area_pa)%r81d, & rio_watermem_siwm => this%rvars(ir_watermem_siwm)%r81d, & rio_vegtempmem_sitm => this%rvars(ir_vegtempmem_sitm)%r81d, & @@ -1778,6 +1784,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_age_pa(io_idx_co_1st) = cpatch%age rio_patchdistturbcat_pa(io_idx_co_1st) = cpatch%anthro_disturbance_label rio_agesinceanthrodist_pa(io_idx_co_1st) = cpatch%age_since_anthro_disturbance + rio_nocomp_pft_label_pa(io_idx_co_1st)= cpatch%nocomp_pft_label rio_area_pa(io_idx_co_1st) = cpatch%area ! set cohorts per patch for IO @@ -2288,6 +2295,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) rio_age_pa => this%rvars(ir_age_pa)%r81d, & rio_patchdistturbcat_pa => this%rvars(ir_patchdistturbcat_pa)%int1d, & rio_agesinceanthrodist_pa => this%rvars(ir_agesinceanthrodist_pa)%r81d, & + rio_nocomp_pft_label_pa => this%rvars(ir_nocomp_pft_label_pa)%int1d, & rio_area_pa => this%rvars(ir_area_pa)%r81d, & rio_watermem_siwm => this%rvars(ir_watermem_siwm)%r81d, & rio_vegtempmem_sitm => this%rvars(ir_vegtempmem_sitm)%r81d, & @@ -2510,6 +2518,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) cpatch%age = rio_age_pa(io_idx_co_1st) cpatch%anthro_disturbance_label = rio_patchdistturbcat_pa(io_idx_co_1st) cpatch%age_since_anthro_disturbance = rio_agesinceanthrodist_pa(io_idx_co_1st) + cpatch%nocomp_pft_label = rio_nocomp_pft_label_pa(io_idx_co_1st) cpatch%area = rio_area_pa(io_idx_co_1st) cpatch%age_class = get_age_class_index(cpatch%age) From a08cbcd5068bc8392712746308eba81743b3f4e3 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Fri, 1 May 2020 04:02:07 -0600 Subject: [PATCH 003/209] phase 2 of nocomp mods --- biogeochem/EDPatchDynamicsMod.F90 | 139 +++++++++++++++++++----------- main/EDInitMod.F90 | 11 ++- main/FatesInventoryInitMod.F90 | 4 +- 3 files changed, 98 insertions(+), 56 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 5016891812..eef81f6705 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -389,14 +389,17 @@ subroutine spawn_patches( currentSite, bc_in) type (ed_patch_type) , pointer :: new_patch_primary type (ed_patch_type) , pointer :: new_patch_secondary type (ed_patch_type) , pointer :: currentPatch + type (ed_patch_type) , pointer :: new_patch_primary_pft(:) + type (ed_patch_type) , pointer :: new_patch_secondary_pft(:) type (ed_cohort_type), pointer :: currentCohort type (ed_cohort_type), pointer :: nc type (ed_cohort_type), pointer :: storesmallcohort type (ed_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) :: patch_site_areadis ! total area disturbed in m2 per patch per day - real(r8) :: site_areadis_pft(numpft) ! total area disturbed per PFT class when nocomp mode is on. m2 per patch per day + real(r8) :: site_areadis_primary_pft(numpft) ! primary area disturbed per PFT in nocomp mode. m2/patch/day + real(r8) :: site_areadis_secondary_pft(numpft) ! secondary area disturbed per PFT in nocomp mode. m2/patch/day + real(r8) :: patch_site_areadis ! total area disturbed in m2 per patch per day real(r8) :: age ! notional age of this patch in years integer :: el ! element loop index integer :: tnull ! is there a tallest cohort? @@ -411,7 +414,9 @@ subroutine spawn_patches( currentSite, bc_in) real(r8) :: leaf_burn_frac ! fraction of leaves burned in fire ! for both woody and grass species real(r8) :: leaf_m ! leaf mass during partial burn calculations + integer :: rec_type ! records type of disturbance while in patch loop integer :: nocomp_pft ! where nocomp mode is on, PFT label + !--------------------------------------------------------------------- storesmallcohort => null() ! storage of the smallest cohort for insertion routine @@ -422,10 +427,10 @@ subroutine spawn_patches( currentSite, bc_in) site_areadis_primary = 0.0_r8 site_areadis_secondary = 0.0_r8 - site_areadis_pft(1:numpft)=0.0_r8 + site_areadis_primary_pft(1:numpft) = 0.0_r8 + site_areadis_secondary_pft(1:numpft) = 0.0_r8 do while(associated(currentPatch)) - if(currentPatch%disturbance_rate>1.0_r8) then write(fates_log(),*) 'patch disturbance rate > 1 ?',currentPatch%disturbance_rate @@ -449,19 +454,28 @@ subroutine spawn_patches( currentSite, bc_in) (currentPatch%disturbance_mode .ne. dtype_ilog) ) then site_areadis_primary = site_areadis_primary + currentPatch%area * currentPatch%disturbance_rate + rec_type = primaryforest else site_areadis_secondary = site_areadis_secondary + currentPatch%area * currentPatch%disturbance_rate - endif + rec_type = secondaryforest + end if ! accumulate PFT specific disturbance rates in nocomp mode - if(hlm_use_nocomp.eq.itrue)then - site_areadis_pft(currentPatch%nocomp_pft_label) = site_areadis_pft(currentPatch%nocomp_pft_label) & + if(hlm_use_nocomp.eq.itrue)then + if(rec_type.eq.primaryforest)then + nocomp_pft = currentPatch%nocomp_pft_label + site_areadis_primary_pft(nocomp_pft) = site_areadis_primary_pft(nocomp_pft) & + + currentPatch%area * currentPatch%disturbance_rate + else + site_areadis_secondary_pft(nocomp_pft) = site_areadis_secondary_pft(nocomp_pft) & + currentPatch%area * currentPatch%disturbance_rate - end if - end if + end if !rectype + end if !nocomp + end if !area currentPatch => currentPatch%older - enddo ! end loop over patches. sum area disturbed for all patches. + + end do ! 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 @@ -471,49 +485,68 @@ subroutine spawn_patches( currentSite, bc_in) ! 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 create_patch(currentSite, new_patch_primary, age, & + if(hlm_use_nocomp.eq.ifalse)then + allocate(new_patch_primary) + call create_patch(currentSite, new_patch_primary, age, & site_areadis_primary, primaryforest,nocomp_pft) - - ! 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() - - endif - + ! 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() + + else !nocomp + do nocomp_pft=1,numpft ! looping round a new patch for each present PFT. + allocate(new_patch_primary) + if( site_areadis_primary_pft(nocomp_pft) .gt. nearzero ) then + call create_patch(currentSite, new_patch_primary, age, & + site_areadis_primary_pft(nocomp_pft), primaryforest,nocomp_pft) + ! Initialize the litter pools to zero + 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() + end if !area + end do !pft + endif !nocomp + end if !primary ! next create patch to receive secondary forest area if ( site_areadis_secondary .gt. nearzero) then - allocate(new_patch_secondary) - call create_patch(currentSite, new_patch_secondary, age, & + if(hlm_use_nocomp.eq.ifalse)then + allocate(new_patch_secondary) + call create_patch(currentSite, new_patch_secondary, age, & site_areadis_secondary, secondaryforest,nocomp_pft) - - ! 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() - - endif + 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() + else !nocomp + do nocomp_pft=1,numpft ! looping round a new patch for each present PFT. allocate(new_patch_secondary) + if( site_areadis_secondary_pft(nocomp_pft) .gt. nearzero ) then + call create_patch(currentSite, new_patch_secondary, age, & + site_areadis_secondary_pft(nocomp_pft), secondaryforest,nocomp_pft) + 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() + end if !area + end do !pft + endif !nocomp + endif !secondary ! loop round all the patches that contribute surviving indivduals and litter ! pools to the new patch. We only loop the pre-existing patches, so @@ -533,11 +566,13 @@ subroutine spawn_patches( currentSite, bc_in) ! will be primary or secondary land receiver patch is primary forest ! only if both the donor patch is primary forest and the dominant ! disturbance type is not logging - if (currentPatch%anthro_disturbance_label .eq. primaryforest .and. & + if(hlm_use_nocomp.eq.ifalse)then + if (currentPatch%anthro_disturbance_label .eq. primaryforest .and. & (currentPatch%disturbance_mode .ne. dtype_ilog)) then - new_patch => new_patch_primary - else - new_patch => new_patch_secondary + new_patch => new_patch_primary + else + new_patch => new_patch_secondary + endif endif if(.not.associated(new_patch))then diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index c2a20ec36a..9d07d89a1f 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -348,7 +348,9 @@ subroutine init_patches( nsites, sites, bc_in) real(r8) :: biomass_stock real(r8) :: litter_stock real(r8) :: seed_stock - + integer :: n + integer :: no_new_patches + integer :: nocomp_pft type(ed_site_type), pointer :: sitep type(ed_patch_type), pointer :: newp @@ -411,7 +413,12 @@ subroutine init_patches( nsites, sites, bc_in) sites(s)%oldest_patch => newp ! make new patch... - + if(hlm_use_nocomp.eq.itrue)then + nocomp_pft = n + else + nocomp_pft = fates_unset_int + end if + call create_patch(sites(s), newp, age, area, primaryforest, nocomp_pft) ! Initialize the litter pools to zero, these diff --git a/main/FatesInventoryInitMod.F90 b/main/FatesInventoryInitMod.F90 index 830ee7d099..5924f7c845 100644 --- a/main/FatesInventoryInitMod.F90 +++ b/main/FatesInventoryInitMod.F90 @@ -61,7 +61,7 @@ module FatesInventoryInitMod use PRTGenericMod, only : phosphorus_element use PRTGenericMod, only : SetState use FatesConstantsMod, only : primaryforest - + use FatesConstantsMod , only : fates_unset_int implicit none private @@ -275,7 +275,7 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) age_init = 0.0_r8 area_init = 0.0_r8 - call create_patch(sites(s), newpatch, age_init, area_init, primaryforest ) + call create_patch(sites(s), newpatch, age_init, area_init, primaryforest, fates_unset_int ) if( inv_format_list(invsite) == 1 ) then From 3f92ed8dcc9e612d70c6db2b06e2780925a9f171 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Fri, 1 May 2020 11:46:07 -0600 Subject: [PATCH 004/209] first pass through spawn_patches --- biogeochem/EDPatchDynamicsMod.F90 | 104 +++++++++++++++++++++++------- main/FatesRestartInterfaceMod.F90 | 8 +-- 2 files changed, 84 insertions(+), 28 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index eef81f6705..36fbb29ff8 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -419,6 +419,10 @@ subroutine spawn_patches( currentSite, bc_in) !--------------------------------------------------------------------- + ! Allocate PFT arrays of patches to form the new patches in nocomp mode. + allocate(new_patch_primary_pft(numpft)) + allocate(new_patch_secondary_pft(numpft)) + storesmallcohort => null() ! storage of the smallest cohort for insertion routine storebigcohort => null() ! storage of the largest cohort for insertion routine @@ -501,9 +505,9 @@ subroutine spawn_patches( currentSite, bc_in) else !nocomp do nocomp_pft=1,numpft ! looping round a new patch for each present PFT. - allocate(new_patch_primary) +! allocate(new_patch_primary_pft(nocompt_pft)) if( site_areadis_primary_pft(nocomp_pft) .gt. nearzero ) then - call create_patch(currentSite, new_patch_primary, age, & + call create_patch(currentSite, new_patch_primary_pft(nocomp_pft), age, & site_areadis_primary_pft(nocomp_pft), primaryforest,nocomp_pft) ! Initialize the litter pools to zero do el=1,num_elements @@ -534,7 +538,7 @@ subroutine spawn_patches( currentSite, bc_in) else !nocomp do nocomp_pft=1,numpft ! looping round a new patch for each present PFT. allocate(new_patch_secondary) if( site_areadis_secondary_pft(nocomp_pft) .gt. nearzero ) then - call create_patch(currentSite, new_patch_secondary, age, & + call create_patch(currentSite, new_patch_secondary_pft(nocomp_pft), age, & site_areadis_secondary_pft(nocomp_pft), secondaryforest,nocomp_pft) do el=1,num_elements call new_patch_secondary%litter(el)%InitConditions(& @@ -566,14 +570,24 @@ subroutine spawn_patches( currentSite, bc_in) ! will be primary or secondary land receiver patch is primary forest ! only if both the donor patch is primary forest and the dominant ! disturbance type is not logging - if(hlm_use_nocomp.eq.ifalse)then if (currentPatch%anthro_disturbance_label .eq. primaryforest .and. & (currentPatch%disturbance_mode .ne. dtype_ilog)) then new_patch => new_patch_primary + rec_type = primaryforest else new_patch => new_patch_secondary + rec_type = secondaryforest endif - endif + + if(hlm_use_nocomp.eq.itrue)then !nocomp case + if(rec_type.eq.primaryforest)then + new_patch => new_patch_primary_pft(currentPatch%nocomp_pft_label) + else + new_patch => new_patch_secondary_pft(currentPatch%nocomp_pft_label) + endif + endif + + if(.not.associated(new_patch))then write(fates_log(),*) 'Patch spawning has attempted to point to' @@ -1047,42 +1061,84 @@ subroutine spawn_patches( currentSite, bc_in) !*************************/ !** INSERT NEW PATCH(ES) INTO LINKED LIST !**********`***************/ - - if ( site_areadis_primary .gt. nearzero) then + + ! currentPatch is the youngest of the pre-existing patches. + !newpatch_primary_pft and newpatch_secondary_pft need to be added into the mix + + if(hlm_use_nocomp.eq.ifalse)then + if ( site_areadis_primary .gt. nearzero) then currentPatch => currentSite%youngest_patch new_patch_primary%older => currentPatch new_patch_primary%younger => null() currentPatch%younger => new_patch_primary currentSite%youngest_patch => new_patch_primary - endif + endif - if ( site_areadis_secondary .gt. nearzero) then + 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 - + endif + else !nocomp case with one new patch for each PFT + do nocomp_pft=1,numpft + if ( site_areadis_primary_pft(nocomp_pft) .gt. nearzero) then + currentPatch => currentSite%youngest_patch + new_patch_primary_pft(nocomp_pft)%older => currentPatch + new_patch_primary_pft(nocomp_pft)%younger => null() + currentPatch%younger => new_patch_primary_pft(nocomp_pft) + currentSite%youngest_patch => new_patch_primary_pft(nocomp_pft) + endif + + if ( site_areadis_secondary .gt. nearzero) then + currentPatch => currentSite%youngest_patch + new_patch_secondary_pft(nocomp_pft)%older => currentPatch + new_patch_secondary_pft(nocomp_pft)%younger=> null() + currentPatch%younger => new_patch_secondary_pft(nocomp_pft) + currentSite%youngest_patch => new_patch_secondary_pft(nocomp_pft) + endif + enddo !pft + endif !nocomp + + + + ! 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_primary .gt. nearzero) then - call terminate_cohorts(currentSite, new_patch_primary, 1,17) - call fuse_cohorts(currentSite,new_patch_primary, bc_in) - call terminate_cohorts(currentSite, new_patch_primary, 2,17) - call sort_cohorts(new_patch_primary) - endif + if(hlm_use_nocomp.eq.ifalse)then + if ( site_areadis_primary .gt. nearzero) then + call terminate_cohorts(currentSite, new_patch_primary, 1,17) + call fuse_cohorts(currentSite,new_patch_primary, bc_in) + call terminate_cohorts(currentSite, new_patch_primary, 2,17) + call sort_cohorts(new_patch_primary) + endif - if ( site_areadis_secondary .gt. nearzero) then - call terminate_cohorts(currentSite, new_patch_secondary, 1,18) - call fuse_cohorts(currentSite,new_patch_secondary, bc_in) - call terminate_cohorts(currentSite, new_patch_secondary, 2,18) - call sort_cohorts(new_patch_secondary) - endif + if ( site_areadis_secondary .gt. nearzero) then + call terminate_cohorts(currentSite, new_patch_secondary, 1,18) + call fuse_cohorts(currentSite,new_patch_secondary, bc_in) + call terminate_cohorts(currentSite, new_patch_secondary, 2,18) + call sort_cohorts(new_patch_secondary) + endif + else !nocomp case + do nocomp_pft=1,numpft + if ( site_areadis_primary_pft(nocomp_pft) .gt. nearzero) then + call terminate_cohorts(currentSite, new_patch_primary_pft(nocomp_pft), 1,17) + call fuse_cohorts(currentSite,new_patch_primary_pft(nocomp_pft), bc_in) + call terminate_cohorts(currentSite, new_patch_primary_pft(nocomp_pft), 2,17) + call sort_cohorts(new_patch_primary_pft(nocomp_pft)) + endif + if ( site_areadis_primary_pft(nocomp_pft) .gt. nearzero) then + call terminate_cohorts(currentSite, new_patch_secondary_pft(nocomp_pft), 1,18) + call fuse_cohorts(currentSite, new_patch_secondary_pft(nocomp_pft), bc_in) + call terminate_cohorts(currentSite, new_patch_secondary_pft(nocomp_pft), 2,18) + call sort_cohorts(new_patch_secondary_pft(nocomp_pft)) + endif + enddo !pft + endif !nocomp endif !end new_patch area diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 0f677ed9c6..2fb57bd6fb 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -7,7 +7,7 @@ module FatesRestartInterfaceMod use FatesConstantsMod, only : fates_long_string_length use FatesConstantsMod, only : itrue use FatesConstantsMod, only : ifalse - use FatesConstantsMod, only : fates_unset_r8 + use FatesConstantsMod, only : fates_unset_r8, fates_unset_int use FatesConstantsMod, only : primaryforest use FatesGlobals, only : fates_log use FatesGlobals, only : endrun => fates_endrun @@ -2018,7 +2018,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) integer :: ft integer :: el ! element loop counter integer, parameter :: recruitstatus = 0 - + integer :: nocomp_pft ! PFT patch label for nocomp mode ! ---------------------------------------------------------------------------------- ! We really only need the counts for the number of patches per site ! and the number of cohorts per patch. These values tell us how much @@ -2055,9 +2055,9 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) ! create patch allocate(newp) - + nocomp_pft = fates_unset_int ! make new patch - call create_patch(sites(s), newp, fates_unset_r8, fates_unset_r8, primaryforest ) + call create_patch(sites(s), newp, fates_unset_r8, fates_unset_r8, primaryforest, nocomp_pft ) ! Initialize the litter pools to zero, these ! pools will be populated by looping over the existing patches From db960fd6f5c1a6290c81cdee5545d0d2dfe7a655 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 4 May 2020 02:53:07 -0600 Subject: [PATCH 005/209] added initialization mods --- main/EDInitMod.F90 | 27 ++++++++++++++++++++++----- 1 file changed, 22 insertions(+), 5 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 9d07d89a1f..07c2e3f117 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -351,6 +351,8 @@ subroutine init_patches( nsites, sites, bc_in) integer :: n integer :: no_new_patches integer :: nocomp_pft + real(r8) :: newparea + type(ed_site_type), pointer :: sitep type(ed_patch_type), pointer :: newp @@ -398,6 +400,7 @@ subroutine init_patches( nsites, sites, bc_in) no_new_patches = numpft else no_new_patches = 1 + newparea = area end if do n = 1, no_new_patches @@ -412,15 +415,29 @@ subroutine init_patches( nsites, sites, bc_in) sites(s)%youngest_patch => newp sites(s)%oldest_patch => newp - ! make new patch... + ! set the PFT index for patches if in nocomp mode. if(hlm_use_nocomp.eq.itrue)then nocomp_pft = n else - nocomp_pft = fates_unset_int + nocomp_pft = 999 end if - - call create_patch(sites(s), newp, age, area, primaryforest, nocomp_pft) - + + if(hlm_use_nocomp.eq.itrue)then + ! In no competition mode, if we are using the fixed_biogeog filter + ! then each PFT has the area dictated by the surface dataset. + ! If not, each PFT gets the same area. + if(hlm_use_fixed_biogeog.eq.itrue)then + newparea = area * sites(s)%area_pft(nocomp_pft) + else + newparea = area / numpft + end if + else ! The default case is initialized w/ one patch with the area of the whole site. + newparea = area + end if + + if(newparea.gt.0._r8)then ! Stop patches being initilialized when PFT not present in nocomop mode + call create_patch(sites(s), newp, age, newparea, primaryforest, nocomp_pft) + end if ! Initialize the litter pools to zero, these ! pools will be populated by looping over the existing patches ! and transfering in mass From 782b61a005d7d3a8b37460303e8254ad267904a5 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 4 May 2020 03:01:33 -0600 Subject: [PATCH 006/209] debug in EPD. will need rolling back --- biogeochem/EDPatchDynamicsMod.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 36fbb29ff8..9085405fa3 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -102,7 +102,7 @@ module EDPatchDynamicsMod character(len=*), parameter, private :: sourcefile = & __FILE__ - logical, parameter :: debug = .false. + logical, parameter :: debug = .true. ! When creating new patches from other patches, we need to send some of the ! litter from the old patch to the new patch. Likewise, when plants die @@ -1198,7 +1198,7 @@ subroutine check_patch_area( currentSite ) end if if(debug) then - write(fates_log(),*) 'Total patch area precision being fixed, adjusting' + write(fates_log(),*) 'Total patch area precision being fixed, adjusting',areatot-area_site write(fates_log(),*) 'largest patch. This may have slight impacts on carbon balance.' end if @@ -2293,7 +2293,7 @@ subroutine fuse_patches( csite, bc_in ) ! Do not fuse patches that have different PFT labels in nocomp mode if(hlm_use_nocomp.eq.itrue.and. & tpp%nocomp_pft_label.ne.currentPatch%nocomp_pft_label)then - fuse_flag = 0 + fuse_flag = 0 end if !-------------------------------------------------------------------------! ! Call the patch fusion routine if there is not a meaningful difference ! From ff0cf19f5d0c3ace455bb09396e5cb9b76911661 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 6 May 2020 10:26:28 -0600 Subject: [PATCH 007/209] init fixes. gets out of init loop --- main/EDInitMod.F90 | 102 ++++++++++++++++++++++++++++++--------------- 1 file changed, 68 insertions(+), 34 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 07c2e3f117..b81f7103a8 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -17,6 +17,7 @@ module EDInitMod use EDCohortDynamicsMod , only : create_cohort, fuse_cohorts, sort_cohorts use EDCohortDynamicsMod , only : InitPRTObject use EDPatchDynamicsMod , only : create_patch + use EDPatchDynamicsMod , only : set_patchno use ChecksBalancesMod , only : SiteMassStock use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type use EDTypesMod , only : numWaterMem @@ -250,6 +251,7 @@ subroutine set_site_properties( nsites, sites,bc_in ) integer :: dleafoff ! DOY for drought-decid leaf-off, initial guess integer :: dleafon ! DOY for drought-decid leaf-on, initial guess integer :: ft ! PFT loop + real(r8) :: sumarea ! area of PFTs in nocomp mode. !---------------------------------------------------------------------- @@ -298,6 +300,13 @@ subroutine set_site_properties( nsites, sites,bc_in ) do ft = 1,numpft sites(s)%area_pft(ft) = bc_in(s)%pft_areafrac(ft) end do + ! re-normalize PFT area to ensure it sums to one. + ! note that in areas of 'bare ground' (PFT 0 in CLM/ELM) + ! the bare ground will no longer be proscribed and should emerge from FATES + sumarea = sum(sites(s)%area_pft(1:numpft)) + do ft = 1,numpft + sites(s)%area_pft(ft) = sites(s)%area_pft(ft)/sumarea + end do end if do ft = 1,numpft @@ -352,9 +361,11 @@ subroutine init_patches( nsites, sites, bc_in) integer :: no_new_patches integer :: nocomp_pft real(r8) :: newparea + real(r8) :: tota !check on area type(ed_site_type), pointer :: sitep type(ed_patch_type), pointer :: newp + type(ed_patch_type), pointer :: recall_younger_patch ! List out some nominal patch values that are used for Near Bear Ground initializations ! as well as initializing inventory @@ -388,14 +399,14 @@ subroutine init_patches( nsites, sites, bc_in) else - !FIX(SPM,032414) clean this up...inits out of this loop - do s = 1, nsites + do s = 1, nsites + write(*,*) 'areapft',sites(s)%area_pft(1:3) ! Initialize the site-level crown area spread factor (0-1) ! It is likely that closed canopy forest inventories ! have smaller spread factors than bare ground (they are crowded) sites(s)%spread = init_spread_near_bare_ground - + if(hlm_use_nocomp.eq.itrue)then no_new_patches = numpft else @@ -405,16 +416,6 @@ subroutine init_patches( nsites, sites, bc_in) do n = 1, no_new_patches - allocate(newp) - - newp%patchno = 1 - newp%younger => null() - newp%older => null() - - sites(s)%youngest_patch => newp - sites(s)%youngest_patch => newp - sites(s)%oldest_patch => newp - ! set the PFT index for patches if in nocomp mode. if(hlm_use_nocomp.eq.itrue)then nocomp_pft = n @@ -434,37 +435,70 @@ subroutine init_patches( nsites, sites, bc_in) else ! The default case is initialized w/ one patch with the area of the whole site. newparea = area end if - + if(newparea.gt.0._r8)then ! Stop patches being initilialized when PFT not present in nocomop mode - call create_patch(sites(s), newp, age, newparea, primaryforest, nocomp_pft) - end if - ! Initialize the litter pools to zero, these - ! pools will be populated by looping over the existing patches - ! and transfering in mass - do el=1,num_elements - call newp%litter(el)%InitConditions(init_leaf_fines=0._r8, & + allocate(newp) + + call create_patch(sites(s), newp, age, newparea, primaryforest, nocomp_pft) + + if(.not.associated(recall_younger_patch))then !is this the first patch? + newp%patchno = 1 + newp%younger => null() + newp%older => null() + + sites(s)%youngest_patch => newp + sites(s)%oldest_patch => newp + allocate(recall_younger_patch) + else ! the new patch is the 'oldest' one, arbitrarily. + newp%patchno = nocomp_pft + newp%younger => recall_younger_patch + newp%older => null() + recall_younger_patch%older => newp + sites(s)%oldest_patch => newp + write(*,*) 'links',s,nocomp_pft,newp%younger%nocomp_pft_label + end if + recall_younger_patch => newp ! remember this patch for the next one to point at. + + + ! Initialize the litter pools to zero, these + ! pools will be populated by looping over the existing patches + ! and transfering in mass + do el=1,num_elements + call newp%litter(el)%InitConditions(init_leaf_fines=0._r8, & init_root_fines=0._r8, & init_ag_cwd=0._r8, & init_bg_cwd=0._r8, & init_seed=0._r8, & init_seed_germ=0._r8) - end do - - sitep => sites(s) - call init_cohorts(sitep, newp, bc_in(s)) - + end do + write(*,*) 'litt', newp%litter(1)%ag_cwd(1) + sitep => sites(s) + call init_cohorts(sitep, newp, bc_in(s)) + end if end do !no new patches - - ! For carbon balance checks, we need to initialize the - ! total carbon stock - do el=1,num_elements - call SiteMassStock(sites(s),el,sites(s)%mass_balance(el)%old_stock, & - biomass_stock,litter_stock,seed_stock) - end do + tota=0.0_r8 + newp=> sites(s)%oldest_patch + do while (associated(newp)) + tota=tota+newp%area + write(*,*)'test links1',s,newp%nocomp_pft_label,tota + newp=>newp%younger + end do + if(tota.lt.area)then + write(*,*) 'error in assigning areas in init patch',s,tota + endif + ! For carbon balance checks, we need to initialize the + ! total carbon stock + do el=1,num_elements + call SiteMassStock(sites(s),el,sites(s)%mass_balance(el)%old_stock, & + biomass_stock,litter_stock,seed_stock) + end do + + call set_patchno(sites(s)) + deallocate(recall_younger_patch) enddo !s - +write(*,*)'end init' end if ! This sets the rhizosphere shells based on the plant initialization From 92f547aef0397c679cf35277909d991dc682ab1f Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 7 May 2020 01:55:17 -0600 Subject: [PATCH 008/209] rolling back changes in EDPatchdynamics to allow debugging of EDInit first --- biogeochem/EDPatchDynamicsMod.F90 | 268 +++++++++--------------------- 1 file changed, 82 insertions(+), 186 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 9085405fa3..3d718df9fd 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -42,7 +42,7 @@ module EDPatchDynamicsMod use FatesInterfaceMod , only : bc_in_type use FatesInterfaceMod , only : hlm_days_per_year use FatesInterfaceMod , only : numpft - use FatesInterfaceMod , only : hlm_use_nocomp + use FatesInterfaceMod , only : hlm_use_nocomp use FatesGlobals , only : endrun => fates_endrun use FatesConstantsMod , only : r8 => fates_r8 use FatesConstantsMod , only : itrue, ifalse @@ -102,7 +102,7 @@ module EDPatchDynamicsMod character(len=*), parameter, private :: sourcefile = & __FILE__ - logical, parameter :: debug = .true. + logical, parameter :: debug = .false. ! When creating new patches from other patches, we need to send some of the ! litter from the old patch to the new patch. Likewise, when plants die @@ -389,17 +389,13 @@ subroutine spawn_patches( currentSite, bc_in) type (ed_patch_type) , pointer :: new_patch_primary type (ed_patch_type) , pointer :: new_patch_secondary type (ed_patch_type) , pointer :: currentPatch - type (ed_patch_type) , pointer :: new_patch_primary_pft(:) - type (ed_patch_type) , pointer :: new_patch_secondary_pft(:) type (ed_cohort_type), pointer :: currentCohort type (ed_cohort_type), pointer :: nc type (ed_cohort_type), pointer :: storesmallcohort type (ed_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_primary_pft(numpft) ! primary area disturbed per PFT in nocomp mode. m2/patch/day - real(r8) :: site_areadis_secondary_pft(numpft) ! secondary area disturbed per PFT in nocomp mode. m2/patch/day - real(r8) :: patch_site_areadis ! total area disturbed in m2 per patch per day + real(r8) :: patch_site_areadis ! total area disturbed in m2 per patch per day real(r8) :: age ! notional age of this patch in years integer :: el ! element loop index integer :: tnull ! is there a tallest cohort? @@ -414,15 +410,8 @@ subroutine spawn_patches( currentSite, bc_in) real(r8) :: leaf_burn_frac ! fraction of leaves burned in fire ! for both woody and grass species real(r8) :: leaf_m ! leaf mass during partial burn calculations - integer :: rec_type ! records type of disturbance while in patch loop - integer :: nocomp_pft ! where nocomp mode is on, PFT label - !--------------------------------------------------------------------- - ! Allocate PFT arrays of patches to form the new patches in nocomp mode. - allocate(new_patch_primary_pft(numpft)) - allocate(new_patch_secondary_pft(numpft)) - storesmallcohort => null() ! storage of the smallest cohort for insertion routine storebigcohort => null() ! storage of the largest cohort for insertion routine @@ -431,10 +420,9 @@ subroutine spawn_patches( currentSite, bc_in) site_areadis_primary = 0.0_r8 site_areadis_secondary = 0.0_r8 - site_areadis_primary_pft(1:numpft) = 0.0_r8 - site_areadis_secondary_pft(1:numpft) = 0.0_r8 do while(associated(currentPatch)) + if(currentPatch%disturbance_rate>1.0_r8) then write(fates_log(),*) 'patch disturbance rate > 1 ?',currentPatch%disturbance_rate @@ -458,28 +446,14 @@ subroutine spawn_patches( currentSite, bc_in) (currentPatch%disturbance_mode .ne. dtype_ilog) ) then site_areadis_primary = site_areadis_primary + currentPatch%area * currentPatch%disturbance_rate - rec_type = primaryforest else site_areadis_secondary = site_areadis_secondary + currentPatch%area * currentPatch%disturbance_rate - rec_type = secondaryforest - end if - - ! accumulate PFT specific disturbance rates in nocomp mode - if(hlm_use_nocomp.eq.itrue)then - if(rec_type.eq.primaryforest)then - nocomp_pft = currentPatch%nocomp_pft_label - site_areadis_primary_pft(nocomp_pft) = site_areadis_primary_pft(nocomp_pft) & - + currentPatch%area * currentPatch%disturbance_rate - else - site_areadis_secondary_pft(nocomp_pft) = site_areadis_secondary_pft(nocomp_pft) & - + currentPatch%area * currentPatch%disturbance_rate - end if !rectype - end if !nocomp + endif + + end if - end if !area currentPatch => currentPatch%older - - end do ! end loop over patches. sum area disturbed for all patches. + 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 @@ -489,68 +463,49 @@ subroutine spawn_patches( currentSite, bc_in) ! 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 - if(hlm_use_nocomp.eq.ifalse)then - allocate(new_patch_primary) - call create_patch(currentSite, new_patch_primary, age, & - site_areadis_primary, primaryforest,nocomp_pft) - ! 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() - - else !nocomp - do nocomp_pft=1,numpft ! looping round a new patch for each present PFT. -! allocate(new_patch_primary_pft(nocompt_pft)) - if( site_areadis_primary_pft(nocomp_pft) .gt. nearzero ) then - call create_patch(currentSite, new_patch_primary_pft(nocomp_pft), age, & - site_areadis_primary_pft(nocomp_pft), primaryforest,nocomp_pft) - ! Initialize the litter pools to zero - 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() - end if !area - end do !pft - endif !nocomp - end if !primary + allocate(new_patch_primary) + + call create_patch(currentSite, new_patch_primary, age, & + site_areadis_primary, primaryforest,1) + + ! 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() + + endif + ! next create patch to receive secondary forest area if ( site_areadis_secondary .gt. nearzero) then - if(hlm_use_nocomp.eq.ifalse)then - allocate(new_patch_secondary) - call create_patch(currentSite, new_patch_secondary, age, & - site_areadis_secondary, secondaryforest,nocomp_pft) - 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() - else !nocomp - do nocomp_pft=1,numpft ! looping round a new patch for each present PFT. allocate(new_patch_secondary) - if( site_areadis_secondary_pft(nocomp_pft) .gt. nearzero ) then - call create_patch(currentSite, new_patch_secondary_pft(nocomp_pft), age, & - site_areadis_secondary_pft(nocomp_pft), secondaryforest,nocomp_pft) - 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() - end if !area - end do !pft - endif !nocomp - endif !secondary + allocate(new_patch_secondary) + call create_patch(currentSite, new_patch_secondary, age, & + site_areadis_secondary, secondaryforest,1) + + ! 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() + + 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 @@ -570,24 +525,12 @@ subroutine spawn_patches( currentSite, bc_in) ! will be primary or secondary land receiver patch is primary forest ! only if both the donor patch is primary forest and the dominant ! disturbance type is not logging - if (currentPatch%anthro_disturbance_label .eq. primaryforest .and. & + if (currentPatch%anthro_disturbance_label .eq. primaryforest .and. & (currentPatch%disturbance_mode .ne. dtype_ilog)) then - new_patch => new_patch_primary - rec_type = primaryforest - else - new_patch => new_patch_secondary - rec_type = secondaryforest - endif - - if(hlm_use_nocomp.eq.itrue)then !nocomp case - if(rec_type.eq.primaryforest)then - new_patch => new_patch_primary_pft(currentPatch%nocomp_pft_label) - else - new_patch => new_patch_secondary_pft(currentPatch%nocomp_pft_label) - endif - endif - - + 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' @@ -1061,84 +1004,42 @@ subroutine spawn_patches( currentSite, bc_in) !*************************/ !** INSERT NEW PATCH(ES) INTO LINKED LIST !**********`***************/ - - ! currentPatch is the youngest of the pre-existing patches. - !newpatch_primary_pft and newpatch_secondary_pft need to be added into the mix - - if(hlm_use_nocomp.eq.ifalse)then - if ( site_areadis_primary .gt. nearzero) then + + if ( site_areadis_primary .gt. nearzero) then currentPatch => currentSite%youngest_patch new_patch_primary%older => currentPatch new_patch_primary%younger => null() currentPatch%younger => new_patch_primary currentSite%youngest_patch => new_patch_primary - endif + endif - if ( site_areadis_secondary .gt. nearzero) then + 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 - else !nocomp case with one new patch for each PFT - do nocomp_pft=1,numpft - if ( site_areadis_primary_pft(nocomp_pft) .gt. nearzero) then - currentPatch => currentSite%youngest_patch - new_patch_primary_pft(nocomp_pft)%older => currentPatch - new_patch_primary_pft(nocomp_pft)%younger => null() - currentPatch%younger => new_patch_primary_pft(nocomp_pft) - currentSite%youngest_patch => new_patch_primary_pft(nocomp_pft) - endif - - if ( site_areadis_secondary .gt. nearzero) then - currentPatch => currentSite%youngest_patch - new_patch_secondary_pft(nocomp_pft)%older => currentPatch - new_patch_secondary_pft(nocomp_pft)%younger=> null() - currentPatch%younger => new_patch_secondary_pft(nocomp_pft) - currentSite%youngest_patch => new_patch_secondary_pft(nocomp_pft) - endif - enddo !pft - endif !nocomp - - - - + 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) - if(hlm_use_nocomp.eq.ifalse)then - if ( site_areadis_primary .gt. nearzero) then - call terminate_cohorts(currentSite, new_patch_primary, 1,17) - call fuse_cohorts(currentSite,new_patch_primary, bc_in) - call terminate_cohorts(currentSite, new_patch_primary, 2,17) - call sort_cohorts(new_patch_primary) - endif + + if ( site_areadis_primary .gt. nearzero) then + call terminate_cohorts(currentSite, new_patch_primary, 1,17) + call fuse_cohorts(currentSite,new_patch_primary, bc_in) + call terminate_cohorts(currentSite, new_patch_primary, 2,17) + call sort_cohorts(new_patch_primary) + endif - if ( site_areadis_secondary .gt. nearzero) then - call terminate_cohorts(currentSite, new_patch_secondary, 1,18) - call fuse_cohorts(currentSite,new_patch_secondary, bc_in) - call terminate_cohorts(currentSite, new_patch_secondary, 2,18) - call sort_cohorts(new_patch_secondary) - endif - else !nocomp case - do nocomp_pft=1,numpft - if ( site_areadis_primary_pft(nocomp_pft) .gt. nearzero) then - call terminate_cohorts(currentSite, new_patch_primary_pft(nocomp_pft), 1,17) - call fuse_cohorts(currentSite,new_patch_primary_pft(nocomp_pft), bc_in) - call terminate_cohorts(currentSite, new_patch_primary_pft(nocomp_pft), 2,17) - call sort_cohorts(new_patch_primary_pft(nocomp_pft)) - endif - if ( site_areadis_primary_pft(nocomp_pft) .gt. nearzero) then - call terminate_cohorts(currentSite, new_patch_secondary_pft(nocomp_pft), 1,18) - call fuse_cohorts(currentSite, new_patch_secondary_pft(nocomp_pft), bc_in) - call terminate_cohorts(currentSite, new_patch_secondary_pft(nocomp_pft), 2,18) - call sort_cohorts(new_patch_secondary_pft(nocomp_pft)) - endif - enddo !pft - endif !nocomp + if ( site_areadis_secondary .gt. nearzero) then + call terminate_cohorts(currentSite, new_patch_secondary, 1,18) + call fuse_cohorts(currentSite,new_patch_secondary, bc_in) + call terminate_cohorts(currentSite, new_patch_secondary, 2,18) + call sort_cohorts(new_patch_secondary) + endif endif !end new_patch area @@ -1198,7 +1099,7 @@ subroutine check_patch_area( currentSite ) end if if(debug) then - write(fates_log(),*) 'Total patch area precision being fixed, adjusting',areatot-area_site + write(fates_log(),*) 'Total patch area precision being fixed, adjusting' write(fates_log(),*) 'largest patch. This may have slight impacts on carbon balance.' end if @@ -1935,7 +1836,7 @@ subroutine create_patch(currentSite, new_patch, age, areap, label,nocomp_pft) real(r8), intent(in) :: age ! notional age of this patch in years real(r8), intent(in) :: areap ! initial area of this patch in m2. integer, intent(in) :: label ! anthropogenic disturbance label - integer, intent(in) :: nocomp_pft ! sets PFT of patch only where nocomp is active + integer, intent(in) :: nocomp_pft ! !LOCAL VARIABLES: !--------------------------------------------------------------------- integer :: el ! element loop index @@ -1981,15 +1882,12 @@ subroutine create_patch(currentSite, new_patch, age, areap, label,nocomp_pft) ! assign anthropgenic disturbance category and label new_patch%anthro_disturbance_label = label - - ! where nocomp is active, set PFT of patch - new_patch%nocomp_pft_label = nocomp_pft - if (label .eq. secondaryforest) then new_patch%age_since_anthro_disturbance = age else new_patch%age_since_anthro_disturbance = -1._r8 ! replace with fates_unset_r8 when possible endif + new_patch%nocomp_pft_label = nocomp_pft ! This new value will be generated when the calculate disturbance ! rates routine is called. This does not need to be remembered or in the restart file. @@ -2127,9 +2025,6 @@ subroutine zero_patch(cp_p) currentPatch%gnd_alb_dir(:) = nan currentPatch%gnd_alb_dif(:) = nan - ! special modes - currentPatch%nocomp_pft_label = fates_unset_int - end subroutine zero_patch ! ============================================================================ @@ -2290,11 +2185,12 @@ subroutine fuse_patches( csite, bc_in ) endif ! sum(biomass(:,:) .gt. force_patchfuse_min_biomass endif ! maxage - ! Do not fuse patches that have different PFT labels in nocomp mode - if(hlm_use_nocomp.eq.itrue.and. & - tpp%nocomp_pft_label.ne.currentPatch%nocomp_pft_label)then - fuse_flag = 0 - end if + + ! Do not fuse patches that have different PFT labels in nocomp mode + if(hlm_use_nocomp.eq.itrue.and. & + tpp%nocomp_pft_label.ne.currentPatch%nocomp_pft_label)then + fuse_flag = 0 + end if !-------------------------------------------------------------------------! ! Call the patch fusion routine if there is not a meaningful difference ! ! any of the pft x height categories ! @@ -2302,7 +2198,7 @@ subroutine fuse_patches( csite, bc_in ) !-------------------------------------------------------------------------! if(fuse_flag == 1)then - + !-----------------------! ! fuse the two patches ! !-----------------------! From ca1a60b5dee17609a0ab6bbee3178529ead5c353 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 7 May 2020 03:37:00 -0600 Subject: [PATCH 009/209] this version of edinit works. committing before cleaning up --- main/EDInitMod.F90 | 75 +++++++++++++++++++++++++++++----------------- 1 file changed, 47 insertions(+), 28 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index b81f7103a8..edc577bf96 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -9,6 +9,7 @@ module EDInitMod use FatesConstantsMod , only : itrue use FatesConstantsMod , only : fates_unset_int use FatesConstantsMod , only : primaryforest + use FatesConstantsMod , only : nearzero use FatesGlobals , only : endrun => fates_endrun use EDTypesMod , only : nclmax use FatesGlobals , only : fates_log @@ -362,10 +363,12 @@ subroutine init_patches( nsites, sites, bc_in) integer :: nocomp_pft real(r8) :: newparea real(r8) :: tota !check on area + integer :: is_first_patch type(ed_site_type), pointer :: sitep + type(ed_patch_type), pointer :: newppft(:) type(ed_patch_type), pointer :: newp - type(ed_patch_type), pointer :: recall_younger_patch + type(ed_patch_type), pointer :: recall_older_patch ! List out some nominal patch values that are used for Near Bear Ground initializations ! as well as initializing inventory @@ -399,21 +402,20 @@ subroutine init_patches( nsites, sites, bc_in) else - + allocate(recall_older_patch) do s = 1, nsites - write(*,*) 'areapft',sites(s)%area_pft(1:3) ! Initialize the site-level crown area spread factor (0-1) ! It is likely that closed canopy forest inventories ! have smaller spread factors than bare ground (they are crowded) sites(s)%spread = init_spread_near_bare_ground - if(hlm_use_nocomp.eq.itrue)then no_new_patches = numpft + allocate(newppft(numpft)) else no_new_patches = 1 newparea = area end if - + is_first_patch = 1 do n = 1, no_new_patches ! set the PFT index for patches if in nocomp mode. @@ -438,27 +440,31 @@ subroutine init_patches( nsites, sites, bc_in) if(newparea.gt.0._r8)then ! Stop patches being initilialized when PFT not present in nocomop mode allocate(newp) + if(hlm_use_nocomp.eq.itrue)then + newp => newppft(nocomp_pft) + endif call create_patch(sites(s), newp, age, newparea, primaryforest, nocomp_pft) - if(.not.associated(recall_younger_patch))then !is this the first patch? + if(is_first_patch.eq.1)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 - allocate(recall_younger_patch) + is_first_patch = 0 else ! the new patch is the 'oldest' one, arbitrarily. + ! 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%younger => recall_younger_patch - newp%older => null() - recall_younger_patch%older => newp - sites(s)%oldest_patch => newp - write(*,*) 'links',s,nocomp_pft,newp%younger%nocomp_pft_label + newp%older => recall_older_patch + newp%younger => null() + recall_older_patch%younger => newp + sites(s)%youngest_patch => newp end if - recall_younger_patch => newp ! remember this patch for the next one to point at. - + recall_older_patch => newp ! remember this patch for the next one to point at. + write(*,*) 'ed init litter01',s,sites(s)%oldest_patch%area ! Initialize the litter pools to zero, these ! pools will be populated by looping over the existing patches @@ -471,34 +477,46 @@ subroutine init_patches( nsites, sites, bc_in) init_seed=0._r8, & init_seed_germ=0._r8) end do - write(*,*) 'litt', newp%litter(1)%ag_cwd(1) + write(*,*) 'ed init litter02',s,sites(s)%oldest_patch%area + write(*,*) 'ed init litter03',s,sites(s)%oldest_patch%litter(1)%ag_cwd(1) +! write(*,*) 'ed init litter04',s,sites(1)%oldest_patch%litter(1)%ag_cwd(1) + sitep => sites(s) call init_cohorts(sitep, newp, bc_in(s)) end if end do !no new patches - - tota=0.0_r8 - newp=> sites(s)%oldest_patch + + !check if the total area adds to the same as site area + tota = 0.0_r8 + newp => sites(s)%oldest_patch do while (associated(newp)) tota=tota+newp%area - write(*,*)'test links1',s,newp%nocomp_pft_label,tota - newp=>newp%younger - end do - if(tota.lt.area)then - write(*,*) 'error in assigning areas in init patch',s,tota - endif + write(*,*) 'test links',s,newp%nocomp_pft_label,tota + newp=>newp%younger + end do + if(abs(tota-area).gt.nearzero)then + write(*,*) 'error in assigning areas in init patch',s,tota-area + endif + ! For carbon balance checks, we need to initialize the ! total carbon stock + write(*,*) 'calling sitemassstock',s do el=1,num_elements call SiteMassStock(sites(s),el,sites(s)%mass_balance(el)%old_stock, & biomass_stock,litter_stock,seed_stock) end do - + write(*,*) 'ed init litter05',s,sites(s)%oldest_patch%area + write(*,*) 'call set_patchno',s call set_patchno(sites(s)) - deallocate(recall_younger_patch) + write(*,*) 'after set_patchno',s +! deallocate(recall_older_patch) + write(*,*) 'ed init litter06', s,sites(s)%oldest_patch%area +! write(*,*) 'ed init litter15',s,sites(1)%oldest_patch%area +! write(*,*) 'ed init litter2', s,sites(s)%oldest_patch%litter(1)%ag_cwd(1) +! write(*,*) 'ed init litter25',s,sites(1)%oldest_patch%litter(1)%ag_cwd(1) enddo !s -write(*,*)'end init' + write(*,*)'end init' end if ! This sets the rhizosphere shells based on the plant initialization @@ -509,6 +527,7 @@ subroutine init_patches( nsites, sites, bc_in) sitep => sites(s) call updateSizeDepRhizHydProps(sitep, bc_in(s)) end do + deallocate(recall_older_patch) end if return From ed08bf1eb7ea3c7c9aa559c7f34c7f172f88a78d Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 14 May 2020 09:16:16 -0600 Subject: [PATCH 010/209] modify number of patches and patch initialization --- main/EDInitMod.F90 | 4 ++-- main/EDTypesMod.F90 | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index edc577bf96..3d5ee7e30a 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -410,7 +410,7 @@ subroutine init_patches( nsites, sites, bc_in) sites(s)%spread = init_spread_near_bare_ground if(hlm_use_nocomp.eq.itrue)then no_new_patches = numpft - allocate(newppft(numpft)) +! allocate(newppft(numpft)) else no_new_patches = 1 newparea = area @@ -441,7 +441,7 @@ subroutine init_patches( nsites, sites, bc_in) if(newparea.gt.0._r8)then ! Stop patches being initilialized when PFT not present in nocomop mode allocate(newp) if(hlm_use_nocomp.eq.itrue)then - newp => newppft(nocomp_pft) + ! newp => newppft(nocomp_pft) endif call create_patch(sites(s), newp, age, newparea, primaryforest, nocomp_pft) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 5902b47be0..b23c492f70 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -22,7 +22,7 @@ module EDTypesMod integer, parameter, public :: maxPatchesPerSite = 14 ! maximum number of patches to live on a site integer, parameter, public :: maxPatchesPerSite_by_disttype(n_anthro_disturbance_categories) = & - (/ 10, 4 /) !!! MUST SUM TO maxPatchesPerSite !!! + (/ 13, 1 /) !!! MUST SUM TO maxPatchesPerSite !!! integer, parameter, public :: maxCohortsPerPatch = 100 ! maximum number of cohorts per patch integer, parameter, public :: nclmax = 2 ! Maximum number of canopy layers From 8ed597aec1c232a972f9ddadd6665c129a5e338c Mon Sep 17 00:00:00 2001 From: rosiealice Date: Fri, 15 May 2020 07:41:32 -0600 Subject: [PATCH 011/209] make disturbance arrays in EPD --- biogeochem/EDPatchDynamicsMod.F90 | 35 ++++++++++++++++++++++++------- 1 file changed, 28 insertions(+), 7 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 3d718df9fd..9d30fd7bce 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -42,7 +42,7 @@ module EDPatchDynamicsMod use FatesInterfaceMod , only : bc_in_type use FatesInterfaceMod , only : hlm_days_per_year use FatesInterfaceMod , only : numpft - use FatesInterfaceMod , only : hlm_use_nocomp + use FatesInterfaceMod , only : hlm_use_nocomp use FatesGlobals , only : endrun => fates_endrun use FatesConstantsMod , only : r8 => fates_r8 use FatesConstantsMod , only : itrue, ifalse @@ -388,6 +388,8 @@ subroutine spawn_patches( currentSite, bc_in) type (ed_patch_type) , pointer :: new_patch type (ed_patch_type) , pointer :: new_patch_primary type (ed_patch_type) , pointer :: new_patch_secondary + type (ed_patch_type) , pointer :: new_patch_primary_pft(:) + type (ed_patch_type) , pointer :: new_patch_secondary_pft(:) type (ed_patch_type) , pointer :: currentPatch type (ed_cohort_type), pointer :: currentCohort type (ed_cohort_type), pointer :: nc @@ -396,6 +398,8 @@ subroutine spawn_patches( currentSite, bc_in) 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) :: patch_site_areadis ! total area disturbed in m2 per patch per day + real(r8) :: site_areadis_primary_pft(numpft) ! primary area disturbed per PFT in nocomp mode. m2/patch/day + real(r8) :: site_areadis_secondary_pft(numpft) ! secondary area disturbed per PFT in nocomp mode. m2/patch/day real(r8) :: age ! notional age of this patch in years integer :: el ! element loop index integer :: tnull ! is there a tallest cohort? @@ -410,7 +414,11 @@ subroutine spawn_patches( currentSite, bc_in) real(r8) :: leaf_burn_frac ! fraction of leaves burned in fire ! for both woody and grass species real(r8) :: leaf_m ! leaf mass during partial burn calculations + integer :: rec_type ! records type of disturbance while in patch loop + integer :: nocomp_pft ! where nocomp mode is on, PFT label + !--------------------------------------------------------------------- + ! Allocate PFT arrays of patches to form the new patches in nocomp mode. storesmallcohort => null() ! storage of the smallest cohort for insertion routine storebigcohort => null() ! storage of the largest cohort for insertion routine @@ -420,6 +428,8 @@ subroutine spawn_patches( currentSite, bc_in) site_areadis_primary = 0.0_r8 site_areadis_secondary = 0.0_r8 + site_areadis_primary_pft(1:numpft) = 0.0_r8 + site_areadis_secondary_pft(1:numpft) = 0.0_r8 do while(associated(currentPatch)) @@ -444,18 +454,29 @@ subroutine spawn_patches( currentSite, bc_in) ! donor patch is primary forest and the dominant disturbance type is not logging if ( currentPatch%anthro_disturbance_label .eq. primaryforest .and. & (currentPatch%disturbance_mode .ne. dtype_ilog) ) then - - site_areadis_primary = site_areadis_primary + currentPatch%area * currentPatch%disturbance_rate + site_areadis_primary = site_areadis_primary + currentPatch%area * currentPatch%disturbance_rate + rec_type = primaryforest else - site_areadis_secondary = site_areadis_secondary + currentPatch%area * currentPatch%disturbance_rate + site_areadis_secondary = site_areadis_secondary + currentPatch%area * currentPatch%disturbance_rate + rec_type = secondaryforest endif - - end if + ! accumulate PFT specific disturbance rates in nocomp mode + if(hlm_use_nocomp.eq.itrue)then + if(rec_type.eq.primaryforest)then + nocomp_pft = currentPatch%nocomp_pft_label + site_areadis_primary_pft(nocomp_pft) = site_areadis_primary_pft(nocomp_pft) & + + currentPatch%area * currentPatch%disturbance_rate + else + site_areadis_secondary_pft(nocomp_pft) = site_areadis_secondary_pft(nocomp_pft) & + + currentPatch%area * currentPatch%disturbance_rate + end if !rectype + end if !nocomp + end if !area currentPatch => currentPatch%older enddo ! end loop over patches. sum area disturbed for all patches. - ! It is possible that no disturbance area was generated + ! It is possible that no disturbance area was generated if ( (site_areadis_primary + site_areadis_secondary) > nearzero) then age = 0.0_r8 From 7e77c3d9e147bf6c1c5bddcd2ad9cc1aec37e0d3 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Fri, 15 May 2020 08:18:52 -0600 Subject: [PATCH 012/209] modifications to spawn patches for PFT array disturbance --- biogeochem/EDPatchDynamicsMod.F90 | 41 ++++++++++++++++++++++++++++--- 1 file changed, 38 insertions(+), 3 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 9d30fd7bce..40d0476c12 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -419,6 +419,8 @@ subroutine spawn_patches( currentSite, bc_in) !--------------------------------------------------------------------- ! Allocate PFT arrays of patches to form the new patches in nocomp mode. + allocate(new_patch_primary_pft(numpft)) + allocate(new_patch_secondary_pft(numpft)) storesmallcohort => null() ! storage of the smallest cohort for insertion routine storebigcohort => null() ! storage of the largest cohort for insertion routine @@ -484,8 +486,8 @@ subroutine spawn_patches( currentSite, bc_in) ! 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 + if(hlm_use_nocomp.eq.ifalse)then allocate(new_patch_primary) - call create_patch(currentSite, new_patch_primary, age, & site_areadis_primary, primaryforest,1) @@ -503,11 +505,29 @@ subroutine spawn_patches( currentSite, bc_in) new_patch_primary%tallest => null() new_patch_primary%shortest => null() - endif + else !nocomp + do nocomp_pft=1,numpft ! looping round a new patch for each present PFT. +! allocate(new_patch_primary_pft(nocompt_pft)) + if( site_areadis_primary_pft(nocomp_pft) .gt. nearzero ) then + call create_patch(currentSite, new_patch_primary_pft(nocomp_pft), age, & + site_areadis_primary_pft(nocomp_pft), primaryforest,nocomp_pft) + ! Initialize the litter pools to zero + 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() + end if !area + end do !pft + endif !nocomp + end if !primary ! next create patch to receive secondary forest area if ( site_areadis_secondary .gt. nearzero) then + if(hlm_use_nocomp.eq.ifalse)then allocate(new_patch_secondary) call create_patch(currentSite, new_patch_secondary, age, & site_areadis_secondary, secondaryforest,1) @@ -526,7 +546,22 @@ subroutine spawn_patches( currentSite, bc_in) new_patch_secondary%tallest => null() new_patch_secondary%shortest => null() - endif +else !nocomp + do nocomp_pft=1,numpft ! looping round a new patch for each present PFT. allocate(new_patch_secondary) + if( site_areadis_secondary_pft(nocomp_pft) .gt. nearzero ) then + call create_patch(currentSite, new_patch_secondary_pft(nocomp_pft), age, & + site_areadis_secondary_pft(nocomp_pft), secondaryforest,nocomp_pft) + 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() + end if !area + end do !pft + endif !nocomp + endif !secondary ! loop round all the patches that contribute surviving indivduals and litter ! pools to the new patch. We only loop the pre-existing patches, so From b48de6a9ac573292064337628d01feadd268b090 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 19 May 2020 07:32:09 -0600 Subject: [PATCH 013/209] modifications to terminate_patches for PFT loops --- biogeochem/EDPatchDynamicsMod.F90 | 199 +++++++++++++++++++++++++----- 1 file changed, 165 insertions(+), 34 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 40d0476c12..7ea71751d7 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -43,6 +43,7 @@ module EDPatchDynamicsMod use FatesInterfaceMod , only : hlm_days_per_year use FatesInterfaceMod , only : numpft use FatesInterfaceMod , only : hlm_use_nocomp + use FatesInterfaceMod , only : hlm_use_fixed_biogeog use FatesGlobals , only : endrun => fates_endrun use FatesConstantsMod , only : r8 => fates_r8 use FatesConstantsMod , only : itrue, ifalse @@ -102,7 +103,7 @@ module EDPatchDynamicsMod character(len=*), parameter, private :: sourcefile = & __FILE__ - logical, parameter :: debug = .false. + logical, parameter :: debug = .true. ! When creating new patches from other patches, we need to send some of the ! litter from the old patch to the new patch. Likewise, when plants die @@ -478,6 +479,7 @@ subroutine spawn_patches( currentSite, bc_in) currentPatch => currentPatch%older enddo ! end loop over patches. sum area disturbed for all patches. + write(*,*) 'areadis', site_areadis_primary_pft(1:12) ! It is possible that no disturbance area was generated if ( (site_areadis_primary + site_areadis_secondary) > nearzero) then @@ -513,12 +515,12 @@ subroutine spawn_patches( currentSite, bc_in) site_areadis_primary_pft(nocomp_pft), primaryforest,nocomp_pft) ! Initialize the litter pools to zero do el=1,num_elements - call new_patch_primary%litter(el)%InitConditions(& + call new_patch_primary_pft(nocomp_pft)%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() + new_patch_primary_pft(nocomp_pft)%tallest => null() + new_patch_primary_pft(nocomp_pft)%shortest => null() end if !area end do !pft endif !nocomp @@ -552,12 +554,12 @@ subroutine spawn_patches( currentSite, bc_in) call create_patch(currentSite, new_patch_secondary_pft(nocomp_pft), age, & site_areadis_secondary_pft(nocomp_pft), secondaryforest,nocomp_pft) do el=1,num_elements - call new_patch_secondary%litter(el)%InitConditions(& + call new_patch_secondary_pft(nocomp_pft)%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() + new_patch_secondary_pft(nocomp_pft)%tallest => null() + new_patch_secondary_pft(nocomp_pft)%shortest => null() end if !area end do !pft endif !nocomp @@ -584,10 +586,20 @@ subroutine spawn_patches( currentSite, bc_in) if (currentPatch%anthro_disturbance_label .eq. primaryforest .and. & (currentPatch%disturbance_mode .ne. dtype_ilog)) then new_patch => new_patch_primary + rec_type = primaryforest else new_patch => new_patch_secondary + rec_type = secondaryforest endif + if(hlm_use_nocomp.eq.itrue)then !nocomp case + if(rec_type.eq.primaryforest)then + new_patch => new_patch_primary_pft(currentPatch%nocomp_pft_label) + else + new_patch => new_patch_secondary_pft(currentPatch%nocomp_pft_label) + endif + endif + if(.not.associated(new_patch))then write(fates_log(),*) 'Patch spawning has attempted to point to' write(fates_log(),*) 'an un-allocated patch' @@ -1061,41 +1073,81 @@ subroutine spawn_patches( currentSite, bc_in) !** INSERT NEW PATCH(ES) INTO LINKED LIST !**********`***************/ - if ( site_areadis_primary .gt. nearzero) then + ! currentPatch is the youngest of the pre-existing patches. + !newpatch_primary_pft and newpatch_secondary_pft need to be added into the mix + + if(hlm_use_nocomp.eq.ifalse)then + if ( site_areadis_primary .gt. nearzero) then currentPatch => currentSite%youngest_patch new_patch_primary%older => currentPatch new_patch_primary%younger => null() currentPatch%younger => new_patch_primary currentSite%youngest_patch => new_patch_primary - endif + endif - if ( site_areadis_secondary .gt. nearzero) then + 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 - + endif + else !nocomp case with one new patch for each PFT + do nocomp_pft=1,numpft + if ( site_areadis_primary_pft(nocomp_pft) .gt. nearzero) then + currentPatch => currentSite%youngest_patch + new_patch_primary_pft(nocomp_pft)%older => currentPatch + new_patch_primary_pft(nocomp_pft)%younger => null() + currentPatch%younger => new_patch_primary_pft(nocomp_pft) + currentSite%youngest_patch => new_patch_primary_pft(nocomp_pft) + endif + + if ( site_areadis_secondary .gt. nearzero) then + currentPatch => currentSite%youngest_patch + new_patch_secondary_pft(nocomp_pft)%older => currentPatch + new_patch_secondary_pft(nocomp_pft)%younger=> null() + currentPatch%younger => new_patch_secondary_pft(nocomp_pft) + currentSite%youngest_patch => new_patch_secondary_pft(nocomp_pft) + endif + enddo !pft + endif !nocomp ! 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_primary .gt. nearzero) then - call terminate_cohorts(currentSite, new_patch_primary, 1,17) - call fuse_cohorts(currentSite,new_patch_primary, bc_in) - call terminate_cohorts(currentSite, new_patch_primary, 2,17) - call sort_cohorts(new_patch_primary) - endif - - if ( site_areadis_secondary .gt. nearzero) then - call terminate_cohorts(currentSite, new_patch_secondary, 1,18) - call fuse_cohorts(currentSite,new_patch_secondary, bc_in) - call terminate_cohorts(currentSite, new_patch_secondary, 2,18) - call sort_cohorts(new_patch_secondary) - endif + if(hlm_use_nocomp.eq.ifalse)then + if ( site_areadis_primary .gt. nearzero) then + call terminate_cohorts(currentSite, new_patch_primary, 1,17) + call fuse_cohorts(currentSite,new_patch_primary, bc_in) + call terminate_cohorts(currentSite, new_patch_primary, 2,17) + call sort_cohorts(new_patch_primary) + endif + + if ( site_areadis_secondary .gt. nearzero) then + call terminate_cohorts(currentSite, new_patch_secondary, 1,18) + call fuse_cohorts(currentSite,new_patch_secondary, bc_in) + call terminate_cohorts(currentSite, new_patch_secondary, 2,18) + call sort_cohorts(new_patch_secondary) + endif + + else !nocomp case + do nocomp_pft=1,numpft + if ( site_areadis_primary_pft(nocomp_pft) .gt. nearzero) then + call terminate_cohorts(currentSite, new_patch_primary_pft(nocomp_pft), 1,17) + call fuse_cohorts(currentSite,new_patch_primary_pft(nocomp_pft), bc_in) + call terminate_cohorts(currentSite, new_patch_primary_pft(nocomp_pft), 2,17) + call sort_cohorts(new_patch_primary_pft(nocomp_pft)) + endif + if ( site_areadis_primary_pft(nocomp_pft) .gt. nearzero) then + call terminate_cohorts(currentSite, new_patch_secondary_pft(nocomp_pft), 1,18) + call fuse_cohorts(currentSite, new_patch_secondary_pft(nocomp_pft), bc_in) + call terminate_cohorts(currentSite, new_patch_secondary_pft(nocomp_pft), 2,18) + call sort_cohorts(new_patch_secondary_pft(nocomp_pft)) + endif + enddo !pft + endif !nocomp endif !end new_patch area @@ -1155,7 +1207,7 @@ subroutine check_patch_area( currentSite ) end if if(debug) then - write(fates_log(),*) 'Total patch area precision being fixed, adjusting' + write(fates_log(),*) 'Total patch area precision being fixed, adjusting',(areatot-area_site) write(fates_log(),*) 'largest patch. This may have slight impacts on carbon balance.' end if @@ -2455,8 +2507,10 @@ subroutine fuse_2_patches(csite, dp, rp) end if ! We have no need for the dp pointer anymore, we have passed on it's legacy + write(*,*) 'deallocating' ,dp%nocomp_pft_label, rp%nocomp_pft_label call dealloc_patch(dp) - deallocate(dp) + +! deallocate(dp) if(associated(youngerp))then @@ -2500,9 +2554,13 @@ subroutine terminate_patches(currentSite) type(ed_patch_type), pointer :: currentPatch type(ed_patch_type), pointer :: olderPatch type(ed_patch_type), pointer :: youngerPatch + type(ed_patch_type), pointer :: fusingPatch integer, parameter :: max_cycles = 10 ! After 10 loops through ! You should had fused integer :: count_cycles + integer :: is_youngest + integer :: is_oldest + integer :: found_fusion_patch real(r8) areatot ! variable for checking whether the total patch area is wrong. !--------------------------------------------------------------------- @@ -2513,13 +2571,17 @@ subroutine terminate_patches(currentSite) do while(associated(currentPatch)) if(currentPatch%area <= min_patch_area)then - + + if(hlm_use_fixed_biogeog.eq.ifalse)then !just fuse to older or younger cohort. + ! 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 + ! the current patch is NOT the youngest. Or is it very very small. + ! so, skip merging if it is the youngest, unless the youngest is tiny. if ( .not.associated(currentPatch,currentSite%youngest_patch) .or. & currentPatch%area <= min_patch_area_forced ) then @@ -2553,10 +2615,71 @@ subroutine terminate_patches(currentSite) ! The fusion process has updated the "younger" pointer on currentPatch - endif - endif - endif + endif ! older or younder patch + endif ! very small area + + else !nocomp. We cannot fuse to patches with a different PFT identity in no competition mode. + + ! Each patch has a PFT identity, and so cannot simply fuse to the older or younger patch + ! For each small current patch, we must first search older patch candidates, and then younger + ! patch candidates. + ! need to think about the youngest of PFT logic later. + + is_youngest = itrue !try and find a younger same-PFT patch + ! discover if this is the youngest patch of its PFT + fusingPatch => currentPatch%younger !if it's the youngest overall then it's defacto youngest of PFT + do while(associated(fusingPatch).and.is_youngest.eq.itrue) + if(fusingPatch%nocomp_pft_label.eq.currentPatch%nocomp_pft_label)then + is_youngest = ifalse ! we found a yonger patch, so this isn't the youngest one. + endif ! PFT + fusingPatch => fusingPatch%younger + enddo !fusing patch + + is_oldest = itrue !try and find a younger same-PFT patch + ! discover if this is the youngest patch of its PFT + fusingPatch => currentPatch%older !if it's the youngest overall then it's defacto youngest of PFT + do while(associated(fusingPatch).and.is_oldest.eq.itrue) + if(fusingPatch%nocomp_pft_label.eq.currentPatch%nocomp_pft_label)then + is_oldest = ifalse ! we found a yonger patch, so this isn't the youngest one. + endif ! PFT + fusingPatch => fusingPatch%older + enddo !fusing patch + + if (is_youngest.eq.itrue .or. currentPatch%area <= min_patch_area_forced ) then + + found_fusion_patch = ifalse + + fusingPatch => currentPatch%older + do while(associated(fusingPatch).and.found_fusion_patch.eq.ifalse ) + if(fusingPatch%nocomp_pft_label.eq.currentPatch%nocomp_pft_label)then + if(debug) & + write(fates_log(),*) 'fusing to older patch of same PFT - this one is too small',& + currentPatch%area, fusingPatch%area, & + currentPatch%nocomp_pft_label, fusingPatch%nocomp_pft_label + call fuse_2_patches(currentSite, fusingPatch, currentPatch) + found_fusion_patch=itrue + endif ! PFT + fusingPatch => fusingPatch%older + enddo !fusing patch + + ! if no older patches, search younger ones. + fusingPatch => currentPatch%younger + do while(associated(fusingPatch).and.found_fusion_patch.eq.ifalse ) + if(fusingPatch%nocomp_pft_label.eq.currentPatch%nocomp_pft_label)then + if(debug) & + write(fates_log(),*) 'fusing to younger patch of same PFT - this one is too small',& + currentPatch%area, fusingPatch%area , & + currentPatch%nocomp_pft_label, fusingPatch%nocomp_pft_label + call fuse_2_patches(currentSite, fusingPatch, currentPatch) + found_fusion_patch=itrue + endif ! PFT + fusingPatch => fusingPatch%younger + enddo !fusing patch + endif ! not youngest, or is very small patch + endif !nocomp + endif ! small area + ! It is possible that an incredibly small patch just fused into another incredibly ! small patch, resulting in an incredibly small patch. It is also possible that this ! resulting incredibly small patch is the oldest patch. If this was true than @@ -2570,8 +2693,12 @@ subroutine terminate_patches(currentSite) else count_cycles = count_cycles + 1 end if - + if(count_cycles > max_cycles) then + if(is_oldest.eq.itrue.and.is_youngest.eq.itrue.and.hlm_use_fixed_biogeog)then + write(fates_log(),*) 'this is the only patch of this PFT' + currentPatch => currentPatch%older + else !not the only patch write(fates_log(),*) 'FATES is having difficulties fusing very small patches.' write(fates_log(),*) 'It is possible that a either a secondary or primary' write(fates_log(),*) 'patch has become the only patch of its kind, and it is' @@ -2579,6 +2706,9 @@ subroutine terminate_patches(currentSite) write(fates_log(),*) 'disabling the endrun statement following this message.' write(fates_log(),*) 'FATES may or may not continue to operate within error' write(fates_log(),*) 'tolerances, but will generate another fail if it does not.' + + write(fates_log(),*) 'cp pft',currentPatch%nocomp_pft_label,currentPatch%area + call endrun(msg=errMsg(sourcefile, __LINE__)) ! Note to user. If you DO decide to remove the end-run above this line @@ -2586,9 +2716,10 @@ subroutine terminate_patches(currentSite) ! an infinite loop. currentPatch => currentPatch%older count_cycles = 0 - end if + end if !only patch + end if !count cycles - enddo + enddo !patch loop !check area is not exceeded call check_patch_area( currentSite ) From 8e8e91fa5ef047637a3a4735946965017ef1c595 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 20 May 2020 06:09:02 -0600 Subject: [PATCH 014/209] reformatting the PFT loop in spawn patches --- biogeochem/EDPatchDynamicsMod.F90 | 192 ++++++++++++++---------------- 1 file changed, 87 insertions(+), 105 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 7ea71751d7..70815cb779 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -417,12 +417,16 @@ subroutine spawn_patches( currentSite, bc_in) real(r8) :: leaf_m ! leaf mass during partial burn calculations integer :: rec_type ! records type of disturbance while in patch loop integer :: nocomp_pft ! where nocomp mode is on, PFT label + integer :: numiter + real(r8) :: areadis_primary + real(r8) :: areadis_secondary !--------------------------------------------------------------------- ! Allocate PFT arrays of patches to form the new patches in nocomp mode. - allocate(new_patch_primary_pft(numpft)) - allocate(new_patch_secondary_pft(numpft)) - + if(hlm_use_nocomp.eq.itrue)then + allocate(new_patch_primary_pft(numpft)) + allocate(new_patch_secondary_pft(numpft)) + endif storesmallcohort => null() ! storage of the smallest cohort for insertion routine storebigcohort => null() ! storage of the largest cohort for insertion routine @@ -482,17 +486,35 @@ subroutine spawn_patches( currentSite, bc_in) write(*,*) 'areadis', site_areadis_primary_pft(1:12) ! It is possible that no disturbance area was generated if ( (site_areadis_primary + site_areadis_secondary) > nearzero) then - + + ! Do the entire patch creation loop around a PFT loop. + numiter = 1 + if(hlm_use_nocomp.eq.itrue)then + numiter = numpft + endif + + do nocomp_pft = 1,numiter 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(hlm_use_nocomp.eq.ifalse)then + areadis_primary = site_areadis_primary + areadis_secondary = site_areadis_secondary + else + areadis_primary = site_areadis_primary_pft(nocomp_pft) + areadis_secondary = site_areadis_secondary_pft(nocomp_pft) + endif + if ( site_areadis_primary .gt. nearzero ) then - if(hlm_use_nocomp.eq.ifalse)then allocate(new_patch_primary) + if(hlm_use_nocomp.eq.ifalse)then call create_patch(currentSite, new_patch_primary, age, & - site_areadis_primary, primaryforest,1) - + areadis_primary, primaryforest,1) + else + call create_patch(currentSite, new_patch_primary, age, & + areadis_primary, primaryforest,nocomp_pft) + endif ! Initialize the litter pools to zero, these ! pools will be populated by looping over the existing patches ! and transfering in mass @@ -506,34 +528,19 @@ subroutine spawn_patches( currentSite, bc_in) end do new_patch_primary%tallest => null() new_patch_primary%shortest => null() - - else !nocomp - do nocomp_pft=1,numpft ! looping round a new patch for each present PFT. -! allocate(new_patch_primary_pft(nocompt_pft)) - if( site_areadis_primary_pft(nocomp_pft) .gt. nearzero ) then - call create_patch(currentSite, new_patch_primary_pft(nocomp_pft), age, & - site_areadis_primary_pft(nocomp_pft), primaryforest,nocomp_pft) - ! Initialize the litter pools to zero - do el=1,num_elements - call new_patch_primary_pft(nocomp_pft)%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_pft(nocomp_pft)%tallest => null() - new_patch_primary_pft(nocomp_pft)%shortest => null() - end if !area - end do !pft - endif !nocomp end if !primary ! next create patch to receive secondary forest area if ( site_areadis_secondary .gt. nearzero) then - if(hlm_use_nocomp.eq.ifalse)then allocate(new_patch_secondary) + if(hlm_use_nocomp.eq.ifalse)then call create_patch(currentSite, new_patch_secondary, age, & - site_areadis_secondary, secondaryforest,1) - + areadis_secondary, secondaryforest,1) + else + call create_patch(currentSite, new_patch_secondary, age, & + areadis_secondary, secondaryforest,nocomp_pft) + endif ! Initialize the litter pools to zero, these ! pools will be populated by looping over the existing patches ! and transfering in mass @@ -547,22 +554,6 @@ subroutine spawn_patches( currentSite, bc_in) end do new_patch_secondary%tallest => null() new_patch_secondary%shortest => null() - -else !nocomp - do nocomp_pft=1,numpft ! looping round a new patch for each present PFT. allocate(new_patch_secondary) - if( site_areadis_secondary_pft(nocomp_pft) .gt. nearzero ) then - call create_patch(currentSite, new_patch_secondary_pft(nocomp_pft), age, & - site_areadis_secondary_pft(nocomp_pft), secondaryforest,nocomp_pft) - do el=1,num_elements - call new_patch_secondary_pft(nocomp_pft)%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_pft(nocomp_pft)%tallest => null() - new_patch_secondary_pft(nocomp_pft)%shortest => null() - end if !area - end do !pft - endif !nocomp endif !secondary ! loop round all the patches that contribute surviving indivduals and litter @@ -592,14 +583,6 @@ subroutine spawn_patches( currentSite, bc_in) rec_type = secondaryforest endif - if(hlm_use_nocomp.eq.itrue)then !nocomp case - if(rec_type.eq.primaryforest)then - new_patch => new_patch_primary_pft(currentPatch%nocomp_pft_label) - else - new_patch => new_patch_secondary_pft(currentPatch%nocomp_pft_label) - endif - endif - if(.not.associated(new_patch))then write(fates_log(),*) 'Patch spawning has attempted to point to' write(fates_log(),*) 'an un-allocated patch' @@ -1076,8 +1059,8 @@ subroutine spawn_patches( currentSite, bc_in) ! currentPatch is the youngest of the pre-existing patches. !newpatch_primary_pft and newpatch_secondary_pft need to be added into the mix - if(hlm_use_nocomp.eq.ifalse)then - if ( site_areadis_primary .gt. nearzero) then + + if ( areadis_primary .gt. nearzero) then currentPatch => currentSite%youngest_patch new_patch_primary%older => currentPatch new_patch_primary%younger => null() @@ -1085,76 +1068,49 @@ subroutine spawn_patches( currentSite, bc_in) currentSite%youngest_patch => new_patch_primary endif - if ( site_areadis_secondary .gt. nearzero) then + if ( 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 - else !nocomp case with one new patch for each PFT - do nocomp_pft=1,numpft - if ( site_areadis_primary_pft(nocomp_pft) .gt. nearzero) then - currentPatch => currentSite%youngest_patch - new_patch_primary_pft(nocomp_pft)%older => currentPatch - new_patch_primary_pft(nocomp_pft)%younger => null() - currentPatch%younger => new_patch_primary_pft(nocomp_pft) - currentSite%youngest_patch => new_patch_primary_pft(nocomp_pft) - endif - - if ( site_areadis_secondary .gt. nearzero) then - currentPatch => currentSite%youngest_patch - new_patch_secondary_pft(nocomp_pft)%older => currentPatch - new_patch_secondary_pft(nocomp_pft)%younger=> null() - currentPatch%younger => new_patch_secondary_pft(nocomp_pft) - currentSite%youngest_patch => new_patch_secondary_pft(nocomp_pft) - endif - enddo !pft - endif !nocomp - + ! 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(hlm_use_nocomp.eq.ifalse)then - if ( site_areadis_primary .gt. nearzero) then + if ( areadis_primary .gt. nearzero) then call terminate_cohorts(currentSite, new_patch_primary, 1,17) call fuse_cohorts(currentSite,new_patch_primary, bc_in) call terminate_cohorts(currentSite, new_patch_primary, 2,17) call sort_cohorts(new_patch_primary) endif - if ( site_areadis_secondary .gt. nearzero) then + if ( areadis_secondary .gt. nearzero) then call terminate_cohorts(currentSite, new_patch_secondary, 1,18) call fuse_cohorts(currentSite,new_patch_secondary, bc_in) call terminate_cohorts(currentSite, new_patch_secondary, 2,18) call sort_cohorts(new_patch_secondary) endif - else !nocomp case - do nocomp_pft=1,numpft - if ( site_areadis_primary_pft(nocomp_pft) .gt. nearzero) then - call terminate_cohorts(currentSite, new_patch_primary_pft(nocomp_pft), 1,17) - call fuse_cohorts(currentSite,new_patch_primary_pft(nocomp_pft), bc_in) - call terminate_cohorts(currentSite, new_patch_primary_pft(nocomp_pft), 2,17) - call sort_cohorts(new_patch_primary_pft(nocomp_pft)) - endif - if ( site_areadis_primary_pft(nocomp_pft) .gt. nearzero) then - call terminate_cohorts(currentSite, new_patch_secondary_pft(nocomp_pft), 1,18) - call fuse_cohorts(currentSite, new_patch_secondary_pft(nocomp_pft), bc_in) - call terminate_cohorts(currentSite, new_patch_secondary_pft(nocomp_pft), 2,18) - call sort_cohorts(new_patch_secondary_pft(nocomp_pft)) - endif - enddo !pft - endif !nocomp - + end do ! PFT loop for nocomp endif !end new_patch area - call check_patch_area(currentSite) call set_patchno(currentSite) + currentpatch => currentSite%youngest_patch + do while(associated(currentpatch)) + write(*,*) 'sp patch list',currentpatch%patchno,currentpatch%nocomp_pft_label + if(associated(currentpatch%younger))then + write(*,*) 'sp check cpy',currentpatch%younger%patchno,currentpatch%younger%nocomp_pft_label + endif + currentpatch => currentpatch%older + + enddo + return end subroutine spawn_patches @@ -2373,7 +2329,16 @@ subroutine fuse_patches( csite, bc_in ) enddo !do while nopatches>maxPatchesPerSite end do ! i_disttype loop - + + currentpatch => currentSite%youngest_patch + do while(associated(currentpatch)) + write(*,*) 'fp patch list',currentpatch%patchno,currentpatch%nocomp_pft_label + if(associated(currentpatch%younger))then + write(*,*) 'fp check cpy',currentpatch%younger%patchno,currentpatch%younger%nocomp_pft_label + endif + currentpatch => currentpatch%older + enddo + end subroutine fuse_patches ! ============================================================================ @@ -2470,7 +2435,7 @@ subroutine fuse_2_patches(csite, dp, rp) else snull = 1 rp%shortest => currentCohort - endif + Endif call insert_cohort(currentCohort, rp%tallest, rp%shortest, tnull, snull, storebigcohort, storesmallcohort) @@ -2507,10 +2472,10 @@ subroutine fuse_2_patches(csite, dp, rp) end if ! We have no need for the dp pointer anymore, we have passed on it's legacy - write(*,*) 'deallocating' ,dp%nocomp_pft_label, rp%nocomp_pft_label call dealloc_patch(dp) + write(*,*) 'deallocating2' ,dp%nocomp_pft_label, rp%nocomp_pft_label, dp%patchno, rp%patchno -! deallocate(dp) + deallocate(dp) if(associated(youngerp))then @@ -2566,6 +2531,18 @@ subroutine terminate_patches(currentSite) !--------------------------------------------------------------------- count_cycles = 0 +write(*,*) 'start terminate patches',currentSite%lat,currentSite%lon + + currentpatch => currentSite%youngest_patch + do while(associated(currentpatch)) + write(*,*) 'tp patch list',currentpatch%patchno,currentpatch%nocomp_pft_label + if(associated(currentpatch%younger))then + write(*,*) 'tp check cpy',currentpatch%younger%patchno,currentpatch%younger%nocomp_pft_label + endif + currentpatch => currentpatch%older + + enddo + currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) @@ -2651,29 +2628,33 @@ subroutine terminate_patches(currentSite) fusingPatch => currentPatch%older do while(associated(fusingPatch).and.found_fusion_patch.eq.ifalse ) + olderPatch => fusingPatch%older if(fusingPatch%nocomp_pft_label.eq.currentPatch%nocomp_pft_label)then if(debug) & write(fates_log(),*) 'fusing to older patch of same PFT - this one is too small',& currentPatch%area, fusingPatch%area, & - currentPatch%nocomp_pft_label, fusingPatch%nocomp_pft_label + currentPatch%nocomp_pft_label, fusingPatch%nocomp_pft_label, & + currentPatch%patchno, fusingPatch%patchno call fuse_2_patches(currentSite, fusingPatch, currentPatch) found_fusion_patch=itrue endif ! PFT - fusingPatch => fusingPatch%older + fusingPatch => olderPatch enddo !fusing patch ! if no older patches, search younger ones. fusingPatch => currentPatch%younger do while(associated(fusingPatch).and.found_fusion_patch.eq.ifalse ) + olderPatch => fusingPatch%older if(fusingPatch%nocomp_pft_label.eq.currentPatch%nocomp_pft_label)then if(debug) & write(fates_log(),*) 'fusing to younger patch of same PFT - this one is too small',& currentPatch%area, fusingPatch%area , & - currentPatch%nocomp_pft_label, fusingPatch%nocomp_pft_label + currentPatch%nocomp_pft_label, fusingPatch%nocomp_pft_label, & + currentPatch%patchno, fusingPatch%patchno call fuse_2_patches(currentSite, fusingPatch, currentPatch) found_fusion_patch=itrue endif ! PFT - fusingPatch => fusingPatch%younger + fusingPatch => olderPatch enddo !fusing patch endif ! not youngest, or is very small patch endif !nocomp @@ -2698,6 +2679,7 @@ subroutine terminate_patches(currentSite) if(is_oldest.eq.itrue.and.is_youngest.eq.itrue.and.hlm_use_fixed_biogeog)then write(fates_log(),*) 'this is the only patch of this PFT' currentPatch => currentPatch%older + count_cycles = 0 else !not the only patch write(fates_log(),*) 'FATES is having difficulties fusing very small patches.' write(fates_log(),*) 'It is possible that a either a secondary or primary' @@ -2723,7 +2705,7 @@ subroutine terminate_patches(currentSite) !check area is not exceeded call check_patch_area( currentSite ) - + write(*,*) 'leaving terminate patches',currentSite%lat,currentSite%lon return end subroutine terminate_patches From 2b08a8d228061bc08dade9b3e4531749229cd796 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 20 May 2020 06:09:29 -0600 Subject: [PATCH 015/209] removing write statements from EDInit --- main/EDInitMod.F90 | 15 +-------------- 1 file changed, 1 insertion(+), 14 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 3d5ee7e30a..b1efc0d3d4 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -440,9 +440,6 @@ subroutine init_patches( nsites, sites, bc_in) if(newparea.gt.0._r8)then ! Stop patches being initilialized when PFT not present in nocomop mode allocate(newp) - if(hlm_use_nocomp.eq.itrue)then - ! newp => newppft(nocomp_pft) - endif call create_patch(sites(s), newp, age, newparea, primaryforest, nocomp_pft) @@ -464,7 +461,6 @@ subroutine init_patches( nsites, sites, bc_in) sites(s)%youngest_patch => newp end if recall_older_patch => newp ! remember this patch for the next one to point at. - write(*,*) 'ed init litter01',s,sites(s)%oldest_patch%area ! Initialize the litter pools to zero, these ! pools will be populated by looping over the existing patches @@ -477,9 +473,6 @@ subroutine init_patches( nsites, sites, bc_in) init_seed=0._r8, & init_seed_germ=0._r8) end do - write(*,*) 'ed init litter02',s,sites(s)%oldest_patch%area - write(*,*) 'ed init litter03',s,sites(s)%oldest_patch%litter(1)%ag_cwd(1) -! write(*,*) 'ed init litter04',s,sites(1)%oldest_patch%litter(1)%ag_cwd(1) sitep => sites(s) call init_cohorts(sitep, newp, bc_in(s)) @@ -505,16 +498,10 @@ 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 - write(*,*) 'ed init litter05',s,sites(s)%oldest_patch%area - write(*,*) 'call set_patchno',s + call set_patchno(sites(s)) - write(*,*) 'after set_patchno',s ! deallocate(recall_older_patch) - write(*,*) 'ed init litter06', s,sites(s)%oldest_patch%area -! write(*,*) 'ed init litter15',s,sites(1)%oldest_patch%area -! write(*,*) 'ed init litter2', s,sites(s)%oldest_patch%litter(1)%ag_cwd(1) -! write(*,*) 'ed init litter25',s,sites(1)%oldest_patch%litter(1)%ag_cwd(1) enddo !s write(*,*)'end init' end if From 30659c9bcb938a546d6833d50b1b1016aae00872 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 20 May 2020 08:45:43 -0600 Subject: [PATCH 016/209] fixing issues with area in spawn patches2667 --- biogeochem/EDPatchDynamicsMod.F90 | 73 +++++++++++++++++++++++-------- 1 file changed, 54 insertions(+), 19 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 70815cb779..338ed262f1 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -565,9 +565,18 @@ subroutine spawn_patches( currentSite, bc_in) do while(associated(currentPatch)) ! This is the amount of patch area that is disturbed, and donated by the donor + if(hlm_use_nocomp.eq.ifalse)then patch_site_areadis = currentPatch%area * currentPatch%disturbance_rate + else + if(currentPatch%nocomp_pft_label.eq.nocomp_pft)then + patch_site_areadis = currentPatch%area * currentPatch%disturbance_rate + else + patch_site_areadis = 0.0_r8 + endif + endif + write(*,*) 'patch donor pft loop' ,currentPatch%nocomp_pft_label,nocomp_pft,& + patch_site_areadis,currentpatch%patchno,currentPatch%disturbance_rate - if ( patch_site_areadis > nearzero ) then ! figure out whether the receiver patch for disturbance from this patch @@ -610,7 +619,7 @@ subroutine spawn_patches( currentSite, bc_in) if(currentPatch%disturbance_mode .ne. dtype_ifire) then currentPatch%burnt_frac_litter(:) = 0._r8 end if - + write(*,*) 'patch site areadis',patch_site_areadis,new_patch%area,nocomp_pft,currentPatch%disturbance_rate call TransLitterNewPatch( currentSite, currentPatch, new_patch, patch_site_areadis) ! Transfer in litter fluxes from plants in various contexts of death and destruction @@ -1043,11 +1052,6 @@ subroutine spawn_patches( currentSite, bc_in) end if ! if ( new_patch%area > nearzero ) then - !zero disturbance rate trackers - currentPatch%disturbance_rate = 0._r8 - currentPatch%disturbance_rates = 0._r8 - currentPatch%fract_ldist_not_harvested = 0._r8 - currentPatch => currentPatch%younger enddo ! currentPatch patch loop. @@ -1094,19 +1098,31 @@ subroutine spawn_patches( currentSite, bc_in) call terminate_cohorts(currentSite, new_patch_secondary, 2,18) call sort_cohorts(new_patch_secondary) endif + write(*,*) 'pft loop', nocomp_pft + end do ! PFT loop for nocomp endif !end new_patch area + currentpatch => currentSite%youngest_patch + do while(associated(currentpatch)) + !zero disturbance rate trackers + currentPatch%disturbance_rate = 0._r8 + currentPatch%disturbance_rates = 0._r8 + currentPatch%fract_ldist_not_harvested = 0._r8 + currentpatch => currentpatch%older + end do + call check_patch_area(currentSite) call set_patchno(currentSite) currentpatch => currentSite%youngest_patch do while(associated(currentpatch)) - write(*,*) 'sp patch list',currentpatch%patchno,currentpatch%nocomp_pft_label if(associated(currentpatch%younger))then - write(*,*) 'sp check cpy',currentpatch%younger%patchno,currentpatch%younger%nocomp_pft_label +! write(*,*) 'sp check cpy',currentpatch%younger%patchno,currentpatch%younger%nocomp_pft_label,& +!currentpatch%younger%area endif +! write(*,*) 'sp patch list',currentpatch%patchno,currentpatch%nocomp_pft_label,currentpatch%area currentpatch => currentpatch%older enddo @@ -2332,10 +2348,11 @@ subroutine fuse_patches( csite, bc_in ) currentpatch => currentSite%youngest_patch do while(associated(currentpatch)) - write(*,*) 'fp patch list',currentpatch%patchno,currentpatch%nocomp_pft_label if(associated(currentpatch%younger))then - write(*,*) 'fp check cpy',currentpatch%younger%patchno,currentpatch%younger%nocomp_pft_label +! write(*,*) 'fp check cpy',currentpatch%younger%patchno,currentpatch%younger%nocomp_pft_label,& +!currentpatch%younger%area endif +! write(*,*) 'fp patch list',currentpatch%patchno,currentpatch%nocomp_pft_label,currentpatch%area currentpatch => currentpatch%older enddo @@ -2535,15 +2552,20 @@ subroutine terminate_patches(currentSite) currentpatch => currentSite%youngest_patch do while(associated(currentpatch)) - write(*,*) 'tp patch list',currentpatch%patchno,currentpatch%nocomp_pft_label - if(associated(currentpatch%younger))then - write(*,*) 'tp check cpy',currentpatch%younger%patchno,currentpatch%younger%nocomp_pft_label - endif +! write(*,*) 'tp o-y patch list',currentpatch%patchno,currentpatch%nocomp_pft_label,currentpatch%area currentpatch => currentpatch%older + enddo + currentpatch => currentSite%oldest_patch + do while(associated(currentpatch)) + write(*,*) 'tp y-o patch list',currentpatch%patchno,currentpatch%nocomp_pft_label,currentpatch%area + currentpatch => currentpatch%younger enddo + + + currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) @@ -2622,7 +2644,7 @@ subroutine terminate_patches(currentSite) fusingPatch => fusingPatch%older enddo !fusing patch - if (is_youngest.eq.itrue .or. currentPatch%area <= min_patch_area_forced ) then + if (is_youngest.eq.ifalse .or. currentPatch%area <= min_patch_area_forced ) then found_fusion_patch = ifalse @@ -2635,7 +2657,7 @@ subroutine terminate_patches(currentSite) currentPatch%area, fusingPatch%area, & currentPatch%nocomp_pft_label, fusingPatch%nocomp_pft_label, & currentPatch%patchno, fusingPatch%patchno - call fuse_2_patches(currentSite, fusingPatch, currentPatch) + call fuse_2_patches(currentSite, currentPatch, fusingPatch) found_fusion_patch=itrue endif ! PFT fusingPatch => olderPatch @@ -2644,14 +2666,19 @@ subroutine terminate_patches(currentSite) ! if no older patches, search younger ones. fusingPatch => currentPatch%younger do while(associated(fusingPatch).and.found_fusion_patch.eq.ifalse ) + + if(fusingPatch%patchno.eq.currentPatch%younger%patchno)then + write(*,*) 'something weird with younger pointer here',fusingPatch%patchno,currentPatch%younger%patchno + end if olderPatch => fusingPatch%older if(fusingPatch%nocomp_pft_label.eq.currentPatch%nocomp_pft_label)then if(debug) & write(fates_log(),*) 'fusing to younger patch of same PFT - this one is too small',& currentPatch%area, fusingPatch%area , & currentPatch%nocomp_pft_label, fusingPatch%nocomp_pft_label, & - currentPatch%patchno, fusingPatch%patchno - call fuse_2_patches(currentSite, fusingPatch, currentPatch) + currentPatch%patchno, fusingPatch%patchno,& + is_youngest,is_oldest + call fuse_2_patches(currentSite, currentPatch, fusingPatch) found_fusion_patch=itrue endif ! PFT fusingPatch => olderPatch @@ -2700,6 +2727,14 @@ subroutine terminate_patches(currentSite) count_cycles = 0 end if !only patch end if !count cycles + call set_patchno(currentSite) + + fusingpatch => currentSite%oldest_patch + write(*,*) 'tp end list' + do while(associated(fusingpatch)) + write(*,*) 'tp end y-o patch list',fusingpatch%patchno,fusingpatch%nocomp_pft_label,fusingpatch%area + fusingpatch => fusingpatch%younger + enddo enddo !patch loop From 02db378f560eeb3746f43960be748df499efd042 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 20 May 2020 09:12:04 -0600 Subject: [PATCH 017/209] fixed references to currentPatch in terminate patches --- biogeochem/EDPatchDynamicsMod.F90 | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 338ed262f1..cda1b0077f 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -574,7 +574,6 @@ subroutine spawn_patches( currentSite, bc_in) patch_site_areadis = 0.0_r8 endif endif - write(*,*) 'patch donor pft loop' ,currentPatch%nocomp_pft_label,nocomp_pft,& patch_site_areadis,currentpatch%patchno,currentPatch%disturbance_rate if ( patch_site_areadis > nearzero ) then @@ -1098,8 +1097,6 @@ subroutine spawn_patches( currentSite, bc_in) call terminate_cohorts(currentSite, new_patch_secondary, 2,18) call sort_cohorts(new_patch_secondary) endif - write(*,*) 'pft loop', nocomp_pft - end do ! PFT loop for nocomp endif !end new_patch area @@ -2663,6 +2660,7 @@ subroutine terminate_patches(currentSite) fusingPatch => olderPatch enddo !fusing patch + if(associated(currentPatch).and.found_fusion_patch.eq.ifalse)then ! if no older patches, search younger ones. fusingPatch => currentPatch%younger do while(associated(fusingPatch).and.found_fusion_patch.eq.ifalse ) @@ -2683,6 +2681,11 @@ subroutine terminate_patches(currentSite) endif ! PFT fusingPatch => olderPatch enddo !fusing patch + endif !current patch exists. + if(found_fusion_patch.eq.itrue)then + currentPatch => fusingPatch + endif + endif ! not youngest, or is very small patch endif !nocomp endif ! small area @@ -2695,6 +2698,7 @@ subroutine terminate_patches(currentSite) ! Think this is impossible? No, this really happens, especially when we have fires. ! So, we don't move forward until we have merged enough area into this thing. + if(currentPatch%area > min_patch_area_forced)then currentPatch => currentPatch%older count_cycles = 0 From 34f3532202cc00537115d085fae4ffc43fe86a54 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 20 May 2020 14:42:22 -0600 Subject: [PATCH 018/209] added olderp ref to cp loop in terminate patches --- biogeochem/EDPatchDynamicsMod.F90 | 47 +++++++++++++++++++++++-------- 1 file changed, 35 insertions(+), 12 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index cda1b0077f..5e67307d24 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -574,7 +574,6 @@ subroutine spawn_patches( currentSite, bc_in) patch_site_areadis = 0.0_r8 endif endif - patch_site_areadis,currentpatch%patchno,currentPatch%disturbance_rate if ( patch_site_areadis > nearzero ) then @@ -2474,6 +2473,7 @@ subroutine fuse_2_patches(csite, dp, rp) ! Define some aliases for the donor patches younger and older neighbors ! which may or may not exist. After we set them, we will remove the donor ! And then we will go about re-setting the map. + if(associated(dp%older))then olderp => dp%older else @@ -2485,6 +2485,9 @@ subroutine fuse_2_patches(csite, dp, rp) youngerp => null() end if + + + ! We have no need for the dp pointer anymore, we have passed on it's legacy call dealloc_patch(dp) write(*,*) 'deallocating2' ,dp%nocomp_pft_label, rp%nocomp_pft_label, dp%patchno, rp%patchno @@ -2532,6 +2535,7 @@ subroutine terminate_patches(currentSite) ! !LOCAL VARIABLES: type(ed_patch_type), pointer :: currentPatch type(ed_patch_type), pointer :: olderPatch + type(ed_patch_type), pointer :: oldercPatch type(ed_patch_type), pointer :: youngerPatch type(ed_patch_type), pointer :: fusingPatch integer, parameter :: max_cycles = 10 ! After 10 loops through @@ -2565,7 +2569,8 @@ subroutine terminate_patches(currentSite) currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) - + write(*,*) 'currentPatch1',currentPatch%patchno,currentPatch%nocomp_pft_label + oldercpatch => currentPatch%older if(currentPatch%area <= min_patch_area)then if(hlm_use_fixed_biogeog.eq.ifalse)then !just fuse to older or younger cohort. @@ -2628,6 +2633,11 @@ subroutine terminate_patches(currentSite) if(fusingPatch%nocomp_pft_label.eq.currentPatch%nocomp_pft_label)then is_youngest = ifalse ! we found a yonger patch, so this isn't the youngest one. endif ! PFT + if(associated(fusingpatch%younger))then + if(fusingpatch%patchno.eq.fusingpatch%younger%patchno)then + write(*,*) 'is_youngest patch list error',fusingpatch%patchno,fusingpatch%younger%patchno + endif + endif fusingPatch => fusingPatch%younger enddo !fusing patch @@ -2648,7 +2658,12 @@ subroutine terminate_patches(currentSite) fusingPatch => currentPatch%older do while(associated(fusingPatch).and.found_fusion_patch.eq.ifalse ) olderPatch => fusingPatch%older - if(fusingPatch%nocomp_pft_label.eq.currentPatch%nocomp_pft_label)then + if(associated(fusingpatch%younger))then + if(fusingpatch%patchno.eq.fusingpatch%younger%patchno)then + write(*,*) 'fuse older patch list error',fusingpatch%patchno,fusingpatch%younger%patchno + endif + endif + if(fusingPatch%nocomp_pft_label.eq.currentPatch%nocomp_pft_label)then if(debug) & write(fates_log(),*) 'fusing to older patch of same PFT - this one is too small',& currentPatch%area, fusingPatch%area, & @@ -2665,9 +2680,9 @@ subroutine terminate_patches(currentSite) fusingPatch => currentPatch%younger do while(associated(fusingPatch).and.found_fusion_patch.eq.ifalse ) - if(fusingPatch%patchno.eq.currentPatch%younger%patchno)then - write(*,*) 'something weird with younger pointer here',fusingPatch%patchno,currentPatch%younger%patchno - end if + if(fusingPatch%patchno.eq.currentPatch%younger%patchno)then + write(*,*) 'something weird with younger pointer here',fusingPatch%patchno,currentPatch%younger%patchno + end if olderPatch => fusingPatch%older if(fusingPatch%nocomp_pft_label.eq.currentPatch%nocomp_pft_label)then if(debug) & @@ -2700,12 +2715,13 @@ subroutine terminate_patches(currentSite) if(currentPatch%area > min_patch_area_forced)then - currentPatch => currentPatch%older + currentPatch => oldercPatch count_cycles = 0 else count_cycles = count_cycles + 1 end if - +! write(*,*) 'currentPatch2',currentPatch%patchno,currentPatch%nocomp_pft_label + if(count_cycles > max_cycles) then if(is_oldest.eq.itrue.and.is_youngest.eq.itrue.and.hlm_use_fixed_biogeog)then write(fates_log(),*) 'this is the only patch of this PFT' @@ -2727,20 +2743,27 @@ subroutine terminate_patches(currentSite) ! Note to user. If you DO decide to remove the end-run above this line ! Make sure that you keep the pointer below this line, or you will get ! an infinite loop. - currentPatch => currentPatch%older + currentPatch => oldercPatch count_cycles = 0 end if !only patch end if !count cycles - call set_patchno(currentSite) + call set_patchno(currentSite) !redo patch numbering for every potential termination. + !n.b. could put filter in here for actual terminations to save time. fusingpatch => currentSite%oldest_patch write(*,*) 'tp end list' do while(associated(fusingpatch)) write(*,*) 'tp end y-o patch list',fusingpatch%patchno,fusingpatch%nocomp_pft_label,fusingpatch%area - fusingpatch => fusingpatch%younger + + if(associated(fusingpatch%younger))then + if(fusingpatch%patchno.eq.fusingpatch%younger%patchno)then + write(*,*) 'patch list error',fusingpatch%patchno,fusingpatch%younger%patchno + endif + endif + fusingpatch => fusingpatch%younger enddo - enddo !patch loop + enddo ! current patch loop !check area is not exceeded call check_patch_area( currentSite ) From ce71fda10a9ce0d35a415f705f1ca0e8f04efbc7 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 20 May 2020 15:46:49 -0600 Subject: [PATCH 019/209] located error in the small size tolerances. Eraase <1% patches to fix --- biogeochem/EDPatchDynamicsMod.F90 | 20 +++++++++++++------- main/EDInitMod.F90 | 15 ++++++++++++++- 2 files changed, 27 insertions(+), 8 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 5e67307d24..146c5a30fa 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -2652,7 +2652,7 @@ subroutine terminate_patches(currentSite) enddo !fusing patch if (is_youngest.eq.ifalse .or. currentPatch%area <= min_patch_area_forced ) then - + write(*,*) 'current patch is termination candidate',currentPatch%area found_fusion_patch = ifalse fusingPatch => currentPatch%older @@ -2670,6 +2670,8 @@ subroutine terminate_patches(currentSite) currentPatch%nocomp_pft_label, fusingPatch%nocomp_pft_label, & currentPatch%patchno, fusingPatch%patchno call fuse_2_patches(currentSite, currentPatch, fusingPatch) + currentPatch => fusingPatch !redirect rest of main loop back to this cp + write(*,*) 'reverting curent patch to ', currentPatch%patchno found_fusion_patch=itrue endif ! PFT fusingPatch => olderPatch @@ -2681,9 +2683,10 @@ subroutine terminate_patches(currentSite) do while(associated(fusingPatch).and.found_fusion_patch.eq.ifalse ) if(fusingPatch%patchno.eq.currentPatch%younger%patchno)then - write(*,*) 'something weird with younger pointer here',fusingPatch%patchno,currentPatch%younger%patchno + write(*,*) 'something weird with younger pointer here',fusingPatch%patchno,fusingPatch%nocomp_pft_label end if olderPatch => fusingPatch%older + if(fusingPatch%nocomp_pft_label.eq.currentPatch%nocomp_pft_label)then if(debug) & write(fates_log(),*) 'fusing to younger patch of same PFT - this one is too small',& @@ -2692,14 +2695,13 @@ subroutine terminate_patches(currentSite) currentPatch%patchno, fusingPatch%patchno,& is_youngest,is_oldest call fuse_2_patches(currentSite, currentPatch, fusingPatch) + currentPatch => fusingPatch found_fusion_patch=itrue endif ! PFT fusingPatch => olderPatch enddo !fusing patch endif !current patch exists. - if(found_fusion_patch.eq.itrue)then - currentPatch => fusingPatch - endif + endif ! not youngest, or is very small patch endif !nocomp @@ -2716,15 +2718,19 @@ subroutine terminate_patches(currentSite) if(currentPatch%area > min_patch_area_forced)then currentPatch => oldercPatch + count_cycles = 0 else count_cycles = count_cycles + 1 + write(*,*) 'iterate count cycles',count_cycles end if -! write(*,*) 'currentPatch2',currentPatch%patchno,currentPatch%nocomp_pft_label + if(associated(oldercPatch))then + write(*,*) 'currentPatch2',currentPatch%patchno,oldercPatch%patchno + endif if(count_cycles > max_cycles) then if(is_oldest.eq.itrue.and.is_youngest.eq.itrue.and.hlm_use_fixed_biogeog)then - write(fates_log(),*) 'this is the only patch of this PFT' + write(fates_log(),*) 'this is the only patch of this PFT',currentPatch%area currentPatch => currentPatch%older count_cycles = 0 else !not the only patch diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index b1efc0d3d4..2a4af75290 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -304,10 +304,23 @@ subroutine set_site_properties( nsites, sites,bc_in ) ! re-normalize PFT area to ensure it sums to one. ! note that in areas of 'bare ground' (PFT 0 in CLM/ELM) ! the bare ground will no longer be proscribed and should emerge from FATES + + do ft = 1,numpft + if(sites(s)%area_pft(ft).lt.0.01_r8)then + sites(s)%area_pft(ft)=0.0_r8 !remove tiny patches to prevent numerical errors. +! write(*,*) 'removing small pft patches',s,sites(s)%area_pft(1:12) + endif + end do + sumarea = sum(sites(s)%area_pft(1:numpft)) do ft = 1,numpft + if(sumarea.gt.0._r8)then sites(s)%area_pft(ft) = sites(s)%area_pft(ft)/sumarea - end do + else + sites(s)%area_pft(ft)= 1.0_r8/numpft + write(*,*) 'setting totally bare patch to all pfts.',s,sumarea,sites(s)%area_pft(ft) + end if + end do !ft end if do ft = 1,numpft From 9ad82a7ed1fa64687a288b0aa0f7c77a6ab0c994 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Fri, 22 May 2020 08:06:10 -0600 Subject: [PATCH 020/209] added filter to init cohorts --- biogeochem/EDPatchDynamicsMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 146c5a30fa..b4ee32e379 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -2573,7 +2573,7 @@ subroutine terminate_patches(currentSite) oldercpatch => currentPatch%older if(currentPatch%area <= min_patch_area)then - if(hlm_use_fixed_biogeog.eq.ifalse)then !just fuse to older or younger cohort. + if(hlm_use_nocomp.eq.ifalse)then !just fuse to older or younger patch ! 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 From ba0aca67b21f0be99b2f9650215616f9f24345c2 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 25 May 2020 08:04:14 -0600 Subject: [PATCH 021/209] fixed memory leak. removed write statements --- biogeochem/EDPatchDynamicsMod.F90 | 80 +++---------------------------- 1 file changed, 7 insertions(+), 73 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index b4ee32e379..d77791d218 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -103,7 +103,7 @@ module EDPatchDynamicsMod character(len=*), parameter, private :: sourcefile = & __FILE__ - logical, parameter :: debug = .true. + logical, parameter :: debug = .false. ! When creating new patches from other patches, we need to send some of the ! litter from the old patch to the new patch. Likewise, when plants die @@ -399,8 +399,6 @@ subroutine spawn_patches( currentSite, bc_in) 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) :: patch_site_areadis ! total area disturbed in m2 per patch per day - real(r8) :: site_areadis_primary_pft(numpft) ! primary area disturbed per PFT in nocomp mode. m2/patch/day - real(r8) :: site_areadis_secondary_pft(numpft) ! secondary area disturbed per PFT in nocomp mode. m2/patch/day real(r8) :: age ! notional age of this patch in years integer :: el ! element loop index integer :: tnull ! is there a tallest cohort? @@ -422,11 +420,7 @@ subroutine spawn_patches( currentSite, bc_in) real(r8) :: areadis_secondary !--------------------------------------------------------------------- - ! Allocate PFT arrays of patches to form the new patches in nocomp mode. - if(hlm_use_nocomp.eq.itrue)then - allocate(new_patch_primary_pft(numpft)) - allocate(new_patch_secondary_pft(numpft)) - endif + storesmallcohort => null() ! storage of the smallest cohort for insertion routine storebigcohort => null() ! storage of the largest cohort for insertion routine @@ -483,7 +477,6 @@ subroutine spawn_patches( currentSite, bc_in) currentPatch => currentPatch%older enddo ! end loop over patches. sum area disturbed for all patches. - write(*,*) 'areadis', site_areadis_primary_pft(1:12) ! It is possible that no disturbance area was generated if ( (site_areadis_primary + site_areadis_secondary) > nearzero) then @@ -617,7 +610,7 @@ subroutine spawn_patches( currentSite, bc_in) if(currentPatch%disturbance_mode .ne. dtype_ifire) then currentPatch%burnt_frac_litter(:) = 0._r8 end if - write(*,*) 'patch site areadis',patch_site_areadis,new_patch%area,nocomp_pft,currentPatch%disturbance_rate + call TransLitterNewPatch( currentSite, currentPatch, new_patch, patch_site_areadis) ! Transfer in litter fluxes from plants in various contexts of death and destruction @@ -1112,17 +1105,7 @@ subroutine spawn_patches( currentSite, bc_in) call check_patch_area(currentSite) call set_patchno(currentSite) - currentpatch => currentSite%youngest_patch - do while(associated(currentpatch)) - if(associated(currentpatch%younger))then -! write(*,*) 'sp check cpy',currentpatch%younger%patchno,currentpatch%younger%nocomp_pft_label,& -!currentpatch%younger%area - endif -! write(*,*) 'sp patch list',currentpatch%patchno,currentpatch%nocomp_pft_label,currentpatch%area - currentpatch => currentpatch%older - - enddo - +! write(*,*) 'end spawn patches',currentsite%lat, currentSite%lon return end subroutine spawn_patches @@ -2342,16 +2325,6 @@ subroutine fuse_patches( csite, bc_in ) end do ! i_disttype loop - currentpatch => currentSite%youngest_patch - do while(associated(currentpatch)) - if(associated(currentpatch%younger))then -! write(*,*) 'fp check cpy',currentpatch%younger%patchno,currentpatch%younger%nocomp_pft_label,& -!currentpatch%younger%area - endif -! write(*,*) 'fp patch list',currentpatch%patchno,currentpatch%nocomp_pft_label,currentpatch%area - currentpatch => currentpatch%older - enddo - end subroutine fuse_patches ! ============================================================================ @@ -2490,7 +2463,6 @@ subroutine fuse_2_patches(csite, dp, rp) ! We have no need for the dp pointer anymore, we have passed on it's legacy call dealloc_patch(dp) - write(*,*) 'deallocating2' ,dp%nocomp_pft_label, rp%nocomp_pft_label, dp%patchno, rp%patchno deallocate(dp) @@ -2549,27 +2521,10 @@ subroutine terminate_patches(currentSite) !--------------------------------------------------------------------- count_cycles = 0 -write(*,*) 'start terminate patches',currentSite%lat,currentSite%lon - - currentpatch => currentSite%youngest_patch - do while(associated(currentpatch)) -! write(*,*) 'tp o-y patch list',currentpatch%patchno,currentpatch%nocomp_pft_label,currentpatch%area - currentpatch => currentpatch%older - enddo - - currentpatch => currentSite%oldest_patch - do while(associated(currentpatch)) - write(*,*) 'tp y-o patch list',currentpatch%patchno,currentpatch%nocomp_pft_label,currentpatch%area - currentpatch => currentpatch%younger - enddo - - - - +!write(*,*) 'start terminate patches',currentSite%lat,currentSite%lon currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) - write(*,*) 'currentPatch1',currentPatch%patchno,currentPatch%nocomp_pft_label oldercpatch => currentPatch%older if(currentPatch%area <= min_patch_area)then @@ -2652,7 +2607,6 @@ subroutine terminate_patches(currentSite) enddo !fusing patch if (is_youngest.eq.ifalse .or. currentPatch%area <= min_patch_area_forced ) then - write(*,*) 'current patch is termination candidate',currentPatch%area found_fusion_patch = ifalse fusingPatch => currentPatch%older @@ -2671,8 +2625,7 @@ subroutine terminate_patches(currentSite) currentPatch%patchno, fusingPatch%patchno call fuse_2_patches(currentSite, currentPatch, fusingPatch) currentPatch => fusingPatch !redirect rest of main loop back to this cp - write(*,*) 'reverting curent patch to ', currentPatch%patchno - found_fusion_patch=itrue + found_fusion_patch=itrue endif ! PFT fusingPatch => olderPatch enddo !fusing patch @@ -2681,10 +2634,6 @@ subroutine terminate_patches(currentSite) ! if no older patches, search younger ones. fusingPatch => currentPatch%younger do while(associated(fusingPatch).and.found_fusion_patch.eq.ifalse ) - - if(fusingPatch%patchno.eq.currentPatch%younger%patchno)then - write(*,*) 'something weird with younger pointer here',fusingPatch%patchno,fusingPatch%nocomp_pft_label - end if olderPatch => fusingPatch%older if(fusingPatch%nocomp_pft_label.eq.currentPatch%nocomp_pft_label)then @@ -2722,11 +2671,7 @@ subroutine terminate_patches(currentSite) count_cycles = 0 else count_cycles = count_cycles + 1 - write(*,*) 'iterate count cycles',count_cycles end if - if(associated(oldercPatch))then - write(*,*) 'currentPatch2',currentPatch%patchno,oldercPatch%patchno - endif if(count_cycles > max_cycles) then if(is_oldest.eq.itrue.and.is_youngest.eq.itrue.and.hlm_use_fixed_biogeog)then @@ -2757,23 +2702,12 @@ subroutine terminate_patches(currentSite) !n.b. could put filter in here for actual terminations to save time. fusingpatch => currentSite%oldest_patch - write(*,*) 'tp end list' - do while(associated(fusingpatch)) - write(*,*) 'tp end y-o patch list',fusingpatch%patchno,fusingpatch%nocomp_pft_label,fusingpatch%area - - if(associated(fusingpatch%younger))then - if(fusingpatch%patchno.eq.fusingpatch%younger%patchno)then - write(*,*) 'patch list error',fusingpatch%patchno,fusingpatch%younger%patchno - endif - endif - fusingpatch => fusingpatch%younger - enddo enddo ! current patch loop !check area is not exceeded call check_patch_area( currentSite ) - write(*,*) 'leaving terminate patches',currentSite%lat,currentSite%lon +! write(*,*) 'leaving terminate patches',currentSite%lat,currentSite%lon return end subroutine terminate_patches From 7dda68f86cd745f91ab017d166129084196e95b1 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 25 May 2020 08:05:45 -0600 Subject: [PATCH 022/209] changes to make one pft per patch --- main/EDInitMod.F90 | 32 ++++++++++++++++++++++++++++++-- 1 file changed, 30 insertions(+), 2 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 2a4af75290..9ef3e0327a 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -554,6 +554,7 @@ subroutine init_cohorts( site_in, patch_in, bc_in) integer :: iage ! index for leaf age loop integer :: el ! index for element loop integer :: element_id ! element index consistent with defs in PRTGeneric + integer :: use_pft_local(numpft) ! determine whether this PFT is used for this patch and site. real(r8) :: c_agw ! biomass above ground (non-leaf) [kgC] real(r8) :: c_bgw ! biomass below ground (non-fineroot) [kgC] real(r8) :: c_leaf ! biomass in leaves [kgC] @@ -576,9 +577,36 @@ subroutine init_cohorts( site_in, patch_in, bc_in) patch_in%tallest => null() patch_in%shortest => null() - + + ! Manage interactions of ixed biogeg (site level filter) and + ! nocomp (patch level filter) + ! Need to cover all potential biogeog x nocomp combinations + ! 1. biogeog = false. nocomp = false: all PFTs on (DEFAULT) + ! 2. biogeog = true. nocomp = false: site level filter + ! 3. biogeog = false. nocomp = true : patch level filter + ! 4. biogeog = true. nocomp = true : patch and site level filter + ! in principle this could be a patch level variable. + do pft = 1,numpft + ! Turn every PFT ON, unless we are in a special case. + use_pft_local(pft) = itrue ! Case 1 + if(hlm_use_fixed_biogeog.eq.itrue)then !filter geographically + use_pft_local(pft) = site_in%use_this_pft(pft) ! Case 2 + if(hlm_use_nocomp.eq.itrue.and.pft.ne.patch_in%nocomp_pft_label)then + ! Having set the biogeog filter as on or off, turn off all patches + ! whose identiy does not correspond to this PFT. + use_pft_local(pft) = ifalse ! Case 3 + endif + else + if(hlm_use_nocomp.eq.itrue.and.pft.ne.patch_in%nocomp_pft_label)then + ! This case has all PFTs on their own patch everywhere. + use_pft_local(pft) = ifalse ! Case 4 + endif + endif + + end do + do pft = 1,numpft - if(site_in%use_this_pft(pft).eq.itrue)then + if(use_pft_local(pft).eq.itrue)then if(EDPftvarcon_inst%initd(pft)>1.0E-7) then allocate(temp_cohort) ! temporary cohort From 5dcef9f01cf2cb8a5711a2ffd54faf96009e1d3a Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 26 May 2020 03:15:31 -0600 Subject: [PATCH 023/209] turning off patch dynamics allows nocomp to run --- main/EDMainMod.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 1b520e56c3..41bd085d85 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -1,4 +1,3 @@ - module EDMainMod ! =========================================================================== @@ -19,6 +18,7 @@ module EDMainMod use FatesInterfaceMod , only : hlm_reference_date use FatesInterfaceMod , only : hlm_use_ed_prescribed_phys use FatesInterfaceMod , only : hlm_use_ed_st3 + use FatesInterfaceMod , only : hlm_use_nocomp use FatesInterfaceMod , only : bc_in_type use FatesInterfaceMod , only : hlm_masterproc use FatesInterfaceMod , only : numpft @@ -241,14 +241,14 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) !********************************************************************************* ! make new patches from disturbed land - if ( hlm_use_ed_st3.eq.ifalse ) then + if ( hlm_use_ed_st3.eq.ifalse.or.hlm_use_nocomp.eq.ifalse) then call spawn_patches(currentSite, bc_in) end if call TotalBalanceCheck(currentSite,3) ! fuse on the spawned patches. - if ( hlm_use_ed_st3.eq.ifalse ) then + if ( hlm_use_ed_st3.eq.ifalse.or.hlm_use_nocomp.eq.ifalse ) then call fuse_patches(currentSite, bc_in ) ! If using BC FATES hydraulics, update the rhizosphere geometry @@ -268,7 +268,7 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) call TotalBalanceCheck(currentSite,4) ! kill patches that are too small - if ( hlm_use_ed_st3.eq.ifalse ) then + if ( hlm_use_ed_st3.eq.ifalse .or.hlm_use_nocomp.eq.ifalse) then call terminate_patches(currentSite) end if From 1e1f013b247dcc157be945bd07c192318db9e5e0 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 26 May 2020 03:16:18 -0600 Subject: [PATCH 024/209] fixing error in spawn_patches --- biogeochem/EDPatchDynamicsMod.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index d77791d218..fc9791ee8c 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -389,8 +389,6 @@ subroutine spawn_patches( currentSite, bc_in) type (ed_patch_type) , pointer :: new_patch type (ed_patch_type) , pointer :: new_patch_primary type (ed_patch_type) , pointer :: new_patch_secondary - type (ed_patch_type) , pointer :: new_patch_primary_pft(:) - type (ed_patch_type) , pointer :: new_patch_secondary_pft(:) type (ed_patch_type) , pointer :: currentPatch type (ed_cohort_type), pointer :: currentCohort type (ed_cohort_type), pointer :: nc @@ -398,6 +396,8 @@ subroutine spawn_patches( currentSite, bc_in) type (ed_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_primary_pft(numpft) + real(r8) :: site_areadis_secondary_pft(numpft) real(r8) :: patch_site_areadis ! total area disturbed in m2 per patch per day real(r8) :: age ! notional age of this patch in years integer :: el ! element loop index From 630d571fa7a39c759418dca994281ad5434082cc Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 26 May 2020 04:45:38 -0600 Subject: [PATCH 025/209] initial go at converstion matrix. Hard wired, e dimensional --- main/EDInitMod.F90 | 40 +++++++++++++++++++++++++++++++++------- 1 file changed, 33 insertions(+), 7 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 9ef3e0327a..7d09c7c240 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -253,6 +253,9 @@ subroutine set_site_properties( nsites, sites,bc_in ) integer :: dleafon ! DOY for drought-decid leaf-on, initial guess integer :: ft ! PFT loop real(r8) :: sumarea ! area of PFTs in nocomp mode. + real(r8) :: hlm_to_fates_pft_map(12) !this should ultimately come from the HLM? + integer :: hlm_pft ! used in fixed biogeog mode + integer :: fates_pft ! used in fixed biogeog mode !---------------------------------------------------------------------- @@ -296,19 +299,42 @@ subroutine set_site_properties( nsites, sites,bc_in ) sites(s)%NF = 0.0_r8 sites(s)%frac_burnt = 0.0_r8 - ! PLACEHOLDER FOR PFT AREA DATA MOVED ACROSS INTERFACE - if(hlm_use_fixed_biogeog.eq.itrue)then - do ft = 1,numpft - sites(s)%area_pft(ft) = bc_in(s)%pft_areafrac(ft) - end do + + if(hlm_use_fixed_biogeog.eq.itrue)then + ! MAPPING OF FATES PFTs on to HLM_PFTs + ! in this first instance, we assume that there & + ! are fewer FATES PFTs than HLM PFTs + + ! PLACEHOLDER FOR NEW FATES PARAMETER. This will always have to be 12 digits long. + hlm_to_fates_pft_map(1) = 1 + hlm_to_fates_pft_map(2) = 1 + hlm_to_fates_pft_map(3) = 2 + hlm_to_fates_pft_map(4) = 2 + hlm_to_fates_pft_map(5) = 3 + hlm_to_fates_pft_map(6) = 3 + hlm_to_fates_pft_map(7) = 4 + hlm_to_fates_pft_map(8) = 4 + hlm_to_fates_pft_map(9) = 5 + hlm_to_fates_pft_map(10) = 5 + hlm_to_fates_pft_map(11) = 6 + hlm_to_fates_pft_map(12) = 6 + + ! assuming here there are 12 pfts on the surface dataset and 6 on fates pft file + ! add up the area associated with each FATES PFT + sites(s)%area_pft(1:numpft) = 0._r8 + do hlm_pft = 1,12 + fates_pft = hlm_to_fates_pft_map(hlm_pft) + sites(s)%area_pft(fates_pft) = sites(s)%area_pft(fates_pft) + bc_in(s)%pft_areafrac(hlm_pft) + end do !hlm_pft + ! re-normalize PFT area to ensure it sums to one. ! note that in areas of 'bare ground' (PFT 0 in CLM/ELM) ! the bare ground will no longer be proscribed and should emerge from FATES do ft = 1,numpft if(sites(s)%area_pft(ft).lt.0.01_r8)then - sites(s)%area_pft(ft)=0.0_r8 !remove tiny patches to prevent numerical errors. -! write(*,*) 'removing small pft patches',s,sites(s)%area_pft(1:12) + sites(s)%area_pft(ft)=0.0_r8 !remove tiny patches to prevent numerical errors in terminate patches + write(*,*) 'removing small pft patches',sites(s)%lon,sites(s)%lat,ft,sites(s)%area_pft(ft) endif end do From 1e4d30c0bf75efd6389b5236950b24f8dd3149df Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 26 May 2020 07:01:11 -0600 Subject: [PATCH 026/209] fixing patch dynamics bug in EDmain --- main/EDMainMod.F90 | 15 +++++++++++---- 1 file changed, 11 insertions(+), 4 deletions(-) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 41bd085d85..b8c0c6b8f2 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -130,7 +130,7 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) ! !LOCAL VARIABLES: type(ed_patch_type), pointer :: currentPatch integer :: el ! Loop counter for elements - + integer :: do_patch_dynamics ! for some modes, we turn off patch dynamics !----------------------------------------------------------------------- if ( hlm_masterproc==itrue ) write(fates_log(),'(A,I4,A,I2.2,A,I2.2)') 'FATES Dynamics: ',& @@ -240,15 +240,22 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) ! Patch dynamics sub-routines: fusion, new patch creation (spwaning), termination. !********************************************************************************* + do_patch_dynamics = itrue + if(hlm_use_ed_st3.eq.ifalse)then + do_patch_dynamics = ifalse + end if + if(hlm_use_nocomp.eq.itrue)then + do_patch_dynamics = ifalse + end if ! make new patches from disturbed land - if ( hlm_use_ed_st3.eq.ifalse.or.hlm_use_nocomp.eq.ifalse) then + if (do_patch_dynamics.eq.itrue ) then call spawn_patches(currentSite, bc_in) end if call TotalBalanceCheck(currentSite,3) ! fuse on the spawned patches. - if ( hlm_use_ed_st3.eq.ifalse.or.hlm_use_nocomp.eq.ifalse ) then + if ( do_patch_dynamics.eq.itrue ) then call fuse_patches(currentSite, bc_in ) ! If using BC FATES hydraulics, update the rhizosphere geometry @@ -268,7 +275,7 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) call TotalBalanceCheck(currentSite,4) ! kill patches that are too small - if ( hlm_use_ed_st3.eq.ifalse .or.hlm_use_nocomp.eq.ifalse) then + if ( do_patch_dynamics.eq.itrue ) then call terminate_patches(currentSite) end if From 2ee7316d54ef0dc25a6b9cd3d8f3a85abdb90a43 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 27 May 2020 02:49:14 -0600 Subject: [PATCH 027/209] fixing erroneous error check --- biogeochem/EDPatchDynamicsMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index fc9791ee8c..7a8282eda1 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -2674,7 +2674,7 @@ subroutine terminate_patches(currentSite) end if if(count_cycles > max_cycles) then - if(is_oldest.eq.itrue.and.is_youngest.eq.itrue.and.hlm_use_fixed_biogeog)then + if(is_oldest.eq.itrue.and.is_youngest.eq.itrue.and.hlm_use_nocomp)then write(fates_log(),*) 'this is the only patch of this PFT',currentPatch%area currentPatch => currentPatch%older count_cycles = 0 From aa620f91139ea757bae38395c27315148315564b Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 27 May 2020 02:55:51 -0600 Subject: [PATCH 028/209] 2D pft mapping array --- main/EDInitMod.F90 | 46 ++++++++++++++++++++++++++++++---------------- 1 file changed, 30 insertions(+), 16 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 7d09c7c240..cc736fac2b 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -253,7 +253,7 @@ subroutine set_site_properties( nsites, sites,bc_in ) integer :: dleafon ! DOY for drought-decid leaf-on, initial guess integer :: ft ! PFT loop real(r8) :: sumarea ! area of PFTs in nocomp mode. - real(r8) :: hlm_to_fates_pft_map(12) !this should ultimately come from the HLM? + real(r8) :: hlm_to_fates_pft_map(12,numpft) !this should ultimately come from the HLM? integer :: hlm_pft ! used in fixed biogeog mode integer :: fates_pft ! used in fixed biogeog mode !---------------------------------------------------------------------- @@ -306,25 +306,31 @@ subroutine set_site_properties( nsites, sites,bc_in ) ! are fewer FATES PFTs than HLM PFTs ! PLACEHOLDER FOR NEW FATES PARAMETER. This will always have to be 12 digits long. - hlm_to_fates_pft_map(1) = 1 - hlm_to_fates_pft_map(2) = 1 - hlm_to_fates_pft_map(3) = 2 - hlm_to_fates_pft_map(4) = 2 - hlm_to_fates_pft_map(5) = 3 - hlm_to_fates_pft_map(6) = 3 - hlm_to_fates_pft_map(7) = 4 - hlm_to_fates_pft_map(8) = 4 - hlm_to_fates_pft_map(9) = 5 - hlm_to_fates_pft_map(10) = 5 - hlm_to_fates_pft_map(11) = 6 - hlm_to_fates_pft_map(12) = 6 + ! protocol is (hlm_pft,fates_pft) + hlm_to_fates_pft_map(1:12,1:numpft)=0._r8 + !this is the fraction that is associated with each fates pft of a given hlm area + !each HLM row neds to sum to one... + hlm_to_fates_pft_map(1,1) = 1 + hlm_to_fates_pft_map(2,1) = 1 + hlm_to_fates_pft_map(3,2) = 1 + hlm_to_fates_pft_map(4,2) = 1 + hlm_to_fates_pft_map(5,3) = 1 + hlm_to_fates_pft_map(6,3) = 1 + hlm_to_fates_pft_map(7,4) = 1 + hlm_to_fates_pft_map(8,4) = 1 + hlm_to_fates_pft_map(9,5) = 1 + hlm_to_fates_pft_map(10,5) = 1 + hlm_to_fates_pft_map(11,6) = 1 + hlm_to_fates_pft_map(12,6) = 1 ! assuming here there are 12 pfts on the surface dataset and 6 on fates pft file ! add up the area associated with each FATES PFT sites(s)%area_pft(1:numpft) = 0._r8 - do hlm_pft = 1,12 - fates_pft = hlm_to_fates_pft_map(hlm_pft) - sites(s)%area_pft(fates_pft) = sites(s)%area_pft(fates_pft) + bc_in(s)%pft_areafrac(hlm_pft) + do hlm_pft = 1,12 + do fates_pft = 1,numpft ! loop round all fates pfts for all hlm pfts + sites(s)%area_pft(fates_pft) = sites(s)%area_pft(fates_pft) + & + hlm_to_fates_pft_map(hlm_pft,fates_pft) * bc_in(s)%pft_areafrac(hlm_pft) + end do end do !hlm_pft ! re-normalize PFT area to ensure it sums to one. @@ -639,6 +645,14 @@ subroutine init_cohorts( site_in, patch_in, bc_in) temp_cohort%pft = pft temp_cohort%n = EDPftvarcon_inst%initd(pft) * patch_in%area + if(hlm_use_nocomp.eq.itrue)then !in nocomp mode we only have one PFT per patch + ! as opposed to numpft's. So we should up the initial density + ! to compensate (otherwise runs are very hard to compare) + ! this multiplies it by the number of PFTs there would have been in + ! the single shared patch in competition mode. + temp_cohort%n = temp_cohort%n * sum(site_in%use_this_pft) + endif + temp_cohort%hite = EDPftvarcon_inst%hgt_min(pft) From a69ac89051a57b55f453d079a01550f3ea661d76 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 27 May 2020 07:53:43 -0600 Subject: [PATCH 029/209] implement new hlm_pft_map 2D parameter --- main/EDPftvarcon.F90 | 26 ++++++++++++++++++++++---- main/FatesParametersInterface.F90 | 1 + 2 files changed, 23 insertions(+), 4 deletions(-) diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index b4654f2c13..b6c74ffb8d 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -293,7 +293,10 @@ module EDPftvarcon real(r8), allocatable :: hydr_fcap_node(:,:) ! fraction of (1-resid_node) that is capillary in source real(r8), allocatable :: hydr_pinot_node(:,:) ! osmotic potential at full turgor real(r8), allocatable :: hydr_kmax_node(:,:) ! maximum xylem conductivity per unit conducting xylem area - + + ! fixed biogeog mode parameter(s) + real(r8), allocatable :: hlm_pft_map(:,:) ! Mapping from HLM PFTs to FATES PFTs in fixed biogeog mode. + contains procedure, public :: Init => EDpftconInit procedure, public :: Register @@ -352,7 +355,7 @@ subroutine Register(this, fates_params) call this%Register_PFT_hydr_organs(fates_params) call this%Register_PFT_prt_organs(fates_params) call this%Register_PFT_leafage(fates_params) - + end subroutine Register !----------------------------------------------------------------------- @@ -379,6 +382,7 @@ subroutine Register_PFT(this, fates_params) use FatesParametersInterface, only : fates_parameters_type, param_string_length use FatesParametersInterface, only : dimension_name_pft, dimension_shape_1d + use FatesParametersInterface, only : dimension_name_hlm_pftno, dimension_shape_2d implicit none @@ -386,6 +390,7 @@ subroutine Register_PFT(this, fates_params) class(fates_parameters_type), intent(inout) :: fates_params character(len=param_string_length), parameter :: dim_names(1) = (/dimension_name_pft/) + character(len=param_string_length) :: pftmap_dim_names(2) integer, parameter :: dim_lower_bound(1) = (/ lower_bound_pft /) @@ -893,7 +898,13 @@ subroutine Register_PFT(this, fates_params) name = 'fates_prescribed_puptake' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - + + pftmap_dim_names(1) = dimension_name_pft + pftmap_dim_names(2) = dimension_name_hlm_pftno + + name = 'fates_hlm_pft_map' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & dimension_names=pftmap_dim_names, lower_bounds=dim_lower_bound) + end subroutine Register_PFT !----------------------------------------------------------------------- @@ -1417,6 +1428,9 @@ subroutine Receive_PFT(this, fates_params) call fates_params%RetreiveParameterAllocate(name=name, & data=this%prescribed_puptake) + name = 'fates_hlm_pft_map' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%hlm_pft_map) end subroutine Receive_PFT @@ -1670,6 +1684,9 @@ subroutine Register_PFT_leafage(this, fates_params) return end subroutine Register_PFT_leafage + + + ! ===================================================================================== subroutine Receive_PFT_leafage(this, fates_params) @@ -2055,7 +2072,6 @@ subroutine FatesReportPFTParams(is_master) write(fates_log(),fmt0) 'hydr_pinot_node = ',EDPftvarcon_inst%hydr_pinot_node write(fates_log(),fmt0) 'hydr_kmax_node = ',EDPftvarcon_inst%hydr_kmax_node - write(fates_log(),fmt0) 'prt_nitr_stoich_p1 = ',EDPftvarcon_inst%prt_nitr_stoich_p1 write(fates_log(),fmt0) 'prt_nitr_stoich_p2 = ',EDPftvarcon_inst%prt_nitr_stoich_p2 write(fates_log(),fmt0) 'prt_phos_stoich_p1 = ',EDPftvarcon_inst%prt_phos_stoich_p1 @@ -2067,6 +2083,8 @@ subroutine FatesReportPFTParams(is_master) write(fates_log(),fmt0) 'turnover_nitr_retrans = ',EDPftvarcon_inst%turnover_nitr_retrans write(fates_log(),fmt0) 'turnover_phos_retrans = ',EDPftvarcon_inst%turnover_phos_retrans + write(fates_log(),fmt0) 'hlm_pft_map = ', EDPftvarcon_inst%hlm_pft_map + write(fates_log(),*) '-------------------------------------------------' end if diff --git a/main/FatesParametersInterface.F90 b/main/FatesParametersInterface.F90 index ebaad3fa7c..f69d4ef5bf 100644 --- a/main/FatesParametersInterface.F90 +++ b/main/FatesParametersInterface.F90 @@ -35,6 +35,7 @@ module FatesParametersInterface character(len=*), parameter, public :: dimension_name_history_age_bins = 'fates_history_age_bins' character(len=*), parameter, public :: dimension_name_history_height_bins = 'fates_history_height_bins' character(len=*), parameter, public :: dimension_name_history_coage_bins = 'fates_history_coage_bins' + character(len=*), parameter, public :: dimension_name_hlm_pftno = 'fates_hlm_pftno' ! Dimensions in the host namespace: character(len=*), parameter, public :: dimension_name_host_allpfts = 'allpfts' From 6927dec561b6d9b639854155ca7c6e5c98131800 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 27 May 2020 08:34:25 -0600 Subject: [PATCH 030/209] adding usage of hlm_pft_map --- main/EDInitMod.F90 | 25 +------------------------ 1 file changed, 1 insertion(+), 24 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index cc736fac2b..e48127d2fb 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -253,7 +253,6 @@ subroutine set_site_properties( nsites, sites,bc_in ) integer :: dleafon ! DOY for drought-decid leaf-on, initial guess integer :: ft ! PFT loop real(r8) :: sumarea ! area of PFTs in nocomp mode. - real(r8) :: hlm_to_fates_pft_map(12,numpft) !this should ultimately come from the HLM? integer :: hlm_pft ! used in fixed biogeog mode integer :: fates_pft ! used in fixed biogeog mode !---------------------------------------------------------------------- @@ -302,34 +301,12 @@ subroutine set_site_properties( nsites, sites,bc_in ) if(hlm_use_fixed_biogeog.eq.itrue)then ! MAPPING OF FATES PFTs on to HLM_PFTs - ! in this first instance, we assume that there & - ! are fewer FATES PFTs than HLM PFTs - - ! PLACEHOLDER FOR NEW FATES PARAMETER. This will always have to be 12 digits long. - ! protocol is (hlm_pft,fates_pft) - hlm_to_fates_pft_map(1:12,1:numpft)=0._r8 - !this is the fraction that is associated with each fates pft of a given hlm area - !each HLM row neds to sum to one... - hlm_to_fates_pft_map(1,1) = 1 - hlm_to_fates_pft_map(2,1) = 1 - hlm_to_fates_pft_map(3,2) = 1 - hlm_to_fates_pft_map(4,2) = 1 - hlm_to_fates_pft_map(5,3) = 1 - hlm_to_fates_pft_map(6,3) = 1 - hlm_to_fates_pft_map(7,4) = 1 - hlm_to_fates_pft_map(8,4) = 1 - hlm_to_fates_pft_map(9,5) = 1 - hlm_to_fates_pft_map(10,5) = 1 - hlm_to_fates_pft_map(11,6) = 1 - hlm_to_fates_pft_map(12,6) = 1 - - ! assuming here there are 12 pfts on the surface dataset and 6 on fates pft file ! add up the area associated with each FATES PFT sites(s)%area_pft(1:numpft) = 0._r8 do hlm_pft = 1,12 do fates_pft = 1,numpft ! loop round all fates pfts for all hlm pfts sites(s)%area_pft(fates_pft) = sites(s)%area_pft(fates_pft) + & - hlm_to_fates_pft_map(hlm_pft,fates_pft) * bc_in(s)%pft_areafrac(hlm_pft) + EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft) * bc_in(s)%pft_areafrac(hlm_pft) end do end do !hlm_pft From f0170fd2834a1db26d83df0b9d0e3b0c9e3adcb5 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 27 May 2020 09:05:14 -0600 Subject: [PATCH 031/209] added default values for hlm_pft_map to the parameter file --- parameter_files/fates_params_default.cdl | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index 067ca4155f..be4d4aed7c 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -12,6 +12,8 @@ dimensions: fates_prt_organs = 6 ; fates_string_length = 60 ; fates_variants = 2 ; + fates_hlm_pftno = 12 ; + variables: double fates_history_ageclass_bin_edges(fates_history_age_bins) ; fates_history_ageclass_bin_edges:units = "yr" ; @@ -495,6 +497,9 @@ variables: double fates_z0mr(fates_pft) ; fates_z0mr:units = "unitless" ; fates_z0mr:long_name = "Ratio of momentum roughness length to canopy top height" ; + double fates_hlm_pft_map(fates_hlm_pftno, fates_pft) ; + fates_hlm_pft_map:units = "area fraction" ; + fates_hlm_pft_map:long_name = "In fixed biogeog mode, fraction of HLM area associated with each FATES PFT" ; double fates_fire_FBD(fates_litterclass) ; fates_fire_FBD:units = "NA" ; fates_fire_FBD:long_name = "spitfire parameter related to fuel bulk density, see SFMain.F90" ; @@ -1206,6 +1211,22 @@ data: fates_z0mr = 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055 ; + fates_hlm_pft_map = + 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, 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, 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, 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 ; From ea3c635d00e7b3863b69d75ffb555c7617eb8f93 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 3 Jun 2020 07:44:03 -0600 Subject: [PATCH 032/209] modify EDINIT to allow HLM_pftno from parameter file to dictate initialization pft number and remove hardwiring --- main/EDInitMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index e48127d2fb..41606efd0c 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -303,7 +303,7 @@ subroutine set_site_properties( nsites, sites,bc_in ) ! MAPPING OF FATES PFTs on to HLM_PFTs ! add up the area associated with each FATES PFT sites(s)%area_pft(1:numpft) = 0._r8 - do hlm_pft = 1,12 + do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) do fates_pft = 1,numpft ! loop round all fates pfts for all hlm pfts sites(s)%area_pft(fates_pft) = sites(s)%area_pft(fates_pft) + & EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft) * bc_in(s)%pft_areafrac(hlm_pft) From f7e876dd06c153d3254bbd0a33cc17a0983af02c Mon Sep 17 00:00:00 2001 From: rosiealice Date: Fri, 10 Jul 2020 03:37:30 -0600 Subject: [PATCH 033/209] reverting spawn patches back to master and therefore removing all the changes that enable multiple patches but cause memory leak --- biogeochem/EDPatchDynamicsMod.F90 | 148 +++++++++--------------------- 1 file changed, 45 insertions(+), 103 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 7a8282eda1..4b4edd5344 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -358,8 +358,8 @@ subroutine disturbance_rates( site_in, bc_in) enddo !patch loop end subroutine disturbance_rates - - ! ============================================================================ + + ! ============================================================================ subroutine spawn_patches( currentSite, bc_in) ! ! !DESCRIPTION: @@ -396,8 +396,6 @@ subroutine spawn_patches( currentSite, bc_in) type (ed_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_primary_pft(numpft) - real(r8) :: site_areadis_secondary_pft(numpft) real(r8) :: patch_site_areadis ! total area disturbed in m2 per patch per day real(r8) :: age ! notional age of this patch in years integer :: el ! element loop index @@ -413,12 +411,6 @@ subroutine spawn_patches( currentSite, bc_in) real(r8) :: leaf_burn_frac ! fraction of leaves burned in fire ! for both woody and grass species real(r8) :: leaf_m ! leaf mass during partial burn calculations - integer :: rec_type ! records type of disturbance while in patch loop - integer :: nocomp_pft ! where nocomp mode is on, PFT label - integer :: numiter - real(r8) :: areadis_primary - real(r8) :: areadis_secondary - !--------------------------------------------------------------------- storesmallcohort => null() ! storage of the smallest cohort for insertion routine @@ -429,8 +421,6 @@ subroutine spawn_patches( currentSite, bc_in) site_areadis_primary = 0.0_r8 site_areadis_secondary = 0.0_r8 - site_areadis_primary_pft(1:numpft) = 0.0_r8 - site_areadis_secondary_pft(1:numpft) = 0.0_r8 do while(associated(currentPatch)) @@ -455,59 +445,30 @@ subroutine spawn_patches( currentSite, bc_in) ! donor patch is primary forest and the dominant disturbance type is not logging if ( currentPatch%anthro_disturbance_label .eq. primaryforest .and. & (currentPatch%disturbance_mode .ne. dtype_ilog) ) then - site_areadis_primary = site_areadis_primary + currentPatch%area * currentPatch%disturbance_rate - rec_type = primaryforest + + site_areadis_primary = site_areadis_primary + currentPatch%area * currentPatch%disturbance_rate else - site_areadis_secondary = site_areadis_secondary + currentPatch%area * currentPatch%disturbance_rate - rec_type = secondaryforest + site_areadis_secondary = site_areadis_secondary + currentPatch%area * currentPatch%disturbance_rate endif + + end if - ! accumulate PFT specific disturbance rates in nocomp mode - if(hlm_use_nocomp.eq.itrue)then - if(rec_type.eq.primaryforest)then - nocomp_pft = currentPatch%nocomp_pft_label - site_areadis_primary_pft(nocomp_pft) = site_areadis_primary_pft(nocomp_pft) & - + currentPatch%area * currentPatch%disturbance_rate - else - site_areadis_secondary_pft(nocomp_pft) = site_areadis_secondary_pft(nocomp_pft) & - + currentPatch%area * currentPatch%disturbance_rate - end if !rectype - end if !nocomp - end if !area currentPatch => currentPatch%older enddo ! end loop over patches. sum area disturbed for all patches. - ! It is possible that no disturbance area was generated + ! It is possible that no disturbance area was generated if ( (site_areadis_primary + site_areadis_secondary) > nearzero) then - - ! Do the entire patch creation loop around a PFT loop. - numiter = 1 - if(hlm_use_nocomp.eq.itrue)then - numiter = numpft - endif - - do nocomp_pft = 1,numiter + 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(hlm_use_nocomp.eq.ifalse)then - areadis_primary = site_areadis_primary - areadis_secondary = site_areadis_secondary - else - areadis_primary = site_areadis_primary_pft(nocomp_pft) - areadis_secondary = site_areadis_secondary_pft(nocomp_pft) - endif - if ( site_areadis_primary .gt. nearzero ) then allocate(new_patch_primary) - if(hlm_use_nocomp.eq.ifalse)then + call create_patch(currentSite, new_patch_primary, age, & - areadis_primary, primaryforest,1) - else - call create_patch(currentSite, new_patch_primary, age, & - areadis_primary, primaryforest,nocomp_pft) - endif + site_areadis_primary, primaryforest) + ! Initialize the litter pools to zero, these ! pools will be populated by looping over the existing patches ! and transfering in mass @@ -521,19 +482,16 @@ subroutine spawn_patches( currentSite, bc_in) end do new_patch_primary%tallest => null() new_patch_primary%shortest => null() - end if !primary + + endif ! next create patch to receive secondary forest area if ( site_areadis_secondary .gt. nearzero) then allocate(new_patch_secondary) - if(hlm_use_nocomp.eq.ifalse)then - call create_patch(currentSite, new_patch_secondary, age, & - areadis_secondary, secondaryforest,1) - else call create_patch(currentSite, new_patch_secondary, age, & - areadis_secondary, secondaryforest,nocomp_pft) - endif + site_areadis_secondary, secondaryforest) + ! Initialize the litter pools to zero, these ! pools will be populated by looping over the existing patches ! and transfering in mass @@ -547,7 +505,8 @@ subroutine spawn_patches( currentSite, bc_in) end do new_patch_secondary%tallest => null() new_patch_secondary%shortest => null() - endif !secondary + + 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 @@ -558,16 +517,9 @@ subroutine spawn_patches( currentSite, bc_in) do while(associated(currentPatch)) ! This is the amount of patch area that is disturbed, and donated by the donor - if(hlm_use_nocomp.eq.ifalse)then patch_site_areadis = currentPatch%area * currentPatch%disturbance_rate - else - if(currentPatch%nocomp_pft_label.eq.nocomp_pft)then - patch_site_areadis = currentPatch%area * currentPatch%disturbance_rate - else - patch_site_areadis = 0.0_r8 - endif - endif + if ( patch_site_areadis > nearzero ) then ! figure out whether the receiver patch for disturbance from this patch @@ -577,10 +529,8 @@ subroutine spawn_patches( currentSite, bc_in) if (currentPatch%anthro_disturbance_label .eq. primaryforest .and. & (currentPatch%disturbance_mode .ne. dtype_ilog)) then new_patch => new_patch_primary - rec_type = primaryforest else new_patch => new_patch_secondary - rec_type = secondaryforest endif if(.not.associated(new_patch))then @@ -1043,6 +993,11 @@ subroutine spawn_patches( currentSite, bc_in) end if ! if ( new_patch%area > nearzero ) then + !zero disturbance rate trackers + currentPatch%disturbance_rate = 0._r8 + currentPatch%disturbance_rates = 0._r8 + currentPatch%fract_ldist_not_harvested = 0._r8 + currentPatch => currentPatch%younger enddo ! currentPatch patch loop. @@ -1051,61 +1006,48 @@ subroutine spawn_patches( currentSite, bc_in) !** INSERT NEW PATCH(ES) INTO LINKED LIST !**********`***************/ - ! currentPatch is the youngest of the pre-existing patches. - !newpatch_primary_pft and newpatch_secondary_pft need to be added into the mix - - - if ( areadis_primary .gt. nearzero) then + if ( site_areadis_primary .gt. nearzero) then currentPatch => currentSite%youngest_patch new_patch_primary%older => currentPatch new_patch_primary%younger => null() currentPatch%younger => new_patch_primary currentSite%youngest_patch => new_patch_primary - endif + endif - if ( areadis_secondary .gt. nearzero) then + 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 - + 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) - if ( areadis_primary .gt. nearzero) then - call terminate_cohorts(currentSite, new_patch_primary, 1,17) - call fuse_cohorts(currentSite,new_patch_primary, bc_in) - call terminate_cohorts(currentSite, new_patch_primary, 2,17) - call sort_cohorts(new_patch_primary) - endif - - if ( areadis_secondary .gt. nearzero) then - call terminate_cohorts(currentSite, new_patch_secondary, 1,18) - call fuse_cohorts(currentSite,new_patch_secondary, bc_in) - call terminate_cohorts(currentSite, new_patch_secondary, 2,18) - call sort_cohorts(new_patch_secondary) - endif - - end do ! PFT loop for nocomp + if ( site_areadis_primary .gt. nearzero) then + call terminate_cohorts(currentSite, new_patch_primary, 1,17) + call fuse_cohorts(currentSite,new_patch_primary, bc_in) + call terminate_cohorts(currentSite, new_patch_primary, 2,17) + call sort_cohorts(new_patch_primary) + endif + + if ( site_areadis_secondary .gt. nearzero) then + call terminate_cohorts(currentSite, new_patch_secondary, 1,18) + call fuse_cohorts(currentSite,new_patch_secondary, bc_in) + call terminate_cohorts(currentSite, new_patch_secondary, 2,18) + call sort_cohorts(new_patch_secondary) + endif + endif !end new_patch area - currentpatch => currentSite%youngest_patch - do while(associated(currentpatch)) - !zero disturbance rate trackers - currentPatch%disturbance_rate = 0._r8 - currentPatch%disturbance_rates = 0._r8 - currentPatch%fract_ldist_not_harvested = 0._r8 - currentpatch => currentpatch%older - end do - + call check_patch_area(currentSite) call set_patchno(currentSite) -! write(*,*) 'end spawn patches',currentsite%lat, currentSite%lon return end subroutine spawn_patches From c4ae2986053a650078da61ddbdc1b2c7224d47a3 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 7 Sep 2020 11:36:40 +0200 Subject: [PATCH 034/209] comment in EDInit --- main/EDInitMod.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 2fd076c76f..c4b7d3915f 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -305,6 +305,8 @@ subroutine set_site_properties( nsites, sites,bc_in ) if(hlm_use_fixed_biogeog.eq.itrue)then ! MAPPING OF FATES PFTs on to HLM_PFTs ! add up the area associated with each FATES PFT + ! where pft_areafrac is the area of land in each HLM PFT and (from surface dataset) + ! hlm_pft_map is the area of that land in each FATES PFT (from param file) sites(s)%area_pft(1:numpft) = 0._r8 do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) do fates_pft = 1,numpft ! loop round all fates pfts for all hlm pfts From cceff87bae46db314ffe085177b03d9676aa3de3 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 7 Sep 2020 11:45:32 +0200 Subject: [PATCH 035/209] fixed apparent merge conflict in patch dynamics --- biogeochem/EDPatchDynamicsMod.F90 | 4 ---- 1 file changed, 4 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index f7e9eb562f..3e7e49ef37 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -2402,9 +2402,6 @@ subroutine fuse_patches( csite, bc_in ) enddo !do while nopatches>maxPatchesPerSite end do ! i_disttype loop -||||||| merged common ancestors - -======= currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) @@ -2419,7 +2416,6 @@ subroutine fuse_patches( csite, bc_in ) currentSite%primary_land_patchfusion_error = primary_land_fraction_afterfusion - primary_land_fraction_beforefusion ->>>>>>> charlie_repo/fates_harvest_offmaster end subroutine fuse_patches ! ============================================================================ From e0f348186766cf0b2579c8a63544290c843821e7 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 7 Sep 2020 11:58:42 +0200 Subject: [PATCH 036/209] modifications to write statements in EDInit --- main/EDInitMod.F90 | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index c4b7d3915f..37a4e5787c 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -511,7 +511,7 @@ subroutine init_patches( nsites, sites, bc_in) newp => sites(s)%oldest_patch do while (associated(newp)) tota=tota+newp%area - write(*,*) 'test links',s,newp%nocomp_pft_label,tota + if ( debug ) write(fates_log(),*) 'test links',s,newp%nocomp_pft_label,tota newp=>newp%younger end do if(abs(tota-area).gt.nearzero)then @@ -527,10 +527,9 @@ subroutine init_patches( nsites, sites, bc_in) end do call set_patchno(sites(s)) -! deallocate(recall_older_patch) +! deallocate(recall_older_patch) !leaving this as a potential fix for memory leak in multipatch nocomp mode enddo !s - write(*,*)'end init' end if ! This sets the rhizosphere shells based on the plant initialization From 312766e94d36dbe35411a10f1ebc13100c8d8a6f Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 7 Sep 2020 15:09:02 +0200 Subject: [PATCH 037/209] a few more comments and a small fix to merge conflicts --- biogeochem/EDPatchDynamicsMod.F90 | 4 ++-- main/EDMainMod.F90 | 3 +++ main/EDPftvarcon.F90 | 5 +++-- 3 files changed, 8 insertions(+), 4 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 3e7e49ef37..8f0e0a3027 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -2607,7 +2607,7 @@ subroutine terminate_patches(currentSite) type(ed_patch_type), pointer :: oldercPatch type(ed_patch_type), pointer :: youngerPatch type(ed_patch_type), pointer :: fusingPatch - integer, parameter :: max_cycles = 1<<<<0 ! After 10 loops through + integer, parameter :: max_cycles = 10 ! After 10 loops through ! You should had fused integer :: count_cycles integer :: is_youngest @@ -2683,7 +2683,7 @@ subroutine terminate_patches(currentSite) currentPatch%area youngerPatch => currentPatch%younger -<<<<<<< HEAD + if (currentPatch%anthro_disturbance_label .eq. youngerPatch% anthro_disturbance_label) then call fuse_2_patches(currentSite, youngerPatch, currentPatch) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index ed7d3256d3..20d6c70d7e 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -247,6 +247,9 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) do_patch_dynamics = ifalse end if if(hlm_use_nocomp.eq.itrue)then + ! n.b. the this is currently set to false to get around a memory leak that occurs + ! when we have multiple patches for each PFT. + ! when this is fixed, we will need another option for 'one patch per PFT' vs 'multiple patches per PFT' do_patch_dynamics = ifalse end if ! make new patches from disturbed land diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index 77323bd172..bed41f0eab 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -918,10 +918,11 @@ subroutine Register_PFT(this, fates_params) call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) + ! adding the hlm_pft_map variable with two dimensions - FATES PFTno and HLM PFTno pftmap_dim_names(1) = dimension_name_pft - pftmap_dim_names(2) = dimension_name_hlm_pftno + pftmap_dim_names(2) = dimension_name_hlm_pftno xs - name = 'fates_hlm_pft_map' + name = 'fates_hlm_pft_map' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & dimension_names=pftmap_dim_names, lower_bounds=dim_lower_bound) end subroutine Register_PFT From 0a5a866606faad6a0964beac60366c0bd64109a4 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 7 Sep 2020 15:39:03 +0200 Subject: [PATCH 038/209] added patch ID's to the new create_patch calls from landuse mods --- biogeochem/EDPatchDynamicsMod.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 8f0e0a3027..d0fe122e50 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -562,7 +562,7 @@ subroutine spawn_patches( currentSite, bc_in) allocate(new_patch_primary) call create_patch(currentSite, new_patch_primary, age, & - site_areadis_primary, primaryforest) + site_areadis_primary, primaryforest,fates_unset_int) ! Initialize the litter pools to zero, these ! pools will be populated by looping over the existing patches @@ -585,7 +585,7 @@ subroutine spawn_patches( currentSite, bc_in) if ( site_areadis_secondary .gt. nearzero) then allocate(new_patch_secondary) call create_patch(currentSite, new_patch_secondary, age, & - site_areadis_secondary, secondaryforest) + site_areadis_secondary, secondaryforest,fates_unset_int) ! Initialize the litter pools to zero, these ! pools will be populated by looping over the existing patches From 0d720013c79a730af821edecd61c0ec55ca223d3 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 7 Sep 2020 15:51:34 +0200 Subject: [PATCH 039/209] added comment to restart interface --- main/FatesRestartInterfaceMod.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index c8825acca5..d9e6c9b1b0 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -2056,6 +2056,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) ! create patch allocate(newp) nocomp_pft = fates_unset_int + ! the nocomp_pft label is set after patch creation has occured in 'get_restart_vectors' ! make new patch call create_patch(sites(s), newp, fates_unset_r8, fates_unset_r8, primaryforest, nocomp_pft ) @@ -2421,7 +2422,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ccohort%prt%variables(i_var)%net_alloc(i_pos) = & this%rvars(ir_prt_var)%r81d(io_idx_co) - ir_prt_var = ir_prt_var + 1 + ir_prt_var = ir_prt_var + 1 ccohort%prt%variables(i_var)%burned(i_pos) = & this%rvars(ir_prt_var)%r81d(io_idx_co) end do From 91ee991223d61d651e23759442099f732c5ddc12 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 7 Sep 2020 16:02:34 +0200 Subject: [PATCH 040/209] added switch names to FatesInterfaceTypesMod.F90 --- main/FatesInterfaceTypesMod.F90 | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index 547e095fa7..eadd3704f8 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -164,6 +164,12 @@ module FatesInterfaceTypesMod integer, public :: hlm_use_fixed_biogeog ! Flag to use FATES fixed biogeography mode ! 1 = TRUE, 0 = FALSE + integer, public :: hlm_use_nocomp ! Flag to use FATES no competition mode + ! 1 = TRUE, 0 = FALSE + + integer, public :: hlm_use_sp ! Flag to use FATES satellite phenology (LAI) mode + ! 1 = TRUE, 0 = FALSE + ! ------------------------------------------------------------------------------------- ! Parameters that are dictated by FATES and known to be required knowledge ! needed by the HLMs From f146bc16fbdcd6f6fa83f5a976d671093bb27928 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 7 Sep 2020 16:07:05 +0200 Subject: [PATCH 041/209] assert that patch dynamics are off when SP mode is on --- main/EDMainMod.F90 | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 20d6c70d7e..4f53ad10fc 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -246,12 +246,19 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) if(hlm_use_ed_st3.eq.ifalse)then do_patch_dynamics = ifalse end if - if(hlm_use_nocomp.eq.itrue)then + + if(hlm_use_nocomp.eq.itrue)then ! n.b. the this is currently set to false to get around a memory leak that occurs ! when we have multiple patches for each PFT. ! when this is fixed, we will need another option for 'one patch per PFT' vs 'multiple patches per PFT' do_patch_dynamics = ifalse - end if + end if + + if(hlm_use_sp.eq.itrue)then + ! if we want to assert LAI + do_patch_dynamics = ifalse + end if + ! make new patches from disturbed land if (do_patch_dynamics.eq.itrue ) then call spawn_patches(currentSite, bc_in) From 8d099f3c68391ec0376e365d392d092c13eb4439 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 8 Sep 2020 12:14:14 +0200 Subject: [PATCH 042/209] allocate SP input variables in FatesInterfaceMod --- main/FatesInterfaceMod.F90 | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index b43992b94f..c95f87c001 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -376,6 +376,12 @@ subroutine allocate_bcin(bc_in, nlevsoil_in, nlevdecomp_in, num_lu_harvest_cats) allocate(bc_in%pft_areafrac(maxpft)) + ! Variables for SP mode. + if(hlm_use_sp.eq.itrue) then + allocate(bc_in%sp_tlai(maxPatchesPerSite)) + allocate(bc_in%sp_tsai(maxPatchesPerSite)) + allocate(bc_in%sp_htop(maxPatchesPerSite)) + end if return end subroutine allocate_bcin @@ -1015,7 +1021,8 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) hlm_use_ed_st3 = unset_int hlm_use_ed_prescribed_phys = unset_int hlm_use_fixed_biogeog = unset_int - !hlm_use_nocomp = unset_int ! future reduced complexity mode + hlm_use_nocomp = unset_int ! future reduced complexity mode + hlm_use_sp = unset_int hlm_use_inventory_init = unset_int hlm_inventory_ctrl_file = 'unset' From 365561f1ae38beda58e7c8b53c5ea37a15d81cd8 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 8 Sep 2020 12:24:50 +0200 Subject: [PATCH 043/209] defined SP input variables in FatesInterfaceTypesMod --- main/FatesInterfaceTypesMod.F90 | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index eadd3704f8..65689ce73c 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -478,6 +478,12 @@ module FatesInterfaceTypesMod ! Fixed biogeography mode real(r8), allocatable :: pft_areafrac(:) ! Fractional area of the FATES column occupied by each PFT + ! Satellite Phenology (SP) input variables. (where each patch only has one PFT) + ! --------------------------------------------------------------------------------- + real(r8),allocatable :: sp_tlai(:) ! Interpolated daily total LAI (leaf area index) input from HLM per patch/pft + real(r8),allocatable :: sp_tsai(:) ! Interpolated sailt total SAI (stem area index) input from HLM per patch/pft + real(r8),allocatable :: sp_htop(:) ! Interpolated daily canopy vegetation height input from HLM per patch/pft + end type bc_in_type From b128762ba8956f154ace8af4d6584a74da1ae0d6 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 8 Sep 2020 13:50:27 +0200 Subject: [PATCH 044/209] changed nocmp and SP transfer from HLM to active in FatesInterfaceMod.F90 --- main/FatesInterfaceMod.F90 | 30 +++++++++++++++++++----------- 1 file changed, 19 insertions(+), 11 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index c95f87c001..15ac63512c 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -1271,12 +1271,20 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) end if ! Future reduced complexity mode - !if(hlm_use_nocomp.eq.unset_int) then - ! if(fates_global_verbose()) then - ! write(fates_log(), *) 'switch for no competition mode. ' - ! end if - ! call endrun(msg=errMsg(sourcefile, __LINE__)) - ! end if + if(hlm_use_nocomp.eq.unset_int) then + if(fates_global_verbose()) then + write(fates_log(), *) 'switch for no competition mode. ' + end if + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if(hlm_use_sp.eq.unset_int) then + if(fates_global_verbose()) then + write(fates_log(), *) 'switch for SP mode. ' + end if + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + if(hlm_use_cohort_age_tracking .eq. unset_int) then if (fates_global_verbose()) then @@ -1394,11 +1402,11 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) end if ! Future reduced complexity mode - !case('use_nocomp') - ! hlm_use_nocomp = ival - ! if (fates_global_verbose()) then - ! write(fates_log(),*) 'Transfering hlm_use_nocomp= ',ival,' to FATES' - ! end if + case('use_nocomp') + hlm_use_nocomp = ival + if (fates_global_verbose()) then + write(fates_log(),*) 'Transfering hlm_use_nocomp= ',ival,' to FATES' + end if case('use_planthydro') From 94b7aff881639ea67a1a6584901f327f79adf38c Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 8 Sep 2020 14:23:47 +0200 Subject: [PATCH 045/209] added check so that nocomp needs to be on for SP to work in FatesInterfaceMod.F90 --- main/FatesInterfaceMod.F90 | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 15ac63512c..aed355bf53 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -1260,8 +1260,6 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) end if call endrun(msg=errMsg(sourcefile, __LINE__)) end if - - if(hlm_use_fixed_biogeog.eq.unset_int) then if(fates_global_verbose()) then @@ -1285,7 +1283,6 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - if(hlm_use_cohort_age_tracking .eq. unset_int) then if (fates_global_verbose()) then write(fates_log(), *) 'switch for cohort_age_tracking unset: hlm_use_cohort_age_tracking, exiting' @@ -1293,6 +1290,10 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) call endrun(msg=errMsg(sourcefile, __LINE__)) end if + if(hlm_use_sp.eq.itrue.and.hlm_use_nocomp.eq.ifalse)then + write(fates_log(), *) 'SP cannot be on if nocomp mode is off. Exiting. ' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if if (fates_global_verbose()) then write(fates_log(), *) 'Checked. All control parameters sent to FATES.' From 87cd4920819285d1c65f0c6d20156a846443337e Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 8 Sep 2020 14:32:58 +0200 Subject: [PATCH 046/209] changed dimensions of SP input variables to maxpft --- main/FatesInterfaceMod.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index aed355bf53..ebd8a5392e 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -378,9 +378,9 @@ subroutine allocate_bcin(bc_in, nlevsoil_in, nlevdecomp_in, num_lu_harvest_cats) ! Variables for SP mode. if(hlm_use_sp.eq.itrue) then - allocate(bc_in%sp_tlai(maxPatchesPerSite)) - allocate(bc_in%sp_tsai(maxPatchesPerSite)) - allocate(bc_in%sp_htop(maxPatchesPerSite)) + allocate(bc_in%hlm_sp_tlai(maxpft)) + allocate(bc_in%hlm_sp_tsai(maxpft)) + allocate(bc_in%hlm_sp_htop(maxpft)) end if return end subroutine allocate_bcin From aeec14292eb8dc6e5aab1b4bb8b0ea3b56c53448 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 8 Sep 2020 14:56:01 +0200 Subject: [PATCH 047/209] fixed a bunch of annoying spacing in EDInit --- main/EDInitMod.F90 | 24 +++++++++++------------- 1 file changed, 11 insertions(+), 13 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 37a4e5787c..17261e61ce 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -326,18 +326,18 @@ subroutine set_site_properties( nsites, sites,bc_in ) endif end do - sumarea = sum(sites(s)%area_pft(1:numpft)) + sumarea = sum(sites(s)%area_pft(1:numpft)) do ft = 1,numpft if(sumarea.gt.0._r8)then - sites(s)%area_pft(ft) = sites(s)%area_pft(ft)/sumarea + sites(s)%area_pft(ft) = sites(s)%area_pft(ft)/sumarea else - sites(s)%area_pft(ft)= 1.0_r8/numpft - write(*,*) 'setting totally bare patch to all pfts.',s,sumarea,sites(s)%area_pft(ft) - end if - end do !ft - end if + sites(s)%area_pft(ft)= 1.0_r8/numpft + write(*,*) 'setting totally bare patch to all pfts.',s,sumarea,sites(s)%area_pft(ft) + end if + end do !ft + end if !fixed biogeog - do ft = 1,numpft + do ft = 1,numpft sites(s)%use_this_pft(ft) = itrue if(hlm_use_fixed_biogeog.eq.itrue)then if(sites(s)%area_pft(ft).gt.0.0_r8)then @@ -346,11 +346,9 @@ subroutine set_site_properties( nsites, sites,bc_in ) sites(s)%use_this_pft(ft) = ifalse end if !area end if !SBG - end do !ft - - end do - - end if + end do !ft + end do !site loop + end if !restart return end subroutine set_site_properties From 4d46a8b4eb8d9da1e89731578f32f50e23b2c15b Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 8 Sep 2020 15:03:48 +0200 Subject: [PATCH 048/209] allocated FATES site SP input variables with PFT arrays --- main/EDInitMod.F90 | 5 +++++ main/EDTypesMod.F90 | 5 +++++ 2 files changed, 10 insertions(+) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 17261e61ce..a672b56f22 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -132,6 +132,11 @@ subroutine init_site_vars( site_in, bc_in ) allocate(site_in%area_pft(1:numpft)) allocate(site_in%use_this_pft(1:numpft)) + ! SP mode + allocate(site_in%sp_tlai(1:numpft)) + allocate(site_in%sp_tsai(1:numpft)) + allocate(site_in%sp_htop(1:numpft)) + do el=1,num_elements allocate(site_in%flux_diags(el)%leaf_litter_input(1:numpft)) allocate(site_in%flux_diags(el)%root_litter_input(1:numpft)) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 18c45cbafb..4e1121a139 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -662,6 +662,11 @@ module EDTypesMod real(r8), allocatable :: area_PFT(:) ! Area allocated to individual PFTs integer, allocatable :: use_this_pft(:) ! Is area_PFT > 0 ? (1=yes, 0=no) + ! SP mode target PFT level variables + real(r8), allocatable :: sp_tlai(:) ! target TLAI per FATES pft + real(r8), allocatable :: sp_tsai(:) ! target TSAI per FATES pft + real(r8), allocatable :: sp_htop(:) ! target HTOP per FATES pft + ! Mass Balance (allocation for each element) type(site_massbal_type), pointer :: mass_balance(:) From e38c7266b175e1c8f30378a26b2ca6907a6e8601 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 8 Sep 2020 15:14:22 +0200 Subject: [PATCH 049/209] turning off cohort and patch dynamics in SP mode --- main/EDMainMod.F90 | 25 +++++++++++++++++-------- 1 file changed, 17 insertions(+), 8 deletions(-) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 4f53ad10fc..e4952c3bfc 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -133,6 +133,7 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) type(ed_patch_type), pointer :: currentPatch integer :: el ! Loop counter for elements integer :: do_patch_dynamics ! for some modes, we turn off patch dynamics + !----------------------------------------------------------------------- if ( hlm_masterproc==itrue ) write(fates_log(),'(A,I4,A,I2.2,A,I2.2)') 'FATES Dynamics: ',& @@ -170,12 +171,12 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) ! We do not allow phenology while in ST3 mode either, it is hypothetically ! possible to allow this, but we have not plugged in the litter fluxes ! of flushing or turning over leaves for non-dynamics runs - if (hlm_use_ed_st3.eq.ifalse) then + if (hlm_use_ed_st3.eq.ifalse.and.hlm_use_sp.eq.false) then call phenology(currentSite, bc_in ) end if - if (hlm_use_ed_st3.eq.ifalse) then ! Bypass if ST3 + if (hlm_use_ed_st3.eq.ifalse.and.hlm_use_sp.eq.false) then ! Bypass if ST3 call fire_model(currentSite, bc_in) ! Calculate disturbance and mortality based on previous timestep vegetation. @@ -183,7 +184,7 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) call disturbance_rates(currentSite, bc_in) end if - if (hlm_use_ed_st3.eq.ifalse) then + if (hlm_use_ed_st3.eq.ifalse.and.hlm_use_sp.eq.false) then ! Integrate state variables from annual rates to daily timestep call ed_integrate_state_variables(currentSite, bc_in ) else @@ -201,7 +202,7 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) ! Reproduction, Recruitment and Cohort Dynamics : controls cohort organization !****************************************************************************** - if(hlm_use_ed_st3.eq.ifalse) then + if(hlm_use_ed_st3.eq.ifalse.and.hlm_use_sp.eq.false) then currentPatch => currentSite%oldest_patch do while (associated(currentPatch)) @@ -215,7 +216,7 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) call TotalBalanceCheck(currentSite,1) - if( hlm_use_ed_st3.eq.ifalse ) then + if( hlm_use_ed_st3.eq.ifalse .and.hlm_use_sp.eq.false ) then currentPatch => currentSite%oldest_patch do while (associated(currentPatch)) @@ -253,6 +254,10 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) ! when this is fixed, we will need another option for 'one patch per PFT' vs 'multiple patches per PFT' do_patch_dynamics = ifalse end if + + if(hlm_use_sp.eq.itrue) ! cover for potential changes in nocomp logic above. + do_patch_dynamics = ifalse + end if if(hlm_use_sp.eq.itrue)then ! if we want to assert LAI @@ -280,15 +285,19 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) end if end if - call TotalBalanceCheck(currentSite,4) + ! SP has changes in leaf carbon but we don't expect them to be in balance. + if(hlm_use_sp.eq.ifalse)then + call TotalBalanceCheck(currentSite,4) + end if ! kill patches that are too small if ( do_patch_dynamics.eq.itrue ) then call terminate_patches(currentSite) end if - - call TotalBalanceCheck(currentSite,5) + if(hlm_use_sp.eq.ifalse)then + call TotalBalanceCheck(currentSite,5) + endif end subroutine ed_ecosystem_dynamics !-------------------------------------------------------------------------------! From 3118ea3b3f2d3a9a5832b2deb62d03ea17aebbfe Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 8 Sep 2020 15:30:12 +0200 Subject: [PATCH 050/209] added call to satellite_phenology routine in EDMain --- main/EDMainMod.F90 | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index e4952c3bfc..bbbbe696c8 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -33,6 +33,7 @@ module EDMainMod use EDPatchDynamicsMod , only : spawn_patches use EDPatchDynamicsMod , only : terminate_patches use EDPhysiologyMod , only : phenology + use EDPhysiologyMod , only : satellite_phenology use EDPhysiologyMod , only : recruitment use EDPhysiologyMod , only : trim_canopy use EDPhysiologyMod , only : SeedIn @@ -171,8 +172,12 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) ! We do not allow phenology while in ST3 mode either, it is hypothetically ! possible to allow this, but we have not plugged in the litter fluxes ! of flushing or turning over leaves for non-dynamics runs - if (hlm_use_ed_st3.eq.ifalse.and.hlm_use_sp.eq.false) then - call phenology(currentSite, bc_in ) + if (hlm_use_ed_st3.eq.ifalse) then + if(hlm_use_sp.eq.false) + call phenology(currentSite, bc_in ) + else + call satellite_phenology(currentSite, bc_in ) + end if ! SP phenology end if From 406c72bdbfb9828b0c567b24ed1120e4a125e2a9 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 8 Sep 2020 15:44:12 +0200 Subject: [PATCH 051/209] begun satellite_phenology subroutine --- biogeochem/EDPhysiologyMod.F90 | 40 ++++++++++++++++++++++++++++++++++ 1 file changed, 40 insertions(+) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 0c23795f9a..3851082310 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -107,6 +107,7 @@ module EDPhysiologyMod public :: trim_canopy public :: phenology + public :: satellite_phenology public :: recruitment public :: ZeroLitterFluxes public :: FluxIntoLitterPools @@ -1063,6 +1064,7 @@ subroutine phenology( currentSite, bc_in ) end subroutine phenology + ! ============================================================================ subroutine phenology_leafonoff(currentSite) ! @@ -1329,7 +1331,45 @@ subroutine phenology_leafonoff(currentSite) end subroutine phenology_leafonoff + ! ===================================================================================== + + subroutine satellite_phenology + + ! ----------------------------------------------------------------------------------- + ! Takes the daily inputs of leaf area index, stem area index and canopy height and + ! translates them into a FATES structure with one patch and one cohort per PFT + ! The leaf area of the cohort is modified each day to match that asserted by the HLM + ! ----------------------------------------------------------------------------------- + + ! To Do in this routine. + ! Get access to HLM input varialbes. + ! Weight them by PFT + ! Loop around patches, and for each single cohort in each patch + ! determine what 'n' should be from the canopy height. + ! determine the leaf biomass that it should have. + ! figure out how this will interact with the canopy_structure routines. + ! determine what 'n' should be from the canopy height. + + currentPatch => currentSite%oldest_patch + do while (associated(currentPatch)) + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if(associated(currentCohort%shorter) + write(*,*) "there is more than one cohort in SP mode.' + end if + + ft =currentCohort%pft + if(ft.ne.currentPatch%nocomp_pft)then + write(*,*) 'wrong PFT label in cohort in SP mode',ft,currentPatch%nocomp_pft + end if + + currentCohort => currentCohort%shorter + end do !cohort loop + + currentPatch => currentPatch%younger + end do ! patch loop + end subroutine satellite_phenology ! ===================================================================================== subroutine SeedIn( currentSite, bc_in ) From 552a0edb70cc222e82d78dccabb2e4f999d69c7b Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 8 Sep 2020 15:56:56 +0200 Subject: [PATCH 052/209] added weighting code for SP variables. need to finish --- biogeochem/EDPhysiologyMod.F90 | 35 +++++++++++++++++++++++++++++++++- 1 file changed, 34 insertions(+), 1 deletion(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 3851082310..7ea94da634 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1351,7 +1351,40 @@ subroutine satellite_phenology ! determine what 'n' should be from the canopy height. currentPatch => currentSite%oldest_patch - do while (associated(currentPatch)) + do while (associated(currentPatch)) + + if(hlm_use_fixed_biogeog.eq.itrue)then + ! WEIGHTING OF FATES PFTs on to HLM_PFTs + ! add up the area associated with each FATES PFT + ! where pft_areafrac is the area of land in each HLM PFT and (from surface dataset) + ! hlm_pft_map is the area of that land in each FATES PFT (from param file) + + currentSite%sp_tlai(1:numpft) = 0._r8 + currentSite%sp_tsai(1:numpft) = 0._r8 + currentSite%sp_htop(1:numpft) = 0._r8 + +! weight each fates PFT target for lai, sai and htop by the area of the +! contrbuting HLM PFTs. + do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) + do fates_pft = 1,numpft ! loop round all fates pfts for all hlm pfts + !leaf area index + currentSite%sp_tlai(fates_pft) = currentSite%sp_tlai(fates_pft) + & + bc_in(s)%hlm_sp_tlai(hlm_pft) * bc_in(s)%pft_areafrac(hlm_pft) + !stem area index + currentSite%sp_tsai(fates_pft) = currentSite%sp_tsai(fates_pft) + & + bc_in(s)%hlm_sp_tsai(hlm_pft) * bc_in(s)%pft_areafrac(hlm_pft) + ! canopy height + currentSite%sp_htop(fates_pft) = currentSite%sp_htop(fates_pft) + & + bc_in(s)%hlm_sp_htop(hlm_pft) * bc_in(s)%pft_areafrac(hlm_pft) + + + end do + end do !hlm_pft + + sumarea = sum(sites(s)%area_pft(1:numpft)) +!** RENORMALIZE FOR TOTAL PFT AREA ACCOUNTING FOR DELETED TINY PACHES + + currentCohort => currentPatch%tallest do while (associated(currentCohort)) if(associated(currentCohort%shorter) From b163fbdce336f9119e172f9046635323ef671567 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 9 Sep 2020 09:45:50 +0200 Subject: [PATCH 053/209] modified comments for pft_areafrac calculation --- main/EDInitMod.F90 | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index a672b56f22..1f7c2c59c5 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -320,10 +320,6 @@ subroutine set_site_properties( nsites, sites,bc_in ) end do end do !hlm_pft - ! re-normalize PFT area to ensure it sums to one. - ! note that in areas of 'bare ground' (PFT 0 in CLM/ELM) - ! the bare ground will no longer be proscribed and should emerge from FATES - do ft = 1,numpft if(sites(s)%area_pft(ft).lt.0.01_r8)then sites(s)%area_pft(ft)=0.0_r8 !remove tiny patches to prevent numerical errors in terminate patches @@ -331,6 +327,11 @@ subroutine set_site_properties( nsites, sites,bc_in ) endif end do + ! re-normalize PFT area to ensure it sums to one. + ! note that in areas of 'bare ground' (PFT 0 in CLM/ELM) + ! the bare ground will no longer be proscribed and should emerge from FATES + ! this may or may not be the right way to deal with this? + sumarea = sum(sites(s)%area_pft(1:numpft)) do ft = 1,numpft if(sumarea.gt.0._r8)then From 12310b026c200a212c5859ee1e677688f8f365ff Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 9 Sep 2020 10:23:01 +0200 Subject: [PATCH 054/209] added normalization to SP variable weighting. Changed indents --- biogeochem/EDPhysiologyMod.F90 | 77 ++++++++++++++++++++-------------- 1 file changed, 46 insertions(+), 31 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 7ea94da634..31b0b1f498 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1353,38 +1353,53 @@ subroutine satellite_phenology currentPatch => currentSite%oldest_patch do while (associated(currentPatch)) - if(hlm_use_fixed_biogeog.eq.itrue)then - ! WEIGHTING OF FATES PFTs on to HLM_PFTs - ! add up the area associated with each FATES PFT - ! where pft_areafrac is the area of land in each HLM PFT and (from surface dataset) - ! hlm_pft_map is the area of that land in each FATES PFT (from param file) - - currentSite%sp_tlai(1:numpft) = 0._r8 - currentSite%sp_tsai(1:numpft) = 0._r8 - currentSite%sp_htop(1:numpft) = 0._r8 - -! weight each fates PFT target for lai, sai and htop by the area of the -! contrbuting HLM PFTs. - do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) - do fates_pft = 1,numpft ! loop round all fates pfts for all hlm pfts - !leaf area index - currentSite%sp_tlai(fates_pft) = currentSite%sp_tlai(fates_pft) + & - bc_in(s)%hlm_sp_tlai(hlm_pft) * bc_in(s)%pft_areafrac(hlm_pft) - !stem area index - currentSite%sp_tsai(fates_pft) = currentSite%sp_tsai(fates_pft) + & - bc_in(s)%hlm_sp_tsai(hlm_pft) * bc_in(s)%pft_areafrac(hlm_pft) - ! canopy height + if(hlm_use_fixed_biogeog.eq.itrue)then + ! WEIGHTING OF FATES PFTs on to HLM_PFTs + ! add up the area associated with each FATES PFT + ! where pft_areafrac is the area of land in each HLM PFT and (from surface dataset) + ! hlm_pft_map is the area of that land in each FATES PFT (from param file) + + currentSite%sp_tlai(1:numpft) = 0._r8 + currentSite%sp_tsai(1:numpft) = 0._r8 + currentSite%sp_htop(1:numpft) = 0._r8 + + ! weight each fates PFT target for lai, sai and htop by the area of the + ! contrbuting HLM PFTs. + do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) + do fates_pft = 1,numpft ! loop round all fates pfts for all hlm pfts + if(sites(s)%area_pft(ft).gt.0.0_r8)then + !leaf area index + currentSite%sp_tlai(fates_pft) = currentSite%sp_tlai(fates_pft) + & + bc_in(s)%hlm_sp_tlai(hlm_pft) * bc_in(s)%pft_areafrac(hlm_pft) + !stem area index + currentSite%sp_tsai(fates_pft) = currentSite%sp_tsai(fates_pft) + & + bc_in(s)%hlm_sp_tsai(hlm_pft) * bc_in(s)%pft_areafrac(hlm_pft) + ! canopy height currentSite%sp_htop(fates_pft) = currentSite%sp_htop(fates_pft) + & - bc_in(s)%hlm_sp_htop(hlm_pft) * bc_in(s)%pft_areafrac(hlm_pft) - - - end do - end do !hlm_pft - - sumarea = sum(sites(s)%area_pft(1:numpft)) -!** RENORMALIZE FOR TOTAL PFT AREA ACCOUNTING FOR DELETED TINY PACHES - - + bc_in(s)%hlm_sp_htop(hlm_pft) * bc_in(s)%pft_areafrac(hlm_pft) + end if ! there is some area in this patch + end do + end do !hlm_pft + + ! weight for total area in each fates_pft + do fates_pft = 1,numpft + if(sites(s)%area_pft(ft).gt.0.0_r8)then + currentSite%sp_htop(fates_pft) = currentSite%sp_htop(fates_pft) & + /sites(s)%area_pft(ft) + currentSite%sp_htop(fates_pft) = currentSite%sp_htop(fates_pft) & + /sites(s)%area_pft(ft) + currentSite%sp_htop(fates_pft) = currentSite%sp_htop(fates_pft) & + /sites(s)%area_pft(ft) + endif + enddo !fates_pft + + ! ------------------------------------------------------------ + ! now we have the target lai, sai and htop for each PFT/patch + ! find properties of the cohort that go along with that + ! 1. Find canopy area from HTOP (height) + ! 2. Find 'n' associated with canopy area, given a closed canopy + ! 3. Find 'bleaf' associated with TLAI and canopy area. + ! ------------------------------------------------------------ currentCohort => currentPatch%tallest do while (associated(currentCohort)) if(associated(currentCohort%shorter) From cf3ed64f3257f92d16e88c340e1b169a1eb8030b Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 9 Sep 2020 10:37:12 +0200 Subject: [PATCH 055/209] added leafc_from_treelai to FatesAllometryMod --- biogeochem/FatesAllometryMod.F90 | 96 ++++++++++++++++++++++++++++++++ 1 file changed, 96 insertions(+) diff --git a/biogeochem/FatesAllometryMod.F90 b/biogeochem/FatesAllometryMod.F90 index ce56a15e35..73197e8b19 100644 --- a/biogeochem/FatesAllometryMod.F90 +++ b/biogeochem/FatesAllometryMod.F90 @@ -123,6 +123,7 @@ module FatesAllometryMod public :: CrownDepth public :: set_root_fraction ! Generic wrapper to calculate normalized ! root profiles + public :: leafc_from_treelai ! Calculate target leaf carbon for a given treelai for SP mode logical , parameter :: verbose_logging = .false. character(len=*), parameter :: sourcefile = __FILE__ @@ -756,6 +757,101 @@ real(r8) function tree_sai( pft, dbh, canopy_trim, c_area, nplant, cl, & return end function tree_sai +! ===================================================================================== + + real(r8) function leafc_from_treelai( treelai, pft, c_area, nplant, cl, canopy_lai, vcmax25top) + + ! ----------------------------------------------------------------------------------- + ! LAI of individual trees is a function of the total leaf area and the total + ! canopy area. + ! ---------------------------------------------------------------------------------- + + ! !ARGUMENTS + real(r8) function leafc_from_treelai( treelai, pft, c_area, nplant, cl, canopy_lai, vcmax25top) + + real(r8), intent(in) :: treelai ! desired tree lai m2/m2 + integer, intent(in) :: pft ! Plant Functional Type index + real(r8), intent(in) :: c_area ! areal extent of canopy (m2) + real(r8), intent(in) :: nplant ! number of individuals in cohort per ha + integer, intent(in) :: cl ! canopy layer index + real(r8), intent(in) :: canopy_lai(nclmax) ! total leaf area index of + ! each canopy layer + real(r8), intent(in) :: vcmax25top ! maximum carboxylation rate at canopy + ! top, ref 25C + + ! !LOCAL VARIABLES: + real(r8), :: leaf_c ! plant leaf carbon [kg] + real(r8) :: leafc_per_unitarea ! KgC of leaf per m2 area of ground. + real(r8) :: slat ! the sla of the top leaf layer. m2/kgC + real(r8) :: canopy_lai_above ! total LAI of canopy layer overlying this tree + real(r8) :: vai_per_lai ! ratio of vegetation area index (ie. sai+lai) + ! to lai for individual tree + real(r8) :: kn ! coefficient for exponential decay of 1/sla and + ! vcmax with canopy depth + real(r8) :: sla_max ! Observational constraint on how large sla + ! (m2/gC) can become + real(r8) :: leafc_slamax ! Leafc_per_unitarea at which sla_max is reached + real(r8) :: clim ! Upper limit for leafc_per_unitarea in exponential + ! tree_lai function + real(r8) :: tree_lai_at_slamax ! lai at which we reach the maximum sla value. + + !---------------------------------------------------------------------- + + if( treelai < 0._r8.or. pft == 0 ) then + write(fates_log(),*) 'negative tree lai in leafc_from_treelai?' + write(fates_log(),*) 'or.. pft was zero?' + write(fates_log(),*) 'problem in leafc_from_treelai',treelai,pft + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + + if(cl>1)then + write(fates_log(),*) 'in sub-canopy layer in leafc_from_treelai' + write(fates_log(),*) 'this is not set up to work for lower canopy layers.' + write(fates_log(),*) 'problem in leafc_from_treelai',cl,pft + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + + slat = g_per_kg * EDPftvarcon_inst%slatop(pft) ! m2/g to m2/kg + leafc_per_unitarea = leaf_c/(c_area/nplant) !KgC/m2 + + if(treelai > 0.0_r8)then + ! Coefficient for exponential decay of 1/sla with canopy depth: + kn = decay_coeff_kn(pft,vcmax25top) + + ! take PFT-level maximum SLA value, even if under a thick canopy (which has units of m2/gC), + ! and put into units of m2/kgC + sla_max = g_per_kg *EDPftvarcon_inst%slamax(pft) + + ! Leafc_per_unitarea at which sla_max is reached due to exponential sla profile in canopy: + leafc_slamax = max(0.0_r8,(slat - sla_max) / (-1.0_r8 * kn * slat * sla_max)) + + ! treelai at which we reach maximum sla. + tree_lai_at_slamax = (log( 1.0_r8- kn * slat * leafc_slamax)) / (-1.0_r8 * kn) + if(treelai > tree_lai_at_slamax)then + ! Inversion of the exponential phase calculation of treelai for a given leafc_per_unitarea + leafc_per_unitarea = (1.0_r8-exp(treelai*(-1.0_r8 * kn)))/(kn*slat) + else ! we exceed the maxumum sla + + ! Add exponential and linear portions of tree_lai + ! Exponential term for leafc = leafc_slamax; + leafc_linear_phase = (treelai-tree_lai_at_slamax)/sla_max + leafc_per_unitarea = leafc_slamax + leafc_linear_phase + end if + + else + leafc_from_treelai = 0.0_r8 + endif ! (leafc_per_unitarea > 0.0_r8) + + return + end function leafc_from_treelai + + ! ===================================================================================== + + + + + + ! ============================================================================ ! Generic sapwood biomass interface ! ============================================================================ From 21e09a454a98bbe9bfc1f4fa724f1b3feed7f516 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 9 Sep 2020 11:02:07 +0200 Subject: [PATCH 056/209] removed refences to canopy_lai in leafc_from_treelai --- biogeochem/FatesAllometryMod.F90 | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) diff --git a/biogeochem/FatesAllometryMod.F90 b/biogeochem/FatesAllometryMod.F90 index 73197e8b19..6c33e5c8f8 100644 --- a/biogeochem/FatesAllometryMod.F90 +++ b/biogeochem/FatesAllometryMod.F90 @@ -759,7 +759,7 @@ end function tree_sai ! ===================================================================================== - real(r8) function leafc_from_treelai( treelai, pft, c_area, nplant, cl, canopy_lai, vcmax25top) + real(r8) function leafc_from_treelai( treelai, pft, c_area, nplant, cl, vcmax25top) ! ----------------------------------------------------------------------------------- ! LAI of individual trees is a function of the total leaf area and the total @@ -767,15 +767,11 @@ real(r8) function leafc_from_treelai( treelai, pft, c_area, nplant, cl, canopy_l ! ---------------------------------------------------------------------------------- ! !ARGUMENTS - real(r8) function leafc_from_treelai( treelai, pft, c_area, nplant, cl, canopy_lai, vcmax25top) - real(r8), intent(in) :: treelai ! desired tree lai m2/m2 integer, intent(in) :: pft ! Plant Functional Type index real(r8), intent(in) :: c_area ! areal extent of canopy (m2) real(r8), intent(in) :: nplant ! number of individuals in cohort per ha integer, intent(in) :: cl ! canopy layer index - real(r8), intent(in) :: canopy_lai(nclmax) ! total leaf area index of - ! each canopy layer real(r8), intent(in) :: vcmax25top ! maximum carboxylation rate at canopy ! top, ref 25C @@ -783,7 +779,6 @@ real(r8) function leafc_from_treelai( treelai, pft, c_area, nplant, cl, canopy_l real(r8), :: leaf_c ! plant leaf carbon [kg] real(r8) :: leafc_per_unitarea ! KgC of leaf per m2 area of ground. real(r8) :: slat ! the sla of the top leaf layer. m2/kgC - real(r8) :: canopy_lai_above ! total LAI of canopy layer overlying this tree real(r8) :: vai_per_lai ! ratio of vegetation area index (ie. sai+lai) ! to lai for individual tree real(r8) :: kn ! coefficient for exponential decay of 1/sla and From c501b561ddb6f6311638680ac50db0e1e5b67363 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 9 Sep 2020 11:03:45 +0200 Subject: [PATCH 057/209] added call to leafc_from_treelai --- biogeochem/EDPhysiologyMod.F90 | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 31b0b1f498..b4c9938b20 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -27,6 +27,7 @@ module EDPhysiologyMod use EDCohortDynamicsMod , only : InitPRTObject use FatesAllometryMod , only : tree_lai use FatesAllometryMod , only : tree_sai + use FatesAllometryMod , only : leafc_from_treelai use FatesAllometryMod , only : decay_coeff_kn use FatesLitterMod , only : litter_type use EDTypesMod , only : site_massbal_type @@ -1402,20 +1403,25 @@ subroutine satellite_phenology ! ------------------------------------------------------------ currentCohort => currentPatch%tallest do while (associated(currentCohort)) + + ! Do some checks if(associated(currentCohort%shorter) write(*,*) "there is more than one cohort in SP mode.' end if ft =currentCohort%pft if(ft.ne.currentPatch%nocomp_pft)then - write(*,*) 'wrong PFT label in cohort in SP mode',ft,currentPatch%nocomp_pft + write(*,*) 'wrong PFT label in cohort in SP mode',ft,currentPatch%nocomp_pft end if currentCohort => currentCohort%shorter end do !cohort loop + leaf_c = leafc_from_treelai( currentCohort%treelai, currentCohort%pft, currentCohort%c_area,& + currentCohort%n, currentCohort%canopy_layer, currentCohort%vcmax25top) + currentPatch => currentPatch%younger - end do ! patch loop + end do ! patch loop end subroutine satellite_phenology ! ===================================================================================== From d149ae67893ec70a8b2a5752f02d5bb0f9284615 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 9 Sep 2020 11:17:35 +0200 Subject: [PATCH 058/209] added calls to allometry functions to estimate cohort properties --- biogeochem/EDPhysiologyMod.F90 | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index b4c9938b20..42dbc815c5 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1417,9 +1417,31 @@ subroutine satellite_phenology currentCohort => currentCohort%shorter end do !cohort loop + !------------------------------------------ + ! Calculate dbh from input height, and c_area from dbh + !------------------------------------------ + currentCohort%hite = currentPatch%sp_htop + call h2d_allom(temp_cohort%hite,ft,temp_cohort%dbh) + currentCohort%n = 1.0_r8 ! make n=1 to get area of one tree. + call carea_allom(currentCohort%dbh,currentCohort%n,spread,currentCohort%pft,currentCohort%c_area) + + !------------------------------------------ + ! Calculate canopy N assuming patch area is full + !------------------------------------------ + currentCohort%n = currentPatch%area / currentCohort%c_area + + ! ------------------------------------------ + ! Calculate leaf carbon from target treelai + ! ------------------------------------------ + currentCohort%treelai = currentPatch%sp_tlai leaf_c = leafc_from_treelai( currentCohort%treelai, currentCohort%pft, currentCohort%c_area,& currentCohort%n, currentCohort%canopy_layer, currentCohort%vcmax25top) + ! assert sai + currentCohort%treesai = currentPatch%sp_tsai + + !NB these will need to be put through the canopy_structure routine in order to figure out exposed lai and sai + currentPatch => currentPatch%younger end do ! patch loop From 57ba8a35f2cb13aa256a686af3dac7d981d7dcb0 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 10 Sep 2020 11:37:21 +0200 Subject: [PATCH 059/209] added fixed value of spread to c_area --- biogeochem/EDPhysiologyMod.F90 | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 42dbc815c5..9e4a90e1ed 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1342,6 +1342,8 @@ subroutine satellite_phenology ! The leaf area of the cohort is modified each day to match that asserted by the HLM ! ----------------------------------------------------------------------------------- + real(r8) :: spread ! need to send a fixed value of patch spread to carea_allom + ! To Do in this routine. ! Get access to HLM input varialbes. ! Weight them by PFT @@ -1423,6 +1425,9 @@ subroutine satellite_phenology currentCohort%hite = currentPatch%sp_htop call h2d_allom(temp_cohort%hite,ft,temp_cohort%dbh) currentCohort%n = 1.0_r8 ! make n=1 to get area of one tree. + spread = 0.0_r8 ! fix this to 0 to remove dynamics of canopy closure, assuming a closed canopy. + ! n.b. the value of this will only affect 'n', which isn't/shouldn't be a diagnostic in + ! SP mode. call carea_allom(currentCohort%dbh,currentCohort%n,spread,currentCohort%pft,currentCohort%c_area) !------------------------------------------ From ae27d49e9c11ab544214fb9e4859f6ef67aea5cf Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 10 Sep 2020 11:48:35 +0200 Subject: [PATCH 060/209] added setstate call for leaf carbon in satellite_phenology --- biogeochem/EDPhysiologyMod.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 9e4a90e1ed..f383eb0be9 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1444,6 +1444,7 @@ subroutine satellite_phenology ! assert sai currentCohort%treesai = currentPatch%sp_tsai + call SetState(prt,leaf_organ, element_id,leaf_c,1) !NB these will need to be put through the canopy_structure routine in order to figure out exposed lai and sai From d5d4466953c26f2ca57f46a9a2e73e861c4a87af Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 10 Sep 2020 12:12:23 +0200 Subject: [PATCH 061/209] added hlm_use_nocomp to FatesInterfaceTypesMod --- main/FatesInterfaceTypesMod.F90 | 3 +++ 1 file changed, 3 insertions(+) diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index 547e095fa7..9ef9dd8498 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -164,6 +164,9 @@ module FatesInterfaceTypesMod integer, public :: hlm_use_fixed_biogeog ! Flag to use FATES fixed biogeography mode ! 1 = TRUE, 0 = FALSE + integer, public :: hlm_use_nocomp ! Flag to use FATES nocomp mode + ! 1 = TRUE, 0 = FALSE + ! ------------------------------------------------------------------------------------- ! Parameters that are dictated by FATES and known to be required knowledge ! needed by the HLMs From fda950c622b99763cd1349b72eb3099649282b54 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 10 Sep 2020 12:23:03 +0200 Subject: [PATCH 062/209] broadcast nocomp parameter in FatesInterfaceMod.F90 --- main/FatesInterfaceMod.F90 | 24 +++++++++++------------- 1 file changed, 11 insertions(+), 13 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index b43992b94f..db120acc17 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -1263,13 +1263,12 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - ! Future reduced complexity mode - !if(hlm_use_nocomp.eq.unset_int) then - ! if(fates_global_verbose()) then - ! write(fates_log(), *) 'switch for no competition mode. ' - ! end if - ! call endrun(msg=errMsg(sourcefile, __LINE__)) - ! end if + if(hlm_use_nocomp.eq.unset_int) then + if(fates_global_verbose()) then + write(fates_log(), *) 'switch for no competition mode. ' + end if + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if if(hlm_use_cohort_age_tracking .eq. unset_int) then if (fates_global_verbose()) then @@ -1386,12 +1385,11 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) write(fates_log(),*) 'Transfering hlm_use_fixed_biogeog= ',ival,' to FATES' end if - ! Future reduced complexity mode - !case('use_nocomp') - ! hlm_use_nocomp = ival - ! if (fates_global_verbose()) then - ! write(fates_log(),*) 'Transfering hlm_use_nocomp= ',ival,' to FATES' - ! end if + case('use_nocomp') + hlm_use_nocomp = ival + if (fates_global_verbose()) then + write(fates_log(),*) 'Transfering hlm_use_nocomp= ',ival,' to FATES' + end if case('use_planthydro') From 0d84fafed3062c5d0d7f3eff369d375b0be2bfa1 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Fri, 11 Sep 2020 02:13:52 -0600 Subject: [PATCH 063/209] uncomment nocomp statement in FatesInterfaceMod --- main/FatesInterfaceMod.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index db120acc17..43376af24d 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -1015,7 +1015,7 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) hlm_use_ed_st3 = unset_int hlm_use_ed_prescribed_phys = unset_int hlm_use_fixed_biogeog = unset_int - !hlm_use_nocomp = unset_int ! future reduced complexity mode + hlm_use_nocomp = unset_int ! future reduced complexity mode hlm_use_inventory_init = unset_int hlm_inventory_ctrl_file = 'unset' @@ -1265,7 +1265,7 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) if(hlm_use_nocomp.eq.unset_int) then if(fates_global_verbose()) then - write(fates_log(), *) 'switch for no competition mode. ' + write(fates_log(), *) 'switch for no competition mode unset. use_nocomp exiting ' end if call endrun(msg=errMsg(sourcefile, __LINE__)) end if @@ -1384,7 +1384,7 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) if (fates_global_verbose()) then write(fates_log(),*) 'Transfering hlm_use_fixed_biogeog= ',ival,' to FATES' end if - + case('use_nocomp') hlm_use_nocomp = ival if (fates_global_verbose()) then From f8f48673e5a92f46f018ccd11cb2e41e37734438 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Fri, 11 Sep 2020 02:15:08 -0600 Subject: [PATCH 064/209] remove typo in EDInitMod --- main/EDPftvarcon.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index bed41f0eab..0adffbef4d 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -920,7 +920,7 @@ subroutine Register_PFT(this, fates_params) ! adding the hlm_pft_map variable with two dimensions - FATES PFTno and HLM PFTno pftmap_dim_names(1) = dimension_name_pft - pftmap_dim_names(2) = dimension_name_hlm_pftno xs + pftmap_dim_names(2) = dimension_name_hlm_pftno name = 'fates_hlm_pft_map' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & dimension_names=pftmap_dim_names, lower_bounds=dim_lower_bound) From 11961e4e71093f816c503e783b9c4edd9b45e89d Mon Sep 17 00:00:00 2001 From: rosiealice Date: Fri, 11 Sep 2020 02:47:35 -0600 Subject: [PATCH 065/209] removed extra write statements from EDPatchDynamicsMod --- biogeochem/EDPatchDynamicsMod.F90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index d0fe122e50..be75565516 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -2619,7 +2619,6 @@ subroutine terminate_patches(currentSite) !--------------------------------------------------------------------- count_cycles = 0 -!write(*,*) 'start terminate patches',currentSite%lat,currentSite%lon currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) @@ -2837,7 +2836,7 @@ subroutine terminate_patches(currentSite) !check area is not exceeded call check_patch_area( currentSite ) -! write(*,*) 'leaving terminate patches',currentSite%lat,currentSite%lon + return end subroutine terminate_patches From fe2169f30ad3b54ccc88b4eb914cfb22da44abff Mon Sep 17 00:00:00 2001 From: rosiealice Date: Fri, 11 Sep 2020 02:52:25 -0600 Subject: [PATCH 066/209] added comment on EDPatchDynamicsMod --- biogeochem/EDPatchDynamicsMod.F90 | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index be75565516..663471fb6d 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -2726,6 +2726,13 @@ subroutine terminate_patches(currentSite) enddo !fusing patch is_oldest = itrue !try and find a younger same-PFT patch + !-------------------------------------------------- + ! n.b. The following code is to figure out how to + ! terminate small patches in nocomp mode + ! It was written in the context of the multi-patch version + ! which is currently inactive and may or may not be needed in the + ! single patch version. + !-------------------------------------------------- ! discover if this is the youngest patch of its PFT fusingPatch => currentPatch%older !if it's the youngest overall then it's defacto youngest of PFT do while(associated(fusingPatch).and.is_oldest.eq.itrue) From 812aa3bc2617a12d056c86ee8da9f9cabf6a6370 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Fri, 11 Sep 2020 03:07:40 -0600 Subject: [PATCH 067/209] debugging --- biogeochem/FatesAllometryMod.F90 | 6 ++++-- main/EDPftvarcon.F90 | 2 +- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/biogeochem/FatesAllometryMod.F90 b/biogeochem/FatesAllometryMod.F90 index 6c33e5c8f8..c397ab5bea 100644 --- a/biogeochem/FatesAllometryMod.F90 +++ b/biogeochem/FatesAllometryMod.F90 @@ -776,7 +776,7 @@ real(r8) function leafc_from_treelai( treelai, pft, c_area, nplant, cl, vcmax25t ! top, ref 25C ! !LOCAL VARIABLES: - real(r8), :: leaf_c ! plant leaf carbon [kg] + real(r8) :: leaf_c ! plant leaf carbon [kg] real(r8) :: leafc_per_unitarea ! KgC of leaf per m2 area of ground. real(r8) :: slat ! the sla of the top leaf layer. m2/kgC real(r8) :: vai_per_lai ! ratio of vegetation area index (ie. sai+lai) @@ -789,7 +789,9 @@ real(r8) function leafc_from_treelai( treelai, pft, c_area, nplant, cl, vcmax25t real(r8) :: clim ! Upper limit for leafc_per_unitarea in exponential ! tree_lai function real(r8) :: tree_lai_at_slamax ! lai at which we reach the maximum sla value. - + real(r8) :: leafc_linear_phase ! amount of leaf carbon needed to get to the target treelai + ! when the slamax value has been reached (i.e. deep layers with unchanging sla) + !---------------------------------------------------------------------- if( treelai < 0._r8.or. pft == 0 ) then diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index bed41f0eab..0adffbef4d 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -920,7 +920,7 @@ subroutine Register_PFT(this, fates_params) ! adding the hlm_pft_map variable with two dimensions - FATES PFTno and HLM PFTno pftmap_dim_names(1) = dimension_name_pft - pftmap_dim_names(2) = dimension_name_hlm_pftno xs + pftmap_dim_names(2) = dimension_name_hlm_pftno name = 'fates_hlm_pft_map' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & dimension_names=pftmap_dim_names, lower_bounds=dim_lower_bound) From a49c7dd4a0e1d2a196713444f7204468cb281b36 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Fri, 11 Sep 2020 03:10:04 -0600 Subject: [PATCH 068/209] changed SP input variable names in FatesInterfaceTypesMod --- main/FatesInterfaceTypesMod.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index 65689ce73c..be21cb4de3 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -480,9 +480,9 @@ module FatesInterfaceTypesMod ! Satellite Phenology (SP) input variables. (where each patch only has one PFT) ! --------------------------------------------------------------------------------- - real(r8),allocatable :: sp_tlai(:) ! Interpolated daily total LAI (leaf area index) input from HLM per patch/pft - real(r8),allocatable :: sp_tsai(:) ! Interpolated sailt total SAI (stem area index) input from HLM per patch/pft - real(r8),allocatable :: sp_htop(:) ! Interpolated daily canopy vegetation height input from HLM per patch/pft + real(r8),allocatable :: hlm_sp_tlai(:) ! Interpolated daily total LAI (leaf area index) input from HLM per patch/pft + real(r8),allocatable :: hlm_sp_tsai(:) ! Interpolated sailt total SAI (stem area index) input from HLM per patch/pft + real(r8),allocatable :: hlm_sp_htop(:) ! Interpolated daily canopy vegetation height input from HLM per patch/pft end type bc_in_type From 875c9d4db14c3c2997b42324c48303e3d00efa51 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Fri, 11 Sep 2020 04:54:54 -0600 Subject: [PATCH 069/209] debugging EDPhysiologyMod.F90 --- biogeochem/EDPhysiologyMod.F90 | 134 +++++++++++++++++++-------------- 1 file changed, 76 insertions(+), 58 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 42dbc815c5..d8a6db408d 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -15,6 +15,7 @@ module EDPhysiologyMod use FatesInterfaceTypesMod, only : nleafage use FatesInterfaceTypesMod, only : hlm_use_planthydro use FatesInterfaceTypesMod, only : hlm_parteh_mode + use FatesInterfaceTypesMod, only : hlm_use_fixed_biogeog use FatesConstantsMod, only : r8 => fates_r8 use FatesConstantsMod, only : nearzero use FatesConstantsMod, only : g_per_kg @@ -1334,7 +1335,7 @@ end subroutine phenology_leafonoff ! ===================================================================================== - subroutine satellite_phenology + subroutine satellite_phenology(currentSite, bc_in) ! ----------------------------------------------------------------------------------- ! Takes the daily inputs of leaf area index, stem area index and canopy height and @@ -1342,6 +1343,25 @@ subroutine satellite_phenology ! The leaf area of the cohort is modified each day to match that asserted by the HLM ! ----------------------------------------------------------------------------------- + ! !USES: + ! + ! !ARGUMENTS: + type(ed_site_type), intent(inout), target :: currentSite + type(bc_in_type), intent(in) :: bc_in + + class(prt_vartypes), pointer :: prt + + ! !LOCAL VARIABLES: + type(ed_patch_type) , pointer :: currentPatch + type(ed_cohort_type), pointer :: currentCohort + + real(r8) :: spread ! dummy value of canopy spread to estimate c_area + real(r8) :: leaf_c ! leaf carbon estimated to generate target tlai + + integer :: fates_pft ! fates pft numer for weighting loop + integer :: hlm_pft ! host land model pft number for weighting loop. + integer :: s ! site index + ! To Do in this routine. ! Get access to HLM input varialbes. ! Weight them by PFT @@ -1351,10 +1371,9 @@ subroutine satellite_phenology ! figure out how this will interact with the canopy_structure routines. ! determine what 'n' should be from the canopy height. - currentPatch => currentSite%oldest_patch - do while (associated(currentPatch)) + currentPatch => currentSite%oldest_patch + do while (associated(currentPatch)) - if(hlm_use_fixed_biogeog.eq.itrue)then ! WEIGHTING OF FATES PFTs on to HLM_PFTs ! add up the area associated with each FATES PFT ! where pft_areafrac is the area of land in each HLM PFT and (from surface dataset) @@ -1365,34 +1384,32 @@ subroutine satellite_phenology currentSite%sp_htop(1:numpft) = 0._r8 ! weight each fates PFT target for lai, sai and htop by the area of the - ! contrbuting HLM PFTs. + ! contrbuting HLM PFTs. + ! we only need to do this for the patch/fates_pft we are currently in + fates_pft = currentPatch%nocomp_pft_label do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) - do fates_pft = 1,numpft ! loop round all fates pfts for all hlm pfts - if(sites(s)%area_pft(ft).gt.0.0_r8)then - !leaf area index - currentSite%sp_tlai(fates_pft) = currentSite%sp_tlai(fates_pft) + & - bc_in(s)%hlm_sp_tlai(hlm_pft) * bc_in(s)%pft_areafrac(hlm_pft) - !stem area index - currentSite%sp_tsai(fates_pft) = currentSite%sp_tsai(fates_pft) + & - bc_in(s)%hlm_sp_tsai(hlm_pft) * bc_in(s)%pft_areafrac(hlm_pft) - ! canopy height - currentSite%sp_htop(fates_pft) = currentSite%sp_htop(fates_pft) + & - bc_in(s)%hlm_sp_htop(hlm_pft) * bc_in(s)%pft_areafrac(hlm_pft) - end if ! there is some area in this patch - end do + if(bc_in%pft_areafrac(hlm_pft).gt.0.0_r8)then + !leaf area index + currentSite%sp_tlai(fates_pft) = currentSite%sp_tlai(fates_pft) + & + bc_in%hlm_sp_tlai(hlm_pft) * bc_in%pft_areafrac(hlm_pft) + !stem area index + currentSite%sp_tsai(fates_pft) = currentSite%sp_tsai(fates_pft) + & + bc_in%hlm_sp_tsai(hlm_pft) * bc_in%pft_areafrac(hlm_pft) + ! canopy height + currentSite%sp_htop(fates_pft) = currentSite%sp_htop(fates_pft) + & + bc_in%hlm_sp_htop(hlm_pft) * bc_in%pft_areafrac(hlm_pft) + end if ! there is some area in this patch end do !hlm_pft - ! weight for total area in each fates_pft - do fates_pft = 1,numpft - if(sites(s)%area_pft(ft).gt.0.0_r8)then + ! weight for total area in each patch/fates_pft + if(currentPatch%area.gt.0.0_r8)then + currentSite%sp_htop(fates_pft) = currentSite%sp_htop(fates_pft) & + /currentPatch%area + currentSite%sp_htop(fates_pft) = currentSite%sp_htop(fates_pft) & + /currentPatch%area currentSite%sp_htop(fates_pft) = currentSite%sp_htop(fates_pft) & - /sites(s)%area_pft(ft) - currentSite%sp_htop(fates_pft) = currentSite%sp_htop(fates_pft) & - /sites(s)%area_pft(ft) - currentSite%sp_htop(fates_pft) = currentSite%sp_htop(fates_pft) & - /sites(s)%area_pft(ft) - endif - enddo !fates_pft + /currentPatch%area + endif ! ------------------------------------------------------------ ! now we have the target lai, sai and htop for each PFT/patch @@ -1405,43 +1422,44 @@ subroutine satellite_phenology do while (associated(currentCohort)) ! Do some checks - if(associated(currentCohort%shorter) - write(*,*) "there is more than one cohort in SP mode.' + if(associated(currentCohort%shorter))then + write(*,*) "there is more than one cohort in SP mode" end if - ft =currentCohort%pft - if(ft.ne.currentPatch%nocomp_pft)then - write(*,*) 'wrong PFT label in cohort in SP mode',ft,currentPatch%nocomp_pft + fates_pft =currentCohort%pft + if(fates_pft.ne.currentPatch%nocomp_pft_label)then + write(*,*) 'wrong PFT label in cohort in SP mode',fates_pft,currentPatch%nocomp_pft_label end if - currentCohort => currentCohort%shorter - end do !cohort loop - - !------------------------------------------ - ! Calculate dbh from input height, and c_area from dbh - !------------------------------------------ - currentCohort%hite = currentPatch%sp_htop - call h2d_allom(temp_cohort%hite,ft,temp_cohort%dbh) - currentCohort%n = 1.0_r8 ! make n=1 to get area of one tree. - call carea_allom(currentCohort%dbh,currentCohort%n,spread,currentCohort%pft,currentCohort%c_area) - - !------------------------------------------ - ! Calculate canopy N assuming patch area is full - !------------------------------------------ - currentCohort%n = currentPatch%area / currentCohort%c_area - - ! ------------------------------------------ - ! Calculate leaf carbon from target treelai - ! ------------------------------------------ - currentCohort%treelai = currentPatch%sp_tlai - leaf_c = leafc_from_treelai( currentCohort%treelai, currentCohort%pft, currentCohort%c_area,& + !------------------------------------------ + ! Calculate dbh from input height, and c_area from dbh + !------------------------------------------ + currentCohort%hite = currentSite%sp_htop(fates_pft) + call h2d_allom(currentCohort%hite,currentCohort%pft,currentCohort%dbh) + currentCohort%n = 1.0_r8 ! make n=1 to get area of one tree. + spread = 0.0_r8 + call carea_allom(currentCohort%dbh,currentCohort%n,spread,currentCohort%pft,currentCohort%c_area) + + !------------------------------------------ + ! Calculate canopy N assuming patch area is full + !------------------------------------------ + currentCohort%n = currentPatch%area / currentCohort%c_area + + ! ------------------------------------------ + ! Calculate leaf carbon from target treelai + ! ------------------------------------------ + currentCohort%treelai = currentSite%sp_tlai(fates_pft) + leaf_c = leafc_from_treelai( currentCohort%treelai, currentCohort%pft, currentCohort%c_area,& currentCohort%n, currentCohort%canopy_layer, currentCohort%vcmax25top) + call SetState(currentCohort%prt,leaf_organ,1,leaf_c,1) + + ! assert sai + currentCohort%treesai = currentSite%sp_tsai(fates_pft) - ! assert sai - currentCohort%treesai = currentPatch%sp_tsai - - !NB these will need to be put through the canopy_structure routine in order to figure out exposed lai and sai + !NB these will need to be put through the canopy_structure routine in order to figure out exposed lai and sai + currentCohort => currentCohort%shorter + end do !cohort loop currentPatch => currentPatch%younger end do ! patch loop From e4762b24dead38e3d5beb2aad91c0a8b529083cc Mon Sep 17 00:00:00 2001 From: rosiealice Date: Fri, 11 Sep 2020 04:55:15 -0600 Subject: [PATCH 070/209] debugging main/EDMainMod.F90 --- main/EDMainMod.F90 | 20 ++++++++------------ 1 file changed, 8 insertions(+), 12 deletions(-) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index bbbbe696c8..6629627bd4 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -19,6 +19,7 @@ module EDMainMod use FatesInterfaceTypesMod , only : hlm_reference_date use FatesInterfaceTypesMod , only : hlm_use_ed_prescribed_phys use FatesInterfaceTypesMod , only : hlm_use_ed_st3 + use FatesInterfaceTypesMod , only : hlm_use_sp use FatesInterfaceTypesMod , only : bc_in_type use FatesInterfaceTypesMod , only : hlm_masterproc use FatesInterfaceTypesMod , only : numpft @@ -172,8 +173,8 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) ! We do not allow phenology while in ST3 mode either, it is hypothetically ! possible to allow this, but we have not plugged in the litter fluxes ! of flushing or turning over leaves for non-dynamics runs - if (hlm_use_ed_st3.eq.ifalse) then - if(hlm_use_sp.eq.false) + if (hlm_use_ed_st3.eq.ifalse)then + if(hlm_use_sp.eq.ifalse) then call phenology(currentSite, bc_in ) else call satellite_phenology(currentSite, bc_in ) @@ -181,7 +182,7 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) end if - if (hlm_use_ed_st3.eq.ifalse.and.hlm_use_sp.eq.false) then ! Bypass if ST3 + if (hlm_use_ed_st3.eq.ifalse.and.hlm_use_sp.eq.ifalse) then ! Bypass if ST3 call fire_model(currentSite, bc_in) ! Calculate disturbance and mortality based on previous timestep vegetation. @@ -189,7 +190,7 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) call disturbance_rates(currentSite, bc_in) end if - if (hlm_use_ed_st3.eq.ifalse.and.hlm_use_sp.eq.false) then + if (hlm_use_ed_st3.eq.ifalse.and.hlm_use_sp.eq.ifalse) then ! Integrate state variables from annual rates to daily timestep call ed_integrate_state_variables(currentSite, bc_in ) else @@ -207,7 +208,7 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) ! Reproduction, Recruitment and Cohort Dynamics : controls cohort organization !****************************************************************************** - if(hlm_use_ed_st3.eq.ifalse.and.hlm_use_sp.eq.false) then + if(hlm_use_ed_st3.eq.ifalse.and.hlm_use_sp.eq.ifalse) then currentPatch => currentSite%oldest_patch do while (associated(currentPatch)) @@ -221,7 +222,7 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) call TotalBalanceCheck(currentSite,1) - if( hlm_use_ed_st3.eq.ifalse .and.hlm_use_sp.eq.false ) then + if( hlm_use_ed_st3.eq.ifalse .and.hlm_use_sp.eq.ifalse ) then currentPatch => currentSite%oldest_patch do while (associated(currentPatch)) @@ -260,15 +261,10 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) do_patch_dynamics = ifalse end if - if(hlm_use_sp.eq.itrue) ! cover for potential changes in nocomp logic above. + if(hlm_use_sp.eq.itrue)then ! cover for potential changes in nocomp logic above. do_patch_dynamics = ifalse end if - if(hlm_use_sp.eq.itrue)then - ! if we want to assert LAI - do_patch_dynamics = ifalse - end if - ! make new patches from disturbed land if (do_patch_dynamics.eq.itrue ) then call spawn_patches(currentSite, bc_in) From a33655a2777f24d5ebcfef8b62af60f3f74f3abc Mon Sep 17 00:00:00 2001 From: rosiealice Date: Fri, 11 Sep 2020 07:58:14 -0600 Subject: [PATCH 071/209] read use_sp in FatesInterfaceMod.F90 --- main/FatesInterfaceMod.F90 | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index ebd8a5392e..926da38def 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -1402,13 +1402,18 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) write(fates_log(),*) 'Transfering hlm_use_fixed_biogeog= ',ival,' to FATES' end if - ! Future reduced complexity mode case('use_nocomp') hlm_use_nocomp = ival if (fates_global_verbose()) then write(fates_log(),*) 'Transfering hlm_use_nocomp= ',ival,' to FATES' end if + case('use_sp') + hlm_use_sp = ival + if (fates_global_verbose()) then + write(fates_log(),*) 'Transfering hlm_use_sp= ',ival,' to FATES' + end if + case('use_planthydro') hlm_use_planthydro = ival From 97b39f10ddfb22f6c701def57263729e56cdf557 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Fri, 11 Sep 2020 08:03:08 -0600 Subject: [PATCH 072/209] commenting out balance check --- main/EDMainMod.F90 | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 6629627bd4..127ace6913 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -219,8 +219,9 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) enddo end if - - call TotalBalanceCheck(currentSite,1) + if(hlm_use_sp.eq.ifalse)then + call TotalBalanceCheck(currentSite,1) + end if if( hlm_use_ed_st3.eq.ifalse .and.hlm_use_sp.eq.ifalse ) then currentPatch => currentSite%oldest_patch @@ -242,9 +243,10 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) currentPatch => currentPatch%younger enddo end if - - call TotalBalanceCheck(currentSite,2) + if(hlm_use_sp.eq.ifalse)then + call TotalBalanceCheck(currentSite,2) + end if !********************************************************************************* ! Patch dynamics sub-routines: fusion, new patch creation (spwaning), termination. !********************************************************************************* From 0028a57cd2eefe05155c092ee00c7e66998a5dd0 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 14 Sep 2020 02:57:32 -0600 Subject: [PATCH 073/209] turned off balance check calls in SP mode in EDMain --- main/EDMainMod.F90 | 21 ++++++++++++++------- 1 file changed, 14 insertions(+), 7 deletions(-) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 127ace6913..7d3df65365 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -168,8 +168,9 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) call ZeroLitterFluxes(currentSite) ! Zero mass balance - call TotalBalanceCheck(currentSite, 0) - + if(hlm_use_sp.eq.ifalse)then + call TotalBalanceCheck(currentSite, 0) + end if ! We do not allow phenology while in ST3 mode either, it is hypothetically ! possible to allow this, but we have not plugged in the litter fluxes ! of flushing or turning over leaves for non-dynamics runs @@ -271,8 +272,10 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) if (do_patch_dynamics.eq.itrue ) then call spawn_patches(currentSite, bc_in) end if - - call TotalBalanceCheck(currentSite,3) + + if(hlm_use_sp.eq.ifalse)then + call TotalBalanceCheck(currentSite,3) + end if ! fuse on the spawned patches. if ( do_patch_dynamics.eq.itrue ) then @@ -569,12 +572,16 @@ subroutine ed_update_site( currentSite, bc_in ) !----------------------------------------------------------------------- call canopy_spread(currentSite) - - call TotalBalanceCheck(currentSite,6) + + if(hlm_use_sp.eq.ifalse)then + call TotalBalanceCheck(currentSite,6) + end if call canopy_structure(currentSite, bc_in) - call TotalBalanceCheck(currentSite,final_check_id) + if(hlm_use_sp.eq.ifalse)then + call TotalBalanceCheck(currentSite,final_check_id) + end if currentPatch => currentSite%oldest_patch do while(associated(currentPatch)) From 6bfa6b2306ffc0b76a7a8b88460f17443a35bca9 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 14 Sep 2020 03:03:37 -0600 Subject: [PATCH 074/209] check for hlm_pft_area --- main/EDPftvarcon.F90 | 24 +++++++++++++++++++++--- 1 file changed, 21 insertions(+), 3 deletions(-) diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index 0adffbef4d..4dd3594af9 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -2137,6 +2137,7 @@ subroutine FatesCheckParams(is_master, parteh_mode) use FatesConstantsMod , only : fates_check_param_set use FatesConstantsMod , only : itrue, ifalse use EDParamsMod , only : logging_mechanical_frac, logging_collateral_frac, logging_direct_frac + use FatesInterfaceTypesMod , only : hlm_use_fixed_biogeog ! Argument logical, intent(in) :: is_master ! Only log if this is the master proc @@ -2149,6 +2150,10 @@ subroutine FatesCheckParams(is_master, parteh_mode) integer :: nleafage ! size of the leaf age class array integer :: iage ! leaf age class index integer :: norgans ! size of the plant organ dimension + integer :: hlm_pft ! used in fixed biogeog mode + integer :: fates_pft ! used in fixed biogeog mode + + real(r8) :: sumarea ! area of PFTs in nocomp mode. npft = size(EDPftvarcon_inst%evergreen,1) @@ -2704,7 +2709,7 @@ subroutine FatesCheckParams(is_master, parteh_mode) end if end if - end do + end do ! iage ! Check the turnover rates on the senescing leaf pool if ( EDPftvarcon_inst%leaf_long(ipft,nleafage)>nearzero ) then @@ -2770,8 +2775,21 @@ subroutine FatesCheckParams(is_master, parteh_mode) end if - end do - + end do !ipft + + ! check that the host-fates PFT map adds to one in both dimension + + do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) + sumarea = sum(EDPftvarcon_inst%hlm_pft_map(1:npft,hlm_oft)) + if(abs(sumarea-1.0_r8).gt. )then + write(fates_log(),*) 'The distribution of this host land model PFT :',hlm_pft + write(fates_log(),*) 'into FATES PFTs, does not add up to 1.0.' + write(fates_log(),*) 'Error is:',sumarea-1.0_r8 + write(fates_log(),*) 'and the hlm_pft_map is:', EDPftvarcon_inst%hlm_pft_map(1:npft,hlm_oft) + write(fates_log(),*) 'Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end do !ipft + !! ! Checks for HYDRO !! if( hlm_use_planthydro == itrue ) then !! From 9eefda82636e318b9594b175bee79d10eaff757f Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 14 Sep 2020 03:03:37 -0600 Subject: [PATCH 075/209] check for hlm_pft_area --- main/EDPftvarcon.F90 | 24 +++++++++++++++++++++--- 1 file changed, 21 insertions(+), 3 deletions(-) diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index 0adffbef4d..4dd3594af9 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -2137,6 +2137,7 @@ subroutine FatesCheckParams(is_master, parteh_mode) use FatesConstantsMod , only : fates_check_param_set use FatesConstantsMod , only : itrue, ifalse use EDParamsMod , only : logging_mechanical_frac, logging_collateral_frac, logging_direct_frac + use FatesInterfaceTypesMod , only : hlm_use_fixed_biogeog ! Argument logical, intent(in) :: is_master ! Only log if this is the master proc @@ -2149,6 +2150,10 @@ subroutine FatesCheckParams(is_master, parteh_mode) integer :: nleafage ! size of the leaf age class array integer :: iage ! leaf age class index integer :: norgans ! size of the plant organ dimension + integer :: hlm_pft ! used in fixed biogeog mode + integer :: fates_pft ! used in fixed biogeog mode + + real(r8) :: sumarea ! area of PFTs in nocomp mode. npft = size(EDPftvarcon_inst%evergreen,1) @@ -2704,7 +2709,7 @@ subroutine FatesCheckParams(is_master, parteh_mode) end if end if - end do + end do ! iage ! Check the turnover rates on the senescing leaf pool if ( EDPftvarcon_inst%leaf_long(ipft,nleafage)>nearzero ) then @@ -2770,8 +2775,21 @@ subroutine FatesCheckParams(is_master, parteh_mode) end if - end do - + end do !ipft + + ! check that the host-fates PFT map adds to one in both dimension + + do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) + sumarea = sum(EDPftvarcon_inst%hlm_pft_map(1:npft,hlm_oft)) + if(abs(sumarea-1.0_r8).gt. )then + write(fates_log(),*) 'The distribution of this host land model PFT :',hlm_pft + write(fates_log(),*) 'into FATES PFTs, does not add up to 1.0.' + write(fates_log(),*) 'Error is:',sumarea-1.0_r8 + write(fates_log(),*) 'and the hlm_pft_map is:', EDPftvarcon_inst%hlm_pft_map(1:npft,hlm_oft) + write(fates_log(),*) 'Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end do !ipft + !! ! Checks for HYDRO !! if( hlm_use_planthydro == itrue ) then !! From b5e9bcd02851e68a25262f9a44e389b69576e761 Mon Sep 17 00:00:00 2001 From: Rosie Fisher Date: Mon, 14 Sep 2020 11:27:21 +0200 Subject: [PATCH 076/209] Update main/EDInitMod.F90 Co-authored-by: Charlie Koven --- main/EDInitMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 37a4e5787c..5ffd8963d3 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -449,7 +449,7 @@ subroutine init_patches( nsites, sites, bc_in) if(hlm_use_nocomp.eq.itrue)then nocomp_pft = n else - nocomp_pft = 999 + nocomp_pft = fates_unset_int end if if(hlm_use_nocomp.eq.itrue)then From ae5582dae26f6a4d7b74bd7b7745af6c5f95fdcc Mon Sep 17 00:00:00 2001 From: Rosie Fisher Date: Mon, 14 Sep 2020 11:28:05 +0200 Subject: [PATCH 077/209] Typo main/EDInitMod.F90 Co-authored-by: Charlie Koven --- main/EDInitMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 5ffd8963d3..cddf7e818a 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -591,7 +591,7 @@ subroutine init_cohorts( site_in, patch_in, bc_in) patch_in%tallest => null() patch_in%shortest => null() - ! Manage interactions of ixed biogeg (site level filter) and + ! Manage interactions of fixed biogeog (site level filter) and ! nocomp (patch level filter) ! Need to cover all potential biogeog x nocomp combinations ! 1. biogeog = false. nocomp = false: all PFTs on (DEFAULT) From a812a358e78bc2c134da50c8751228925613e15a Mon Sep 17 00:00:00 2001 From: Rosie Fisher Date: Mon, 14 Sep 2020 11:28:38 +0200 Subject: [PATCH 078/209] Small number tolerance in main/EDInitMod.F90 Co-authored-by: Charlie Koven --- main/EDInitMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index cddf7e818a..14a4d1f370 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -620,7 +620,7 @@ subroutine init_cohorts( site_in, patch_in, bc_in) do pft = 1,numpft if(use_pft_local(pft).eq.itrue)then - if(EDPftvarcon_inst%initd(pft)>1.0E-7) then + if(EDPftvarcon_inst%initd(pft)>nearzero) then allocate(temp_cohort) ! temporary cohort From 5a464232066fb4616566bba5f119607038451720 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 14 Sep 2020 03:56:26 -0600 Subject: [PATCH 079/209] removed now irrelevant comment in FatesInterfaceMod.F90 --- main/FatesInterfaceMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 43376af24d..2b3e5eed4e 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -1015,7 +1015,7 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) hlm_use_ed_st3 = unset_int hlm_use_ed_prescribed_phys = unset_int hlm_use_fixed_biogeog = unset_int - hlm_use_nocomp = unset_int ! future reduced complexity mode + hlm_use_nocomp = unset_int hlm_use_inventory_init = unset_int hlm_inventory_ctrl_file = 'unset' From 95737dd782a6651647832c121890c63aac4b5143 Mon Sep 17 00:00:00 2001 From: Rosie Fisher Date: Mon, 14 Sep 2020 12:07:18 +0200 Subject: [PATCH 080/209] minor typo in biogeochem/EDPatchDynamicsMod.F90 Co-authored-by: Charlie Koven --- biogeochem/EDPatchDynamicsMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 663471fb6d..b99b6a430e 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -2518,7 +2518,7 @@ subroutine fuse_2_patches(csite, dp, rp) else snull = 1 rp%shortest => currentCohort - Endif + endif call insert_cohort(currentCohort, rp%tallest, rp%shortest, tnull, snull, storebigcohort, storesmallcohort) From 9f38e0c07861f902136212120672ef65f7b92a98 Mon Sep 17 00:00:00 2001 From: Rosie Fisher Date: Mon, 14 Sep 2020 12:08:35 +0200 Subject: [PATCH 081/209] comment in biogeochem/EDPatchDynamicsMod.F90 Co-authored-by: Charlie Koven --- biogeochem/EDPatchDynamicsMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index b99b6a430e..216d21c747 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -2663,7 +2663,7 @@ subroutine terminate_patches(currentSite) ! patch. As mentioned earlier, we try not to fuse it. gotfused = .true. - else !anthro label + else !anthro labels of two patches are not the same 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 From 74a4fe7f984a2d127b3d835a6b1634b5fc82ca1c Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 14 Sep 2020 04:17:10 -0600 Subject: [PATCH 082/209] typo in EDPftvarcon.F90 --- main/EDPftvarcon.F90 | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index 4dd3594af9..a63b0e8797 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -2780,14 +2780,15 @@ subroutine FatesCheckParams(is_master, parteh_mode) ! check that the host-fates PFT map adds to one in both dimension do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) - sumarea = sum(EDPftvarcon_inst%hlm_pft_map(1:npft,hlm_oft)) - if(abs(sumarea-1.0_r8).gt. )then + sumarea = sum(EDPftvarcon_inst%hlm_pft_map(1:npft,hlm_pft)) + if(abs(sumarea-1.0_r8).gt. nearzero )then write(fates_log(),*) 'The distribution of this host land model PFT :',hlm_pft write(fates_log(),*) 'into FATES PFTs, does not add up to 1.0.' write(fates_log(),*) 'Error is:',sumarea-1.0_r8 - write(fates_log(),*) 'and the hlm_pft_map is:', EDPftvarcon_inst%hlm_pft_map(1:npft,hlm_oft) + write(fates_log(),*) 'and the hlm_pft_map is:', EDPftvarcon_inst%hlm_pft_map(1:npft,hlm_pft) write(fates_log(),*) 'Aborting' call endrun(msg=errMsg(sourcefile, __LINE__)) + end if end do !ipft !! ! Checks for HYDRO From 6b1d5f2dbc498c2943c3006621b9ba3ea32a7f65 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 14 Sep 2020 04:43:03 -0600 Subject: [PATCH 083/209] removing modifications from terminate_patches --- biogeochem/EDPatchDynamicsMod.F90 | 109 +----------------------------- 1 file changed, 2 insertions(+), 107 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 216d21c747..5279b166ac 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -2604,15 +2604,10 @@ subroutine terminate_patches(currentSite) ! !LOCAL VARIABLES: type(ed_patch_type), pointer :: currentPatch type(ed_patch_type), pointer :: olderPatch - type(ed_patch_type), pointer :: oldercPatch type(ed_patch_type), pointer :: youngerPatch - type(ed_patch_type), pointer :: fusingPatch integer, parameter :: max_cycles = 10 ! After 10 loops through ! You should had fused integer :: count_cycles - integer :: is_youngest - integer :: is_oldest - integer :: found_fusion_patch logical :: gotfused real(r8) areatot ! variable for checking whether the total patch area is wrong. @@ -2622,10 +2617,9 @@ subroutine terminate_patches(currentSite) currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) - oldercpatch => currentPatch%older + if(currentPatch%area <= min_patch_area)then - if(hlm_use_nocomp.eq.ifalse)then !just fuse to older or younger patch ! 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 @@ -2703,96 +2697,6 @@ subroutine terminate_patches(currentSite) endif ! older or younder patch endif ! very small area - else !nocomp. We cannot fuse to patches with a different PFT identity in no competition mode. - - ! Each patch has a PFT identity, and so cannot simply fuse to the older or younger patch - ! For each small current patch, we must first search older patch candidates, and then younger - ! patch candidates. - ! need to think about the youngest of PFT logic later. - - is_youngest = itrue !try and find a younger same-PFT patch - ! discover if this is the youngest patch of its PFT - fusingPatch => currentPatch%younger !if it's the youngest overall then it's defacto youngest of PFT - do while(associated(fusingPatch).and.is_youngest.eq.itrue) - if(fusingPatch%nocomp_pft_label.eq.currentPatch%nocomp_pft_label)then - is_youngest = ifalse ! we found a yonger patch, so this isn't the youngest one. - endif ! PFT - if(associated(fusingpatch%younger))then - if(fusingpatch%patchno.eq.fusingpatch%younger%patchno)then - write(*,*) 'is_youngest patch list error',fusingpatch%patchno,fusingpatch%younger%patchno - endif - endif - fusingPatch => fusingPatch%younger - enddo !fusing patch - - is_oldest = itrue !try and find a younger same-PFT patch - !-------------------------------------------------- - ! n.b. The following code is to figure out how to - ! terminate small patches in nocomp mode - ! It was written in the context of the multi-patch version - ! which is currently inactive and may or may not be needed in the - ! single patch version. - !-------------------------------------------------- - ! discover if this is the youngest patch of its PFT - fusingPatch => currentPatch%older !if it's the youngest overall then it's defacto youngest of PFT - do while(associated(fusingPatch).and.is_oldest.eq.itrue) - if(fusingPatch%nocomp_pft_label.eq.currentPatch%nocomp_pft_label)then - is_oldest = ifalse ! we found a yonger patch, so this isn't the youngest one. - endif ! PFT - fusingPatch => fusingPatch%older - enddo !fusing patch - - if (is_youngest.eq.ifalse .or. currentPatch%area <= min_patch_area_forced ) then - found_fusion_patch = ifalse - - fusingPatch => currentPatch%older - do while(associated(fusingPatch).and.found_fusion_patch.eq.ifalse ) - olderPatch => fusingPatch%older - if(associated(fusingpatch%younger))then - if(fusingpatch%patchno.eq.fusingpatch%younger%patchno)then - write(*,*) 'fuse older patch list error',fusingpatch%patchno,fusingpatch%younger%patchno - endif - endif - if(fusingPatch%nocomp_pft_label.eq.currentPatch%nocomp_pft_label)then - if(debug) & - write(fates_log(),*) 'fusing to older patch of same PFT - this one is too small',& - currentPatch%area, fusingPatch%area, & - currentPatch%nocomp_pft_label, fusingPatch%nocomp_pft_label, & - currentPatch%patchno, fusingPatch%patchno - call fuse_2_patches(currentSite, currentPatch, fusingPatch) - currentPatch => fusingPatch !redirect rest of main loop back to this cp - found_fusion_patch=itrue - endif ! PFT - fusingPatch => olderPatch - enddo !fusing patch - - if(associated(currentPatch).and.found_fusion_patch.eq.ifalse)then - ! if no older patches, search younger ones. - fusingPatch => currentPatch%younger - do while(associated(fusingPatch).and.found_fusion_patch.eq.ifalse ) - olderPatch => fusingPatch%older - - if(fusingPatch%nocomp_pft_label.eq.currentPatch%nocomp_pft_label)then - if(debug) & - write(fates_log(),*) 'fusing to younger patch of same PFT - this one is too small',& - currentPatch%area, fusingPatch%area , & - currentPatch%nocomp_pft_label, fusingPatch%nocomp_pft_label, & - currentPatch%patchno, fusingPatch%patchno,& - is_youngest,is_oldest - call fuse_2_patches(currentSite, currentPatch, fusingPatch) - currentPatch => fusingPatch - found_fusion_patch=itrue - endif ! PFT - fusingPatch => olderPatch - enddo !fusing patch - endif !current patch exists. - - - endif ! not youngest, or is very small patch - endif !nocomp - endif ! small area - - ! It is possible that an incredibly small patch just fused into another incredibly ! small patch, resulting in an incredibly small patch. It is also possible that this ! resulting incredibly small patch is the oldest patch. If this was true than @@ -2810,11 +2714,6 @@ subroutine terminate_patches(currentSite) end if if(count_cycles > max_cycles) then - if(is_oldest.eq.itrue.and.is_youngest.eq.itrue.and.hlm_use_nocomp)then - write(fates_log(),*) 'this is the only patch of this PFT',currentPatch%area - currentPatch => currentPatch%older - count_cycles = 0 - else !not the only patch write(fates_log(),*) 'FATES is having difficulties fusing very small patches.' write(fates_log(),*) 'It is possible that a either a secondary or primary' write(fates_log(),*) 'patch has become the only patch of its kind, and it is' @@ -2822,17 +2721,13 @@ subroutine terminate_patches(currentSite) write(fates_log(),*) 'disabling the endrun statement following this message.' write(fates_log(),*) 'FATES may or may not continue to operate within error' write(fates_log(),*) 'tolerances, but will generate another fail if it does not.' - - write(fates_log(),*) 'cp pft',currentPatch%nocomp_pft_label,currentPatch%area - call endrun(msg=errMsg(sourcefile, __LINE__)) ! Note to user. If you DO decide to remove the end-run above this line ! Make sure that you keep the pointer below this line, or you will get ! an infinite loop. - currentPatch => oldercPatch + currentPatch => currentPatch%older count_cycles = 0 - end if !only patch end if !count cycles call set_patchno(currentSite) !redo patch numbering for every potential termination. !n.b. could put filter in here for actual terminations to save time. From a0efc39d7aaca9bd0acc3f7bc5de39390102c1ef Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 14 Sep 2020 04:55:43 -0600 Subject: [PATCH 084/209] endif statements in teminate patches --- biogeochem/EDPatchDynamicsMod.F90 | 15 ++++++--------- 1 file changed, 6 insertions(+), 9 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 5279b166ac..3c69d3b463 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -2690,13 +2690,11 @@ subroutine terminate_patches(currentSite) currentPatch%anthro_disturbance_label = youngerPatch%anthro_disturbance_label call fuse_2_patches(currentSite, youngerPatch, currentPatch) gotfused = .true. - endif - endif - ! The fusion process has updated the "younger" pointer on currentPatch - - endif ! older or younder patch - endif ! very small area - + endif ! count cycles + endif ! anthro labels + endif ! has an older patch + endif ! is not the youngest patch + endif ! very small patch ! It is possible that an incredibly small patch just fused into another incredibly ! small patch, resulting in an incredibly small patch. It is also possible that this ! resulting incredibly small patch is the oldest patch. If this was true than @@ -2704,9 +2702,8 @@ subroutine terminate_patches(currentSite) ! Think this is impossible? No, this really happens, especially when we have fires. ! So, we don't move forward until we have merged enough area into this thing. - if(currentPatch%area > min_patch_area_forced)then - currentPatch => oldercPatch + currentPatch => currentPatch%older count_cycles = 0 else From 948eb2a64ab3dfa95c8765809dd6f0f3ff10f8b8 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 14 Sep 2020 04:59:40 -0600 Subject: [PATCH 085/209] spacing in terminate patches --- biogeochem/EDPatchDynamicsMod.F90 | 9 --------- 1 file changed, 9 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 3c69d3b463..bc0aae4c66 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -2555,15 +2555,10 @@ subroutine fuse_2_patches(csite, dp, rp) youngerp => null() end if - - - ! We have no need for the dp pointer anymore, we have passed on it's legacy call dealloc_patch(dp) - deallocate(dp) - if(associated(youngerp))then ! Update the younger patch's new older patch (because it isn't dp anymore) youngerp%older => olderp @@ -2627,8 +2622,6 @@ subroutine terminate_patches(currentSite) ! However, if the patch to be fused is excessivlely small, then fuse ! at all costs. If it is not fused, it will make - ! the current patch is NOT the youngest. Or is it very very small. - ! so, skip merging if it is the youngest, unless the youngest is tiny. if ( .not.associated(currentPatch,currentSite%youngest_patch) .or. & currentPatch%area <= min_patch_area_forced ) then @@ -2729,8 +2722,6 @@ subroutine terminate_patches(currentSite) call set_patchno(currentSite) !redo patch numbering for every potential termination. !n.b. could put filter in here for actual terminations to save time. - fusingpatch => currentSite%oldest_patch - enddo ! current patch loop !check area is not exceeded From 025aabf0e0e62dd91f94f934cf87ef19bc14e57e Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 14 Sep 2020 05:01:23 -0600 Subject: [PATCH 086/209] remove set_patchno call --- biogeochem/EDPatchDynamicsMod.F90 | 2 -- 1 file changed, 2 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index bc0aae4c66..7147f39595 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -2719,8 +2719,6 @@ subroutine terminate_patches(currentSite) currentPatch => currentPatch%older count_cycles = 0 end if !count cycles - call set_patchno(currentSite) !redo patch numbering for every potential termination. - !n.b. could put filter in here for actual terminations to save time. enddo ! current patch loop From d0a525622d60baf51bdbbfbcef6bc8490295d53e Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 14 Sep 2020 07:50:49 -0600 Subject: [PATCH 087/209] code to manage bare gound in SP mode --- main/EDInitMod.F90 | 37 ++++++++++++++++++++++++++----------- 1 file changed, 26 insertions(+), 11 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 782c3481b3..c8c5d58e50 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -332,15 +332,20 @@ subroutine set_site_properties( nsites, sites,bc_in ) ! the bare ground will no longer be proscribed and should emerge from FATES ! this may or may not be the right way to deal with this? - sumarea = sum(sites(s)%area_pft(1:numpft)) - do ft = 1,numpft - if(sumarea.gt.0._r8)then - sites(s)%area_pft(ft) = sites(s)%area_pft(ft)/sumarea - else - sites(s)%area_pft(ft)= 1.0_r8/numpft - write(*,*) 'setting totally bare patch to all pfts.',s,sumarea,sites(s)%area_pft(ft) - end if - end do !ft + if(hlm_use_sp.eq.ifalse)then + sumarea = sum(sites(s)%area_pft(1:numpft)) + do ft = 1,numpft + if(sumarea.gt.0._r8)then + sites(s)%area_pft(ft) = sites(s)%area_pft(ft)/sumarea + else + sites(s)%area_pft(ft)= 1.0_r8/numpft + write(*,*) 'setting totally bare patch to all pfts.',s,sumarea,sites(s)%area_pft(ft) + end if + else ! for sp mode, assert a bare ground patch + sites(s)%area_bareground = 1.0_r8 - sumarea + end if !sp mode + end do !ft + end if !fixed biogeog do ft = 1,numpft @@ -441,6 +446,9 @@ subroutine init_patches( nsites, sites, bc_in) sites(s)%spread = init_spread_near_bare_ground if(hlm_use_nocomp.eq.itrue)then no_new_patches = numpft + if(hlm_use_sp.eq.itrue)then + no_new_patches = numpft + 1 ! bare ground patch in SP mode. + endif ! allocate(newppft(numpft)) else no_new_patches = 1 @@ -467,7 +475,12 @@ subroutine init_patches( nsites, sites, bc_in) end if else ! The default case is initialized w/ one patch with the area of the whole site. newparea = area - end if + end if !nocomp mode + + if(hlm_use_sp.eq.itrue.and.n.gt.numpft)then + newparea = sites(s)%area_bareground + nocomp_pft = 0 + end if if(newparea.gt.0._r8)then ! Stop patches being initilialized when PFT not present in nocomop mode allocate(newp) @@ -506,7 +519,9 @@ subroutine init_patches( nsites, sites, bc_in) end do sitep => sites(s) - call init_cohorts(sitep, newp, bc_in(s)) + if(hlm_use_sp.eq.ifalse.and.nocomp_pft.eq.0)then !don't initialize cohorts for SP bare ground patch + call init_cohorts(sitep, newp, bc_in(s)) + end if end if end do !no new patches From 573dad509748f443e4a971a717545283c4fd16fa Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 14 Sep 2020 08:08:16 -0600 Subject: [PATCH 088/209] debugging after merge --- biogeochem/EDPhysiologyMod.F90 | 9 ++++----- main/EDInitMod.F90 | 3 ++- main/EDPftvarcon.F90 | 7 ++++--- main/EDTypesMod.F90 | 2 ++ 4 files changed, 12 insertions(+), 9 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 9aa9798132..ea9d4d783c 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1363,8 +1363,6 @@ subroutine satellite_phenology(currentSite, bc_in) integer :: s ! site index - real(r8) :: spread ! need to send a fixed value of patch spread to carea_allom - ! To Do in this routine. ! Get access to HLM input varialbes. ! Weight them by PFT @@ -1437,8 +1435,8 @@ subroutine satellite_phenology(currentSite, bc_in) !------------------------------------------ ! Calculate dbh from input height, and c_area from dbh !------------------------------------------ - currentCohort%hite = currentPatch%sp_htop - call h2d_allom(temp_cohort%hite,ft,temp_cohort%dbh) + currentCohort%hite = currentSite%sp_htop(fates_pft) + call h2d_allom(currentCohort%hite,fates_pft,currentCohort%dbh) currentCohort%n = 1.0_r8 ! make n=1 to get area of one tree. spread = 0.0_r8 ! fix this to 0 to remove dynamics of canopy closure, assuming a closed canopy. ! n.b. the value of this will only affect 'n', which isn't/shouldn't be a diagnostic in @@ -1453,7 +1451,8 @@ subroutine satellite_phenology(currentSite, bc_in) ! ------------------------------------------ ! Calculate leaf carbon from target treelai ! ------------------------------------------ - currentCohort%treelai = currentPatch%sp_tlai + currentCohort%treelai = currentSite%sp_tlai(fates_pft) + leaf_c = leafc_from_treelai( currentCohort%treelai, currentCohort%pft, currentCohort%c_area,& currentCohort%n, currentCohort%canopy_layer, currentCohort%vcmax25top) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index c8c5d58e50..c8c5c50e48 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -42,6 +42,7 @@ module EDInitMod use FatesInterfaceTypesMod , only : hlm_use_planthydro use FatesInterfaceTypesMod , only : hlm_use_inventory_init use FatesInterfaceTypesMod , only : hlm_use_fixed_biogeog + use FatesInterfaceTypesMod , only : hlm_use_sp use FatesInterfaceTypesMod , only : numpft use FatesInterfaceTypesMod , only : nleafage use FatesInterfaceTypesMod , only : nlevsclass @@ -341,10 +342,10 @@ subroutine set_site_properties( nsites, sites,bc_in ) sites(s)%area_pft(ft)= 1.0_r8/numpft write(*,*) 'setting totally bare patch to all pfts.',s,sumarea,sites(s)%area_pft(ft) end if + end do !ft else ! for sp mode, assert a bare ground patch sites(s)%area_bareground = 1.0_r8 - sumarea end if !sp mode - end do !ft end if !fixed biogeog diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index ab46fa45ae..efd529aa2a 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -2778,14 +2778,15 @@ subroutine FatesCheckParams(is_master, parteh_mode) ! check that the host-fates PFT map adds to one in both dimension do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) - sumarea = sum(EDPftvarcon_inst%hlm_pft_map(1:npft,hlm_oft)) - if(abs(sumarea-1.0_r8).gt. )then + sumarea = sum(EDPftvarcon_inst%hlm_pft_map(1:npft,hlm_pft)) + if(abs(sumarea-1.0_r8).gt.nearzero)then write(fates_log(),*) 'The distribution of this host land model PFT :',hlm_pft write(fates_log(),*) 'into FATES PFTs, does not add up to 1.0.' write(fates_log(),*) 'Error is:',sumarea-1.0_r8 - write(fates_log(),*) 'and the hlm_pft_map is:', EDPftvarcon_inst%hlm_pft_map(1:npft,hlm_oft) + write(fates_log(),*) 'and the hlm_pft_map is:', EDPftvarcon_inst%hlm_pft_map(1:npft,hlm_pft) write(fates_log(),*) 'Aborting' call endrun(msg=errMsg(sourcefile, __LINE__)) + end if end do !ipft !! ! Checks for HYDRO diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 4e1121a139..e2cbcfbf11 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -666,6 +666,8 @@ module EDTypesMod real(r8), allocatable :: sp_tlai(:) ! target TLAI per FATES pft real(r8), allocatable :: sp_tsai(:) ! target TSAI per FATES pft real(r8), allocatable :: sp_htop(:) ! target HTOP per FATES pft + + real(r8) :: area_bareground ! in SP mode we assert a bare ground fraction ! Mass Balance (allocation for each element) From 867ff49e3441548aa0abf5bd8f783798ec853969 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 15 Sep 2020 03:13:22 -0600 Subject: [PATCH 089/209] fixing bare ground initialization errors. now runs --- main/EDInitMod.F90 | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index c8c5c50e48..ced8c2740b 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -313,6 +313,7 @@ subroutine set_site_properties( nsites, sites,bc_in ) ! add up the area associated with each FATES PFT ! where pft_areafrac is the area of land in each HLM PFT and (from surface dataset) ! hlm_pft_map is the area of that land in each FATES PFT (from param file) + sites(s)%area_pft(1:numpft) = 0._r8 do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) do fates_pft = 1,numpft ! loop round all fates pfts for all hlm pfts @@ -321,10 +322,11 @@ subroutine set_site_properties( nsites, sites,bc_in ) end do end do !hlm_pft + sumarea = sum(sites(s)%area_pft(1:numpft)) do ft = 1,numpft - if(sites(s)%area_pft(ft).lt.0.01_r8)then + if(sites(s)%area_pft(ft).lt.0.01_r8.and.sites(s)%area_pft(ft).gt.0.0_r8)then + if ( debug ) write(fates_log(),*) 'removing small pft patches',s,ft,sites(s)%area_pft(ft) sites(s)%area_pft(ft)=0.0_r8 !remove tiny patches to prevent numerical errors in terminate patches - write(*,*) 'removing small pft patches',sites(s)%lon,sites(s)%lat,ft,sites(s)%area_pft(ft) endif end do @@ -340,10 +342,11 @@ subroutine set_site_properties( nsites, sites,bc_in ) sites(s)%area_pft(ft) = sites(s)%area_pft(ft)/sumarea else sites(s)%area_pft(ft)= 1.0_r8/numpft - write(*,*) 'setting totally bare patch to all pfts.',s,sumarea,sites(s)%area_pft(ft) end if end do !ft else ! for sp mode, assert a bare ground patch + sumarea = sum(sites(s)%area_pft(1:numpft)) + ! here we subsume the destroyed tiny patches into the bare ground fraction. sites(s)%area_bareground = 1.0_r8 - sumarea end if !sp mode @@ -479,7 +482,7 @@ subroutine init_patches( nsites, sites, bc_in) end if !nocomp mode if(hlm_use_sp.eq.itrue.and.n.gt.numpft)then - newparea = sites(s)%area_bareground + newparea = sites(s)%area_bareground * area nocomp_pft = 0 end if @@ -534,13 +537,12 @@ subroutine init_patches( nsites, sites, bc_in) if ( debug ) write(fates_log(),*) 'test links',s,newp%nocomp_pft_label,tota newp=>newp%younger end do - if(abs(tota-area).gt.nearzero)then - write(*,*) 'error in assigning areas in init patch',s,tota-area + if(abs(tota-area).gt.nearzero*area)then + write(*,*) 'error in assigning areas in init patch',s,sites(s)%lat,tota-area,tota endif ! For carbon balance checks, we need to initialize the ! total carbon stock - write(*,*) 'calling sitemassstock',s do el=1,num_elements call SiteMassStock(sites(s),el,sites(s)%mass_balance(el)%old_stock, & biomass_stock,litter_stock,seed_stock) From 49d1eee8f928514affbb30a9820a9d976cc032ae Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 16 Sep 2020 01:56:54 -0600 Subject: [PATCH 090/209] moved SP check on totalbalancecheck into subroutine --- main/EDMainMod.F90 | 43 +++++++++++++++++-------------------------- 1 file changed, 17 insertions(+), 26 deletions(-) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 7d3df65365..6d13609701 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -168,9 +168,8 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) call ZeroLitterFluxes(currentSite) ! Zero mass balance - if(hlm_use_sp.eq.ifalse)then - call TotalBalanceCheck(currentSite, 0) - end if + call TotalBalanceCheck(currentSite, 0) + ! We do not allow phenology while in ST3 mode either, it is hypothetically ! possible to allow this, but we have not plugged in the litter fluxes ! of flushing or turning over leaves for non-dynamics runs @@ -220,9 +219,8 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) enddo end if - if(hlm_use_sp.eq.ifalse)then - call TotalBalanceCheck(currentSite,1) - end if + call TotalBalanceCheck(currentSite,1) + if( hlm_use_ed_st3.eq.ifalse .and.hlm_use_sp.eq.ifalse ) then currentPatch => currentSite%oldest_patch @@ -245,9 +243,8 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) enddo end if - if(hlm_use_sp.eq.ifalse)then - call TotalBalanceCheck(currentSite,2) - end if + call TotalBalanceCheck(currentSite,2) + !********************************************************************************* ! Patch dynamics sub-routines: fusion, new patch creation (spwaning), termination. !********************************************************************************* @@ -273,9 +270,7 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) call spawn_patches(currentSite, bc_in) end if - if(hlm_use_sp.eq.ifalse)then - call TotalBalanceCheck(currentSite,3) - end if + call TotalBalanceCheck(currentSite,3) ! fuse on the spawned patches. if ( do_patch_dynamics.eq.itrue ) then @@ -292,18 +287,15 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) end if ! SP has changes in leaf carbon but we don't expect them to be in balance. - if(hlm_use_sp.eq.ifalse)then - call TotalBalanceCheck(currentSite,4) - end if + call TotalBalanceCheck(currentSite,4) ! kill patches that are too small if ( do_patch_dynamics.eq.itrue ) then call terminate_patches(currentSite) end if - if(hlm_use_sp.eq.ifalse)then - call TotalBalanceCheck(currentSite,5) - endif + call TotalBalanceCheck(currentSite,5) + end subroutine ed_ecosystem_dynamics !-------------------------------------------------------------------------------! @@ -570,18 +562,15 @@ subroutine ed_update_site( currentSite, bc_in ) ! !LOCAL VARIABLES: type (ed_patch_type) , pointer :: currentPatch !----------------------------------------------------------------------- - - call canopy_spread(currentSite) - if(hlm_use_sp.eq.ifalse)then - call TotalBalanceCheck(currentSite,6) + call canopy_spread(currentSite) end if + call TotalBalanceCheck(currentSite,6) + call canopy_structure(currentSite, bc_in) - if(hlm_use_sp.eq.ifalse)then - call TotalBalanceCheck(currentSite,final_check_id) - end if + call TotalBalanceCheck(currentSite,final_check_id) currentPatch => currentSite%oldest_patch do while(associated(currentPatch)) @@ -657,6 +646,8 @@ subroutine TotalBalanceCheck (currentSite, call_index ) ! upon fail (lots of text) !----------------------------------------------------------------------- + if(hlm_use_sp.eq.ifalse)then + change_in_stock = 0.0_r8 @@ -768,7 +759,7 @@ subroutine TotalBalanceCheck (currentSite, call_index ) end if end do - + end if ! not SP mode end subroutine TotalBalanceCheck ! ===================================================================================== From 40686b41b61a35c4195a7a76792b0f0414f821b8 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 17 Sep 2020 02:24:45 -0600 Subject: [PATCH 091/209] changes to EDPhysiology to get treelai calcas right --- biogeochem/EDPhysiologyMod.F90 | 70 +++++++++++++++++++++++----------- 1 file changed, 48 insertions(+), 22 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index ea9d4d783c..01ba620d66 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -35,6 +35,7 @@ module EDPhysiologyMod use EDTypesMod , only : numlevsoil_max use EDTypesMod , only : numWaterMem use EDTypesMod , only : dl_sf, dinc_ed, area_inv + use EDTypesMod , only : AREA use FatesLitterMod , only : ncwd use FatesLitterMod , only : ndcmpy use FatesLitterMod , only : ilabile @@ -1357,7 +1358,8 @@ subroutine satellite_phenology(currentSite, bc_in) real(r8) :: spread ! dummy value of canopy spread to estimate c_area real(r8) :: leaf_c ! leaf carbon estimated to generate target tlai - + real(r8) :: sumarea + real(r8) :: check_treelai integer :: fates_pft ! fates pft numer for weighting loop integer :: hlm_pft ! host land model pft number for weighting loop. integer :: s ! site index @@ -1372,44 +1374,51 @@ subroutine satellite_phenology(currentSite, bc_in) ! figure out how this will interact with the canopy_structure routines. ! determine what 'n' should be from the canopy height. - currentPatch => currentSite%oldest_patch - do while (associated(currentPatch)) + + currentSite%sp_tlai(1:numpft) = 0._r8 + currentSite%sp_tsai(1:numpft) = 0._r8 + currentSite%sp_htop(1:numpft) = 0._r8 + + currentPatch => currentSite%oldest_patch + do while (associated(currentPatch)) ! WEIGHTING OF FATES PFTs on to HLM_PFTs ! add up the area associated with each FATES PFT ! where pft_areafrac is the area of land in each HLM PFT and (from surface dataset) ! hlm_pft_map is the area of that land in each FATES PFT (from param file) - currentSite%sp_tlai(1:numpft) = 0._r8 - currentSite%sp_tsai(1:numpft) = 0._r8 - currentSite%sp_htop(1:numpft) = 0._r8 - ! weight each fates PFT target for lai, sai and htop by the area of the ! contrbuting HLM PFTs. ! we only need to do this for the patch/fates_pft we are currently in fates_pft = currentPatch%nocomp_pft_label + + sumarea = 0.0_r8 do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) - if(bc_in%pft_areafrac(hlm_pft).gt.0.0_r8)then - !leaf area index + if(bc_in%pft_areafrac(hlm_pft) * EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft).gt.0.0_r8)then + sumarea = sumarea + bc_in%pft_areafrac(hlm_pft)*EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft) + !leaf area index currentSite%sp_tlai(fates_pft) = currentSite%sp_tlai(fates_pft) + & - bc_in%hlm_sp_tlai(hlm_pft) * bc_in%pft_areafrac(hlm_pft) + bc_in%hlm_sp_tlai(hlm_pft) * bc_in%pft_areafrac(hlm_pft) & + * EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft) !stem area index currentSite%sp_tsai(fates_pft) = currentSite%sp_tsai(fates_pft) + & - bc_in%hlm_sp_tsai(hlm_pft) * bc_in%pft_areafrac(hlm_pft) + bc_in%hlm_sp_tsai(hlm_pft) * bc_in%pft_areafrac(hlm_pft) & + * EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft) ! canopy height currentSite%sp_htop(fates_pft) = currentSite%sp_htop(fates_pft) + & - bc_in%hlm_sp_htop(hlm_pft) * bc_in%pft_areafrac(hlm_pft) + bc_in%hlm_sp_htop(hlm_pft) * bc_in%pft_areafrac(hlm_pft) & + * EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft) end if ! there is some area in this patch end do !hlm_pft ! weight for total area in each patch/fates_pft if(currentPatch%area.gt.0.0_r8)then + currentSite%sp_tlai(fates_pft) = currentSite%sp_tlai(fates_pft) & + /(currentPatch%area/area) + currentSite%sp_tsai(fates_pft) = currentSite%sp_tsai(fates_pft) & + /(currentPatch%area/area) currentSite%sp_htop(fates_pft) = currentSite%sp_htop(fates_pft) & - /currentPatch%area - currentSite%sp_htop(fates_pft) = currentSite%sp_htop(fates_pft) & - /currentPatch%area - currentSite%sp_htop(fates_pft) = currentSite%sp_htop(fates_pft) & - /currentPatch%area + /(currentPatch%area/area) endif ! ------------------------------------------------------------ @@ -1424,12 +1433,16 @@ subroutine satellite_phenology(currentSite, bc_in) ! Do some checks if(associated(currentCohort%shorter))then - write(*,*) "there is more than one cohort in SP mode" + write(fates_log(),*) 'SP mode has >1 cohort' + write(fates_log(),*) "SP mode >1 cohort: PFT",currentCohort%pft, currentCohort%shorter%pft + write(fates_log(),*) "SP mode >1 cohort: CL",currentCohort%canopy_layer, currentCohort%shorter%canopy_layer + call endrun(msg=errMsg(sourcefile, __LINE__)) end if fates_pft =currentCohort%pft if(fates_pft.ne.currentPatch%nocomp_pft_label)then - write(*,*) 'wrong PFT label in cohort in SP mode',fates_pft,currentPatch%nocomp_pft_label + write(fates_log(),*) 'wrong PFT label in cohort in SP mode',fates_pft,currentPatch%nocomp_pft_label + call endrun(msg=errMsg(sourcefile, __LINE__)) end if !------------------------------------------ @@ -1437,12 +1450,14 @@ subroutine satellite_phenology(currentSite, bc_in) !------------------------------------------ currentCohort%hite = currentSite%sp_htop(fates_pft) call h2d_allom(currentCohort%hite,fates_pft,currentCohort%dbh) - currentCohort%n = 1.0_r8 ! make n=1 to get area of one tree. - spread = 0.0_r8 ! fix this to 0 to remove dynamics of canopy closure, assuming a closed canopy. + + currentCohort%n = 1.0_r8 ! make n=1 to get area of one tree. + spread = 1.0_r8 ! fix this to 0 to remove dynamics of canopy closure, assuming a closed canopy. ! n.b. the value of this will only affect 'n', which isn't/shouldn't be a diagnostic in ! SP mode. call carea_allom(currentCohort%dbh,currentCohort%n,spread,currentCohort%pft,currentCohort%c_area) + !------------------------------------------ ! Calculate canopy N assuming patch area is full !------------------------------------------ @@ -1453,9 +1468,21 @@ subroutine satellite_phenology(currentSite, bc_in) ! ------------------------------------------ currentCohort%treelai = currentSite%sp_tlai(fates_pft) + ! correct c_area for the new nplant + currentCohort%c_area = currentCohort%c_area * currentCohort%n + leaf_c = leafc_from_treelai( currentCohort%treelai, currentCohort%pft, currentCohort%c_area,& currentCohort%n, currentCohort%canopy_layer, currentCohort%vcmax25top) + !check reverse - maybe can delete eventually + check_treelai = tree_lai(leaf_c, currentCohort%pft, currentCohort%c_area, & + currentCohort%n, currentCohort%canopy_layer, & + currentPatch%canopy_layer_tlai,currentCohort%vcmax25top ) + + if( abs(currentCohort%treelai-check_treelai).gt.nearzero)then + write(fates_log(),*) 'error in validate treelai',currentCohort%treelai,check_treelai,currentCohort%pft + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if call SetState(currentCohort%prt,leaf_organ,1,leaf_c,1) ! assert sai @@ -1979,7 +2006,6 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) ! ----------------------------------------------------------------------------------- call prt%CheckInitialConditions() - ! This initializes the cohort call create_cohort(currentSite,currentPatch, temp_cohort%pft, temp_cohort%n, & temp_cohort%hite, temp_cohort%coage, temp_cohort%dbh, prt, & From 47a005778101bc6bffeb6bda404832bf4c52157c Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 17 Sep 2020 02:27:18 -0600 Subject: [PATCH 092/209] changes to FatesAllometryMod.F90 to get treelai right --- biogeochem/FatesAllometryMod.F90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/biogeochem/FatesAllometryMod.F90 b/biogeochem/FatesAllometryMod.F90 index c397ab5bea..469cff083d 100644 --- a/biogeochem/FatesAllometryMod.F90 +++ b/biogeochem/FatesAllometryMod.F90 @@ -810,21 +810,21 @@ real(r8) function leafc_from_treelai( treelai, pft, c_area, nplant, cl, vcmax25t slat = g_per_kg * EDPftvarcon_inst%slatop(pft) ! m2/g to m2/kg leafc_per_unitarea = leaf_c/(c_area/nplant) !KgC/m2 - + if(treelai > 0.0_r8)then ! Coefficient for exponential decay of 1/sla with canopy depth: kn = decay_coeff_kn(pft,vcmax25top) - ! take PFT-level maximum SLA value, even if under a thick canopy (which has units of m2/gC), ! and put into units of m2/kgC sla_max = g_per_kg *EDPftvarcon_inst%slamax(pft) ! Leafc_per_unitarea at which sla_max is reached due to exponential sla profile in canopy: leafc_slamax = max(0.0_r8,(slat - sla_max) / (-1.0_r8 * kn * slat * sla_max)) - + ! treelai at which we reach maximum sla. tree_lai_at_slamax = (log( 1.0_r8- kn * slat * leafc_slamax)) / (-1.0_r8 * kn) - if(treelai > tree_lai_at_slamax)then + + if(treelai < tree_lai_at_slamax)then ! Inversion of the exponential phase calculation of treelai for a given leafc_per_unitarea leafc_per_unitarea = (1.0_r8-exp(treelai*(-1.0_r8 * kn)))/(kn*slat) else ! we exceed the maxumum sla @@ -834,7 +834,7 @@ real(r8) function leafc_from_treelai( treelai, pft, c_area, nplant, cl, vcmax25t leafc_linear_phase = (treelai-tree_lai_at_slamax)/sla_max leafc_per_unitarea = leafc_slamax + leafc_linear_phase end if - + leafc_from_treelai = leafc_per_unitarea*(c_area/nplant) else leafc_from_treelai = 0.0_r8 endif ! (leafc_per_unitarea > 0.0_r8) From b7fa39c7b3e11a7f060dd6805427140281d5ef7f Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 17 Sep 2020 02:31:15 -0600 Subject: [PATCH 093/209] added check for no cohorts in bare patch --- biogeochem/EDCanopyStructureMod.F90 | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 0e2de53919..27fb709409 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1333,7 +1333,6 @@ subroutine canopy_summarization( nsites, sites, bc_in ) call carea_allom(currentCohort%dbh,currentCohort%n,sites(s)%spread,& currentCohort%pft,currentCohort%c_area) - currentCohort%treelai = tree_lai(leaf_c, & currentCohort%pft, currentCohort%c_area, currentCohort%n, & currentCohort%canopy_layer, currentPatch%canopy_layer_tlai,currentCohort%vcmax25top ) @@ -1346,7 +1345,10 @@ subroutine canopy_summarization( nsites, sites, bc_in ) currentPatch%total_tree_area = currentPatch%total_tree_area + currentCohort%c_area endif endif - + if(currentPatch%nocomp_pft_label.eq.0)then + write(*,*) 'cohorts in barepatch',currentPatch%total_canopy_area,currentPatch%nocomp_pft_label,currentCohort%c_area + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if ! Check for erroneous zero values. if(currentCohort%dbh <= 0._r8 .or. currentCohort%n == 0._r8)then write(fates_log(),*) 'FATES: dbh or n is zero in canopy_summarization', & @@ -1964,7 +1966,6 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) ! Calculate area indices for output boundary to HLM ! It is assumed that cpatch%canopy_area_profile and cpat%xai_profiles ! have been updated (ie ed_leaf_area_profile has been called since dynamics has been called) - bc_out(s)%elai_pa(ifp) = calc_areaindex(currentPatch,'elai') bc_out(s)%tlai_pa(ifp) = calc_areaindex(currentPatch,'tlai') bc_out(s)%esai_pa(ifp) = calc_areaindex(currentPatch,'esai') @@ -2062,6 +2063,7 @@ function calc_areaindex(cpatch,ai_type) result(ai) 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 From d755c44d7fd99aa02fa95b5f500102940ab89f16 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 17 Sep 2020 02:33:36 -0600 Subject: [PATCH 094/209] added check to avoid copying cohorts in sp mode --- biogeochem/EDCohortDynamicsMod.F90 | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index a4124d9b34..8e6fa26125 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -9,6 +9,7 @@ module EDCohortDynamicsMod use FatesInterfaceTypesMod , only : hlm_freq_day use FatesInterfaceTypesMod , only : bc_in_type use FatesInterfaceTypesMod , only : hlm_use_planthydro + use FatesInterfaceTypesMod , only : hlm_use_sp use FatesInterfaceTypesMod , only : hlm_use_cohort_age_tracking use FatesConstantsMod , only : r8 => fates_r8 use FatesConstantsMod , only : fates_unset_int @@ -226,7 +227,7 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & new_cohort%laimemory = laimemory new_cohort%sapwmemory = sapwmemory new_cohort%structmemory = structmemory - + write(*,*) 'createing cohort', pft, nn, clayer ! This sets things like vcmax25top, that depend on the ! leaf age fractions (which are defined by PARTEH) call UpdateCohortBioPhysRates(new_cohort) @@ -1664,6 +1665,11 @@ subroutine copy_cohort( currentCohort,copyc ) o => currentCohort n => copyc + if(hlm_use_sp.eq.itrue)then + write(fates_log(),*) 'copying cohort shouldnt happen in SP mode' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + n%indexnumber = fates_unset_int ! VEGETATION STRUCTURE From 06db8290f410a4b1dca6f99ee20b37caa82b7fdf Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 17 Sep 2020 02:42:35 -0600 Subject: [PATCH 095/209] remove write --- biogeochem/EDCohortDynamicsMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 8e6fa26125..d5dd51be4e 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -227,7 +227,7 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & new_cohort%laimemory = laimemory new_cohort%sapwmemory = sapwmemory new_cohort%structmemory = structmemory - write(*,*) 'createing cohort', pft, nn, clayer + ! This sets things like vcmax25top, that depend on the ! leaf age fractions (which are defined by PARTEH) call UpdateCohortBioPhysRates(new_cohort) From 8c8b559cb1475d5a00af7d9851f17ca71c00420b Mon Sep 17 00:00:00 2001 From: rosiealice Date: Fri, 18 Sep 2020 04:28:25 -0600 Subject: [PATCH 096/209] changed copy cohort error --- biogeochem/EDCohortDynamicsMod.F90 | 3 ++- biogeochem/EDPhysiologyMod.F90 | 4 ++-- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index d5dd51be4e..0b9ab3bc60 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -1666,7 +1666,8 @@ subroutine copy_cohort( currentCohort,copyc ) n => copyc if(hlm_use_sp.eq.itrue)then - write(fates_log(),*) 'copying cohort shouldnt happen in SP mode' + write(fates_log(),*) 'copying cohort shouldnt happen in SP mode,area,pft',o%c_area,o%pft + call endrun(msg=errMsg(sourcefile, __LINE__)) end if diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 01ba620d66..3f9ede346a 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1479,8 +1479,8 @@ subroutine satellite_phenology(currentSite, bc_in) currentCohort%n, currentCohort%canopy_layer, & currentPatch%canopy_layer_tlai,currentCohort%vcmax25top ) - if( abs(currentCohort%treelai-check_treelai).gt.nearzero)then - write(fates_log(),*) 'error in validate treelai',currentCohort%treelai,check_treelai,currentCohort%pft + if( abs(currentCohort%treelai-check_treelai).gt.1.0e-12)then !this is not as precise as nearzerio (10^-16 typically) + write(fates_log(),*) 'error in validate treelai',currentCohort%treelai,check_treelai,currentCohort%treelai-check_treelai call endrun(msg=errMsg(sourcefile, __LINE__)) end if call SetState(currentCohort%prt,leaf_organ,1,leaf_c,1) From c5d084adf06202af2933674917c24c1cc4760390 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 21 Sep 2020 04:45:58 -0600 Subject: [PATCH 097/209] checks in EDcanopystructure --- biogeochem/EDCanopyStructureMod.F90 | 47 ++++++++++++++++-------- main/FatesHistoryInterfaceMod.F90 | 2 +- parameter_files/fates_params_default.cdl | 7 ++-- 3 files changed, 37 insertions(+), 19 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 27fb709409..9500ba8eef 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -27,9 +27,11 @@ module EDCanopyStructureMod use FatesInterfaceTypesMod , only : hlm_days_per_year use FatesInterfaceTypesMod , only : hlm_use_planthydro use FatesInterfaceTypesMod , only : hlm_use_cohort_age_tracking + use FatesInterfaceTypesMod , only : hlm_use_sp use FatesInterfaceTypesMod , only : numpft use FatesPlantHydraulicsMod, only : UpdateH2OVeg,InitHydrCohort, RecruitWaterStorage use EDTypesMod , only : maxCohortsPerPatch + use shr_infnan_mod , only : isnan => shr_infnan_isnan use PRTGenericMod, only : leaf_organ use PRTGenericMod, only : all_carbon_elements @@ -149,7 +151,7 @@ subroutine canopy_structure( currentSite , bc_in ) !---------------------------------------------------------------------- - + if(hlm_use_sp.eq.ifalse)then currentPatch => currentSite%oldest_patch ! ! zero site-level demotion / promotion tracking info @@ -321,7 +323,7 @@ subroutine canopy_structure( currentSite , bc_in ) currentPatch => currentPatch%younger enddo !patch - + end if ! SP mode return end subroutine canopy_structure @@ -364,11 +366,10 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr) real(r8) :: total_crownarea_of_tied_cohorts ! First, determine how much total canopy area we have in this layer - call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr,arealayer) demote_area = arealayer - currentPatch%area - + if ( demote_area > area_target_precision ) then ! Is this layer currently over-occupied? @@ -378,10 +379,9 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr) sumweights = 0.0_r8 currentCohort => currentPatch%shortest do while (associated(currentCohort)) - call carea_allom(currentCohort%dbh,currentCohort%n, & currentSite%spread,currentCohort%pft,currentCohort%c_area) - + if(debug) then if(currentCohort%c_area<0._r8)then write(fates_log(),*) 'negative c_area stage 1d: ',currentCohort%dbh,i_lyr,currentCohort%n, & @@ -655,7 +655,7 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr) ! remains in the upper-story. The original is the one ! demoted to the understory - + allocate(copyc) ! Initialize the PARTEH object and point to the @@ -1330,9 +1330,10 @@ subroutine canopy_summarization( nsites, sites, bc_in ) call coagetype_class_index(currentCohort%coage,currentCohort%pft, & currentCohort%coage_class,currentCohort%coage_by_pft_class) end if - + if(hlm_use_sp.eq.ifalse)then call carea_allom(currentCohort%dbh,currentCohort%n,sites(s)%spread,& currentCohort%pft,currentCohort%c_area) + endif currentCohort%treelai = tree_lai(leaf_c, & currentCohort%pft, currentCohort%c_area, currentCohort%n, & currentCohort%canopy_layer, currentPatch%canopy_layer_tlai,currentCohort%vcmax25top ) @@ -1346,9 +1347,17 @@ subroutine canopy_summarization( nsites, sites, bc_in ) endif endif if(currentPatch%nocomp_pft_label.eq.0)then - write(*,*) 'cohorts in barepatch',currentPatch%total_canopy_area,currentPatch%nocomp_pft_label,currentCohort%c_area + write(fates_log(),*) 'cohorts in barepatch',currentPatch%total_canopy_area,currentPatch%nocomp_pft_label,currentCohort%c_area call endrun(msg=errMsg(sourcefile, __LINE__)) end if + if(hlm_use_sp.eq.itrue.and.associated(currentPatch%tallest%shorter))then + write(fates_log(),*) 'morethanonecohort',s,currentPatch%nocomp_pft_label + endif + if(currentPatch%total_canopy_area-currentPatch%area.gt.1.0e-16)then + write(fates_log(),*) 'canopy area too large in summarization1,s,pft,error:',s,currentPatch%nocomp_pft_label,currentPatch%total_canopy_area-currentPatch%area,& + currentPatch%area,currentPatch%tallest%c_area + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if ! Check for erroneous zero values. if(currentCohort%dbh <= 0._r8 .or. currentCohort%n == 0._r8)then write(fates_log(),*) 'FATES: dbh or n is zero in canopy_summarization', & @@ -1371,9 +1380,11 @@ subroutine canopy_summarization( nsites, sites, bc_in ) enddo ! ends 'do while(associated(currentCohort)) if ( currentPatch%total_canopy_area>currentPatch%area ) then - if ( currentPatch%total_canopy_area-currentPatch%area > 0.001_r8 ) then + if ( currentPatch%total_canopy_area-currentPatch%area > 1.0e-16_r8 ) then write(fates_log(),*) 'FATES: canopy area bigger than area', & - currentPatch%total_canopy_area ,currentPatch%area + currentPatch%total_canopy_area ,currentPatch%area, & + currentPatch%total_canopy_area -currentPatch%area,& + currentPatch%nocomp_pft_label call endrun(msg=errMsg(sourcefile, __LINE__)) end if currentPatch%total_canopy_area = currentPatch%area @@ -1955,14 +1966,17 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) bc_out(s)%canopy_fraction_pa(ifp) = & min(1.0_r8,currentPatch%total_canopy_area/currentPatch%area)*(currentPatch%area/AREA) - + if(isnan(bc_out(s)%canopy_fraction_pa(ifp)))then + write(*,*) 'nan canopy_fraction_pa in canopystructure, ifp, canopy area,patch area:',ifp,currentPatch%total_canopy_area,currentPatch%area + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if bare_frac_area = (1.0_r8 - min(1.0_r8,currentPatch%total_canopy_area/currentPatch%area)) * & (currentPatch%area/AREA) total_patch_area = total_patch_area + bc_out(s)%canopy_fraction_pa(ifp) + bare_frac_area total_canopy_area = total_canopy_area + bc_out(s)%canopy_fraction_pa(ifp) - + ! Calculate area indices for output boundary to HLM ! It is assumed that cpatch%canopy_area_profile and cpat%xai_profiles ! have been updated (ie ed_leaf_area_profile has been called since dynamics has been called) @@ -1970,7 +1984,6 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) bc_out(s)%tlai_pa(ifp) = calc_areaindex(currentPatch,'tlai') bc_out(s)%esai_pa(ifp) = calc_areaindex(currentPatch,'esai') bc_out(s)%tsai_pa(ifp) = calc_areaindex(currentPatch,'tsai') - ! Fraction of vegetation free of snow. This is used to flag those ! patches which shall under-go photosynthesis ! INTERF-TODO: we may want to stop using frac_veg_nosno_alb and let @@ -2045,7 +2058,7 @@ function calc_areaindex(cpatch,ai_type) result(ai) real(r8) :: ai ! TODO: THIS MIN LAI IS AN ARTIFACT FROM TESTING LONG-AGO AND SHOULD BE REMOVED ! THIS HAS BEEN KEPT THUS FAR TO MAINTAIN B4B IN TESTING OTHER COMMITS - real(r8),parameter :: ai_min = 0.1_r8 + real(r8) :: ai_min = 0.1_r8 real(r8),pointer :: ai_profile ai = 0._r8 @@ -2167,6 +2180,10 @@ function NumPotentialCanopyLayers(currentPatch,site_spread,include_substory) res ! If so we need to make another layer. if(arealayer > currentPatch%area)then z = z + 1 + if(hlm_use_sp)then + write(*,*) 'SPmode, canopy_layer full:',arealayer,currentPatch%area + end if + endif end if diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index c5dd9b4d75..2db45f3970 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -2906,8 +2906,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) cpatch => cpatch%younger end do - + ! ------------------------------------------------------------------------------ ! Diagnostics discretized by element type ! ------------------------------------------------------------------------------ diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index 8486546707..83ab5a7fbf 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -12,7 +12,7 @@ dimensions: fates_prt_organs = 6 ; fates_string_length = 60 ; fates_variants = 2 ; - fates_hlm_pftno = 12 ; + fates_hlm_pftno = 14 ; variables: double fates_history_ageclass_bin_edges(fates_history_age_bins) ; @@ -1228,8 +1228,9 @@ data: 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; - + 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, 1; fates_fire_FBD = 15.4, 16.8, 19.6, 999, 4, 4 ; From 95089d1e41479787fd8a0e7cfcf8c51fb1a5612b Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 21 Sep 2020 04:46:54 -0600 Subject: [PATCH 098/209] added carea to create_cohort --- biogeochem/EDCohortDynamicsMod.F90 | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 0b9ab3bc60..40e461d13a 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -136,7 +136,7 @@ module EDCohortDynamicsMod subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & prt, laimemory, sapwmemory, structmemory, & - status, recruitstatus,ctrim, clayer, spread, bc_in) + status, recruitstatus,ctrim, carea, clayer, spread, bc_in) ! ! !DESCRIPTION: ! create new cohort @@ -179,6 +179,7 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & ! leaf biomass that we are targeting? real(r8), intent(in) :: spread ! The community assembly effects how ! spread crowns are in horizontal space + real(r8), intent(in) :: carea ! area of cohort NLY USED IN SP MODE. type(bc_in_type), intent(in) :: bc_in ! External boundary conditions @@ -255,8 +256,11 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & endif ! Assign canopy extent and depth - call carea_allom(new_cohort%dbh,new_cohort%n,spread,new_cohort%pft,new_cohort%c_area) - + if(hlm_use_sp.eq.ifalse)then + call carea_allom(new_cohort%dbh,new_cohort%n,spread,new_cohort%pft,new_cohort%c_area) + else + new_cohort%c_area = carea ! set this from previously precision-controlled value + endif ! Query PARTEH for the leaf carbon [kg] leaf_c = new_cohort%prt%GetState(leaf_organ,carbon12_element) From 4202f4ba515e2e5481517ca535e474721930feac Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 21 Sep 2020 04:47:42 -0600 Subject: [PATCH 099/209] added carea to create_cohort in inventory --- main/FatesInventoryInitMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/FatesInventoryInitMod.F90 b/main/FatesInventoryInitMod.F90 index 6dcd3e2f58..2d0acd24e8 100644 --- a/main/FatesInventoryInitMod.F90 +++ b/main/FatesInventoryInitMod.F90 @@ -1131,7 +1131,7 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & call create_cohort(csite, cpatch, temp_cohort%pft, temp_cohort%n, temp_cohort%hite, & temp_cohort%coage, temp_cohort%dbh, & prt_obj, temp_cohort%laimemory,temp_cohort%sapwmemory, temp_cohort%structmemory, & - cstatus, rstatus, temp_cohort%canopy_trim, & + cstatus, rstatus, temp_cohort%canopy_trim,temp_cohort%c_area, & 1, csite%spread, bc_in) deallocate(temp_cohort) ! get rid of temporary cohort From 003a7a383e75f2bff0315066fc2a5a6a5d5f3c3a Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 21 Sep 2020 08:03:39 -0600 Subject: [PATCH 100/209] updates to satelllite phenology in edphys --- biogeochem/EDPhysiologyMod.F90 | 104 ++++++++++++++++++++++++--------- 1 file changed, 78 insertions(+), 26 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 3f9ede346a..eacae06580 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -111,6 +111,7 @@ module EDPhysiologyMod public :: trim_canopy public :: phenology public :: satellite_phenology + public :: assign_cohort_SP_properties public :: recruitment public :: ZeroLitterFluxes public :: FluxIntoLitterPools @@ -1430,14 +1431,6 @@ subroutine satellite_phenology(currentSite, bc_in) ! ------------------------------------------------------------ currentCohort => currentPatch%tallest do while (associated(currentCohort)) - - ! Do some checks - if(associated(currentCohort%shorter))then - write(fates_log(),*) 'SP mode has >1 cohort' - write(fates_log(),*) "SP mode >1 cohort: PFT",currentCohort%pft, currentCohort%shorter%pft - write(fates_log(),*) "SP mode >1 cohort: CL",currentCohort%canopy_layer, currentCohort%shorter%canopy_layer - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if fates_pft =currentCohort%pft if(fates_pft.ne.currentPatch%nocomp_pft_label)then @@ -1445,10 +1438,55 @@ subroutine satellite_phenology(currentSite, bc_in) call endrun(msg=errMsg(sourcefile, __LINE__)) end if + call assign_cohort_SP_properties(currentCohort, currentSite%sp_htop(fates_pft), currentSite%sp_tlai(fates_pft) , currentSite%sp_tsai(fates_pft),currentPatch%area,ifalse,leaf_c) + + currentCohort => currentCohort%shorter + end do !cohort loop + currentPatch => currentPatch%younger + end do ! patch loop + + end subroutine satellite_phenology + +! ===================================================================================== + + subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,leaf_c) + + ! Takes the daily inputs of leaf area index, stem area index and canopy height and + ! translates them into a FATES structure with one patch and one cohort per PFT + ! The leaf area of the cohort is modified each day to match that asserted by the HLM + ! -----------------------------------------------------------------------------------! + use EDTypesMod , only : nclmax + + type(ed_cohort_type), intent(inout), target :: currentCohort + + real(r8), intent(in) :: tlai ! target leaf area index from SP inputs + real(r8), intent(in) :: tsai ! target stem area index from SP inputs + real(r8), intent(in) :: htop ! target tree height from SP inputs + real(r8), intent(in) :: parea ! patch area for this PFT + integer, intent(in) :: init ! are we in the initialization routine? if so do not set leaf_c + real(r8), intent(out) :: leaf_c ! leaf carbon estimated to generate target tlai + + integer :: fates_pft ! fates pft numer for weighting loop + real(r8) :: spread ! dummy value of canopy spread to estimate c_area + real(r8) :: sumarea + real(r8) :: check_treelai + real(r8) :: canopylai(1:nclmax) + real(r8) :: fracerr + real(r8) :: oldcarea + + ! Do some checks + if(associated(currentCohort%shorter))then + write(fates_log(),*) 'SP mode has >1 cohort' + write(fates_log(),*) "SP mode >1 cohort: PFT",currentCohort%pft, currentCohort%shorter%pft + write(fates_log(),*) "SP mode >1 cohort: CL",currentCohort%canopy_layer, currentCohort%shorter%canopy_layer + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + !------------------------------------------ ! Calculate dbh from input height, and c_area from dbh !------------------------------------------ - currentCohort%hite = currentSite%sp_htop(fates_pft) + currentCohort%hite = htop + fates_pft = currentCohort%pft call h2d_allom(currentCohort%hite,fates_pft,currentCohort%dbh) currentCohort%n = 1.0_r8 ! make n=1 to get area of one tree. @@ -1461,41 +1499,54 @@ subroutine satellite_phenology(currentSite, bc_in) !------------------------------------------ ! Calculate canopy N assuming patch area is full !------------------------------------------ - currentCohort%n = currentPatch%area / currentCohort%c_area + currentCohort%n = parea / currentCohort%c_area + + ! correct c_area for the new nplant + call carea_allom(currentCohort%dbh,currentCohort%n,spread,currentCohort%pft,currentCohort%c_area) ! ------------------------------------------ ! Calculate leaf carbon from target treelai ! ------------------------------------------ - currentCohort%treelai = currentSite%sp_tlai(fates_pft) - - ! correct c_area for the new nplant - currentCohort%c_area = currentCohort%c_area * currentCohort%n - + currentCohort%treelai = tlai + canopylai(:) = 0._r8 leaf_c = leafc_from_treelai( currentCohort%treelai, currentCohort%pft, currentCohort%c_area,& currentCohort%n, currentCohort%canopy_layer, currentCohort%vcmax25top) !check reverse - maybe can delete eventually check_treelai = tree_lai(leaf_c, currentCohort%pft, currentCohort%c_area, & currentCohort%n, currentCohort%canopy_layer, & - currentPatch%canopy_layer_tlai,currentCohort%vcmax25top ) + canopylai,currentCohort%vcmax25top ) if( abs(currentCohort%treelai-check_treelai).gt.1.0e-12)then !this is not as precise as nearzerio (10^-16 typically) write(fates_log(),*) 'error in validate treelai',currentCohort%treelai,check_treelai,currentCohort%treelai-check_treelai call endrun(msg=errMsg(sourcefile, __LINE__)) end if - call SetState(currentCohort%prt,leaf_organ,1,leaf_c,1) + + ! the carea_allom routine sometimes generates precision-tolerance level errors in the canopy area + if(abs(currentCohort%c_area-parea).gt.nearzero)then + if(abs(currentCohort%c_area-parea).lt.10.e-9)then !correct this if it's a very sall error + oldcarea = currentCohort%c_area + !generate new cohort area + currentCohort%c_area = currentCohort%c_area - (currentCohort%c_area- parea) + currentCohort%n = currentCohort%n * (currentCohort%c_area/oldcarea) + if(abs(currentCohort%c_area-parea).gt.nearzero)then + write(fates_log(),*) 'SPassign, c_area still broken',currentCohort%c_area-parea,currentCohort%c_area-oldcarea + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + else + write(fates_log(),*) 'SPassign, big error in c_area',currentCohort%c_area-parea,currentCohort%pft + end if ! still broken + end if !small error + + if(init.eq.ifalse)then + call SetState(currentCohort%prt,leaf_organ,1,leaf_c,1) + endif ! assert sai - currentCohort%treesai = currentSite%sp_tsai(fates_pft) + currentCohort%treesai = tsai - !NB these will need to be put through the canopy_structure routine in order to figure out exposed lai and sai + end subroutine assign_cohort_SP_properties - currentCohort => currentCohort%shorter - end do !cohort loop - currentPatch => currentPatch%younger - end do ! patch loop - - end subroutine satellite_phenology ! ===================================================================================== subroutine SeedIn( currentSite, bc_in ) @@ -2011,7 +2062,8 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) temp_cohort%hite, temp_cohort%coage, temp_cohort%dbh, prt, & temp_cohort%laimemory, temp_cohort%sapwmemory, temp_cohort%structmemory, & cohortstatus, recruitstatus, & - temp_cohort%canopy_trim, currentPatch%NCL_p, currentSite%spread, bc_in) + temp_cohort%canopy_trim,temp_cohort%c_area, & + currentPatch%NCL_p, currentSite%spread, bc_in) ! Note that if hydraulics is on, the number of cohorts may had ! changed due to hydraulic constraints. From f34b399fc3c5158dee6a3d0a430407e47db6dde0 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 21 Sep 2020 09:03:52 -0600 Subject: [PATCH 101/209] large EDInit updates. now runs to third ts --- main/EDInitMod.F90 | 177 +++++++++++++++++++++++++++++++-------------- 1 file changed, 124 insertions(+), 53 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index ced8c2740b..d6e8a97c55 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -19,6 +19,7 @@ module EDInitMod use EDCohortDynamicsMod , only : InitPRTObject use EDPatchDynamicsMod , only : create_patch use EDPatchDynamicsMod , only : set_patchno + use EDPhysiologyMod , only : assign_cohort_sp_properties use ChecksBalancesMod , only : SiteMassStock use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type use EDTypesMod , only : numWaterMem @@ -325,9 +326,18 @@ subroutine set_site_properties( nsites, sites,bc_in ) sumarea = sum(sites(s)%area_pft(1:numpft)) do ft = 1,numpft if(sites(s)%area_pft(ft).lt.0.01_r8.and.sites(s)%area_pft(ft).gt.0.0_r8)then - if ( debug ) write(fates_log(),*) 'removing small pft patches',s,ft,sites(s)%area_pft(ft) - sites(s)%area_pft(ft)=0.0_r8 !remove tiny patches to prevent numerical errors in terminate patches - endif + write(fates_log(),*) 'removing small pft patches',s,ft,sites(s)%area_pft(ft) + sites(s)%area_pft(ft)=0.0_r8 + ! remove tiny patches to prevent numerical errors in terminate patches + endif + end do +! change units to m2 from fractions + do ft = 1,numpft + sites(s)%area_pft(ft)= sites(s)%area_pft(ft) * AREA ! rescale units to m2. + if(sites(s)%area_pft(ft).lt.0._r8)then + write(fates_log(),*) 'negative area',s,ft,sites(s)%area_pft(ft) + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if end do ! re-normalize PFT area to ensure it sums to one. @@ -346,10 +356,13 @@ subroutine set_site_properties( nsites, sites,bc_in ) end do !ft else ! for sp mode, assert a bare ground patch sumarea = sum(sites(s)%area_pft(1:numpft)) - ! here we subsume the destroyed tiny patches into the bare ground fraction. - sites(s)%area_bareground = 1.0_r8 - sumarea + + if(sumarea.lt.area)then !make some bare ground + sites(s)%area_bareground = area - sumarea + else + sites(s)%area_bareground = 0.0_r8 + end if end if !sp mode - end if !fixed biogeog do ft = 1,numpft @@ -458,8 +471,43 @@ subroutine init_patches( nsites, sites, bc_in) no_new_patches = 1 newparea = area end if - is_first_patch = 1 - do n = 1, no_new_patches + + !check if the total area adds to the same as site area + if(hlm_use_sp.eq.itrue)then + tota = 0.0_r8 + do n = 0, no_new_patches + if(n.eq.0)then + newparea = sites(s)%area_bareground + else + newparea = sites(s)%area_pft(n) + end if + tota=tota+newparea + end do !n + + if(abs(tota-area).gt.1.0e-16_r8)then + if(abs(tota-area).lt.1.0e-10_r8)then + write(*,*) 'error in assigning areas in init patch BEF',s,sites(s)%lat,tota-area,tota + if(sites(s)%area_bareground.gt.nearzero.and.sites(s)%area_bareground.gt.tota-area)then + !modify area of bare ground if thre is a bare ground patch and it is big enough + write(fates_log(),*) 'fixing patch precision in bg patch', sites(s)%area_bareground , tota-area,sites(s)%area_bareground - (tota-area) + sites(s)%area_bareground = sites(s)%area_bareground - (tota-area) !units of m2 + else !no bare ground + do n = 0, no_new_patches + if(sites(s)%area_pft(n).gt.tota-area)then + sites(s)%area_pft(n) = sites(s)%area_pft(n) - (tota-area) + write(fates_log(),*) 'fixing patch precision in veg patch',n,sites(s)%area_pft(n), tota-area + end if + end do + endif !area left in patches + else !this is a big error + write(fates_log(),*) 'error large', s,tota-area + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif ! big error + end if ! too much patch area + end if ! SP + + is_first_patch = 1 + do n = 0, no_new_patches ! set the PFT index for patches if in nocomp mode. if(hlm_use_nocomp.eq.itrue)then @@ -473,7 +521,7 @@ subroutine init_patches( nsites, sites, bc_in) ! then each PFT has the area dictated by the surface dataset. ! If not, each PFT gets the same area. if(hlm_use_fixed_biogeog.eq.itrue)then - newparea = area * sites(s)%area_pft(nocomp_pft) + newparea = sites(s)%area_pft(nocomp_pft) else newparea = area / numpft end if @@ -481,8 +529,8 @@ subroutine init_patches( nsites, sites, bc_in) newparea = area end if !nocomp mode - if(hlm_use_sp.eq.itrue.and.n.gt.numpft)then - newparea = sites(s)%area_bareground * area + if(hlm_use_sp.eq.itrue.and.n.eq.0)then + newparea = sites(s)%area_bareground nocomp_pft = 0 end if @@ -490,7 +538,7 @@ subroutine init_patches( nsites, sites, bc_in) allocate(newp) call create_patch(sites(s), newp, age, newparea, primaryforest, nocomp_pft) - + if(is_first_patch.eq.1)then !is this the first patch? ! set poointers for first patch (or only patch, if nocomp is false) newp%patchno = 1 @@ -523,8 +571,12 @@ subroutine init_patches( nsites, sites, bc_in) end do sitep => sites(s) - if(hlm_use_sp.eq.ifalse.and.nocomp_pft.eq.0)then !don't initialize cohorts for SP bare ground patch - call init_cohorts(sitep, newp, bc_in(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 + call init_cohorts(sitep, newp, bc_in(s)) end if end if end do !no new patches @@ -534,12 +586,22 @@ subroutine init_patches( nsites, sites, bc_in) newp => sites(s)%oldest_patch do while (associated(newp)) tota=tota+newp%area - if ( debug ) write(fates_log(),*) 'test links',s,newp%nocomp_pft_label,tota newp=>newp%younger end do + if(abs(tota-area).gt.nearzero*area)then - write(*,*) 'error in assigning areas in init patch',s,sites(s)%lat,tota-area,tota - endif + if(abs(tota-area).lt.1.0e-10_r8)then ! this is a precision error + if(sites(s)%oldest_patch%area.gt.(tota-area+nearzero))then + ! remove or add extra area from bare ground patch + sites(s)%oldest_patch%area = sites(s)%oldest_patch%area - (tota-area) + write(*,*) 'fixing patch precision O',s, tota-area + else + sites(s)%youngest_patch%area = sites(s)%oldest_patch%area - (tota-area) + endif + else !this is a big error + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif ! big error + end if ! too much patch area ! For carbon balance checks, we need to initialize the ! total carbon stock @@ -549,7 +611,6 @@ subroutine init_patches( nsites, sites, bc_in) end do call set_patchno(sites(s)) -! deallocate(recall_older_patch) !leaving this as a potential fix for memory leak in multipatch nocomp mode enddo !s end if @@ -607,7 +668,7 @@ subroutine init_cohorts( site_in, patch_in, bc_in) real(r8) :: stem_drop_fraction integer, parameter :: rstatus = 0 - + integer init !---------------------------------------------------------------------- patch_in%tallest => null() @@ -627,8 +688,8 @@ subroutine init_cohorts( site_in, patch_in, bc_in) if(hlm_use_fixed_biogeog.eq.itrue)then !filter geographically use_pft_local(pft) = site_in%use_this_pft(pft) ! Case 2 if(hlm_use_nocomp.eq.itrue.and.pft.ne.patch_in%nocomp_pft_label)then - ! Having set the biogeog filter as on or off, turn off all patches - ! whose identiy does not correspond to this PFT. + ! Having set the biogeog filter as on or off, turn off all PFTs + ! whose identiy does not correspond to this patch label. use_pft_local(pft) = ifalse ! Case 3 endif else @@ -639,7 +700,6 @@ subroutine init_cohorts( site_in, patch_in, bc_in) endif end do - do pft = 1,numpft if(use_pft_local(pft).eq.itrue)then if(EDPftvarcon_inst%initd(pft)>nearzero) then @@ -656,13 +716,24 @@ subroutine init_cohorts( site_in, patch_in, bc_in) temp_cohort%n = temp_cohort%n * sum(site_in%use_this_pft) endif - temp_cohort%hite = EDPftvarcon_inst%hgt_min(pft) - + temp_cohort%canopy_trim = 1.0_r8 - ! Calculate the plant diameter from height - call h2d_allom(temp_cohort%hite,pft,temp_cohort%dbh) + ! h,dbh,leafc,n from SP values or from small initial size. - temp_cohort%canopy_trim = 1.0_r8 + if(hlm_use_sp.eq.itrue)then + init = itrue + call assign_cohort_SP_properties(temp_cohort, 0.5_r8,0.2_r8, 0.1_r8,patch_in%area,init,c_leaf) + + else + temp_cohort%hite = EDPftvarcon_inst%hgt_min(pft) + + ! Calculate the plant diameter from height + call h2d_allom(temp_cohort%hite,pft,temp_cohort%dbh) + + ! Calculate the leaf biomass from allometry + ! (calculates a maximum first, then applies canopy trim) + call bleaf(temp_cohort%dbh,pft,temp_cohort%canopy_trim,c_leaf) + end if ! sp mode ! Calculate total above-ground biomass from allometry call bagw_allom(temp_cohort%dbh,pft,c_agw) @@ -670,10 +741,6 @@ subroutine init_cohorts( site_in, patch_in, bc_in) ! Calculate coarse root biomass from allometry call bbgw_allom(temp_cohort%dbh,pft,c_bgw) - ! Calculate the leaf biomass from allometry - ! (calculates a maximum first, then applies canopy trim) - call bleaf(temp_cohort%dbh,pft,temp_cohort%canopy_trim,c_leaf) - ! Calculate fine root biomass from allometry ! (calculates a maximum and then trimming value) call bfineroot(temp_cohort%dbh,pft,temp_cohort%canopy_trim,c_fnrt) @@ -691,28 +758,30 @@ subroutine init_cohorts( site_in, patch_in, bc_in) cstatus = leaves_on stem_drop_fraction = EDPftvarcon_inst%phen_stem_drop_fraction(temp_cohort%pft) - - if( EDPftvarcon_inst%season_decid(pft) == itrue .and. & - any(site_in%cstatus == [phen_cstat_nevercold,phen_cstat_iscold])) then - temp_cohort%laimemory = c_leaf - temp_cohort%sapwmemory = c_sapw * stem_drop_fraction - temp_cohort%structmemory = c_struct * stem_drop_fraction - c_leaf = 0._r8 - c_sapw = (1.0_r8-stem_drop_fraction) * c_sapw - c_struct = (1.0_r8-stem_drop_fraction) * c_struct - cstatus = leaves_off - endif - if ( EDPftvarcon_inst%stress_decid(pft) == itrue .and. & - any(site_in%dstatus == [phen_dstat_timeoff,phen_dstat_moistoff])) then - temp_cohort%laimemory = c_leaf - temp_cohort%sapwmemory = c_sapw * stem_drop_fraction - temp_cohort%structmemory = c_struct * stem_drop_fraction - c_leaf = 0._r8 - c_sapw = (1.0_r8-stem_drop_fraction) * c_sapw - c_struct = (1.0_r8-stem_drop_fraction) * c_struct - cstatus = leaves_off - endif + if(hlm_use_sp.eq.ifalse)then ! do not override SP vales with phenology + if( EDPftvarcon_inst%season_decid(pft) == itrue .and. & + any(site_in%cstatus == [phen_cstat_nevercold,phen_cstat_iscold])) then + temp_cohort%laimemory = c_leaf + temp_cohort%sapwmemory = c_sapw * stem_drop_fraction + temp_cohort%structmemory = c_struct * stem_drop_fraction + c_leaf = 0._r8 + c_sapw = (1.0_r8-stem_drop_fraction) * c_sapw + c_struct = (1.0_r8-stem_drop_fraction) * c_struct + cstatus = leaves_off + endif + + if ( EDPftvarcon_inst%stress_decid(pft) == itrue .and. & + any(site_in%dstatus == [phen_dstat_timeoff,phen_dstat_moistoff])) then + temp_cohort%laimemory = c_leaf + temp_cohort%sapwmemory = c_sapw * stem_drop_fraction + temp_cohort%structmemory = c_struct * stem_drop_fraction + c_leaf = 0._r8 + c_sapw = (1.0_r8-stem_drop_fraction) * c_sapw + c_struct = (1.0_r8-stem_drop_fraction) * c_struct + cstatus = leaves_off + endif + end if ! SP mode if ( debug ) write(fates_log(),*) 'EDInitMod.F90 call create_cohort ' @@ -788,7 +857,8 @@ subroutine init_cohorts( site_in, patch_in, bc_in) call create_cohort(site_in, patch_in, pft, temp_cohort%n, temp_cohort%hite, & temp_cohort%coage, temp_cohort%dbh, prt_obj, temp_cohort%laimemory, & temp_cohort%sapwmemory, temp_cohort%structmemory, cstatus, rstatus, & - temp_cohort%canopy_trim, 1, site_in%spread, bc_in) + temp_cohort%canopy_trim, temp_cohort%c_area,1, site_in%spread, bc_in) + deallocate(temp_cohort) ! get rid of temporary cohort @@ -806,6 +876,7 @@ subroutine init_cohorts( site_in, patch_in, bc_in) call fuse_cohorts(site_in, patch_in,bc_in) call sort_cohorts(patch_in) + end subroutine init_cohorts ! =============================================================================================== From 77729ab9dd683f9580ac2e738adcf1b56ea4df57 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 28 Sep 2020 05:59:24 -0600 Subject: [PATCH 102/209] modified initialization of SP variables --- main/EDInitMod.F90 | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index d6e8a97c55..5a8935d761 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -457,6 +457,10 @@ subroutine init_patches( nsites, sites, bc_in) allocate(recall_older_patch) do s = 1, nsites + sites(s)%sp_tlai(:) = 0._r8 + sites(s)%sp_tsai(:) = 0._r8 + sites(s)%sp_htop(:) = 0._r8 + ! Initialize the site-level crown area spread factor (0-1) ! It is likely that closed canopy forest inventories ! have smaller spread factors than bare ground (they are crowded) @@ -486,10 +490,9 @@ subroutine init_patches( nsites, sites, bc_in) if(abs(tota-area).gt.1.0e-16_r8)then if(abs(tota-area).lt.1.0e-10_r8)then - write(*,*) 'error in assigning areas in init patch BEF',s,sites(s)%lat,tota-area,tota if(sites(s)%area_bareground.gt.nearzero.and.sites(s)%area_bareground.gt.tota-area)then !modify area of bare ground if thre is a bare ground patch and it is big enough - write(fates_log(),*) 'fixing patch precision in bg patch', sites(s)%area_bareground , tota-area,sites(s)%area_bareground - (tota-area) + write(fates_log(),*) 'fixing patch precision in bg patch', sites(s)%area_bareground , tota-area sites(s)%area_bareground = sites(s)%area_bareground - (tota-area) !units of m2 else !no bare ground do n = 0, no_new_patches @@ -572,6 +575,7 @@ subroutine init_patches( nsites, sites, bc_in) 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 From 5fb8de8730b9447d0ce369b2e7b75c82272b4bbd Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 28 Sep 2020 07:53:36 -0600 Subject: [PATCH 103/209] seperate loops in satellite_phenology --- biogeochem/EDPhysiologyMod.F90 | 26 +++++++++++++++++++++----- 1 file changed, 21 insertions(+), 5 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index eacae06580..9e9593f58a 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1376,9 +1376,9 @@ subroutine satellite_phenology(currentSite, bc_in) ! determine what 'n' should be from the canopy height. - currentSite%sp_tlai(1:numpft) = 0._r8 - currentSite%sp_tsai(1:numpft) = 0._r8 - currentSite%sp_htop(1:numpft) = 0._r8 + currentSite%sp_tlai(:) = 0._r8 + currentSite%sp_tsai(:) = 0._r8 + currentSite%sp_htop(:) = 0._r8 currentPatch => currentSite%oldest_patch do while (associated(currentPatch)) @@ -1391,10 +1391,13 @@ subroutine satellite_phenology(currentSite, bc_in) ! weight each fates PFT target for lai, sai and htop by the area of the ! contrbuting HLM PFTs. ! we only need to do this for the patch/fates_pft we are currently in - fates_pft = currentPatch%nocomp_pft_label + fates_pft = currentPatch%nocomp_pft_label + if(fates_pft.ne.0)then sumarea = 0.0_r8 + do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) + if(bc_in%pft_areafrac(hlm_pft) * EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft).gt.0.0_r8)then sumarea = sumarea + bc_in%pft_areafrac(hlm_pft)*EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft) !leaf area index @@ -1421,7 +1424,14 @@ subroutine satellite_phenology(currentSite, bc_in) currentSite%sp_htop(fates_pft) = currentSite%sp_htop(fates_pft) & /(currentPatch%area/area) endif - + + + end if ! bare patch + currentPatch => currentPatch%younger + end do ! patch loop + currentPatch => currentSite%oldest_patch + do while (associated(currentPatch)) + ! ------------------------------------------------------------ ! now we have the target lai, sai and htop for each PFT/patch ! find properties of the cohort that go along with that @@ -1438,6 +1448,10 @@ subroutine satellite_phenology(currentSite, bc_in) call endrun(msg=errMsg(sourcefile, __LINE__)) end if + if(fates_pft.eq.0)then + write(fates_log(),*) 'PFT0 in SP mode' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if call assign_cohort_SP_properties(currentCohort, currentSite%sp_htop(fates_pft), currentSite%sp_tlai(fates_pft) , currentSite%sp_tsai(fates_pft),currentPatch%area,ifalse,leaf_c) currentCohort => currentCohort%shorter @@ -1486,6 +1500,7 @@ subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,l ! Calculate dbh from input height, and c_area from dbh !------------------------------------------ currentCohort%hite = htop + fates_pft = currentCohort%pft call h2d_allom(currentCohort%hite,fates_pft,currentCohort%dbh) @@ -1521,6 +1536,7 @@ subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,l write(fates_log(),*) 'error in validate treelai',currentCohort%treelai,check_treelai,currentCohort%treelai-check_treelai call endrun(msg=errMsg(sourcefile, __LINE__)) end if + ! the carea_allom routine sometimes generates precision-tolerance level errors in the canopy area if(abs(currentCohort%c_area-parea).gt.nearzero)then From 1afadcc196754b59c743751357e541fda1c784db Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 28 Sep 2020 07:56:18 -0600 Subject: [PATCH 104/209] modified nan check --- biogeochem/EDCanopyStructureMod.F90 | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 9500ba8eef..ea29b6a40a 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1933,7 +1933,6 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) endif bc_out(s)%hbot_pa(ifp) = max(0._r8, min(0.2_r8, bc_out(s)%htop_pa(ifp)- 1.0_r8)) - ! Use leaf area weighting for all cohorts in the patch to define the characteristic ! leaf width used by the HLM ! ---------------------------------------------------------------------------- @@ -1957,7 +1956,6 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) bc_out(s)%displa_pa(ifp) = EDPftvarcon_inst%displar(1) * bc_out(s)%htop_pa(ifp) bc_out(s)%dleaf_pa(ifp) = EDPftvarcon_inst%dleaf(1) - ! We are assuming here that grass is all located underneath tree canopies. ! The alternative is to assume it is all spatial distinct from tree canopies. ! In which case, the bare area would have to be reduced by the grass area... @@ -1967,7 +1965,7 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) bc_out(s)%canopy_fraction_pa(ifp) = & min(1.0_r8,currentPatch%total_canopy_area/currentPatch%area)*(currentPatch%area/AREA) if(isnan(bc_out(s)%canopy_fraction_pa(ifp)))then - write(*,*) 'nan canopy_fraction_pa in canopystructure, ifp, canopy area,patch area:',ifp,currentPatch%total_canopy_area,currentPatch%area + write(fates_log(),*) 'nan canopy_fraction_pa in canopystructure:',ifp call endrun(msg=errMsg(sourcefile, __LINE__)) end if bare_frac_area = (1.0_r8 - min(1.0_r8,currentPatch%total_canopy_area/currentPatch%area)) * & From aa04775f0fd0e1329cc1d0b5cb597bb0b1e010f0 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 29 Sep 2020 02:11:37 -0600 Subject: [PATCH 105/209] fixing compile errors in FatesAllometry --- biogeochem/FatesAllometryMod.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/biogeochem/FatesAllometryMod.F90 b/biogeochem/FatesAllometryMod.F90 index 60b03d54fa..c694614f35 100644 --- a/biogeochem/FatesAllometryMod.F90 +++ b/biogeochem/FatesAllometryMod.F90 @@ -808,7 +808,7 @@ real(r8) function leafc_from_treelai( treelai, pft, c_area, nplant, cl, vcmax25t call endrun(msg=errMsg(sourcefile, __LINE__)) endif - slat = g_per_kg * EDPftvarcon_inst%slatop(pft) ! m2/g to m2/kg + slat = g_per_kg * prt_params%slatop(pft) leafc_per_unitarea = leaf_c/(c_area/nplant) !KgC/m2 if(treelai > 0.0_r8)then @@ -816,7 +816,7 @@ real(r8) function leafc_from_treelai( treelai, pft, c_area, nplant, cl, vcmax25t kn = decay_coeff_kn(pft,vcmax25top) ! take PFT-level maximum SLA value, even if under a thick canopy (which has units of m2/gC), ! and put into units of m2/kgC - sla_max = g_per_kg *EDPftvarcon_inst%slamax(pft) + sla_max = g_per_kg * prt_params%slamax(pft) ! Leafc_per_unitarea at which sla_max is reached due to exponential sla profile in canopy: leafc_slamax = max(0.0_r8,(slat - sla_max) / (-1.0_r8 * kn * slat * sla_max)) From e1048554846f5abd6c7908c38604d84e55f3bed9 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 29 Sep 2020 02:42:20 -0600 Subject: [PATCH 106/209] fixing compiling/merge errors in EDpftvarcn --- main/EDPftvarcon.F90 | 704 +------------------------------------------ 1 file changed, 1 insertion(+), 703 deletions(-) diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index dfe3e39df2..a44235eba8 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -1405,37 +1405,8 @@ subroutine FatesReportPFTParams(is_master) write(fates_log(),fmt0) 'hydr_fcap_node = ',EDPftvarcon_inst%hydr_fcap_node write(fates_log(),fmt0) 'hydr_pinot_node = ',EDPftvarcon_inst%hydr_pinot_node write(fates_log(),fmt0) 'hydr_kmax_node = ',EDPftvarcon_inst%hydr_kmax_node -<<<<<<< HEAD - - write(fates_log(),fmt0) 'prt_nitr_stoich_p1 = ',EDPftvarcon_inst%prt_nitr_stoich_p1 - write(fates_log(),fmt0) 'prt_nitr_stoich_p2 = ',EDPftvarcon_inst%prt_nitr_stoich_p2 - write(fates_log(),fmt0) 'prt_phos_stoich_p1 = ',EDPftvarcon_inst%prt_phos_stoich_p1 - write(fates_log(),fmt0) 'prt_phos_stoich_p2 = ',EDPftvarcon_inst%prt_phos_stoich_p2 - write(fates_log(),fmt0) 'prt_grperc_organ = ',EDPftvarcon_inst%prt_grperc_organ - write(fates_log(),fmt0) 'prt_alloc_priority = ',EDPftvarcon_inst%prt_alloc_priority - - write(fates_log(),fmt0) 'turnover_carb_retrans = ',EDPftvarcon_inst%turnover_carb_retrans - write(fates_log(),fmt0) 'turnover_nitr_retrans = ',EDPftvarcon_inst%turnover_nitr_retrans - write(fates_log(),fmt0) 'turnover_phos_retrans = ',EDPftvarcon_inst%turnover_phos_retrans write(fates_log(),fmt0) 'hlm_pft_map = ', EDPftvarcon_inst%hlm_pft_map - -||||||| merged common ancestors - - - write(fates_log(),fmt0) 'prt_nitr_stoich_p1 = ',EDPftvarcon_inst%prt_nitr_stoich_p1 - write(fates_log(),fmt0) 'prt_nitr_stoich_p2 = ',EDPftvarcon_inst%prt_nitr_stoich_p2 - write(fates_log(),fmt0) 'prt_phos_stoich_p1 = ',EDPftvarcon_inst%prt_phos_stoich_p1 - write(fates_log(),fmt0) 'prt_phos_stoich_p2 = ',EDPftvarcon_inst%prt_phos_stoich_p2 - write(fates_log(),fmt0) 'prt_grperc_organ = ',EDPftvarcon_inst%prt_grperc_organ - write(fates_log(),fmt0) 'prt_alloc_priority = ',EDPftvarcon_inst%prt_alloc_priority - - write(fates_log(),fmt0) 'turnover_carb_retrans = ',EDPftvarcon_inst%turnover_carb_retrans - write(fates_log(),fmt0) 'turnover_nitr_retrans = ',EDPftvarcon_inst%turnover_nitr_retrans - write(fates_log(),fmt0) 'turnover_phos_retrans = ',EDPftvarcon_inst%turnover_phos_retrans - -======= ->>>>>>> 03a17bfebbc7d947ab4f7b88b649a31cdac213fb write(fates_log(),*) '-------------------------------------------------' end if @@ -1722,341 +1693,6 @@ subroutine FatesCheckParams(is_master) end if -<<<<<<< HEAD - - ! Check re-translocations - ! Seems reasonable to assume that sapwood, structure and reproduction - ! should not be re-translocating mass upon turnover. - ! Note to advanced users. Feel free to remove these checks... - ! ------------------------------------------------------------------- - - if ( (EDPftvarcon_inst%turnover_carb_retrans(ipft,repro_organ) > nearzero) ) then - write(fates_log(),*) ' Retranslocation of reproductive tissues should be zero.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' carbon: ',EDPftvarcon_inst%turnover_carb_retrans(ipft,repro_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - if (parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if ((EDPftvarcon_inst%turnover_nitr_retrans(ipft,repro_organ) > nearzero) .or. & - (EDPftvarcon_inst%turnover_phos_retrans(ipft,repro_organ) > nearzero) ) then - write(fates_log(),*) ' Retranslocation of reproductive tissues should be zero.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' carbon: ',EDPftvarcon_inst%turnover_carb_retrans(ipft,repro_organ) - write(fates_log(),*) ' nitr: ',EDPftvarcon_inst%turnover_nitr_retrans(ipft,repro_organ) - write(fates_log(),*) ' phos: ',EDPftvarcon_inst%turnover_phos_retrans(ipft,repro_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - if ((EDPftvarcon_inst%turnover_carb_retrans(ipft,sapw_organ) > nearzero)) then - write(fates_log(),*) ' Retranslocation of sapwood tissues should be zero.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' carbon: ',EDPftvarcon_inst%turnover_carb_retrans(ipft,sapw_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - if (parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if ((EDPftvarcon_inst%turnover_nitr_retrans(ipft,sapw_organ) > nearzero) .or. & - (EDPftvarcon_inst%turnover_phos_retrans(ipft,sapw_organ) > nearzero) ) then - write(fates_log(),*) ' Retranslocation of sapwood tissues should be zero.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' carbon: ',EDPftvarcon_inst%turnover_carb_retrans(ipft,sapw_organ) - write(fates_log(),*) ' nitr: ',EDPftvarcon_inst%turnover_nitr_retrans(ipft,sapw_organ) - write(fates_log(),*) ' phos: ',EDPftvarcon_inst%turnover_phos_retrans(ipft,sapw_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - if ((EDPftvarcon_inst%turnover_carb_retrans(ipft,struct_organ) > nearzero)) then - write(fates_log(),*) ' Retranslocation of structural(dead) tissues should be zero.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' carbon: ',EDPftvarcon_inst%turnover_carb_retrans(ipft,struct_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - if (parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if ((EDPftvarcon_inst%turnover_nitr_retrans(ipft,struct_organ) > nearzero) .or. & - (EDPftvarcon_inst%turnover_phos_retrans(ipft,struct_organ) > nearzero) ) then - write(fates_log(),*) ' Retranslocation of structural(dead) tissues should be zero.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' nitr: ',EDPftvarcon_inst%turnover_nitr_retrans(ipft,struct_organ) - write(fates_log(),*) ' phos: ',EDPftvarcon_inst%turnover_phos_retrans(ipft,struct_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - ! Leaf retranslocation should be between 0 and 1 - if ( (EDPftvarcon_inst%turnover_carb_retrans(ipft,leaf_organ) > 1.0_r8) .or. & - (EDPftvarcon_inst%turnover_carb_retrans(ipft,leaf_organ) < 0.0_r8) ) then - write(fates_log(),*) ' Retranslocation of leaf tissues should be between 0 and 1.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' carbon: ',EDPftvarcon_inst%turnover_carb_retrans(ipft,leaf_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - if (parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if ((EDPftvarcon_inst%turnover_nitr_retrans(ipft,leaf_organ) > 1.0_r8) .or. & - (EDPftvarcon_inst%turnover_phos_retrans(ipft,leaf_organ) > 1.0_r8) .or. & - (EDPftvarcon_inst%turnover_nitr_retrans(ipft,leaf_organ) < 0.0_r8) .or. & - (EDPftvarcon_inst%turnover_phos_retrans(ipft,leaf_organ) < 0.0_r8)) then - write(fates_log(),*) ' Retranslocation of leaf tissues should be between 0 and 1.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' nitr: ',EDPftvarcon_inst%turnover_nitr_retrans(ipft,leaf_organ) - write(fates_log(),*) ' phos: ',EDPftvarcon_inst%turnover_phos_retrans(ipft,leaf_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - ! Fineroot retranslocation should be between 0-1 - if ((EDPftvarcon_inst%turnover_carb_retrans(ipft,fnrt_organ) > 1.0_r8) .or. & - (EDPftvarcon_inst%turnover_carb_retrans(ipft,fnrt_organ) < 0.0_r8)) then - write(fates_log(),*) ' Retranslocation of leaf tissues should be between 0 and 1.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' carbon: ',EDPftvarcon_inst%turnover_carb_retrans(ipft,fnrt_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - if (parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if ((EDPftvarcon_inst%turnover_nitr_retrans(ipft,fnrt_organ) > 1.0_r8) .or. & - (EDPftvarcon_inst%turnover_phos_retrans(ipft,fnrt_organ) > 1.0_r8) .or. & - (EDPftvarcon_inst%turnover_nitr_retrans(ipft,fnrt_organ) < 0.0_r8) .or. & - (EDPftvarcon_inst%turnover_phos_retrans(ipft,fnrt_organ) < 0.0_r8)) then - write(fates_log(),*) ' Retranslocation of leaf tissues should be between 0 and 1.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' nitr: ',EDPftvarcon_inst%turnover_nitr_retrans(ipft,fnrt_organ) - write(fates_log(),*) ' phos: ',EDPftvarcon_inst%turnover_phos_retrans(ipft,fnrt_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - ! Storage retranslocation should be between 0-1 (storage retrans seems weird, but who knows) - if ((EDPftvarcon_inst%turnover_carb_retrans(ipft,store_organ) > 1.0_r8) .or. & - (EDPftvarcon_inst%turnover_carb_retrans(ipft,store_organ) < 0.0_r8)) then - write(fates_log(),*) ' Retranslocation of leaf tissues should be between 0 and 1.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' carbon: ',EDPftvarcon_inst%turnover_carb_retrans(ipft,store_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - if (parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if ((EDPftvarcon_inst%turnover_nitr_retrans(ipft,store_organ) > 1.0_r8) .or. & - (EDPftvarcon_inst%turnover_phos_retrans(ipft,store_organ) > 1.0_r8) .or. & - (EDPftvarcon_inst%turnover_nitr_retrans(ipft,store_organ) < 0.0_r8) .or. & - (EDPftvarcon_inst%turnover_phos_retrans(ipft,store_organ) < 0.0_r8)) then - write(fates_log(),*) ' Retranslocation of leaf tissues should be between 0 and 1.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' nitr: ',EDPftvarcon_inst%turnover_nitr_retrans(ipft,store_organ) - write(fates_log(),*) ' phos: ',EDPftvarcon_inst%turnover_phos_retrans(ipft,store_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - ! Growth respiration - if (parteh_mode .eq. prt_carbon_allom_hyp) then - if ( ( EDPftvarcon_inst%grperc(ipft) < 0.0_r8) .or. & - ( EDPftvarcon_inst%grperc(ipft) > 1.0_r8 ) ) then - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' Growth respiration must be between 0 and 1: ',EDPftvarcon_inst%grperc(ipft) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - elseif(parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if ( ( any(EDPftvarcon_inst%prt_grperc_organ(ipft,:) < 0.0_r8)) .or. & - ( any(EDPftvarcon_inst%prt_grperc_organ(ipft,:) >= 1.0_r8)) ) then - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' Growth respiration must be between 0 and 1: ',EDPftvarcon_inst%prt_grperc_organ(ipft,:) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - ! Stoichiometric Ratios - - ! Firstly, the seed production and germination models cannot handle nutrients. So - ! we assume (for now) that seeds do not have nutrients (parteh_mode = 1 is c only) - if(parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if ( (EDPftvarcon_inst%prt_nitr_stoich_p1(ipft,repro_organ) > nearzero) .or. & - (EDPftvarcon_inst%prt_nitr_stoich_p1(ipft,repro_organ) < -nearzero) .or. & - (EDPftvarcon_inst%prt_phos_stoich_p1(ipft,repro_organ) > nearzero) .or. & - (EDPftvarcon_inst%prt_phos_stoich_p1(ipft,repro_organ) < -nearzero) .or. & - (EDPftvarcon_inst%prt_nitr_stoich_p2(ipft,repro_organ) > nearzero) .or. & - (EDPftvarcon_inst%prt_nitr_stoich_p2(ipft,repro_organ) < -nearzero) .or. & - (EDPftvarcon_inst%prt_phos_stoich_p2(ipft,repro_organ) > nearzero) .or. & - (EDPftvarcon_inst%prt_phos_stoich_p2(ipft,repro_organ) < -nearzero) ) then - write(fates_log(),*) 'N & P should be zero in reproductive tissues' - write(fates_log(),*) 'until nutrients are coupled into recruitment' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) EDPftvarcon_inst%prt_nitr_stoich_p1(ipft,repro_organ) - write(fates_log(),*) EDPftvarcon_inst%prt_phos_stoich_p1(ipft,repro_organ) - write(fates_log(),*) EDPftvarcon_inst%prt_nitr_stoich_p2(ipft,repro_organ) - write(fates_log(),*) EDPftvarcon_inst%prt_phos_stoich_p2(ipft,repro_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - ! The first nitrogen stoichiometry is used in all cases - if ( (any(EDPftvarcon_inst%prt_nitr_stoich_p1(ipft,:) < 0.0_r8)) .or. & - (any(EDPftvarcon_inst%prt_nitr_stoich_p1(ipft,:) >= 1.0_r8))) then - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' N per C stoichiometry must bet between 0-1' - write(fates_log(),*) EDPftvarcon_inst%prt_nitr_stoich_p1(ipft,:) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - if(parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if( (any(EDPftvarcon_inst%prt_nitr_stoich_p2(ipft,:) < 0.0_r8)) .or. & - (any(EDPftvarcon_inst%prt_nitr_stoich_p2(ipft,:) >= 1.0_r8)) ) then - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' N per C stoichiometry must bet between 0-1' - write(fates_log(),*) EDPftvarcon_inst%prt_nitr_stoich_p2(ipft,:) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - ! Stoichiometric Ratios - if (parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if ( (any(EDPftvarcon_inst%prt_phos_stoich_p1(ipft,:) < 0.0_r8)) .or. & - (any(EDPftvarcon_inst%prt_phos_stoich_p1(ipft,:) >= 1.0_r8)) .or. & - (any(EDPftvarcon_inst%prt_phos_stoich_p2(ipft,:) < 0.0_r8)) .or. & - (any(EDPftvarcon_inst%prt_phos_stoich_p2(ipft,:) >= 1.0_r8)) ) then - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' P per C stoichiometry must bet between 0-1' - write(fates_log(),*) EDPftvarcon_inst%prt_phos_stoich_p1(ipft,:) - write(fates_log(),*) EDPftvarcon_inst%prt_phos_stoich_p2(ipft,:) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - if (parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if ( any(EDPftvarcon_inst%prt_alloc_priority(ipft,:) < 0) .or. & - any(EDPftvarcon_inst%prt_alloc_priority(ipft,:) > 6) ) then - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' Allocation priorities should be 0-6 for H1' - write(fates_log(),*) EDPftvarcon_inst%prt_alloc_priority(ipft,:) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - - ! Check turnover time-scales - - nleafage = size(EDPftvarcon_inst%leaf_long,dim=2) - - do iage = 1, nleafage - - if ( EDPftvarcon_inst%leaf_long(ipft,iage)>nearzero ) then - - ! Check that leaf turnover doesn't exeed 1 day - if ( (years_per_day / EDPftvarcon_inst%leaf_long(ipft,iage)) > 1._r8 ) then - write(fates_log(),*) 'Leaf turnover time-scale is greater than 1 day!' - write(fates_log(),*) 'ipft: ',ipft,' iage: ',iage - write(fates_log(),*) 'leaf_long(ipft,iage): ',EDPftvarcon_inst%leaf_long(ipft,iage),' [years]' - write(fates_log(),*) 'Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - ! Check to make sure that all other age-classes for this PFT also - ! have non-zero entries, it wouldn't make sense otherwise - if ( any(EDPftvarcon_inst%leaf_long(ipft,:) <= nearzero) ) then - write(fates_log(),*) 'You specified a leaf_long that is zero or' - write(fates_log(),*) 'invalid for a particular age class.' - write(fates_log(),*) 'Yet, other age classes for this PFT are non-zero.' - write(fates_log(),*) 'this doesnt make sense.' - write(fates_log(),*) 'ipft = ',ipft - write(fates_log(),*) 'leaf_long(ipft,:) = ',EDPftvarcon_inst%leaf_long(ipft,:) - write(fates_log(),*) 'Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - else - if (EDPftvarcon_inst%evergreen(ipft) .eq. itrue) then - write(fates_log(),*) 'You specified zero leaf turnover: ' - write(fates_log(),*) 'ipft: ',ipft,' iage: ',iage - write(fates_log(),*) 'leaf_long(ipft,iage): ',EDPftvarcon_inst%leaf_long(ipft,iage) - write(fates_log(),*) 'yet this is an evergreen PFT, and it only makes sense' - write(fates_log(),*) 'that an evergreen would have leaf maintenance turnover' - write(fates_log(),*) 'disable this error if you are ok with this' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - end do ! iage - - ! Check the turnover rates on the senescing leaf pool - if ( EDPftvarcon_inst%leaf_long(ipft,nleafage)>nearzero ) then - - ! Check that leaf turnover doesn't exeed 1 day - if ( (years_per_day / & - (EDPftvarcon_inst%leaf_long(ipft,nleafage) * & - EDPftvarcon_inst%senleaf_long_fdrought(ipft))) > 1._r8 ) then - write(fates_log(),*) 'Drought-senescent turnover time-scale is greater than 1 day!' - write(fates_log(),*) 'ipft: ',ipft - write(fates_log(),*) 'leaf_long(ipft,nleafage)*senleaf_long_fdrought: ', & - EDPftvarcon_inst%leaf_long(ipft,nleafage)*EDPftvarcon_inst%senleaf_long_fdrought(ipft),' [years]' - write(fates_log(),*) 'Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - if ( EDPftvarcon_inst%senleaf_long_fdrought(ipft)1._r8 ) then - write(fates_log(),*) 'senleaf_long_fdrought(ipft) must be greater than 0 ' - write(fates_log(),*) 'or less than or equal to 1.' - write(fates_log(),*) 'Set this to 1 if you want no accelerated senescence turnover' - write(fates_log(),*) 'ipft = ',ipft - write(fates_log(),*) 'senleaf_long_fdrought(ipft) = ',EDPftvarcon_inst%senleaf_long_fdrought(ipft) - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - - if ( EDPftvarcon_inst%root_long(ipft)>nearzero ) then - - ! Check that root turnover doesn't exeed 1 day - if ( (years_per_day / EDPftvarcon_inst%root_long(ipft)) > 1._r8 ) then - write(fates_log(),*) 'Root turnover time-scale is greater than 1 day!' - write(fates_log(),*) 'ipft: ',ipft - write(fates_log(),*) 'root_long(ipft): ',EDPftvarcon_inst%root_long(ipft),' [years]' - write(fates_log(),*) 'Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - else - if (EDPftvarcon_inst%evergreen(ipft) .eq. itrue) then - write(fates_log(),*) 'You specified zero root turnover: ' - write(fates_log(),*) 'ipft: ',ipft - write(fates_log(),*) 'root_long(ipft): ',EDPftvarcon_inst%root_long(ipft) - write(fates_log(),*) 'yet this is an evergreen PFT, and it only makes sense' - write(fates_log(),*) 'that an evergreen would have root maintenance turnover' - write(fates_log(),*) 'disable this error if you are ok with this' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - ! Check Branch turnover doesn't exceed one day - if ( EDPftvarcon_inst%branch_turnover(ipft)>nearzero ) then - - ! Check that branch turnover doesn't exeed 1 day - if ( (years_per_day / EDPftvarcon_inst%branch_turnover(ipft)) > 1._r8 ) then - write(fates_log(),*) 'Branch turnover time-scale is greater than 1 day!' - write(fates_log(),*) 'ipft: ',ipft - write(fates_log(),*) 'branch_turnover(ipft): ',EDPftvarcon_inst%branch_turnover(ipft),' [years]' - write(fates_log(),*) 'Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - end do !ipft - ! check that the host-fates PFT map adds to one in both dimension do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) sumarea = sum(EDPftvarcon_inst%hlm_pft_map(1:npft,hlm_pft)) @@ -2068,348 +1704,10 @@ subroutine FatesCheckParams(is_master) write(fates_log(),*) 'Aborting' call endrun(msg=errMsg(sourcefile, __LINE__)) end if - end do !ipft -||||||| merged common ancestors - - ! Check re-translocations - ! Seems reasonable to assume that sapwood, structure and reproduction - ! should not be re-translocating mass upon turnover. - ! Note to advanced users. Feel free to remove these checks... - ! ------------------------------------------------------------------- - - if ( (EDPftvarcon_inst%turnover_carb_retrans(ipft,repro_organ) > nearzero) ) then - write(fates_log(),*) ' Retranslocation of reproductive tissues should be zero.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' carbon: ',EDPftvarcon_inst%turnover_carb_retrans(ipft,repro_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - if (parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if ((EDPftvarcon_inst%turnover_nitr_retrans(ipft,repro_organ) > nearzero) .or. & - (EDPftvarcon_inst%turnover_phos_retrans(ipft,repro_organ) > nearzero) ) then - write(fates_log(),*) ' Retranslocation of reproductive tissues should be zero.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' carbon: ',EDPftvarcon_inst%turnover_carb_retrans(ipft,repro_organ) - write(fates_log(),*) ' nitr: ',EDPftvarcon_inst%turnover_nitr_retrans(ipft,repro_organ) - write(fates_log(),*) ' phos: ',EDPftvarcon_inst%turnover_phos_retrans(ipft,repro_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - if ((EDPftvarcon_inst%turnover_carb_retrans(ipft,sapw_organ) > nearzero)) then - write(fates_log(),*) ' Retranslocation of sapwood tissues should be zero.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' carbon: ',EDPftvarcon_inst%turnover_carb_retrans(ipft,sapw_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - if (parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if ((EDPftvarcon_inst%turnover_nitr_retrans(ipft,sapw_organ) > nearzero) .or. & - (EDPftvarcon_inst%turnover_phos_retrans(ipft,sapw_organ) > nearzero) ) then - write(fates_log(),*) ' Retranslocation of sapwood tissues should be zero.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' carbon: ',EDPftvarcon_inst%turnover_carb_retrans(ipft,sapw_organ) - write(fates_log(),*) ' nitr: ',EDPftvarcon_inst%turnover_nitr_retrans(ipft,sapw_organ) - write(fates_log(),*) ' phos: ',EDPftvarcon_inst%turnover_phos_retrans(ipft,sapw_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - if ((EDPftvarcon_inst%turnover_carb_retrans(ipft,struct_organ) > nearzero)) then - write(fates_log(),*) ' Retranslocation of structural(dead) tissues should be zero.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' carbon: ',EDPftvarcon_inst%turnover_carb_retrans(ipft,struct_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - if (parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if ((EDPftvarcon_inst%turnover_nitr_retrans(ipft,struct_organ) > nearzero) .or. & - (EDPftvarcon_inst%turnover_phos_retrans(ipft,struct_organ) > nearzero) ) then - write(fates_log(),*) ' Retranslocation of structural(dead) tissues should be zero.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' nitr: ',EDPftvarcon_inst%turnover_nitr_retrans(ipft,struct_organ) - write(fates_log(),*) ' phos: ',EDPftvarcon_inst%turnover_phos_retrans(ipft,struct_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - ! Leaf retranslocation should be between 0 and 1 - if ( (EDPftvarcon_inst%turnover_carb_retrans(ipft,leaf_organ) > 1.0_r8) .or. & - (EDPftvarcon_inst%turnover_carb_retrans(ipft,leaf_organ) < 0.0_r8) ) then - write(fates_log(),*) ' Retranslocation of leaf tissues should be between 0 and 1.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' carbon: ',EDPftvarcon_inst%turnover_carb_retrans(ipft,leaf_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - if (parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if ((EDPftvarcon_inst%turnover_nitr_retrans(ipft,leaf_organ) > 1.0_r8) .or. & - (EDPftvarcon_inst%turnover_phos_retrans(ipft,leaf_organ) > 1.0_r8) .or. & - (EDPftvarcon_inst%turnover_nitr_retrans(ipft,leaf_organ) < 0.0_r8) .or. & - (EDPftvarcon_inst%turnover_phos_retrans(ipft,leaf_organ) < 0.0_r8)) then - write(fates_log(),*) ' Retranslocation of leaf tissues should be between 0 and 1.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' nitr: ',EDPftvarcon_inst%turnover_nitr_retrans(ipft,leaf_organ) - write(fates_log(),*) ' phos: ',EDPftvarcon_inst%turnover_phos_retrans(ipft,leaf_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - ! Fineroot retranslocation should be between 0-1 - if ((EDPftvarcon_inst%turnover_carb_retrans(ipft,fnrt_organ) > 1.0_r8) .or. & - (EDPftvarcon_inst%turnover_carb_retrans(ipft,fnrt_organ) < 0.0_r8)) then - write(fates_log(),*) ' Retranslocation of leaf tissues should be between 0 and 1.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' carbon: ',EDPftvarcon_inst%turnover_carb_retrans(ipft,fnrt_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - if (parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if ((EDPftvarcon_inst%turnover_nitr_retrans(ipft,fnrt_organ) > 1.0_r8) .or. & - (EDPftvarcon_inst%turnover_phos_retrans(ipft,fnrt_organ) > 1.0_r8) .or. & - (EDPftvarcon_inst%turnover_nitr_retrans(ipft,fnrt_organ) < 0.0_r8) .or. & - (EDPftvarcon_inst%turnover_phos_retrans(ipft,fnrt_organ) < 0.0_r8)) then - write(fates_log(),*) ' Retranslocation of leaf tissues should be between 0 and 1.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' nitr: ',EDPftvarcon_inst%turnover_nitr_retrans(ipft,fnrt_organ) - write(fates_log(),*) ' phos: ',EDPftvarcon_inst%turnover_phos_retrans(ipft,fnrt_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - ! Storage retranslocation should be between 0-1 (storage retrans seems weird, but who knows) - if ((EDPftvarcon_inst%turnover_carb_retrans(ipft,store_organ) > 1.0_r8) .or. & - (EDPftvarcon_inst%turnover_carb_retrans(ipft,store_organ) < 0.0_r8)) then - write(fates_log(),*) ' Retranslocation of leaf tissues should be between 0 and 1.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' carbon: ',EDPftvarcon_inst%turnover_carb_retrans(ipft,store_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - if (parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if ((EDPftvarcon_inst%turnover_nitr_retrans(ipft,store_organ) > 1.0_r8) .or. & - (EDPftvarcon_inst%turnover_phos_retrans(ipft,store_organ) > 1.0_r8) .or. & - (EDPftvarcon_inst%turnover_nitr_retrans(ipft,store_organ) < 0.0_r8) .or. & - (EDPftvarcon_inst%turnover_phos_retrans(ipft,store_organ) < 0.0_r8)) then - write(fates_log(),*) ' Retranslocation of leaf tissues should be between 0 and 1.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' nitr: ',EDPftvarcon_inst%turnover_nitr_retrans(ipft,store_organ) - write(fates_log(),*) ' phos: ',EDPftvarcon_inst%turnover_phos_retrans(ipft,store_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - ! Growth respiration - if (parteh_mode .eq. prt_carbon_allom_hyp) then - if ( ( EDPftvarcon_inst%grperc(ipft) < 0.0_r8) .or. & - ( EDPftvarcon_inst%grperc(ipft) > 1.0_r8 ) ) then - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' Growth respiration must be between 0 and 1: ',EDPftvarcon_inst%grperc(ipft) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - elseif(parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if ( ( any(EDPftvarcon_inst%prt_grperc_organ(ipft,:) < 0.0_r8)) .or. & - ( any(EDPftvarcon_inst%prt_grperc_organ(ipft,:) >= 1.0_r8)) ) then - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' Growth respiration must be between 0 and 1: ',EDPftvarcon_inst%prt_grperc_organ(ipft,:) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - ! Stoichiometric Ratios - - ! Firstly, the seed production and germination models cannot handle nutrients. So - ! we assume (for now) that seeds do not have nutrients (parteh_mode = 1 is c only) - if(parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if ( (EDPftvarcon_inst%prt_nitr_stoich_p1(ipft,repro_organ) > nearzero) .or. & - (EDPftvarcon_inst%prt_nitr_stoich_p1(ipft,repro_organ) < -nearzero) .or. & - (EDPftvarcon_inst%prt_phos_stoich_p1(ipft,repro_organ) > nearzero) .or. & - (EDPftvarcon_inst%prt_phos_stoich_p1(ipft,repro_organ) < -nearzero) .or. & - (EDPftvarcon_inst%prt_nitr_stoich_p2(ipft,repro_organ) > nearzero) .or. & - (EDPftvarcon_inst%prt_nitr_stoich_p2(ipft,repro_organ) < -nearzero) .or. & - (EDPftvarcon_inst%prt_phos_stoich_p2(ipft,repro_organ) > nearzero) .or. & - (EDPftvarcon_inst%prt_phos_stoich_p2(ipft,repro_organ) < -nearzero) ) then - write(fates_log(),*) 'N & P should be zero in reproductive tissues' - write(fates_log(),*) 'until nutrients are coupled into recruitment' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) EDPftvarcon_inst%prt_nitr_stoich_p1(ipft,repro_organ) - write(fates_log(),*) EDPftvarcon_inst%prt_phos_stoich_p1(ipft,repro_organ) - write(fates_log(),*) EDPftvarcon_inst%prt_nitr_stoich_p2(ipft,repro_organ) - write(fates_log(),*) EDPftvarcon_inst%prt_phos_stoich_p2(ipft,repro_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - ! The first nitrogen stoichiometry is used in all cases - if ( (any(EDPftvarcon_inst%prt_nitr_stoich_p1(ipft,:) < 0.0_r8)) .or. & - (any(EDPftvarcon_inst%prt_nitr_stoich_p1(ipft,:) >= 1.0_r8))) then - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' N per C stoichiometry must bet between 0-1' - write(fates_log(),*) EDPftvarcon_inst%prt_nitr_stoich_p1(ipft,:) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - if(parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if( (any(EDPftvarcon_inst%prt_nitr_stoich_p2(ipft,:) < 0.0_r8)) .or. & - (any(EDPftvarcon_inst%prt_nitr_stoich_p2(ipft,:) >= 1.0_r8)) ) then - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' N per C stoichiometry must bet between 0-1' - write(fates_log(),*) EDPftvarcon_inst%prt_nitr_stoich_p2(ipft,:) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - ! Stoichiometric Ratios - if (parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if ( (any(EDPftvarcon_inst%prt_phos_stoich_p1(ipft,:) < 0.0_r8)) .or. & - (any(EDPftvarcon_inst%prt_phos_stoich_p1(ipft,:) >= 1.0_r8)) .or. & - (any(EDPftvarcon_inst%prt_phos_stoich_p2(ipft,:) < 0.0_r8)) .or. & - (any(EDPftvarcon_inst%prt_phos_stoich_p2(ipft,:) >= 1.0_r8)) ) then - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' P per C stoichiometry must bet between 0-1' - write(fates_log(),*) EDPftvarcon_inst%prt_phos_stoich_p1(ipft,:) - write(fates_log(),*) EDPftvarcon_inst%prt_phos_stoich_p2(ipft,:) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - if (parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if ( any(EDPftvarcon_inst%prt_alloc_priority(ipft,:) < 0) .or. & - any(EDPftvarcon_inst%prt_alloc_priority(ipft,:) > 6) ) then - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' Allocation priorities should be 0-6 for H1' - write(fates_log(),*) EDPftvarcon_inst%prt_alloc_priority(ipft,:) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - - ! Check turnover time-scales - - nleafage = size(EDPftvarcon_inst%leaf_long,dim=2) - - do iage = 1, nleafage - - if ( EDPftvarcon_inst%leaf_long(ipft,iage)>nearzero ) then - - ! Check that leaf turnover doesn't exeed 1 day - if ( (years_per_day / EDPftvarcon_inst%leaf_long(ipft,iage)) > 1._r8 ) then - write(fates_log(),*) 'Leaf turnover time-scale is greater than 1 day!' - write(fates_log(),*) 'ipft: ',ipft,' iage: ',iage - write(fates_log(),*) 'leaf_long(ipft,iage): ',EDPftvarcon_inst%leaf_long(ipft,iage),' [years]' - write(fates_log(),*) 'Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - ! Check to make sure that all other age-classes for this PFT also - ! have non-zero entries, it wouldn't make sense otherwise - if ( any(EDPftvarcon_inst%leaf_long(ipft,:) <= nearzero) ) then - write(fates_log(),*) 'You specified a leaf_long that is zero or' - write(fates_log(),*) 'invalid for a particular age class.' - write(fates_log(),*) 'Yet, other age classes for this PFT are non-zero.' - write(fates_log(),*) 'this doesnt make sense.' - write(fates_log(),*) 'ipft = ',ipft - write(fates_log(),*) 'leaf_long(ipft,:) = ',EDPftvarcon_inst%leaf_long(ipft,:) - write(fates_log(),*) 'Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - else - if (EDPftvarcon_inst%evergreen(ipft) .eq. itrue) then - write(fates_log(),*) 'You specified zero leaf turnover: ' - write(fates_log(),*) 'ipft: ',ipft,' iage: ',iage - write(fates_log(),*) 'leaf_long(ipft,iage): ',EDPftvarcon_inst%leaf_long(ipft,iage) - write(fates_log(),*) 'yet this is an evergreen PFT, and it only makes sense' - write(fates_log(),*) 'that an evergreen would have leaf maintenance turnover' - write(fates_log(),*) 'disable this error if you are ok with this' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - end do - - ! Check the turnover rates on the senescing leaf pool - if ( EDPftvarcon_inst%leaf_long(ipft,nleafage)>nearzero ) then - - ! Check that leaf turnover doesn't exeed 1 day - if ( (years_per_day / & - (EDPftvarcon_inst%leaf_long(ipft,nleafage) * & - EDPftvarcon_inst%senleaf_long_fdrought(ipft))) > 1._r8 ) then - write(fates_log(),*) 'Drought-senescent turnover time-scale is greater than 1 day!' - write(fates_log(),*) 'ipft: ',ipft - write(fates_log(),*) 'leaf_long(ipft,nleafage)*senleaf_long_fdrought: ', & - EDPftvarcon_inst%leaf_long(ipft,nleafage)*EDPftvarcon_inst%senleaf_long_fdrought(ipft),' [years]' - write(fates_log(),*) 'Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - if ( EDPftvarcon_inst%senleaf_long_fdrought(ipft)1._r8 ) then - write(fates_log(),*) 'senleaf_long_fdrought(ipft) must be greater than 0 ' - write(fates_log(),*) 'or less than or equal to 1.' - write(fates_log(),*) 'Set this to 1 if you want no accelerated senescence turnover' - write(fates_log(),*) 'ipft = ',ipft - write(fates_log(),*) 'senleaf_long_fdrought(ipft) = ',EDPftvarcon_inst%senleaf_long_fdrought(ipft) - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - - if ( EDPftvarcon_inst%root_long(ipft)>nearzero ) then - - ! Check that root turnover doesn't exeed 1 day - if ( (years_per_day / EDPftvarcon_inst%root_long(ipft)) > 1._r8 ) then - write(fates_log(),*) 'Root turnover time-scale is greater than 1 day!' - write(fates_log(),*) 'ipft: ',ipft - write(fates_log(),*) 'root_long(ipft): ',EDPftvarcon_inst%root_long(ipft),' [years]' - write(fates_log(),*) 'Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - else - if (EDPftvarcon_inst%evergreen(ipft) .eq. itrue) then - write(fates_log(),*) 'You specified zero root turnover: ' - write(fates_log(),*) 'ipft: ',ipft - write(fates_log(),*) 'root_long(ipft): ',EDPftvarcon_inst%root_long(ipft) - write(fates_log(),*) 'yet this is an evergreen PFT, and it only makes sense' - write(fates_log(),*) 'that an evergreen would have root maintenance turnover' - write(fates_log(),*) 'disable this error if you are ok with this' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - ! Check Branch turnover doesn't exceed one day - if ( EDPftvarcon_inst%branch_turnover(ipft)>nearzero ) then - - ! Check that branch turnover doesn't exeed 1 day - if ( (years_per_day / EDPftvarcon_inst%branch_turnover(ipft)) > 1._r8 ) then - write(fates_log(),*) 'Branch turnover time-scale is greater than 1 day!' - write(fates_log(),*) 'ipft: ',ipft - write(fates_log(),*) 'branch_turnover(ipft): ',EDPftvarcon_inst%branch_turnover(ipft),' [years]' - write(fates_log(),*) 'Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - - end do + end do !ipft -======= - end do ->>>>>>> 03a17bfebbc7d947ab4f7b88b649a31cdac213fb !! ! Checks for HYDRO !! if( hlm_use_planthydro == itrue ) then !! From ee3ce528a0f46e6a50f843f5022b2c8bda149571 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 29 Sep 2020 02:48:26 -0600 Subject: [PATCH 107/209] fixing last compiling/merge errors in EDpftvarcn --- main/EDPftvarcon.F90 | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index a44235eba8..214ca75d3b 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -1693,19 +1693,19 @@ subroutine FatesCheckParams(is_master) end if - ! check that the host-fates PFT map adds to one in both dimension - do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) - sumarea = sum(EDPftvarcon_inst%hlm_pft_map(1:npft,hlm_pft)) - if(abs(sumarea-1.0_r8).gt.nearzero)then - write(fates_log(),*) 'The distribution of this host land model PFT :',hlm_pft - write(fates_log(),*) 'into FATES PFTs, does not add up to 1.0.' - write(fates_log(),*) 'Error is:',sumarea-1.0_r8 - write(fates_log(),*) 'and the hlm_pft_map is:', EDPftvarcon_inst%hlm_pft_map(1:npft,hlm_pft) - write(fates_log(),*) 'Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - end do !ipft + ! check that the host-fates PFT map adds to one in both dimension + do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) + sumarea = sum(EDPftvarcon_inst%hlm_pft_map(1:npft,hlm_pft)) + if(abs(sumarea-1.0_r8).gt.nearzero)then + write(fates_log(),*) 'The distribution of this host land model PFT :',hlm_pft + write(fates_log(),*) 'into FATES PFTs, does not add up to 1.0.' + write(fates_log(),*) 'Error is:',sumarea-1.0_r8 + write(fates_log(),*) 'and the hlm_pft_map is:', EDPftvarcon_inst%hlm_pft_map(1:npft,hlm_pft) + write(fates_log(),*) 'Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end do !hlm_pft + end do !ipft !! ! Checks for HYDRO From 1b96395d3a75a6ce1ef66046414905236a483731 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 29 Sep 2020 02:54:48 -0600 Subject: [PATCH 108/209] fixing merge errors in EDInit --- main/EDInitMod.F90 | 26 ++------------------------ 1 file changed, 2 insertions(+), 24 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 23e7ef4f7a..0789c78025 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -769,20 +769,9 @@ subroutine init_cohorts( site_in, patch_in, bc_in) stem_drop_fraction = EDPftvarcon_inst%phen_stem_drop_fraction(temp_cohort%pft) - if( EDPftvarcon_inst%season_decid(pft) == itrue .and. & - any(site_in%cstatus == [phen_cstat_nevercold,phen_cstat_iscold])) then - temp_cohort%laimemory = c_leaf - temp_cohort%sapwmemory = c_sapw * stem_drop_fraction - temp_cohort%structmemory = c_struct * stem_drop_fraction - c_leaf = 0._r8 - c_sapw = (1.0_r8-stem_drop_fraction) * c_sapw - c_struct = (1.0_r8-stem_drop_fraction) * c_struct - cstatus = leaves_off - endif - if(hlm_use_sp.eq.ifalse)then ! do not override SP vales with phenology - if( EDPftvarcon_inst%season_decid(pft) == itrue .and. & - any(site_in%cstatus == [phen_cstat_nevercold,phen_cstat_iscold])) then + if ( prt_params%stress_decid(pft) == itrue .and. & + any(site_in%dstatus == [phen_dstat_timeoff,phen_dstat_moistoff])) then temp_cohort%laimemory = c_leaf temp_cohort%sapwmemory = c_sapw * stem_drop_fraction temp_cohort%structmemory = c_struct * stem_drop_fraction @@ -791,17 +780,6 @@ subroutine init_cohorts( site_in, patch_in, bc_in) c_struct = (1.0_r8-stem_drop_fraction) * c_struct cstatus = leaves_off endif - - if ( EDPftvarcon_inst%stress_decid(pft) == itrue .and. & - any(site_in%dstatus == [phen_dstat_timeoff,phen_dstat_moistoff])) then - temp_cohort%laimemory = c_leaf - temp_cohort%sapwmemory = c_sapw * stem_drop_fraction - temp_cohort%structmemory = c_struct * stem_drop_fraction - c_leaf = 0._r8 - c_sapw = (1.0_r8-stem_drop_fraction) * c_sapw - c_struct = (1.0_r8-stem_drop_fraction) * c_struct - cstatus = leaves_off - endif end if ! SP mode if ( debug ) write(fates_log(),*) 'EDInitMod.F90 call create_cohort ' From 0635560d552cae8a3373b44fd2c4b14fe51d8117 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 29 Sep 2020 03:32:16 -0600 Subject: [PATCH 109/209] turning off trim canopy --- main/EDMainMod.F90 | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index ae7528e069..76a031e688 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -702,8 +702,9 @@ subroutine ed_update_site( currentSite, bc_in, bc_out ) ! If this is the second to last day of the year, then perform trimming if( hlm_day_of_year == hlm_days_per_year-1) then - write(fates_log(),*) 'calling trim canopy' - call trim_canopy(currentSite) + if(hlm_use_sp.eq.ifalse)then + call trim_canopy(currentSite) + endif endif end subroutine ed_update_site From 96abe15012af067c2c02cdf13763b89a26a31c22 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 5 Oct 2020 05:08:25 -0600 Subject: [PATCH 110/209] setting pa label --- biogeochem/EDCanopyStructureMod.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 89f725a107..72e8b29c35 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1972,6 +1972,8 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) total_patch_area = total_patch_area + bc_out(s)%canopy_fraction_pa(ifp) + bare_frac_area total_canopy_area = total_canopy_area + bc_out(s)%canopy_fraction_pa(ifp) + + bc_out(s)%nocomp_pft_label_pa(ifp) = currentPatch%nocomp_pft_label ! Calculate area indices for output boundary to HLM ! It is assumed that cpatch%canopy_area_profile and cpat%xai_profiles From 8eec5202fa59711223ec56ca0b7aeca7b74730ae Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 5 Oct 2020 05:35:43 -0600 Subject: [PATCH 111/209] made pft_label_pa variable --- main/FatesInterfaceMod.F90 | 6 +++++- main/FatesInterfaceTypesMod.F90 | 10 ++++++++-- 2 files changed, 13 insertions(+), 3 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 496df88b58..3c0fd82c6f 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -295,7 +295,8 @@ subroutine zero_bcs(fates,s) fates%bc_out(s)%displa_pa(:) = 0.0_r8 fates%bc_out(s)%z0m_pa(:) = 0.0_r8 fates%bc_out(s)%dleaf_pa(:) = 0.0_r8 - + fates%bc_out(s)%nocomp_pft_label_pa(:) = 0 + fates%bc_out(s)%canopy_fraction_pa(:) = 0.0_r8 fates%bc_out(s)%frac_veg_nosno_alb_pa(:) = 0.0_r8 @@ -392,6 +393,7 @@ subroutine allocate_bcin(bc_in, nlevsoil_in, nlevdecomp_in, num_lu_harvest_cats) allocate(bc_in%plant_p_uptake_flux(1,1)) end if + allocate(bc_in%zi_sisl(0:nlevsoil_in)) allocate(bc_in%dz_sisl(nlevsoil_in)) allocate(bc_in%z_sisl(nlevsoil_in)) @@ -586,6 +588,8 @@ subroutine allocate_bcout(bc_out, nlevsoil_in, nlevdecomp_in) allocate(bc_out%canopy_fraction_pa(maxPatchesPerSite)) allocate(bc_out%frac_veg_nosno_alb_pa(maxPatchesPerSite)) + + allocate(bc_out%nocomp_pft_label_pa(maxPatchesPerSite)) ! Plant-Hydro BC's if (hlm_use_planthydro.eq.itrue) then diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index 1be8695b63..ba3fa9191c 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -336,6 +336,10 @@ module FatesInterfaceTypesMod ! be equivalent (ie integer ascending) ! Or, all will be 1. + integer,allocatable :: sp_patch_index(:) ! in SP mode, we need to map the p values for each patch + ! back onto the 'IFP' order i ED. So this is the number of e ! ach patch in the site. It does not correspond to PFT, more + ! to the number of occupied PFTs before it in the array. + ! Vegetation Dynamics ! --------------------------------------------------------------------------------- @@ -393,7 +397,7 @@ module FatesInterfaceTypesMod ! 2 = patch is currently marked for photosynthesis ! 3 = patch has been called for photosynthesis at least once integer, allocatable :: filter_photo_pa(:) - + ! atmospheric pressure (Pa) real(r8) :: forc_pbot @@ -660,7 +664,9 @@ module FatesInterfaceTypesMod ! vegetation in the patch is exposed. ! [0,1] - ! FATES Hydraulics + integer, allocatable :: nocomp_pft_label_pa(:) ! in nocomp and SP mode, each patch has a PFT identity. + + ! FATES Hydraulics From 5796f3607800f5ac38b302d31e9c256b051015af Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 8 Oct 2020 06:43:25 -0600 Subject: [PATCH 112/209] added checks on all FATES loops that use IFP to not include bare ground patches --- biogeochem/EDPhysiologyMod.F90 | 5 +++-- biogeophys/EDAccumulateFluxesMod.F90 | 2 ++ biogeophys/EDBtranMod.F90 | 3 ++- biogeophys/EDSurfaceAlbedoMod.F90 | 6 ++++-- biogeophys/FatesPlantHydraulicsMod.F90 | 3 ++- biogeophys/FatesPlantRespPhotosynthMod.F90 | 7 +++---- main/FatesRestartInterfaceMod.F90 | 3 ++- 7 files changed, 18 insertions(+), 11 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 851ce93981..8ebe490c7b 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -2493,7 +2493,7 @@ subroutine fragmentation_scaler( currentPatch, bc_in) catanf_30 = catanf(30._r8) ifp = currentPatch%patchno - + if(currentPatch%nocomp_pft_label.gt.0)then if ( .not. use_century_tfunc ) then !calculate rate constant scalar for soil temperature,assuming that the base rate constants !are assigned for non-moisture limiting conditions at 25C. @@ -2517,7 +2517,8 @@ subroutine fragmentation_scaler( currentPatch, bc_in) w_scalar = sum(currentPatch%btran_ft(1:numpft))/real(numpft,r8) currentPatch%fragmentation_scaler = min(1.0_r8,max(0.0_r8,t_scalar * w_scalar)) - + endif ! not bare ground + end subroutine fragmentation_scaler ! ============================================================================ diff --git a/biogeophys/EDAccumulateFluxesMod.F90 b/biogeophys/EDAccumulateFluxesMod.F90 index 4d873cca85..9355389185 100644 --- a/biogeophys/EDAccumulateFluxesMod.F90 +++ b/biogeophys/EDAccumulateFluxesMod.F90 @@ -64,6 +64,7 @@ subroutine AccumulateFluxes_ED(nsites, sites, bc_in, bc_out, dt_time) cpatch => sites(s)%oldest_patch do while (associated(cpatch)) + if(cpatch%nocomp_pft_label.gt.0)then ifp = ifp+1 if( bc_in(s)%filter_photo_pa(ifp) == 3 ) then @@ -104,6 +105,7 @@ subroutine AccumulateFluxes_ED(nsites, sites, bc_in, bc_out, dt_time) ccohort => ccohort%taller enddo ! while(associated(ccohort)) end if + end if ! not bare ground cpatch => cpatch%younger end do ! while(associated(cpatch)) end do diff --git a/biogeophys/EDBtranMod.F90 b/biogeophys/EDBtranMod.F90 index e7faac9cc3..694a24bd25 100644 --- a/biogeophys/EDBtranMod.F90 +++ b/biogeophys/EDBtranMod.F90 @@ -133,6 +133,7 @@ subroutine btran_ed( nsites, sites, bc_in, bc_out) ifp = 0 cpatch => sites(s)%oldest_patch do while (associated(cpatch)) + if(cpatch%nocomp_pft_label.gt.0)then ! only for veg patches ifp=ifp+1 ! THIS SHOULD REALLY BE A COHORT LOOP ONCE WE HAVE rootfr_ft FOR COHORTS (RGK) @@ -234,7 +235,7 @@ subroutine btran_ed( nsites, sites, bc_in, bc_out) bc_out(s)%rootr_pasl(ifp,j) = bc_out(s)%rootr_pasl(ifp,j)/temprootr enddo end if - + endif ! not bare ground cpatch => cpatch%younger end do diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index 4e5309ea61..a3e420b9a0 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -89,6 +89,7 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) ifp = 0 currentpatch => sites(s)%oldest_patch do while (associated(currentpatch)) + if(currentpatch%nocomp_pft_label.gt.0)then ifp = ifp+1 currentPatch%f_sun (:,:,:) = 0._r8 @@ -148,6 +149,7 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) 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 @@ -1061,7 +1063,7 @@ subroutine ED_SunShadeFracs(nsites, sites,bc_in,bc_out) cpatch => sites(s)%oldest_patch do while (associated(cpatch)) - + if(cpatch%nocomp_pft_label.gt.0)then !only for veg patches ifp=ifp+1 if( debug ) write(fates_log(),*) 'edsurfRad_5600',ifp,s,cpatch%NCL_p,numpft @@ -1199,7 +1201,7 @@ subroutine ED_SunShadeFracs(nsites, sites,bc_in,bc_out) cpatch%nrmlzd_parprof_dif_z(idiffuse,CL,iv)) end do ! iv end do ! CL - + endif ! not bareground patch cpatch => cpatch%younger enddo diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 57b9870916..33e5c41d21 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -2332,6 +2332,7 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) ifp = 0 cpatch => sites(s)%oldest_patch do while (associated(cpatch)) + if(cpatch%nocomp_pft_label.gt.0)then ifp = ifp + 1 ! ---------------------------------------------------------------------------- @@ -2495,7 +2496,7 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) ccohort => ccohort%shorter enddo !cohort - + endif ! not barground patch cpatch => cpatch%younger enddo !patch diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index bfe01d25be..23f7153da2 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -1,4 +1,3 @@ - module FATESPlantRespPhotosynthMod !------------------------------------------------------------------------------------- @@ -279,7 +278,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ifp = 0 currentpatch => sites(s)%oldest_patch do while (associated(currentpatch)) - + if(currentpatch%nocomp_pft_label.gt.0)then ifp = ifp+1 NCL_p = currentPatch%NCL_p @@ -817,8 +816,8 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) end if - currentPatch => currentPatch%younger - + end if ! not bare ground patch + currentPatch => currentPatch%younger end do deallocate(rootfr_ft) diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index fe90aa5d56..866af8095d 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -2922,6 +2922,7 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) ifp = 0 currentpatch => sites(s)%oldest_patch do while (associated(currentpatch)) + if(currentpatch%nocomp_pft_label.gt.0)then ifp = ifp+1 currentPatch%f_sun (:,:,:) = 0._r8 @@ -2986,7 +2987,7 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) end if ! if the vegetation and zenith filter is active - + end if ! not bare ground currentPatch => currentPatch%younger end do ! Loop linked-list patches enddo ! Loop Sites From 6b2d0624b83a97b0fe2accf3172eaea8f45f2e29 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 8 Oct 2020 06:46:09 -0600 Subject: [PATCH 113/209] added modificaitons to set_patchno to make bareground patches have a patchno of 0 --- biogeochem/EDPatchDynamicsMod.F90 | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 5a4d716e92..49b4b54dd8 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -45,6 +45,7 @@ module EDPatchDynamicsMod use FatesInterfaceTypesMod , only : bc_in_type use FatesInterfaceTypesMod , only : hlm_days_per_year use FatesInterfaceTypesMod , only : numpft + use FatesInterfaceTypesMod , only : hlm_use_sp use FatesInterfaceTypesMod , only : hlm_use_nocomp use FatesInterfaceTypesMod , only : hlm_use_fixed_biogeog use FatesGlobals , only : endrun => fates_endrun @@ -1274,6 +1275,22 @@ subroutine set_patchno( currentSite ) currentPatch => currentPatch%younger enddo + if(hlm_use_sp)then + patchno = 1 + currentPatch => currentSite%oldest_patch + do while(associated(currentPatch)) + if(currentPatch%nocomp_pft_label.eq.0)then + ! for bareground patch, we make the patch number 0 + ! we also do not count this in the veg. patch numbering scheme. + currentPatch%patchno = 0 + else + currentPatch%patchno = patchno + patchno = patchno + 1 + endif + currentPatch => currentPatch%younger + enddo + endif + end subroutine set_patchno ! ============================================================================ From 5893d9726e2633c89e3bf7045fd4def30b0d63e2 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 8 Oct 2020 06:59:30 -0600 Subject: [PATCH 114/209] changes to EDCanopystructure. Running at this point with LAI OK and GPP OK except in Amazon --- biogeochem/EDCanopyStructureMod.F90 | 18 ++++++++++++++---- 1 file changed, 14 insertions(+), 4 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 72e8b29c35..6152aee40a 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1275,7 +1275,7 @@ subroutine canopy_summarization( nsites, sites, bc_in ) type (ed_cohort_type) , pointer :: currentCohort integer :: s integer :: ft ! plant functional type - integer :: ifp + integer :: ifp ! the number of the vegeted patch (1,2,3). In SP mode bareground patch is 0 integer :: patchn ! identification number for each patch. real(r8) :: canopy_leaf_area ! total amount of leaf area in the vegetated area. m2. real(r8) :: leaf_c ! leaf carbon [kg] @@ -1915,8 +1915,9 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) currentPatch => sites(s)%oldest_patch c = fcolumn(s) do while(associated(currentPatch)) + if(currentPatch%nocomp_pft_label.gt.0)then ! only set values for vegetated patches in fixed modes ifp = ifp+1 - + endif ! stay with ifp=0 for bareground patch. if ( currentPatch%total_canopy_area-currentPatch%area > 0.000001_r8 ) then write(fates_log(),*) 'ED: canopy area bigger than area',currentPatch%total_canopy_area ,currentPatch%area currentPatch%total_canopy_area = currentPatch%area @@ -1959,9 +1960,13 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) ! In which case, the bare area would have to be reduced by the grass area... ! currentPatch%total_canopy_area/currentPatch%area is fraction of this patch cover by plants ! currentPatch%area/AREA is the fraction of the soil covered by this patch. - + if(currentPatch%area.gt.0.0_r8)then bc_out(s)%canopy_fraction_pa(ifp) = & min(1.0_r8,currentPatch%total_canopy_area/currentPatch%area)*(currentPatch%area/AREA) + else + bc_out(s)%canopy_fraction_pa(ifp) = 0.0_r8 + endif + if(isnan(bc_out(s)%canopy_fraction_pa(ifp)))then write(fates_log(),*) 'nan canopy_fraction_pa in canopystructure:',ifp call endrun(msg=errMsg(sourcefile, __LINE__)) @@ -1995,7 +2000,6 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) else bc_out(s)%frac_veg_nosno_alb_pa(ifp) = 0.0_r8 end if - currentPatch => currentPatch%younger end do @@ -2018,8 +2022,14 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) currentPatch => sites(s)%oldest_patch ifp = 0 do while(associated(currentPatch)) + if(.not.hlm_use_sp.or.currentPatch%nocomp_pft_label.gt.0)then ifp = ifp+1 bc_out(s)%canopy_fraction_pa(ifp) = bc_out(s)%canopy_fraction_pa(ifp)/total_patch_area + else ! when it is both SP mode and the bareground patch + bc_out(s)%canopy_fraction_pa(ifp) =0.0_r8 + endif ! veg patch + + currentPatch => currentPatch%younger end do From e4032f9fe83a4cf219220f91528f10b03e34a554 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Fri, 30 Oct 2020 04:07:56 -0600 Subject: [PATCH 115/209] modified hlm_pft_map to have correct relation between fates and hlm pfts --- parameter_files/fates_params_default.cdl | 29 ++++++++++++------------ 1 file changed, 14 insertions(+), 15 deletions(-) diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index 06a3a59e84..c259b3c5df 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -1236,21 +1236,20 @@ data: 0.055, 0.055, 0.055 ; fates_hlm_pft_map = - 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, 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, 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, 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, 1; - + 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 ; From df2173df7e3de9dba800a54adaf8bcbd9e5db021 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 5 Nov 2020 03:39:48 -0700 Subject: [PATCH 116/209] copying minor changes from nocomp code review in EDInit --- main/EDInitMod.F90 | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 0789c78025..c96b2e6d85 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -417,7 +417,7 @@ subroutine init_patches( nsites, sites, bc_in) real(r8) :: litter_stock real(r8) :: seed_stock integer :: n - integer :: no_new_patches + integer :: num_new_patches integer :: nocomp_pft real(r8) :: newparea real(r8) :: tota !check on area @@ -471,13 +471,13 @@ subroutine init_patches( nsites, sites, bc_in) ! have smaller spread factors than bare ground (they are crowded) sites(s)%spread = init_spread_near_bare_ground if(hlm_use_nocomp.eq.itrue)then - no_new_patches = numpft + num_new_patches = numpft if(hlm_use_sp.eq.itrue)then - no_new_patches = numpft + 1 ! bare ground patch in SP mode. + num_new_patches = numpft + 1 ! bare ground patch in SP mode. endif ! allocate(newppft(numpft)) else - no_new_patches = 1 + num_new_patches = 1 newparea = area end if @@ -514,7 +514,7 @@ subroutine init_patches( nsites, sites, bc_in) end if ! too much patch area end if ! SP - is_first_patch = 1 + is_first_patch = itrue do n = 0, no_new_patches ! set the PFT index for patches if in nocomp mode. @@ -547,14 +547,14 @@ subroutine init_patches( nsites, sites, bc_in) call create_patch(sites(s), newp, age, newparea, primaryforest, nocomp_pft) - if(is_first_patch.eq.1)then !is this the first patch? + 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 = 0 + is_first_patch = ifalse else ! the new patch is the 'oldest' one, arbitrarily. ! Set pointers for N>1 patches. Note this only happens when nocomp mode s on. ! The new patch is the 'youngest' one, arbitrarily. @@ -722,6 +722,7 @@ subroutine init_cohorts( site_in, patch_in, bc_in) ! to compensate (otherwise runs are very hard to compare) ! this multiplies it by the number of PFTs there would have been in ! the single shared patch in competition mode. + ! n.b. that this is the same as currentcohort%n = %initd(pft) &AREA temp_cohort%n = temp_cohort%n * sum(site_in%use_this_pft) endif From c2a18bb5ad2d9c825e3a253349fce2c3cd38f828 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 5 Nov 2020 03:54:16 -0700 Subject: [PATCH 117/209] modified comments in canopystructure --- biogeochem/EDCanopyStructureMod.F90 | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 6152aee40a..bca967919f 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1346,24 +1346,28 @@ subroutine canopy_summarization( nsites, sites, bc_in ) currentPatch%total_tree_area = currentPatch%total_tree_area + currentCohort%c_area endif endif + + ! adding checks for SP and NOCOMP modes. if(currentPatch%nocomp_pft_label.eq.0)then - write(fates_log(),*) 'cohorts in barepatch',currentPatch%total_canopy_area,currentPatch%nocomp_pft_label,currentCohort%c_area - call endrun(msg=errMsg(sourcefile, __LINE__)) + write(fates_log(),*) 'cohorts in barepatch',currentPatch%total_canopy_area,currentPatch%nocomp_pft_label call endrun(msg=errMsg(sourcefile, __LINE__)) end if - if(hlm_use_sp.eq.itrue.and.associated(currentPatch%tallest%shorter))then - write(fates_log(),*) 'morethanonecohort',s,currentPatch%nocomp_pft_label - endif + + if(hlm_use_sp.eq.itrue.and.associated(currentPatch%tallest%shorter))then + write(fates_log(),*) 'more than one cohort in SP mode',s,currentPatch%nocomp_pft_label + endif + if(currentPatch%total_canopy_area-currentPatch%area.gt.1.0e-16)then - write(fates_log(),*) 'canopy area too large in summarization1,s,pft,error:',s,currentPatch%nocomp_pft_label,currentPatch%total_canopy_area-currentPatch%area,& - currentPatch%area,currentPatch%tallest%c_area + write(fates_log(),*) 'too much canopy in summary',s,currentPatch%total_canopy_area-currentPatch%area call endrun(msg=errMsg(sourcefile, __LINE__)) end if + ! Check for erroneous zero values. if(currentCohort%dbh <= 0._r8 .or. currentCohort%n == 0._r8)then write(fates_log(),*) 'FATES: dbh or n is zero in canopy_summarization', & currentCohort%dbh,currentCohort%n call endrun(msg=errMsg(sourcefile, __LINE__)) endif + if(currentCohort%pft == 0.or.currentCohort%canopy_trim <= 0._r8)then write(fates_log(),*) 'FATES: PFT or trim is zero in canopy_summarization', & currentCohort%pft,currentCohort%canopy_trim From f8de4d817d016c056469fb687abfe0c8e1f4faf9 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 5 Nov 2020 04:05:40 -0700 Subject: [PATCH 118/209] tidying up CanopyStructure --- biogeochem/EDCanopyStructureMod.F90 | 15 ++++++--------- main/EDInitMod.F90 | 6 +++--- 2 files changed, 9 insertions(+), 12 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index bca967919f..b1643b700d 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -32,8 +32,6 @@ module EDCanopyStructureMod use FatesInterfaceTypesMod , only : numpft use FatesPlantHydraulicsMod, only : UpdateH2OVeg,InitHydrCohort, RecruitWaterStorage use EDTypesMod , only : maxCohortsPerPatch - use shr_infnan_mod , only : isnan => shr_infnan_isnan - use PRTGenericMod, only : leaf_organ use PRTGenericMod, only : all_carbon_elements use PRTGenericMod, only : leaf_organ @@ -1349,7 +1347,8 @@ subroutine canopy_summarization( nsites, sites, bc_in ) ! adding checks for SP and NOCOMP modes. if(currentPatch%nocomp_pft_label.eq.0)then - write(fates_log(),*) 'cohorts in barepatch',currentPatch%total_canopy_area,currentPatch%nocomp_pft_label call endrun(msg=errMsg(sourcefile, __LINE__)) + write(fates_log(),*) 'cohorts in barepatch',currentPatch%total_canopy_area,currentPatch%nocomp_pft_label + call endrun(msg=errMsg(sourcefile, __LINE__)) end if if(hlm_use_sp.eq.itrue.and.associated(currentPatch%tallest%shorter))then @@ -1357,8 +1356,8 @@ subroutine canopy_summarization( nsites, sites, bc_in ) endif if(currentPatch%total_canopy_area-currentPatch%area.gt.1.0e-16)then - write(fates_log(),*) 'too much canopy in summary',s,currentPatch%total_canopy_area-currentPatch%area - call endrun(msg=errMsg(sourcefile, __LINE__)) + write(fates_log(),*) 'too much canopy in summary',s,currentPatch%total_canopy_area-currentPatch%area + call endrun(msg=errMsg(sourcefile, __LINE__)) end if ! Check for erroneous zero values. @@ -1971,10 +1970,6 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) bc_out(s)%canopy_fraction_pa(ifp) = 0.0_r8 endif - if(isnan(bc_out(s)%canopy_fraction_pa(ifp)))then - write(fates_log(),*) 'nan canopy_fraction_pa in canopystructure:',ifp - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if bare_frac_area = (1.0_r8 - min(1.0_r8,currentPatch%total_canopy_area/currentPatch%area)) * & (currentPatch%area/AREA) @@ -1987,10 +1982,12 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) ! Calculate area indices for output boundary to HLM ! It is assumed that cpatch%canopy_area_profile and cpat%xai_profiles ! have been updated (ie ed_leaf_area_profile has been called since dynamics has been called) + bc_out(s)%elai_pa(ifp) = calc_areaindex(currentPatch,'elai') bc_out(s)%tlai_pa(ifp) = calc_areaindex(currentPatch,'tlai') bc_out(s)%esai_pa(ifp) = calc_areaindex(currentPatch,'esai') bc_out(s)%tsai_pa(ifp) = calc_areaindex(currentPatch,'tsai') + ! Fraction of vegetation free of snow. This is used to flag those ! patches which shall under-go photosynthesis ! INTERF-TODO: we may want to stop using frac_veg_nosno_alb and let diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index c96b2e6d85..143eee5dc8 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -484,7 +484,7 @@ subroutine init_patches( nsites, sites, bc_in) !check if the total area adds to the same as site area if(hlm_use_sp.eq.itrue)then tota = 0.0_r8 - do n = 0, no_new_patches + do n = 0, num_new_patches if(n.eq.0)then newparea = sites(s)%area_bareground else @@ -500,7 +500,7 @@ subroutine init_patches( nsites, sites, bc_in) write(fates_log(),*) 'fixing patch precision in bg patch', sites(s)%area_bareground , tota-area sites(s)%area_bareground = sites(s)%area_bareground - (tota-area) !units of m2 else !no bare ground - do n = 0, no_new_patches + do n = 0, num_new_patches if(sites(s)%area_pft(n).gt.tota-area)then sites(s)%area_pft(n) = sites(s)%area_pft(n) - (tota-area) write(fates_log(),*) 'fixing patch precision in veg patch',n,sites(s)%area_pft(n), tota-area @@ -515,7 +515,7 @@ subroutine init_patches( nsites, sites, bc_in) end if ! SP is_first_patch = itrue - do n = 0, no_new_patches + do n = 0, num_new_patches ! set the PFT index for patches if in nocomp mode. if(hlm_use_nocomp.eq.itrue)then From a1d871068c1b80030737cdf57d43efbab87d78a7 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 5 Nov 2020 04:11:39 -0700 Subject: [PATCH 119/209] reverted aimin change --- biogeochem/EDCanopyStructureMod.F90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index b1643b700d..d259b67e61 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -2067,7 +2067,7 @@ function calc_areaindex(cpatch,ai_type) result(ai) real(r8) :: ai ! TODO: THIS MIN LAI IS AN ARTIFACT FROM TESTING LONG-AGO AND SHOULD BE REMOVED ! THIS HAS BEEN KEPT THUS FAR TO MAINTAIN B4B IN TESTING OTHER COMMITS - real(r8) :: ai_min = 0.1_r8 + real(r8),parameter :: ai_min = 0.1_r8 real(r8),pointer :: ai_profile ai = 0._r8 @@ -2085,7 +2085,6 @@ function calc_areaindex(cpatch,ai_type) result(ai) 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 From efeadf1b923d770cb529782a9dbc7a11a82114ed Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 5 Nov 2020 04:19:02 -0700 Subject: [PATCH 120/209] removing redundant check from copycohort --- biogeochem/EDCohortDynamicsMod.F90 | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index e7eeae6d15..e6fd43f66f 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -268,7 +268,7 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & if(hlm_use_sp.eq.ifalse)then call carea_allom(new_cohort%dbh,new_cohort%n,spread,new_cohort%pft,new_cohort%c_area) else - new_cohort%c_area = carea ! set this from previously precision-controlled value + new_cohort%c_area = carea ! set this from previously precision-controlled value in SP mode endif ! Query PARTEH for the leaf carbon [kg] leaf_c = new_cohort%prt%GetState(leaf_organ,carbon12_element) @@ -1768,12 +1768,6 @@ subroutine copy_cohort( currentCohort,copyc ) o => currentCohort n => copyc - if(hlm_use_sp.eq.itrue)then - write(fates_log(),*) 'copying cohort shouldnt happen in SP mode,area,pft',o%c_area,o%pft - - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - n%indexnumber = fates_unset_int ! VEGETATION STRUCTURE From 3c56759cbc6f22855fb56f75371814b5ee8014d6 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 5 Nov 2020 06:07:18 -0700 Subject: [PATCH 121/209] minor fixes to spacing in patch dynamics --- biogeochem/EDPatchDynamicsMod.F90 | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 49b4b54dd8..c27f5495f8 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -431,7 +431,8 @@ subroutine disturbance_rates( site_in, bc_in) end subroutine disturbance_rates - ! ============================================================================ + ! ============================================================================ + subroutine spawn_patches( currentSite, bc_in) ! ! !DESCRIPTION: @@ -2560,7 +2561,6 @@ subroutine fuse_2_patches(csite, dp, rp) ! Define some aliases for the donor patches younger and older neighbors ! which may or may not exist. After we set them, we will remove the donor ! And then we will go about re-setting the map. - if(associated(dp%older))then olderp => dp%older else @@ -2576,6 +2576,7 @@ subroutine fuse_2_patches(csite, dp, rp) call dealloc_patch(dp) deallocate(dp) + if(associated(youngerp))then ! Update the younger patch's new older patch (because it isn't dp anymore) youngerp%older => olderp From 49015da3f01b172d795af68fee527f5fecc4a787 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 5 Nov 2020 07:18:07 -0700 Subject: [PATCH 122/209] added start_patch and removed pre-initpatch checks --- main/EDInitMod.F90 | 48 ++++++++++------------------------------------ 1 file changed, 10 insertions(+), 38 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 143eee5dc8..14b566dbcd 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -417,6 +417,7 @@ subroutine init_patches( nsites, sites, bc_in) real(r8) :: litter_stock real(r8) :: seed_stock integer :: n + integer :: start_patch integer :: num_new_patches integer :: nocomp_pft real(r8) :: newparea @@ -470,52 +471,22 @@ subroutine init_patches( nsites, sites, bc_in) ! It is likely that closed canopy forest inventories ! have smaller spread factors than bare ground (they are crowded) sites(s)%spread = init_spread_near_bare_ground + + start_patch = 1 ! start at the first vegetated patch if(hlm_use_nocomp.eq.itrue)then num_new_patches = numpft if(hlm_use_sp.eq.itrue)then num_new_patches = numpft + 1 ! bare ground patch in SP mode. + start_patch = 0 ! start at the bare ground patch endif ! allocate(newppft(numpft)) - else + else !default num_new_patches = 1 newparea = area - end if - - !check if the total area adds to the same as site area - if(hlm_use_sp.eq.itrue)then - tota = 0.0_r8 - do n = 0, num_new_patches - if(n.eq.0)then - newparea = sites(s)%area_bareground - else - newparea = sites(s)%area_pft(n) - end if - tota=tota+newparea - end do !n - - if(abs(tota-area).gt.1.0e-16_r8)then - if(abs(tota-area).lt.1.0e-10_r8)then - if(sites(s)%area_bareground.gt.nearzero.and.sites(s)%area_bareground.gt.tota-area)then - !modify area of bare ground if thre is a bare ground patch and it is big enough - write(fates_log(),*) 'fixing patch precision in bg patch', sites(s)%area_bareground , tota-area - sites(s)%area_bareground = sites(s)%area_bareground - (tota-area) !units of m2 - else !no bare ground - do n = 0, num_new_patches - if(sites(s)%area_pft(n).gt.tota-area)then - sites(s)%area_pft(n) = sites(s)%area_pft(n) - (tota-area) - write(fates_log(),*) 'fixing patch precision in veg patch',n,sites(s)%area_pft(n), tota-area - end if - end do - endif !area left in patches - else !this is a big error - write(fates_log(),*) 'error large', s,tota-area - call endrun(msg=errMsg(sourcefile, __LINE__)) - endif ! big error - end if ! too much patch area - end if ! SP + end if !nocomp - is_first_patch = itrue - do n = 0, num_new_patches + is_first_patch = itrue + do n = start_patch, num_new_patches ! set the PFT index for patches if in nocomp mode. if(hlm_use_nocomp.eq.itrue)then @@ -537,7 +508,7 @@ subroutine init_patches( nsites, sites, bc_in) newparea = area end if !nocomp mode - if(hlm_use_sp.eq.itrue.and.n.eq.0)then + if(hlm_use_sp.eq.itrue.and.n.eq.0)then ! bare ground patch newparea = sites(s)%area_bareground nocomp_pft = 0 end if @@ -608,6 +579,7 @@ subroutine init_patches( nsites, sites, bc_in) sites(s)%youngest_patch%area = sites(s)%oldest_patch%area - (tota-area) endif else !this is a big error + write(*,*) 'issue with patch area in EDinit',tota-area,tota call endrun(msg=errMsg(sourcefile, __LINE__)) endif ! big error end if ! too much patch area From 9bd54e3e1e4c8972131c093685b30a09e99508c8 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 5 Nov 2020 16:49:24 -0700 Subject: [PATCH 123/209] modified error statements in canopystructure --- biogeochem/EDCanopyStructureMod.F90 | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index d259b67e61..a2e860ad28 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1351,14 +1351,18 @@ subroutine canopy_summarization( nsites, sites, bc_in ) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - if(hlm_use_sp.eq.itrue.and.associated(currentPatch%tallest%shorter))then - write(fates_log(),*) 'more than one cohort in SP mode',s,currentPatch%nocomp_pft_label - endif + if(hlm_use_sp.eq.itrue)then - if(currentPatch%total_canopy_area-currentPatch%area.gt.1.0e-16)then - write(fates_log(),*) 'too much canopy in summary',s,currentPatch%total_canopy_area-currentPatch%area - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if + if(associated(currentPatch%tallest%shorter))then + write(fates_log(),*) 'more than one cohort in SP mode',s,currentPatch%nocomp_pft_label + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if(currentPatch%total_canopy_area-currentPatch%area.gt.1.0e-16)then + write(fates_log(),*) 'too much canopy in summary',s,currentPatch%total_canopy_area-currentPatch%area + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if !sp mode ! Check for erroneous zero values. if(currentCohort%dbh <= 0._r8 .or. currentCohort%n == 0._r8)then @@ -1383,7 +1387,7 @@ subroutine canopy_summarization( nsites, sites, bc_in ) enddo ! ends 'do while(associated(currentCohort)) if ( currentPatch%total_canopy_area>currentPatch%area ) then - if ( currentPatch%total_canopy_area-currentPatch%area > 1.0e-16_r8 ) then + if ( currentPatch%total_canopy_area-currentPatch%area > 1.0e-10_r8 ) then write(fates_log(),*) 'FATES: canopy area bigger than area', & currentPatch%total_canopy_area ,currentPatch%area, & currentPatch%total_canopy_area -currentPatch%area,& From d6edbb34a2747697d3f07acbfad3133474ce420e Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 5 Nov 2020 16:54:35 -0700 Subject: [PATCH 124/209] modified area_pft units in nocomp mode --- main/EDInitMod.F90 | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 14b566dbcd..211f58834d 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -350,13 +350,16 @@ subroutine set_site_properties( nsites, sites,bc_in ) ! the bare ground will no longer be proscribed and should emerge from FATES ! this may or may not be the right way to deal with this? - if(hlm_use_sp.eq.ifalse)then + if(hlm_use_sp.eq.ifalse)then ! when not in SP mode, subsume bare ground evenly into the existing patches. + !n.b. that it might be better if nocomp mode used the same bare groud logic as SP mode. sumarea = sum(sites(s)%area_pft(1:numpft)) do ft = 1,numpft if(sumarea.gt.0._r8)then - sites(s)%area_pft(ft) = sites(s)%area_pft(ft)/sumarea + sites(s)%area_pft(ft) = area * sites(s)%area_pft(ft)/sumarea else - sites(s)%area_pft(ft)= 1.0_r8/numpft + sites(s)%area_pft(ft) = area/numpft + ! in nocomp mode where there is only bare ground, we assign equal area to + ! all pfts and let the model figure out whether land should be bare or not. end if end do !ft else ! for sp mode, assert a bare ground patch @@ -551,11 +554,10 @@ subroutine init_patches( nsites, sites, bc_in) 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 + else ! normal non SP case always call init cohorts call init_cohorts(sitep, newp, bc_in(s)) end if end if From abadd8d34b464094259172d6aa9b65b02b6a8b14 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Fri, 6 Nov 2020 01:33:52 -0700 Subject: [PATCH 125/209] adding check which requires SP mode to also use fixed_biogeog mode --- main/FatesInterfaceMod.F90 | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 3c0fd82c6f..844c180663 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -1475,6 +1475,12 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) write(fates_log(), *) 'SP cannot be on if nocomp mode is off. Exiting. ' call endrun(msg=errMsg(sourcefile, __LINE__)) end if + + + if(hlm_use_sp.eq.itrue.and.hlm_use_fixed_biogeog.eq.ifalse)then + write(fates_log(), *) 'SP cannot be on if fixed biogeog mode is off. Exiting. ' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if if (fates_global_verbose()) then write(fates_log(), *) 'Checked. All control parameters sent to FATES.' From 1b035ac394b06ee5cb1e32bf48d742a41699c8ae Mon Sep 17 00:00:00 2001 From: rosiealice Date: Fri, 6 Nov 2020 02:47:36 -0700 Subject: [PATCH 126/209] fixing issue with IFP bareground couting in defualt mode --- biogeochem/EDCanopyStructureMod.F90 | 12 ++++++------ biogeophys/EDAccumulateFluxesMod.F90 | 2 +- biogeophys/EDBtranMod.F90 | 2 +- biogeophys/EDSurfaceAlbedoMod.F90 | 4 ++-- biogeophys/FatesPlantHydraulicsMod.F90 | 2 +- biogeophys/FatesPlantRespPhotosynthMod.F90 | 2 +- 6 files changed, 12 insertions(+), 12 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index a2e860ad28..d3109383ce 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1653,7 +1653,6 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) currentCohort => currentPatch%shortest do while(associated(currentCohort)) - ft = currentCohort%pft cl = currentCohort%canopy_layer @@ -1922,7 +1921,7 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) currentPatch => sites(s)%oldest_patch c = fcolumn(s) do while(associated(currentPatch)) - if(currentPatch%nocomp_pft_label.gt.0)then ! only set values for vegetated patches in fixed modes + if(currentPatch%nocomp_pft_label.ne.0)then ! only increase ifp for veg patches not BG (in SP mode) ifp = ifp+1 endif ! stay with ifp=0 for bareground patch. if ( currentPatch%total_canopy_area-currentPatch%area > 0.000001_r8 ) then @@ -2027,11 +2026,11 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) currentPatch => sites(s)%oldest_patch ifp = 0 do while(associated(currentPatch)) - if(.not.hlm_use_sp.or.currentPatch%nocomp_pft_label.gt.0)then + if(currentPatch%nocomp_pft_label.ne.0)then ! for vegetated patches only ifp = ifp+1 bc_out(s)%canopy_fraction_pa(ifp) = bc_out(s)%canopy_fraction_pa(ifp)/total_patch_area - else ! when it is both SP mode and the bareground patch - bc_out(s)%canopy_fraction_pa(ifp) =0.0_r8 + else ! for the bareground patch (in SP mode). + bc_out(s)%canopy_fraction_pa(ifp) =0.0_r8 endif ! veg patch @@ -2089,6 +2088,7 @@ function calc_areaindex(cpatch,ai_type) result(ai) 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 @@ -2193,7 +2193,7 @@ function NumPotentialCanopyLayers(currentPatch,site_spread,include_substory) res if(arealayer > currentPatch%area)then z = z + 1 if(hlm_use_sp)then - write(*,*) 'SPmode, canopy_layer full:',arealayer,currentPatch%area + write(fates_log(),*) 'SPmode, canopy_layer full:',arealayer,currentPatch%area end if endif diff --git a/biogeophys/EDAccumulateFluxesMod.F90 b/biogeophys/EDAccumulateFluxesMod.F90 index 9355389185..f9bf10e44f 100644 --- a/biogeophys/EDAccumulateFluxesMod.F90 +++ b/biogeophys/EDAccumulateFluxesMod.F90 @@ -64,7 +64,7 @@ subroutine AccumulateFluxes_ED(nsites, sites, bc_in, bc_out, dt_time) cpatch => sites(s)%oldest_patch do while (associated(cpatch)) - if(cpatch%nocomp_pft_label.gt.0)then + if(cpatch%nocomp_pft_label.ne.0)then ifp = ifp+1 if( bc_in(s)%filter_photo_pa(ifp) == 3 ) then diff --git a/biogeophys/EDBtranMod.F90 b/biogeophys/EDBtranMod.F90 index 694a24bd25..5bdcd966bb 100644 --- a/biogeophys/EDBtranMod.F90 +++ b/biogeophys/EDBtranMod.F90 @@ -133,7 +133,7 @@ subroutine btran_ed( nsites, sites, bc_in, bc_out) ifp = 0 cpatch => sites(s)%oldest_patch do while (associated(cpatch)) - if(cpatch%nocomp_pft_label.gt.0)then ! only for veg patches + if(cpatch%nocomp_pft_label.ne.0)then ! only for veg patches ifp=ifp+1 ! THIS SHOULD REALLY BE A COHORT LOOP ONCE WE HAVE rootfr_ft FOR COHORTS (RGK) diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index a3e420b9a0..60a8f69ecf 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -89,7 +89,7 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) ifp = 0 currentpatch => sites(s)%oldest_patch do while (associated(currentpatch)) - if(currentpatch%nocomp_pft_label.gt.0)then + if(currentpatch%nocomp_pft_label.ne.0)then ifp = ifp+1 currentPatch%f_sun (:,:,:) = 0._r8 @@ -1063,7 +1063,7 @@ subroutine ED_SunShadeFracs(nsites, sites,bc_in,bc_out) cpatch => sites(s)%oldest_patch do while (associated(cpatch)) - if(cpatch%nocomp_pft_label.gt.0)then !only for veg patches + if(cpatch%nocomp_pft_label.ne.0)then !only for veg patches ifp=ifp+1 if( debug ) write(fates_log(),*) 'edsurfRad_5600',ifp,s,cpatch%NCL_p,numpft diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 33e5c41d21..7dda7cc928 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -2332,7 +2332,7 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) ifp = 0 cpatch => sites(s)%oldest_patch do while (associated(cpatch)) - if(cpatch%nocomp_pft_label.gt.0)then + if(cpatch%nocomp_pft_label.ne.0)then ifp = ifp + 1 ! ---------------------------------------------------------------------------- diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index 23f7153da2..6f74e95979 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -278,7 +278,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ifp = 0 currentpatch => sites(s)%oldest_patch do while (associated(currentpatch)) - if(currentpatch%nocomp_pft_label.gt.0)then + if(currentpatch%nocomp_pft_label.ne.0)then ifp = ifp+1 NCL_p = currentPatch%NCL_p From a7ad770e7980b8c43954830e24a2a21046a48dfa Mon Sep 17 00:00:00 2001 From: rosiealice Date: Fri, 6 Nov 2020 03:29:54 -0700 Subject: [PATCH 127/209] modifying comments in EDPhysiology --- biogeochem/EDPhysiologyMod.F90 | 65 ++++++++++++++++++---------------- 1 file changed, 35 insertions(+), 30 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 8ebe490c7b..ed4d24cba9 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1371,32 +1371,27 @@ subroutine satellite_phenology(currentSite, bc_in) ! Get access to HLM input varialbes. ! Weight them by PFT ! Loop around patches, and for each single cohort in each patch - ! determine what 'n' should be from the canopy height. - ! determine the leaf biomass that it should have. - ! figure out how this will interact with the canopy_structure routines. - ! determine what 'n' should be from the canopy height. - + ! call assign_cohort_SP_properties to determine cohort height, dbh, 'n', area, leafc from drivers. currentSite%sp_tlai(:) = 0._r8 currentSite%sp_tsai(:) = 0._r8 currentSite%sp_htop(:) = 0._r8 + ! WEIGHTING OF FATES PFTs on to HLM_PFTs + ! 1. Add up the area associated with each FATES PFT + ! where pft_areafrac is the area of land in each HLM PFT and (from surface dataset) + ! hlm_pft_map is the area of that land in each FATES PFT (from param file) + + ! 2. weight each fates PFT target for lai, sai and htop by the area of the + ! contrbuting HLM PFTs. + currentPatch => currentSite%oldest_patch do while (associated(currentPatch)) - ! WEIGHTING OF FATES PFTs on to HLM_PFTs - ! add up the area associated with each FATES PFT - ! where pft_areafrac is the area of land in each HLM PFT and (from surface dataset) - ! hlm_pft_map is the area of that land in each FATES PFT (from param file) - - ! weight each fates PFT target for lai, sai and htop by the area of the - ! contrbuting HLM PFTs. - ! we only need to do this for the patch/fates_pft we are currently in fates_pft = currentPatch%nocomp_pft_label if(fates_pft.ne.0)then sumarea = 0.0_r8 - do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) if(bc_in%pft_areafrac(hlm_pft) * EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft).gt.0.0_r8)then @@ -1426,25 +1421,28 @@ subroutine satellite_phenology(currentSite, bc_in) /(currentPatch%area/area) endif - - end if ! bare patch + end if ! not bare patch currentPatch => currentPatch%younger end do ! patch loop + + ! ------------------------------------------------------------ + ! now we have the target lai, sai and htop for each PFT/patch + ! find properties of the cohort that go along with that + ! 1. Find canopy area from HTOP (height) + ! 2. Find 'n' associated with canopy area, given a closed canopy + ! 3. Find 'bleaf' associated with TLAI and canopy area. + ! These things happen in the catchily titled "assign_cohort_SP_properties" routine. + ! ------------------------------------------------------------ + currentPatch => currentSite%oldest_patch do while (associated(currentPatch)) - ! ------------------------------------------------------------ - ! now we have the target lai, sai and htop for each PFT/patch - ! find properties of the cohort that go along with that - ! 1. Find canopy area from HTOP (height) - ! 2. Find 'n' associated with canopy area, given a closed canopy - ! 3. Find 'bleaf' associated with TLAI and canopy area. - ! ------------------------------------------------------------ currentCohort => currentPatch%tallest do while (associated(currentCohort)) + ! FIRST SOME CHECKS. fates_pft =currentCohort%pft - if(fates_pft.ne.currentPatch%nocomp_pft_label)then + if(fates_pft.ne.currentPatch%nocomp_pft_label)then ! does this cohort belong in this PFT patch? write(fates_log(),*) 'wrong PFT label in cohort in SP mode',fates_pft,currentPatch%nocomp_pft_label call endrun(msg=errMsg(sourcefile, __LINE__)) end if @@ -1453,6 +1451,8 @@ subroutine satellite_phenology(currentSite, bc_in) write(fates_log(),*) 'PFT0 in SP mode' call endrun(msg=errMsg(sourcefile, __LINE__)) end if + + ! Call routine to invert SP drivers into cohort properites. call assign_cohort_SP_properties(currentCohort, currentSite%sp_htop(fates_pft), currentSite%sp_tlai(fates_pft) , currentSite%sp_tsai(fates_pft),currentPatch%area,ifalse,leaf_c) currentCohort => currentCohort%shorter @@ -1466,6 +1466,7 @@ end subroutine satellite_phenology subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,leaf_c) + ! -----------------------------------------------------------------------------------! ! Takes the daily inputs of leaf area index, stem area index and canopy height and ! translates them into a FATES structure with one patch and one cohort per PFT ! The leaf area of the cohort is modified each day to match that asserted by the HLM @@ -1506,12 +1507,11 @@ subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,l call h2d_allom(currentCohort%hite,fates_pft,currentCohort%dbh) currentCohort%n = 1.0_r8 ! make n=1 to get area of one tree. - spread = 1.0_r8 ! fix this to 0 to remove dynamics of canopy closure, assuming a closed canopy. + spread = 1.0_r8 ! fix this to 0 to remove dynamics of canopy closure, assuming a closed canopy. ! n.b. the value of this will only affect 'n', which isn't/shouldn't be a diagnostic in ! SP mode. call carea_allom(currentCohort%dbh,currentCohort%n,spread,currentCohort%pft,currentCohort%c_area) - !------------------------------------------ ! Calculate canopy N assuming patch area is full !------------------------------------------ @@ -1528,19 +1528,24 @@ subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,l leaf_c = leafc_from_treelai( currentCohort%treelai, currentCohort%pft, currentCohort%c_area,& currentCohort%n, currentCohort%canopy_layer, currentCohort%vcmax25top) - !check reverse - maybe can delete eventually + !check that the inverse calculation of leafc from treelai is the same as the + ! standard calculation of treelai from leafc. Maybe can delete eventually? + check_treelai = tree_lai(leaf_c, currentCohort%pft, currentCohort%c_area, & currentCohort%n, currentCohort%canopy_layer, & canopylai,currentCohort%vcmax25top ) - if( abs(currentCohort%treelai-check_treelai).gt.1.0e-12)then !this is not as precise as nearzerio (10^-16 typically) + if( abs(currentCohort%treelai-check_treelai).gt.1.0e-12)then !this is not as precise as nearzero write(fates_log(),*) 'error in validate treelai',currentCohort%treelai,check_treelai,currentCohort%treelai-check_treelai call endrun(msg=errMsg(sourcefile, __LINE__)) end if - ! the carea_allom routine sometimes generates precision-tolerance level errors in the canopy area - if(abs(currentCohort%c_area-parea).gt.nearzero)then + ! these mean that the canopy area does not exactly add up to the patch area, which causes chaos in + ! the radiation routines. Correct both the area and the 'n' to remove error, and don't use + !! carea_allom in SP mode after this point. + + if(abs(currentCohort%c_area-parea).gt.nearzero)then ! there is an error if(abs(currentCohort%c_area-parea).lt.10.e-9)then !correct this if it's a very sall error oldcarea = currentCohort%c_area !generate new cohort area From ca81774a585983e18916b2a0f616d309fc30171e Mon Sep 17 00:00:00 2001 From: rosiealice Date: Fri, 13 Nov 2020 06:00:31 -0700 Subject: [PATCH 128/209] reverting canopy area error tolerance back to previous higher value --- biogeochem/EDCanopyStructureMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index d3109383ce..d9d44a8e31 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1387,7 +1387,7 @@ subroutine canopy_summarization( nsites, sites, bc_in ) enddo ! ends 'do while(associated(currentCohort)) if ( currentPatch%total_canopy_area>currentPatch%area ) then - if ( currentPatch%total_canopy_area-currentPatch%area > 1.0e-10_r8 ) then + if ( currentPatch%total_canopy_area-currentPatch%area > 0.001_r8 ) then write(fates_log(),*) 'FATES: canopy area bigger than area', & currentPatch%total_canopy_area ,currentPatch%area, & currentPatch%total_canopy_area -currentPatch%area,& From 2a7c346282dfd290225c0c9d264a0ea4fe75c10a Mon Sep 17 00:00:00 2001 From: ckoven Date: Fri, 20 Nov 2020 11:21:08 -0700 Subject: [PATCH 129/209] updated ncvarsort.py and modify_fates_paramfile.py to work with new fates_hlm_pftno dimension on parameter file --- tools/modify_fates_paramfile.py | 2 +- tools/ncvarsort.py | 7 ++++--- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/tools/modify_fates_paramfile.py b/tools/modify_fates_paramfile.py index 12fb552cdc..86d547d9d2 100755 --- a/tools/modify_fates_paramfile.py +++ b/tools/modify_fates_paramfile.py @@ -91,7 +91,7 @@ def main(): npft_file = var.shape[i] pftdim = i otherdimpresent = False - elif var.dimensions[i] in ['fates_history_age_bins','fates_history_size_bins','fates_history_coage_bins','fates_history_height_bins','fates_NCWD','fates_litterclass','fates_leafage_class','fates_prt_organs','fates_hydr_organs','fates_variants']: + elif var.dimensions[i] in ['fates_history_age_bins','fates_history_size_bins','fates_history_coage_bins','fates_history_height_bins','fates_NCWD','fates_litterclass','fates_leafage_class','fates_prt_organs','fates_hydr_organs','fates_variants','fates_hlm_pftno']: otherdimpresent = True otherdimname = var.dimensions[i] otherdimlength = var.shape[i] diff --git a/tools/ncvarsort.py b/tools/ncvarsort.py index 3f0f3a3a47..f2546060f8 100755 --- a/tools/ncvarsort.py +++ b/tools/ncvarsort.py @@ -45,9 +45,10 @@ def main(): (u'fates_hydr_organs', u'fates_pft'):6, (u'fates_leafage_class', u'fates_pft'):6, (u'fates_prt_organs', u'fates_pft'):6, - (u'fates_litterclass',):7, - (u'fates_NCWD',):8, - ():9} + (u'fates_hlm_pftno', u'fates_pft'):7, + (u'fates_litterclass',):8, + (u'fates_NCWD',):9, + ():10} # # 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.iteritems(): From 5f556966f71984d701833acbfb45328c355d011a Mon Sep 17 00:00:00 2001 From: Rosie Fisher Date: Mon, 23 Nov 2020 14:20:37 +0100 Subject: [PATCH 130/209] Update biogeochem/EDCanopyStructureMod.F90 Co-authored-by: Charlie Koven --- biogeochem/EDCanopyStructureMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index d9d44a8e31..e598ab18be 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1967,7 +1967,7 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) ! currentPatch%total_canopy_area/currentPatch%area is fraction of this patch cover by plants ! currentPatch%area/AREA is the fraction of the soil covered by this patch. if(currentPatch%area.gt.0.0_r8)then - bc_out(s)%canopy_fraction_pa(ifp) = & + bc_out(s)%canopy_fraction_pa(ifp) = & min(1.0_r8,currentPatch%total_canopy_area/currentPatch%area)*(currentPatch%area/AREA) else bc_out(s)%canopy_fraction_pa(ifp) = 0.0_r8 From ef67e8cdd6cc2a1d21356aa796cbf2ef145aa490 Mon Sep 17 00:00:00 2001 From: Rosie Fisher Date: Mon, 23 Nov 2020 14:22:38 +0100 Subject: [PATCH 131/209] Update biogeochem/EDCanopyStructureMod.F90 CDK2 Co-authored-by: Charlie Koven --- biogeochem/EDCanopyStructureMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index e598ab18be..d229c036fb 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1970,7 +1970,7 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) bc_out(s)%canopy_fraction_pa(ifp) = & min(1.0_r8,currentPatch%total_canopy_area/currentPatch%area)*(currentPatch%area/AREA) else - bc_out(s)%canopy_fraction_pa(ifp) = 0.0_r8 + bc_out(s)%canopy_fraction_pa(ifp) = 0.0_r8 endif bare_frac_area = (1.0_r8 - min(1.0_r8,currentPatch%total_canopy_area/currentPatch%area)) * & From 518b621e863aee6012980807d7cf3354d64c5f1f Mon Sep 17 00:00:00 2001 From: Rosie Fisher Date: Mon, 23 Nov 2020 14:22:57 +0100 Subject: [PATCH 132/209] Update biogeochem/EDCanopyStructureMod.F90 CDK3 Co-authored-by: Charlie Koven --- biogeochem/EDCanopyStructureMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index d229c036fb..d4e1cf2ee7 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1273,7 +1273,7 @@ subroutine canopy_summarization( nsites, sites, bc_in ) type (ed_cohort_type) , pointer :: currentCohort integer :: s integer :: ft ! plant functional type - integer :: ifp ! the number of the vegeted patch (1,2,3). In SP mode bareground patch is 0 + integer :: ifp ! the number of the vegetated patch (1,2,3). In SP mode bareground patch is 0 integer :: patchn ! identification number for each patch. real(r8) :: canopy_leaf_area ! total amount of leaf area in the vegetated area. m2. real(r8) :: leaf_c ! leaf carbon [kg] From 90bbd1e56a4d76c4206aa44087b4d938a99d777b Mon Sep 17 00:00:00 2001 From: Rosie Fisher Date: Mon, 23 Nov 2020 14:29:02 +0100 Subject: [PATCH 133/209] add currentPatch%nocomp_pft_label to log file HT --- biogeochem/EDCanopyStructureMod.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index d4e1cf2ee7..adf164a538 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1359,7 +1359,8 @@ subroutine canopy_summarization( nsites, sites, bc_in ) end if if(currentPatch%total_canopy_area-currentPatch%area.gt.1.0e-16)then - write(fates_log(),*) 'too much canopy in summary',s,currentPatch%total_canopy_area-currentPatch%area + write(fates_log(),*) 'too much canopy in summary',s, & + currentPatch%nocomp_pft_label, currentPatch%total_canopy_area-currentPatch%area call endrun(msg=errMsg(sourcefile, __LINE__)) end if end if !sp mode From 7e4d62d7b0d079fd7eb1277f7adc03dec0a98d04 Mon Sep 17 00:00:00 2001 From: Rosie Fisher Date: Mon, 23 Nov 2020 14:31:16 +0100 Subject: [PATCH 134/209] Update biogeochem/EDPhysiologyMod.F90 CDK5 Co-authored-by: Charlie Koven --- biogeochem/EDPhysiologyMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index ed4d24cba9..d85d44508b 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1546,7 +1546,7 @@ subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,l !! carea_allom in SP mode after this point. if(abs(currentCohort%c_area-parea).gt.nearzero)then ! there is an error - if(abs(currentCohort%c_area-parea).lt.10.e-9)then !correct this if it's a very sall error + if(abs(currentCohort%c_area-parea).lt.10.e-9)then !correct this if it's a very small error oldcarea = currentCohort%c_area !generate new cohort area currentCohort%c_area = currentCohort%c_area - (currentCohort%c_area- parea) From 4d8af4a7a40d3812e3143439cd1b3165ef8b0411 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 23 Nov 2020 07:00:43 -0700 Subject: [PATCH 135/209] remove use_sp statement from canopy structure routine --- biogeochem/EDCanopyStructureMod.F90 | 4 ++-- main/EDMainMod.F90 | 4 +++- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index d9d44a8e31..58be3abdaa 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -150,7 +150,6 @@ subroutine canopy_structure( currentSite , bc_in ) !---------------------------------------------------------------------- - if(hlm_use_sp.eq.ifalse)then currentPatch => currentSite%oldest_patch ! ! zero site-level demotion / promotion tracking info @@ -322,7 +321,7 @@ subroutine canopy_structure( currentSite , bc_in ) currentPatch => currentPatch%younger enddo !patch - end if ! SP mode + return end subroutine canopy_structure @@ -1328,6 +1327,7 @@ subroutine canopy_summarization( nsites, sites, bc_in ) call coagetype_class_index(currentCohort%coage,currentCohort%pft, & currentCohort%coage_class,currentCohort%coage_by_pft_class) end if + if(hlm_use_sp.eq.ifalse)then call carea_allom(currentCohort%dbh,currentCohort%n,sites(s)%spread,& currentCohort%pft,currentCohort%c_area) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 76a031e688..c7bdc30f41 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -668,7 +668,9 @@ subroutine ed_update_site( currentSite, bc_in, bc_out ) call TotalBalanceCheck(currentSite,6) - call canopy_structure(currentSite, bc_in) + if(hlm_use_sp.eq.ifalse)then + call canopy_structure(currentSite, bc_in) + endif call TotalBalanceCheck(currentSite,final_check_id) From a396a835f0d1ce913cdf888c4b38a8c5b0f5f997 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 23 Nov 2020 07:10:11 -0700 Subject: [PATCH 136/209] add dummy n variable --- biogeochem/EDPhysiologyMod.F90 | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index d85d44508b..24c3705753 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1482,9 +1482,10 @@ subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,l integer, intent(in) :: init ! are we in the initialization routine? if so do not set leaf_c real(r8), intent(out) :: leaf_c ! leaf carbon estimated to generate target tlai - integer :: fates_pft ! fates pft numer for weighting loop - real(r8) :: spread ! dummy value of canopy spread to estimate c_area - real(r8) :: sumarea + real(r8) :: dummy_n ! set cohort n to a dummy value of 1.0 + integer :: fates_pft ! fates pft numer for weighting loop + real(r8) :: spread ! dummy value of canopy spread to estimate c_area + real(r8) :: sumarea real(r8) :: check_treelai real(r8) :: canopylai(1:nclmax) real(r8) :: fracerr @@ -1506,11 +1507,11 @@ subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,l fates_pft = currentCohort%pft call h2d_allom(currentCohort%hite,fates_pft,currentCohort%dbh) - currentCohort%n = 1.0_r8 ! make n=1 to get area of one tree. + dummy_n = 1.0_r8 ! make n=1 to get area of one tree. spread = 1.0_r8 ! fix this to 0 to remove dynamics of canopy closure, assuming a closed canopy. ! n.b. the value of this will only affect 'n', which isn't/shouldn't be a diagnostic in ! SP mode. - call carea_allom(currentCohort%dbh,currentCohort%n,spread,currentCohort%pft,currentCohort%c_area) + call carea_allom(currentCohort%dbh,dummy_n,spread,currentCohort%pft,currentCohort%c_area) !------------------------------------------ ! Calculate canopy N assuming patch area is full From 04b9e9dcda5d737d6f91455ade1fd299ce5a5bcc Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 23 Nov 2020 07:50:38 -0700 Subject: [PATCH 137/209] indenting in fatesinterface --- main/FatesInterfaceMod.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 844c180663..28ef965f96 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -1443,14 +1443,14 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) end if - if(hlm_use_fixed_biogeog.eq.unset_int) then + if(hlm_use_fixed_biogeog.eq.unset_int) then if(fates_global_verbose()) then write(fates_log(), *) 'switch for fixed biogeog unset: him_use_fixed_biogeog, exiting' end if call endrun(msg=errMsg(sourcefile, __LINE__)) end if - if(hlm_use_nocomp.eq.unset_int) then + if(hlm_use_nocomp.eq.unset_int) then if(fates_global_verbose()) then write(fates_log(), *) 'switch for no competition mode. ' end if From e1129ce76060ce541044791a32a9bba8ceb0d069 Mon Sep 17 00:00:00 2001 From: Rosie Fisher Date: Mon, 23 Nov 2020 15:51:38 +0100 Subject: [PATCH 138/209] Update main/FatesRestartInterfaceMod.F90 CDK6 Co-authored-by: Charlie Koven --- main/FatesRestartInterfaceMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 866af8095d..1328edef8c 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -2588,7 +2588,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ccohort%prt%variables(i_var)%net_alloc(i_pos) = & this%rvars(ir_prt_var)%r81d(io_idx_co) - ir_prt_var = ir_prt_var + 1 + ir_prt_var = ir_prt_var + 1 ccohort%prt%variables(i_var)%burned(i_pos) = & this%rvars(ir_prt_var)%r81d(io_idx_co) end do From 206a844a102944ed8980d6de2c3175b5bbcc9d3b Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 23 Nov 2020 08:00:43 -0700 Subject: [PATCH 139/209] change comment. HT --- biogeochem/EDCanopyStructureMod.F90 | 3 ++- parameter_files/fates_params_default.cdl | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 17e4bb69e2..ee22a48623 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1922,7 +1922,8 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) currentPatch => sites(s)%oldest_patch c = fcolumn(s) do while(associated(currentPatch)) - if(currentPatch%nocomp_pft_label.ne.0)then ! only increase ifp for veg patches not BG (in SP mode) + if(currentPatch%nocomp_pft_label.ne.0)then + ! only increase ifp for veg patches, not bareground (in SP mode) ifp = ifp+1 endif ! stay with ifp=0 for bareground patch. if ( currentPatch%total_canopy_area-currentPatch%area > 0.000001_r8 ) then diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index c259b3c5df..a886c4c78e 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -505,7 +505,7 @@ variables: fates_z0mr:long_name = "Ratio of momentum roughness length to canopy top height" ; double fates_hlm_pft_map(fates_hlm_pftno, fates_pft) ; fates_hlm_pft_map:units = "area fraction" ; - fates_hlm_pft_map:long_name = "In fixed biogeog mode, fraction of HLM area associated with each FATES PFT" ; + 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 = "NA" ; fates_fire_FBD:long_name = "spitfire parameter related to fuel bulk density, see SFMain.F90" ; From 4611ded5e3dad9d225a68faec63b2b2134a3b01a Mon Sep 17 00:00:00 2001 From: Rosie Fisher Date: Mon, 23 Nov 2020 16:01:07 +0100 Subject: [PATCH 140/209] Update biogeochem/EDPhysiologyMod.F90 HT1 Co-authored-by: huitang-earth --- biogeochem/EDPhysiologyMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 24c3705753..22bbde2397 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1450,7 +1450,7 @@ subroutine satellite_phenology(currentSite, bc_in) if(fates_pft.eq.0)then write(fates_log(),*) 'PFT0 in SP mode' call endrun(msg=errMsg(sourcefile, __LINE__)) - end if + end if ! Call routine to invert SP drivers into cohort properites. call assign_cohort_SP_properties(currentCohort, currentSite%sp_htop(fates_pft), currentSite%sp_tlai(fates_pft) , currentSite%sp_tsai(fates_pft),currentPatch%area,ifalse,leaf_c) From 60dcff6f39d3c424970aaa70b135336b695d51a9 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 24 Nov 2020 06:41:25 -0700 Subject: [PATCH 141/209] removed sumarea calcs from edphysiology --- biogeochem/EDPhysiologyMod.F90 | 4 ---- 1 file changed, 4 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 24c3705753..63e61676eb 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1360,7 +1360,6 @@ subroutine satellite_phenology(currentSite, bc_in) real(r8) :: spread ! dummy value of canopy spread to estimate c_area real(r8) :: leaf_c ! leaf carbon estimated to generate target tlai - real(r8) :: sumarea real(r8) :: check_treelai integer :: fates_pft ! fates pft numer for weighting loop integer :: hlm_pft ! host land model pft number for weighting loop. @@ -1391,11 +1390,9 @@ subroutine satellite_phenology(currentSite, bc_in) fates_pft = currentPatch%nocomp_pft_label if(fates_pft.ne.0)then - sumarea = 0.0_r8 do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) if(bc_in%pft_areafrac(hlm_pft) * EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft).gt.0.0_r8)then - sumarea = sumarea + bc_in%pft_areafrac(hlm_pft)*EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft) !leaf area index currentSite%sp_tlai(fates_pft) = currentSite%sp_tlai(fates_pft) + & bc_in%hlm_sp_tlai(hlm_pft) * bc_in%pft_areafrac(hlm_pft) & @@ -1485,7 +1482,6 @@ subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,l real(r8) :: dummy_n ! set cohort n to a dummy value of 1.0 integer :: fates_pft ! fates pft numer for weighting loop real(r8) :: spread ! dummy value of canopy spread to estimate c_area - real(r8) :: sumarea real(r8) :: check_treelai real(r8) :: canopylai(1:nclmax) real(r8) :: fracerr From 12c6d6f7604ba0c18dec8f8aafd46dd75cd91450 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 24 Nov 2020 06:50:41 -0700 Subject: [PATCH 142/209] tidy up leafc_from_treelai function --- biogeochem/FatesAllometryMod.F90 | 15 ++++++--------- 1 file changed, 6 insertions(+), 9 deletions(-) diff --git a/biogeochem/FatesAllometryMod.F90 b/biogeochem/FatesAllometryMod.F90 index c694614f35..00ded88348 100644 --- a/biogeochem/FatesAllometryMod.F90 +++ b/biogeochem/FatesAllometryMod.F90 @@ -807,17 +807,14 @@ real(r8) function leafc_from_treelai( treelai, pft, c_area, nplant, cl, vcmax25t write(fates_log(),*) 'problem in leafc_from_treelai',cl,pft call endrun(msg=errMsg(sourcefile, __LINE__)) endif - + + ! convert PFT-level canopy top and maximum SLA values and convert from m2/gC to m2/kgC slat = g_per_kg * prt_params%slatop(pft) - leafc_per_unitarea = leaf_c/(c_area/nplant) !KgC/m2 + sla_max = g_per_kg * prt_params%slamax(pft) + ! Coefficient for exponential decay of 1/sla with canopy depth: + kn = decay_coeff_kn(pft,vcmax25top) - if(treelai > 0.0_r8)then - ! Coefficient for exponential decay of 1/sla with canopy depth: - kn = decay_coeff_kn(pft,vcmax25top) - ! take PFT-level maximum SLA value, even if under a thick canopy (which has units of m2/gC), - ! and put into units of m2/kgC - sla_max = g_per_kg * prt_params%slamax(pft) - + if(treelai > 0.0_r8)then ! Leafc_per_unitarea at which sla_max is reached due to exponential sla profile in canopy: leafc_slamax = max(0.0_r8,(slat - sla_max) / (-1.0_r8 * kn * slat * sla_max)) From a9269df5cef1838c4e383c39cf95d1d55310c808 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 24 Nov 2020 07:11:39 -0700 Subject: [PATCH 143/209] moving negative check into small patch loop in edinit as per HT request --- main/EDInitMod.F90 | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 211f58834d..a4c9cfd15f 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -335,15 +335,12 @@ subroutine set_site_properties( nsites, sites,bc_in ) sites(s)%area_pft(ft)=0.0_r8 ! remove tiny patches to prevent numerical errors in terminate patches endif - end do -! change units to m2 from fractions - do ft = 1,numpft - sites(s)%area_pft(ft)= sites(s)%area_pft(ft) * AREA ! rescale units to m2. if(sites(s)%area_pft(ft).lt.0._r8)then write(fates_log(),*) 'negative area',s,ft,sites(s)%area_pft(ft) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - end do + sites(s)%area_pft(ft)= sites(s)%area_pft(ft) * AREA ! rescale units to m2. + end do ! re-normalize PFT area to ensure it sums to one. ! note that in areas of 'bare ground' (PFT 0 in CLM/ELM) From 4a67dd87ed77a2c16951aae90735138d5fdd23cb Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 24 Nov 2020 07:23:06 -0700 Subject: [PATCH 144/209] removed sp_patch_index --- main/FatesInterfaceTypesMod.F90 | 4 ---- 1 file changed, 4 deletions(-) diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index ba3fa9191c..4002af90ea 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -336,10 +336,6 @@ module FatesInterfaceTypesMod ! be equivalent (ie integer ascending) ! Or, all will be 1. - integer,allocatable :: sp_patch_index(:) ! in SP mode, we need to map the p values for each patch - ! back onto the 'IFP' order i ED. So this is the number of e ! ach patch in the site. It does not correspond to PFT, more - ! to the number of occupied PFTs before it in the array. - ! Vegetation Dynamics ! --------------------------------------------------------------------------------- From 1f1980975fd336dc9d1c61d8a2d9ba772158ac52 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 24 Nov 2020 07:31:55 -0700 Subject: [PATCH 145/209] added cmments to area check in EDInit --- main/EDInitMod.F90 | 10 ++++++---- main/EDPftvarcon.F90 | 3 ++- 2 files changed, 8 insertions(+), 5 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index a4c9cfd15f..1a4ebf89b5 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -571,13 +571,15 @@ subroutine init_patches( nsites, sites, bc_in) if(abs(tota-area).gt.nearzero*area)then if(abs(tota-area).lt.1.0e-10_r8)then ! this is a precision error if(sites(s)%oldest_patch%area.gt.(tota-area+nearzero))then - ! remove or add extra area from bare ground patch + ! remove or add extra area + ! if the oldest patch has enough area, use that sites(s)%oldest_patch%area = sites(s)%oldest_patch%area - (tota-area) - write(*,*) 'fixing patch precision O',s, tota-area - else + write(*,*) 'fixing patch precision - oldest',s, tota-area + else ! or otherwise take the area from the youngest patch. sites(s)%youngest_patch%area = sites(s)%oldest_patch%area - (tota-area) + write(*,*) 'fixing patch precision -youngest ',s, tota-area endif - else !this is a big error + else !this is a big error not just a precision error. write(*,*) 'issue with patch area in EDinit',tota-area,tota call endrun(msg=errMsg(sourcefile, __LINE__)) endif ! big error diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index 214ca75d3b..6ca06b3f43 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -1693,7 +1693,8 @@ subroutine FatesCheckParams(is_master) end if - ! check that the host-fates PFT map adds to one in both dimension + ! check that the host-fates PFT map adds to one along HLM dimension so that all the HLM area + ! goes to a FATES PFT. Each FATES PFT can get < or > 1 of an HLM PFT. do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) sumarea = sum(EDPftvarcon_inst%hlm_pft_map(1:npft,hlm_pft)) if(abs(sumarea-1.0_r8).gt.nearzero)then From 9b31a8ccb79e8c072ef4491b6de8cb3d1dac5b7a Mon Sep 17 00:00:00 2001 From: Rosie Fisher Date: Wed, 25 Nov 2020 10:58:16 +0100 Subject: [PATCH 146/209] Update biogeochem/EDCohortDynamicsMod.F90 CDK7 Co-authored-by: Charlie Koven --- biogeochem/EDCohortDynamicsMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index e6fd43f66f..ae9983f356 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -188,7 +188,7 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & ! leaf biomass that we are targeting? real(r8), intent(in) :: spread ! The community assembly effects how ! spread crowns are in horizontal space - real(r8), intent(in) :: carea ! area of cohort NLY USED IN SP MODE. + real(r8), intent(in) :: carea ! area of cohort ONLY USED IN SP MODE. type(bc_in_type), intent(in) :: bc_in ! External boundary conditions From 6a4dec9aa1bf4d61e301379e143f0b4311f5e77f Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 25 Nov 2020 08:05:43 -0700 Subject: [PATCH 147/209] indenting all of EDCanopyStructureMod.F90 --- biogeochem/EDCanopyStructureMod.F90 | 3286 +++++++++++++-------------- 1 file changed, 1643 insertions(+), 1643 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index ee22a48623..3460871e7f 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -59,1133 +59,1133 @@ module EDCanopyStructureMod character(len=*), parameter, private :: sourcefile = & __FILE__ - + real(r8), parameter :: area_target_precision = 1.0E-11_r8 ! Area conservation - ! will attempt to reduce errors - ! below this level - + ! will attempt to reduce errors + ! below this level + real(r8), parameter :: area_check_precision = 1.0E-7_r8 ! Area conservation checks must - ! be within this absolute tolerance + ! be within this absolute tolerance real(r8), parameter :: area_check_rel_precision = 1.0E-4_r8 ! Area conservation checks must - ! be within this relative tolerance + ! be within this relative tolerance real(r8), parameter :: similar_height_tol = 1.0E-3_r8 ! I think trees that differ by 1mm - ! can be roughly considered the same right? + ! can be roughly considered the same right? ! 10/30/09: Created by Rosie Fisher ! 2017/2018: Modifications and updates by Ryan Knox ! ============================================================================ -contains +contains + + ! ============================================================================ + subroutine canopy_structure( currentSite , bc_in ) + ! + ! !DESCRIPTION: + ! create cohort instance + ! + ! This routine allocates the 'canopy_layer' attribute to each cohort + ! All top leaves in the same canopy layer get the same light resources. + ! The first canopy layer is the 'canopy' or 'overstorey'. The second is the 'understorey'. + ! More than two layers is not permitted at the moment + ! Seeds germinating into the 3rd or higher layers are automatically removed. + ! + ! ------Perfect Plasticity----- + ! The idea of these canopy layers derives originally from Purves et al. 2009 + ! Their concept is that, given enoughplasticity in canopy position, size, shape and depth + ! all of the gound area will be filled perfectly by leaves, and additional leaves will have + ! to exist in the understorey. + ! Purves et al. use the concept of 'Z*' to assume that the height required to attain a place in the + ! canopy is spatially uniform. In this implementation, described in Fisher et al. (2010, New Phyt) we + ! extent that concept to assume that position in the canopy has some random element, and that BOTH height + ! and chance combine to determine whether trees get into the canopy. + ! Thus, when the canopy is closed and there is excess area, some of it must be demoted + ! If we demote -all- the trees less than a given height, there is a massive advantage in being the cohort that is + ! the biggest when the canopy is closed. + ! In this implementation, the amount demoted, ('weight') is a function of the height weighted by the competitive exclusion + ! parameter (ED_val_comp_excln). + + ! Complexity in this routine results from a few things. + ! Firstly, the complication of the demotion amount sometimes being larger than the cohort area (for a very small, short cohort) + ! Second, occasionaly, disturbance (specifically fire) can cause the canopy layer to become less than closed, + ! without changing the area of the patch. If this happens, then some of the plants in the lower layer need to be 'promoted' so + ! all of the routine has to happen in both the downwards and upwards directions. + ! + ! The order of events here is therefore: + ! (The entire subroutine has a single outer 'patch' loop. + ! Section 1: figure out the total area, and whether there are >1 canopy layers at all. + ! + ! Sorts out cohorts into canopy and understorey layers... + ! + ! !USES: + + use EDParamsMod, only : ED_val_comp_excln + use EDTypesMod , only : min_patch_area + use FatesInterfaceTypesMod, only : bc_in_type + ! + ! !ARGUMENTS + type(ed_site_type) , intent(inout), target :: currentSite + type(bc_in_type), intent(in) :: bc_in + + ! + ! !LOCAL VARIABLES: + type(ed_patch_type) , pointer :: currentPatch + type(ed_cohort_type), pointer :: currentCohort + integer :: i_lyr ! current layer index + integer :: z ! Current number of canopy layers. (1= canopy, 2 = understorey) + integer :: ipft + real(r8) :: arealayer(nclmax+2) ! Amount of plant area currently in each canopy layer + integer :: patch_area_counter ! count iterations used to solve canopy areas + logical :: area_not_balanced ! logical controlling if the patch layer areas + ! have successfully been redistributed + integer :: return_code ! math checks on variables will return>0 if problems exist + + ! We only iterate because of possible imprecisions generated by the cohort + ! termination process. These should be super small, so at the most + ! try to re-balance 3 times. If that doesn't give layer areas + ! within tolerance of canopy area, there is something wrong + + integer, parameter :: max_patch_iterations = 10 + + + !---------------------------------------------------------------------- + currentPatch => currentSite%oldest_patch + ! + ! zero site-level demotion / promotion tracking info + currentSite%demotion_rate(:) = 0._r8 + currentSite%promotion_rate(:) = 0._r8 + currentSite%demotion_carbonflux = 0._r8 + currentSite%promotion_carbonflux = 0._r8 + + + ! + ! Section 1: Check total canopy area. + ! + do while (associated(currentPatch)) ! Patch loop + + ! ------------------------------------------------------------------------------ + ! Perform numerical checks on some cohort and patch structures + ! ------------------------------------------------------------------------------ + + ! canopy layer has a special bounds check + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if( currentCohort%canopy_layer < 1 .or. currentCohort%canopy_layer > nclmax+1 ) then + write(fates_log(),*) 'lat:',currentSite%lat + write(fates_log(),*) 'lon:',currentSite%lon + write(fates_log(),*) 'BOGUS CANOPY LAYER: ',currentCohort%canopy_layer + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + currentCohort => currentCohort%shorter + enddo + + + ! Does any layer have excess area in it? Keep going until it does not... + patch_area_counter = 0 + area_not_balanced = .true. + + do while(area_not_balanced) + + ! --------------------------------------------------------------------------- + ! Demotion Phase: Identify upper layers that are too full, and demote them to + ! the layers below. + ! --------------------------------------------------------------------------- + + ! Its possible that before we even enter this scheme + ! some cohort numbers are very low. Terminate them. + call terminate_cohorts(currentSite, currentPatch, 1, 12) + + ! Calculate how many layers we have in this canopy + ! This also checks the understory to see if its crown + ! area is large enough to warrant a temporary sub-understory layer + z = NumPotentialCanopyLayers(currentPatch,currentSite%spread,include_substory=.false.) + + do i_lyr = 1,z ! Loop around the currently occupied canopy layers. + call DemoteFromLayer(currentSite, currentPatch, i_lyr) + end do + + ! After demotions, we may then again have cohorts that are very very + ! very sparse, remove them + call terminate_cohorts(currentSite, currentPatch, 1,13) + + call fuse_cohorts(currentSite, currentPatch, bc_in) + + ! Remove cohorts for various other reasons + call terminate_cohorts(currentSite, currentPatch, 2,13) + + + ! --------------------------------------------------------------------------------------- + ! Promotion Phase: Identify if any upper-layers are underful and layers below them + ! have cohorts that can be split and promoted to the layer above. + ! --------------------------------------------------------------------------------------- + + ! Re-calculate Number of layers without the false substory + z = NumPotentialCanopyLayers(currentPatch,currentSite%spread,include_substory=.false.) + + ! We only promote if we have at least two layers + if (z>1) then + + do i_lyr=1,z-1 + call PromoteIntoLayer(currentSite, currentPatch, i_lyr) + end do + + ! Remove cohorts that are incredibly sparse + call terminate_cohorts(currentSite, currentPatch, 1,14) + + call fuse_cohorts(currentSite, currentPatch, bc_in) + + ! Remove cohorts for various other reasons + call terminate_cohorts(currentSite, currentPatch, 2,14) + + end if + + ! --------------------------------------------------------------------------------------- + ! Check on Layer Area (if the layer differences are not small + ! Continue trying to demote/promote. Its possible on the first pass through, + ! that cohort fusion has nudged the areas a little bit. + ! --------------------------------------------------------------------------------------- + + z = NumPotentialCanopyLayers(currentPatch,currentSite%spread,include_substory=.false.) + area_not_balanced = .false. + do i_lyr = 1,z + call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr,arealayer(i_lyr)) + if( ((arealayer(i_lyr)-currentPatch%area)/currentPatch%area > area_check_rel_precision) .or. & + ((arealayer(i_lyr)-currentPatch%area) > area_check_precision ) ) then + area_not_balanced = .true. + endif + enddo + + ! --------------------------------------------------------------------------------------- + ! Gracefully exit if too many iterations have gone by + ! --------------------------------------------------------------------------------------- + + patch_area_counter = patch_area_counter + 1 + if(patch_area_counter > max_patch_iterations .and. area_not_balanced) then + write(fates_log(),*) 'PATCH AREA CHECK NOT CLOSING' + write(fates_log(),*) 'patch area:',currentpatch%area + do i_lyr = 1,z + write(fates_log(),*) 'layer: ',i_lyr,' area: ',arealayer(i_lyr) + write(fates_log(),*) 'rel error: ',(arealayer(i_lyr)-currentPatch%area)/currentPatch%area + write(fates_log(),*) 'abs error: ',arealayer(i_lyr)-currentPatch%area + enddo + write(fates_log(),*) 'lat:',currentSite%lat + write(fates_log(),*) 'lon:',currentSite%lon + write(fates_log(),*) 'spread:',currentSite%spread + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + write(fates_log(),*) 'coh ilayer:',currentCohort%canopy_layer + write(fates_log(),*) 'coh dbh:',currentCohort%dbh + write(fates_log(),*) 'coh pft:',currentCohort%pft + write(fates_log(),*) 'coh n:',currentCohort%n + write(fates_log(),*) 'coh carea:',currentCohort%c_area + ipft=currentCohort%pft + write(fates_log(),*) 'maxh:',prt_params%allom_dbh_maxheight(ipft) + write(fates_log(),*) 'lmode: ',prt_params%allom_lmode(ipft) + write(fates_log(),*) 'd2bl2: ',prt_params%allom_d2bl2(ipft) + write(fates_log(),*) 'd2bl_ediff: ',prt_params%allom_blca_expnt_diff(ipft) + write(fates_log(),*) 'd2ca_min: ',prt_params%allom_d2ca_coefficient_min(ipft) + write(fates_log(),*) 'd2ca_max: ',prt_params%allom_d2ca_coefficient_max(ipft) + currentCohort => currentCohort%shorter + enddo + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + enddo ! do while(area_not_balanced) + + + ! Set current canopy layer occupancy indicator. + currentPatch%NCL_p = min(nclmax,z) + + ! ------------------------------------------------------------------------------------------- + ! if we are using "strict PPA", then calculate a z_star value as + ! the height of the smallest tree in the canopy + ! loop from top to bottom and locate the shortest cohort in level 1 whose shorter + ! neighbor is in level 2 set zstar as the ehight of that shortest level 1 cohort + ! ------------------------------------------------------------------------------------------- + + if ( ED_val_comp_excln .lt. 0.0_r8) then + currentPatch%zstar = 0._r8 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if(currentCohort%canopy_layer .eq. 2)then + if (associated(currentCohort%taller)) then + if (currentCohort%taller%canopy_layer .eq. 1 ) then + currentPatch%zstar = currentCohort%taller%hite + endif + endif + endif + currentCohort => currentCohort%shorter + enddo + endif + + currentPatch => currentPatch%younger + enddo !patch + + return + end subroutine canopy_structure + + + ! ============================================================================================== + + + subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr) + + use EDParamsMod, only : ED_val_comp_excln + use SFParamsMod, only : SF_val_CWD_frac + + ! !ARGUMENTS + type(ed_site_type), intent(inout), target :: currentSite + type(ed_patch_type), intent(inout), target :: currentPatch + integer, intent(in) :: i_lyr ! Current canopy layer of interest + + ! !LOCAL VARIABLES: + type(ed_cohort_type), pointer :: currentCohort + type(ed_cohort_type), pointer :: copyc + type(ed_cohort_type), pointer :: nextc ! The next cohort in line + integer :: i_cwd ! Index for CWD pool + real(r8) :: cc_loss ! cohort crown area loss in demotion (m2) + real(r8) :: leaf_c ! leaf carbon [kg] + real(r8) :: fnrt_c ! fineroot carbon [kg] + real(r8) :: sapw_c ! sapwood carbon [kg] + real(r8) :: store_c ! storage carbon [kg] + real(r8) :: struct_c ! structure carbon [kg] + real(r8) :: scale_factor ! for prob. exclusion - scales weight to a fraction + real(r8) :: scale_factor_min ! "" minimum before exeedance of 1 + real(r8) :: scale_factor_res ! "" applied to residual areas + real(r8) :: area_res ! residual area to demote after weakest cohort hits max + real(r8) :: newarea + real(r8) :: demote_area + real(r8) :: sumweights + real(r8) :: sumequal ! for rank-ordered same-size cohorts + ! this tallies their excluded area + real(r8) :: arealayer ! the area of the current canopy layer + logical :: tied_size_with_neighbors + real(r8) :: total_crownarea_of_tied_cohorts + + ! First, determine how much total canopy area we have in this layer + call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr,arealayer) + + demote_area = arealayer - currentPatch%area + + if ( demote_area > area_target_precision ) then + + ! Is this layer currently over-occupied? + ! In that case, we need to work out which cohorts to demote. + ! We go in order from shortest to tallest for ranked demotion + + sumweights = 0.0_r8 + currentCohort => currentPatch%shortest + do while (associated(currentCohort)) + call carea_allom(currentCohort%dbh,currentCohort%n, & + currentSite%spread,currentCohort%pft,currentCohort%c_area) + + if(debug) then + if(currentCohort%c_area<0._r8)then + write(fates_log(),*) 'negative c_area stage 1d: ',currentCohort%dbh,i_lyr,currentCohort%n, & + currentSite%spread,currentCohort%pft,currentCohort%c_area + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + if( currentCohort%canopy_layer == i_lyr)then + + if (ED_val_comp_excln .ge. 0.0_r8 ) then + + ! ---------------------------------------------------------- + ! Stochastic method. + ! Weight cohort demotion by inverse size to a constant power. + ! In this hypothesis, it is assumed that even the tallest + ! cohorts have a chance (although smaller) of being forced + ! to the understory. + ! ---------------------------------------------------------- + + currentCohort%excl_weight = 1._r8 / (currentCohort%hite**ED_val_comp_excln) + sumweights = sumweights + currentCohort%excl_weight + + else + + ! ----------------------------------------------------------- + ! Rank ordered deterministic method + ! ----------------------------------------------------------- + ! If there are cohorts that have the exact same height (which is possible, really) + ! we don't want to unilaterally promote/demote one before the others. + ! So we <>mote them as a unit + ! now we need to go through and figure out how many equal-size cohorts there are. + ! then we need to go through, add up the collective crown areas of all equal-sized + ! and equal-canopy-layer cohorts, + ! and then demote from each as if they were a single group + + total_crownarea_of_tied_cohorts = currentCohort%c_area + + tied_size_with_neighbors = .false. + nextc => currentCohort%taller + do while (associated(nextc)) + if ( abs(nextc%hite - currentCohort%hite) < similar_height_tol ) then + if( nextc%canopy_layer .eq. currentCohort%canopy_layer ) then + tied_size_with_neighbors = .true. + total_crownarea_of_tied_cohorts = & + total_crownarea_of_tied_cohorts + nextc%c_area + end if + else + exit + endif + nextc => nextc%taller + end do + + if ( tied_size_with_neighbors ) then + + currentCohort%excl_weight = & + max(0.0_r8,min(currentCohort%c_area, & + (currentCohort%c_area/total_crownarea_of_tied_cohorts) * & + (demote_area - sumweights) )) + + sumequal = currentCohort%excl_weight + + nextc => currentCohort%taller + do while (associated(nextc)) + if ( abs(nextc%hite - currentCohort%hite) < similar_height_tol ) then + if (nextc%canopy_layer .eq. currentCohort%canopy_layer ) then + ! now we know the total crown area of all equal-sized, + ! equal-canopy-layer cohorts + nextc%excl_weight = & + max(0.0_r8,min(nextc%c_area, & + (nextc%c_area/total_crownarea_of_tied_cohorts) * & + (demote_area - sumweights) )) + sumequal = sumequal + nextc%excl_weight + end if + else + exit + endif + nextc => nextc%taller + end do + + ! Update the current cohort pointer to the last similar cohort + ! Its ok if this is not in the right layer + if(associated(nextc))then + currentCohort => nextc%shorter + else + currentCohort => currentPatch%tallest + end if + sumweights = sumweights + sumequal + + else + currentCohort%excl_weight = & + max(min(currentCohort%c_area, demote_area - sumweights ), 0._r8) + sumweights = sumweights + currentCohort%excl_weight + end if + + endif + endif + currentCohort => currentCohort%taller + enddo + + ! If this is probabalistic demotion, we need to do a round of normalization. + ! And then a few rounds where we pre-calculate the demotion areas + ! and adjust things if the demoted area wants to be greater than + ! what is available. The math is too hard to explain here, see + ! the tech note section on promotion/demotion. + + if (ED_val_comp_excln .ge. 0.0_r8 ) then + + scale_factor_min = 1.e10_r8 + scale_factor = 0._r8 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + + if(currentCohort%canopy_layer == i_lyr) then + + currentCohort%excl_weight = currentCohort%excl_weight/sumweights + if( 1._r8/currentCohort%excl_weight < scale_factor_min ) & + scale_factor_min = 1._r8/currentCohort%excl_weight + + scale_factor = scale_factor + currentCohort%excl_weight * currentCohort%c_area + + endif + currentCohort => currentCohort%shorter + enddo + + ! This is the factor by which we need to multiply + ! the demotion probabilities, so the sum result equals + ! the total amount to demote + + scale_factor = demote_area/scale_factor + + if(scale_factor <= scale_factor_min) then + + ! Trivial case, all of the demotion fractions are less than 1. + + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == i_lyr) then + currentCohort%excl_weight = currentCohort%c_area * currentCohort%excl_weight * scale_factor + + if(debug) then + if((currentCohort%excl_weight > (currentCohort%c_area+area_target_precision)) .or. & + (currentCohort%excl_weight < 0._r8) ) then + write(fates_log(),*) 'exclusion area too big (1)' + write(fates_log(),*) 'currentCohort%c_area: ',currentCohort%c_area + write(fates_log(),*) 'dbh: ',currentCohort%dbh + write(fates_log(),*) 'n: ',currentCohort%n + write(fates_log(),*) 'spread: ',currentSite%spread + write(fates_log(),*) 'pft: ',currentCohort%pft + write(fates_log(),*) 'currentCohort%excl_weight: ',currentCohort%excl_weight + write(fates_log(),*) 'excess: ',currentCohort%excl_weight - currentCohort%c_area + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + endif + currentCohort => currentCohort%shorter + enddo + + else + + + ! Non-trivial case, at least 1 cohort's demotion + ! rate would exceed its area, given the trivial scale factor + + area_res = 0._r8 + scale_factor_res = 0._r8 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == i_lyr) then + area_res = area_res + & + currentCohort%c_area * currentCohort%excl_weight * & + scale_factor_min + scale_factor_res = scale_factor_res + & + currentCohort%c_area * & + (1._r8 - (currentCohort%excl_weight * scale_factor_min)) + endif + currentCohort => currentCohort%shorter + enddo + + area_res = demote_area - area_res + + scale_factor_res = area_res / scale_factor_res + + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == i_lyr) then + + currentCohort%excl_weight = currentCohort%c_area * & + (currentCohort%excl_weight * scale_factor_min + & + (1._r8 - (currentCohort%excl_weight*scale_factor_min) ) * scale_factor_res) + + if(debug)then + if((currentCohort%excl_weight > & + (currentCohort%c_area+area_target_precision)) .or. & + (currentCohort%excl_weight < 0._r8) ) then + write(fates_log(),*) 'exclusion area error (2)' + write(fates_log(),*) 'currentCohort%c_area: ',currentCohort%c_area + write(fates_log(),*) 'currentCohort%excl_weight: ', & + currentCohort%excl_weight + write(fates_log(),*) 'excess: ', & + currentCohort%excl_weight - currentCohort%c_area + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + endif + currentCohort => currentCohort%shorter + enddo + + end if + + end if + + + ! perform a check and see if the demotions meet the demand + sumweights = 0._r8 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == i_lyr) then + sumweights = sumweights + currentCohort%excl_weight + end if + currentCohort => currentCohort%shorter + end do + + if (abs(sumweights - demote_area) > area_check_precision ) then + write(fates_log(),*) 'demotions dont add up' + write(fates_log(),*) 'sum demotions: ',sumweights + write(fates_log(),*) 'area needed to be demoted: ',demote_area + write(fates_log(),*) 'excess: ',sumweights - demote_area + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + + ! Weights have been calculated. Now move them to the lower layer + + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + + if(currentCohort%canopy_layer == i_lyr )then + + cc_loss = currentCohort%excl_weight + leaf_c = currentCohort%prt%GetState(leaf_organ,all_carbon_elements) + store_c = currentCohort%prt%GetState(store_organ,all_carbon_elements) + fnrt_c = currentCohort%prt%GetState(fnrt_organ,all_carbon_elements) + sapw_c = currentCohort%prt%GetState(sapw_organ,all_carbon_elements) + struct_c = currentCohort%prt%GetState(struct_organ,all_carbon_elements) + + if ( (cc_loss-currentCohort%c_area) > -nearzero .and. & + (cc_loss-currentCohort%c_area) < area_target_precision ) then + + ! If the whole cohort is being demoted, just change its + ! layer index + + currentCohort%canopy_layer = i_lyr+1 + + ! keep track of number and biomass of demoted cohort + currentSite%demotion_rate(currentCohort%size_class) = & + currentSite%demotion_rate(currentCohort%size_class) + currentCohort%n + currentSite%demotion_carbonflux = currentSite%demotion_carbonflux + & + (leaf_c + store_c + fnrt_c + sapw_c + struct_c) * currentCohort%n + + elseif( (cc_loss < currentCohort%c_area) .and. & + (cc_loss > area_target_precision) ) then + + ! If only part of the cohort is demoted + ! then it must be split (little more complicated) + + ! Make a copy of the current cohort. The copy and the original + ! conserve total number density of the original. The copy + ! remains in the upper-story. The original is the one + ! demoted to the understory + + + allocate(copyc) + + ! Initialize the PARTEH object and point to the + ! correct boundary condition fields + copyc%prt => null() + call InitPRTObject(copyc%prt) + call InitPRTBoundaryConditions(copyc) + + if( hlm_use_planthydro.eq.itrue ) then + call InitHydrCohort(currentSite,copyc) + endif + + call copy_cohort(currentCohort, copyc) + + newarea = currentCohort%c_area - cc_loss + copyc%n = currentCohort%n*newarea/currentCohort%c_area + currentCohort%n = currentCohort%n - copyc%n + + copyc%canopy_layer = i_lyr !the taller cohort is the copy + + ! Demote the current cohort to the understory. + currentCohort%canopy_layer = i_lyr + 1 + + ! keep track of number and biomass of demoted cohort + currentSite%demotion_rate(currentCohort%size_class) = & + currentSite%demotion_rate(currentCohort%size_class) + currentCohort%n + currentSite%demotion_carbonflux = currentSite%demotion_carbonflux + & + (leaf_c + store_c + fnrt_c + sapw_c + struct_c) * currentCohort%n + + call carea_allom(copyc%dbh,copyc%n,currentSite%spread,copyc%pft,copyc%c_area) + call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & + currentCohort%pft,currentCohort%c_area) + + !----------- Insert copy into linked list ------------------------! + copyc%shorter => currentCohort + if(associated(currentCohort%taller))then + copyc%taller => currentCohort%taller + currentCohort%taller%shorter => copyc + else + currentPatch%tallest => copyc + copyc%taller => null() + endif + currentCohort%taller => copyc + + elseif(cc_loss > currentCohort%c_area)then + + write(fates_log(),*) 'more area than the cohort has is being demoted' + write(fates_log(),*) 'loss:',cc_loss + write(fates_log(),*) 'existing area:',currentCohort%c_area + write(fates_log(),*) 'excess: ',cc_loss - currentCohort%c_area + call endrun(msg=errMsg(sourcefile, __LINE__)) + + end if + + ! kill the ones which go into canopy layers that are not allowed + + if(currentCohort%canopy_layer>nclmax )then + + ! put the litter from the terminated cohorts + ! straight into the fragmenting pools + call SendCohortToLitter(currentSite,currentPatch, & + currentCohort,currentCohort%n) + + currentCohort%n = 0.0_r8 + currentCohort%c_area = 0.0_r8 + currentCohort%canopy_layer = i_lyr + + end if + + call carea_allom(currentCohort%dbh,currentCohort%n, & + currentSite%spread,currentCohort%pft,currentCohort%c_area) + + endif !canopy layer = i_ly + + currentCohort => currentCohort%shorter + enddo !currentCohort + + + ! Update the area calculations of the current layer + ! And the layer below that may or may not had recieved + ! Demotions + + call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr,arealayer) + + if ( (abs(arealayer - currentPatch%area)/arealayer > area_check_rel_precision ) .or. & + (abs(arealayer - currentPatch%area) > area_check_precision) ) then + write(fates_log(),*) 'demotion did not trim area within tolerance' + write(fates_log(),*) 'arealayer:',arealayer + write(fates_log(),*) 'patch%area:',currentPatch%area + write(fates_log(),*) 'ilayer: ',i_lyr + write(fates_log(),*) 'bias:',arealayer - currentPatch%area + write(fates_log(),*) 'rel bias:',(arealayer - currentPatch%area)/arealayer + write(fates_log(),*) 'demote_area:',demote_area + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + + end if + + return + end subroutine DemoteFromLayer + + ! ============================================================================================== + + subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) + + ! ------------------------------------------------------------------------------------------- + ! Check whether the intended 'full' layers are actually filling all the space. + ! If not, promote some fraction of cohorts upwards. + ! THIS SECTION MIGHT BE TRIGGERED BY A FIRE OR MORTALITY EVENT, FOLLOWED BY A PATCH FUSION, + ! SO THE TOP LAYER IS NO LONGER FULL. + ! ------------------------------------------------------------------------------------------- + + use EDParamsMod, only : ED_val_comp_excln + + ! !ARGUMENTS + type(ed_site_type), intent(inout), target :: currentSite + type(ed_patch_type), intent(inout), target :: currentPatch + integer, intent(in) :: i_lyr ! Current canopy layer of interest + + ! !LOCAL VARIABLES: + type(ed_cohort_type), pointer :: currentCohort + type(ed_cohort_type), pointer :: copyc + type(ed_cohort_type), pointer :: nextc ! the next cohort, or used for looping + ! cohorts against the current + + real(r8) :: scale_factor ! for prob. exclusion - scales weight to a fraction + real(r8) :: scale_factor_min ! "" minimum before exeedance of 1 + real(r8) :: scale_factor_res ! "" applied to residual areas + real(r8) :: area_res ! residual area to demote after weakest cohort hits max + real(r8) :: promote_area + real(r8) :: newarea + real(r8) :: sumweights + real(r8) :: sumequal ! for tied cohorts, the sum of weights in + ! their group + real(r8) :: cc_gain ! cohort crown area gain in promotion (m2) + real(r8) :: arealayer_current ! area (m2) of the current canopy layer + real(r8) :: arealayer_below ! area (m2) of the layer below the current layer + real(r8) :: leaf_c ! leaf carbon [kg] + real(r8) :: fnrt_c ! fineroot carbon [kg] + real(r8) :: sapw_c ! sapwood carbon [kg] + real(r8) :: store_c ! storage carbon [kg] + real(r8) :: struct_c ! structure carbon [kg] + + logical :: tied_size_with_neighbors + real(r8) :: total_crownarea_of_tied_cohorts + + call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr,arealayer_current) + call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr+1,arealayer_below) + + + ! how much do we need to gain? + promote_area = currentPatch%area - arealayer_current + + if( promote_area > area_target_precision ) then + + if(arealayer_below <= promote_area ) then + + ! --------------------------------------------------------------------------- + ! Promote all cohorts from layer below if that whole layer has area smaller + ! than the tolerance on the gains needed into current layer + ! --------------------------------------------------------------------------- + + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + !look at the cohorts in the canopy layer below... + if(currentCohort%canopy_layer == i_lyr+1)then + + leaf_c = currentCohort%prt%GetState(leaf_organ,all_carbon_elements) + store_c = currentCohort%prt%GetState(store_organ,all_carbon_elements) + fnrt_c = currentCohort%prt%GetState(fnrt_organ,all_carbon_elements) + sapw_c = currentCohort%prt%GetState(sapw_organ,all_carbon_elements) + struct_c = currentCohort%prt%GetState(struct_organ,all_carbon_elements) + + currentCohort%canopy_layer = i_lyr + call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & + currentCohort%pft,currentCohort%c_area) + ! keep track of number and biomass of promoted cohort + currentSite%promotion_rate(currentCohort%size_class) = & + currentSite%promotion_rate(currentCohort%size_class) + currentCohort%n + currentSite%promotion_carbonflux = currentSite%promotion_carbonflux + & + (leaf_c + fnrt_c + store_c + sapw_c + struct_c) * currentCohort%n + + endif + currentCohort => currentCohort%shorter + enddo + + else + + ! --------------------------------------------------------------------------- + ! This is the non-trivial case where the lower layer can accomodate + ! more than what is necessary. + ! --------------------------------------------------------------------------- + + + ! figure out with what weighting we need to promote cohorts. + ! This is the opposite of the demotion weighting... + + sumweights = 0.0_r8 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & + currentCohort%pft,currentCohort%c_area) + if(currentCohort%canopy_layer == i_lyr+1)then !look at the cohorts in the canopy layer below... + + if (ED_val_comp_excln .ge. 0.0_r8 ) then + + ! ------------------------------------------------------------------ + ! Stochastic case, as above (in demotion portion of code) + ! ------------------------------------------------------------------ + + currentCohort%prom_weight = currentCohort%hite**ED_val_comp_excln + sumweights = sumweights + currentCohort%prom_weight + else + + ! ------------------------------------------------------------------ + ! Rank ordered deterministic method + ! If there are cohorts that have the exact same height (which is possible, really) + ! we don't want to unilaterally promote/demote one before the others. + ! So we <>mote them as a unit + ! now we need to go through and figure out how many equal-size cohorts there are. + ! then we need to go through, add up the collective crown areas of all equal-sized + ! and equal-canopy-layer cohorts, + ! and then demote from each as if they were a single group + ! ------------------------------------------------------------------ + + total_crownarea_of_tied_cohorts = currentCohort%c_area + tied_size_with_neighbors = .false. + nextc => currentCohort%shorter + do while (associated(nextc)) + if ( abs(nextc%hite - currentCohort%hite) < similar_height_tol ) then + if( nextc%canopy_layer .eq. currentCohort%canopy_layer ) then + tied_size_with_neighbors = .true. + total_crownarea_of_tied_cohorts = & + total_crownarea_of_tied_cohorts + nextc%c_area + end if + else + exit + endif + nextc => nextc%shorter + end do + + if ( tied_size_with_neighbors ) then + + currentCohort%prom_weight = & + max(0.0_r8,min(currentCohort%c_area, & + (currentCohort%c_area/total_crownarea_of_tied_cohorts) * & + (promote_area - sumweights) )) + sumequal = currentCohort%prom_weight + + nextc => currentCohort%shorter + do while (associated(nextc)) + if ( abs(nextc%hite - currentCohort%hite) < similar_height_tol ) then + if (nextc%canopy_layer .eq. currentCohort%canopy_layer ) then + ! now we know the total crown area of all equal-sized, + ! equal-canopy-layer cohorts + nextc%prom_weight = & + max(0.0_r8,min(nextc%c_area, & + (nextc%c_area/total_crownarea_of_tied_cohorts) * & + (promote_area - sumweights) )) + sumequal = sumequal + nextc%prom_weight + end if + else + exit + endif + nextc => nextc%shorter + end do + + ! Update the current cohort pointer to the last similar cohort + ! Its ok if this is not in the right layer + if(associated(nextc))then + currentCohort => nextc%taller + else + currentCohort => currentPatch%shortest + end if + sumweights = sumweights + sumequal + + else + currentCohort%prom_weight = & + max(min(currentCohort%c_area, promote_area - sumweights ), 0._r8) + sumweights = sumweights + currentCohort%prom_weight + + end if + + endif + endif + currentCohort => currentCohort%shorter + enddo !currentCohort + + + ! If this is probabalistic promotion, we need to do a round of normalization. + ! And then a few rounds where we pre-calculate the promotion areas + ! and adjust things if the promoted area wants to be greater than + ! what is available. + + if (ED_val_comp_excln .ge. 0.0_r8 ) then + + scale_factor_min = 1.e10_r8 + scale_factor = 0._r8 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + + if(currentCohort%canopy_layer == (i_lyr+1) ) then + + currentCohort%prom_weight = currentCohort%prom_weight/sumweights + if( 1._r8/currentCohort%prom_weight < scale_factor_min ) & + scale_factor_min = 1._r8/currentCohort%prom_weight + + scale_factor = scale_factor + currentCohort%prom_weight * currentCohort%c_area + + endif + currentCohort => currentCohort%shorter + enddo + + ! This is the factor by which we need to multiply + ! the demotion probabilities, so the sum result equals + ! the total amount to demote + scale_factor = promote_area/scale_factor + + + if(scale_factor <= scale_factor_min) then + + ! Trivial case, all of the demotion fractions + ! are less than 1. + + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == (i_lyr+1) ) then + currentCohort%prom_weight = currentCohort%c_area * & + currentCohort%prom_weight * scale_factor + + if(debug)then + if((currentCohort%prom_weight > & + (currentCohort%c_area+area_target_precision)) .or. & + (currentCohort%prom_weight < 0._r8) ) then + write(fates_log(),*) 'promotion area too big (1)' + write(fates_log(),*) 'currentCohort%c_area: ',currentCohort%c_area + write(fates_log(),*) 'currentCohort%prom_weight: ', & + currentCohort%prom_weight + write(fates_log(),*) 'excess: ', & + currentCohort%prom_weight - currentCohort%c_area + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + endif + currentCohort => currentCohort%shorter + enddo + + else + + ! Non-trivial case, at least 1 cohort's promotion + ! rate would exceed its area, given the trivial scale factor + + area_res = 0._r8 + scale_factor_res = 0._r8 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == (i_lyr+1) ) then + area_res = area_res + & + currentCohort%c_area*currentCohort%prom_weight*scale_factor_min + scale_factor_res = scale_factor_res + & + currentCohort%c_area * & + (1._r8 - (currentCohort%prom_weight * scale_factor_min)) + endif + currentCohort => currentCohort%shorter + enddo + + area_res = promote_area - area_res + + scale_factor_res = area_res / scale_factor_res - ! ============================================================================ - subroutine canopy_structure( currentSite , bc_in ) - ! - ! !DESCRIPTION: - ! create cohort instance - ! - ! This routine allocates the 'canopy_layer' attribute to each cohort - ! All top leaves in the same canopy layer get the same light resources. - ! The first canopy layer is the 'canopy' or 'overstorey'. The second is the 'understorey'. - ! More than two layers is not permitted at the moment - ! Seeds germinating into the 3rd or higher layers are automatically removed. - ! - ! ------Perfect Plasticity----- - ! The idea of these canopy layers derives originally from Purves et al. 2009 - ! Their concept is that, given enoughplasticity in canopy position, size, shape and depth - ! all of the gound area will be filled perfectly by leaves, and additional leaves will have - ! to exist in the understorey. - ! Purves et al. use the concept of 'Z*' to assume that the height required to attain a place in the - ! canopy is spatially uniform. In this implementation, described in Fisher et al. (2010, New Phyt) we - ! extent that concept to assume that position in the canopy has some random element, and that BOTH height - ! and chance combine to determine whether trees get into the canopy. - ! Thus, when the canopy is closed and there is excess area, some of it must be demoted - ! If we demote -all- the trees less than a given height, there is a massive advantage in being the cohort that is - ! the biggest when the canopy is closed. - ! In this implementation, the amount demoted, ('weight') is a function of the height weighted by the competitive exclusion - ! parameter (ED_val_comp_excln). - - ! Complexity in this routine results from a few things. - ! Firstly, the complication of the demotion amount sometimes being larger than the cohort area (for a very small, short cohort) - ! Second, occasionaly, disturbance (specifically fire) can cause the canopy layer to become less than closed, - ! without changing the area of the patch. If this happens, then some of the plants in the lower layer need to be 'promoted' so - ! all of the routine has to happen in both the downwards and upwards directions. - ! - ! The order of events here is therefore: - ! (The entire subroutine has a single outer 'patch' loop. - ! Section 1: figure out the total area, and whether there are >1 canopy layers at all. - ! - ! Sorts out cohorts into canopy and understorey layers... - ! - ! !USES: - - use EDParamsMod, only : ED_val_comp_excln - use EDTypesMod , only : min_patch_area - use FatesInterfaceTypesMod, only : bc_in_type - ! - ! !ARGUMENTS - type(ed_site_type) , intent(inout), target :: currentSite - type(bc_in_type), intent(in) :: bc_in - - ! - ! !LOCAL VARIABLES: - type(ed_patch_type) , pointer :: currentPatch - type(ed_cohort_type), pointer :: currentCohort - integer :: i_lyr ! current layer index - integer :: z ! Current number of canopy layers. (1= canopy, 2 = understorey) - integer :: ipft - real(r8) :: arealayer(nclmax+2) ! Amount of plant area currently in each canopy layer - integer :: patch_area_counter ! count iterations used to solve canopy areas - logical :: area_not_balanced ! logical controlling if the patch layer areas - ! have successfully been redistributed - integer :: return_code ! math checks on variables will return>0 if problems exist - - ! We only iterate because of possible imprecisions generated by the cohort - ! termination process. These should be super small, so at the most - ! try to re-balance 3 times. If that doesn't give layer areas - ! within tolerance of canopy area, there is something wrong - - integer, parameter :: max_patch_iterations = 10 - - - !---------------------------------------------------------------------- - currentPatch => currentSite%oldest_patch - ! - ! zero site-level demotion / promotion tracking info - currentSite%demotion_rate(:) = 0._r8 - currentSite%promotion_rate(:) = 0._r8 - currentSite%demotion_carbonflux = 0._r8 - currentSite%promotion_carbonflux = 0._r8 - - - ! - ! Section 1: Check total canopy area. - ! - do while (associated(currentPatch)) ! Patch loop - - ! ------------------------------------------------------------------------------ - ! Perform numerical checks on some cohort and patch structures - ! ------------------------------------------------------------------------------ - - ! canopy layer has a special bounds check - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if( currentCohort%canopy_layer < 1 .or. currentCohort%canopy_layer > nclmax+1 ) then - write(fates_log(),*) 'lat:',currentSite%lat - write(fates_log(),*) 'lon:',currentSite%lon - write(fates_log(),*) 'BOGUS CANOPY LAYER: ',currentCohort%canopy_layer - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - currentCohort => currentCohort%shorter - enddo - - - ! Does any layer have excess area in it? Keep going until it does not... - patch_area_counter = 0 - area_not_balanced = .true. - - do while(area_not_balanced) - - ! --------------------------------------------------------------------------- - ! Demotion Phase: Identify upper layers that are too full, and demote them to - ! the layers below. - ! --------------------------------------------------------------------------- - - ! Its possible that before we even enter this scheme - ! some cohort numbers are very low. Terminate them. - call terminate_cohorts(currentSite, currentPatch, 1, 12) - - ! Calculate how many layers we have in this canopy - ! This also checks the understory to see if its crown - ! area is large enough to warrant a temporary sub-understory layer - z = NumPotentialCanopyLayers(currentPatch,currentSite%spread,include_substory=.false.) - - do i_lyr = 1,z ! Loop around the currently occupied canopy layers. - call DemoteFromLayer(currentSite, currentPatch, i_lyr) - end do - - ! After demotions, we may then again have cohorts that are very very - ! very sparse, remove them - call terminate_cohorts(currentSite, currentPatch, 1,13) - - call fuse_cohorts(currentSite, currentPatch, bc_in) - - ! Remove cohorts for various other reasons - call terminate_cohorts(currentSite, currentPatch, 2,13) - - - ! --------------------------------------------------------------------------------------- - ! Promotion Phase: Identify if any upper-layers are underful and layers below them - ! have cohorts that can be split and promoted to the layer above. - ! --------------------------------------------------------------------------------------- - - ! Re-calculate Number of layers without the false substory - z = NumPotentialCanopyLayers(currentPatch,currentSite%spread,include_substory=.false.) - - ! We only promote if we have at least two layers - if (z>1) then - - do i_lyr=1,z-1 - call PromoteIntoLayer(currentSite, currentPatch, i_lyr) - end do - - ! Remove cohorts that are incredibly sparse - call terminate_cohorts(currentSite, currentPatch, 1,14) - - call fuse_cohorts(currentSite, currentPatch, bc_in) - - ! Remove cohorts for various other reasons - call terminate_cohorts(currentSite, currentPatch, 2,14) - - end if - - ! --------------------------------------------------------------------------------------- - ! Check on Layer Area (if the layer differences are not small - ! Continue trying to demote/promote. Its possible on the first pass through, - ! that cohort fusion has nudged the areas a little bit. - ! --------------------------------------------------------------------------------------- - - z = NumPotentialCanopyLayers(currentPatch,currentSite%spread,include_substory=.false.) - area_not_balanced = .false. - do i_lyr = 1,z - call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr,arealayer(i_lyr)) - if( ((arealayer(i_lyr)-currentPatch%area)/currentPatch%area > area_check_rel_precision) .or. & - ((arealayer(i_lyr)-currentPatch%area) > area_check_precision ) ) then - area_not_balanced = .true. - endif - enddo - - ! --------------------------------------------------------------------------------------- - ! Gracefully exit if too many iterations have gone by - ! --------------------------------------------------------------------------------------- - - patch_area_counter = patch_area_counter + 1 - if(patch_area_counter > max_patch_iterations .and. area_not_balanced) then - write(fates_log(),*) 'PATCH AREA CHECK NOT CLOSING' - write(fates_log(),*) 'patch area:',currentpatch%area - do i_lyr = 1,z - write(fates_log(),*) 'layer: ',i_lyr,' area: ',arealayer(i_lyr) - write(fates_log(),*) 'rel error: ',(arealayer(i_lyr)-currentPatch%area)/currentPatch%area - write(fates_log(),*) 'abs error: ',arealayer(i_lyr)-currentPatch%area - enddo - write(fates_log(),*) 'lat:',currentSite%lat - write(fates_log(),*) 'lon:',currentSite%lon - write(fates_log(),*) 'spread:',currentSite%spread - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - write(fates_log(),*) 'coh ilayer:',currentCohort%canopy_layer - write(fates_log(),*) 'coh dbh:',currentCohort%dbh - write(fates_log(),*) 'coh pft:',currentCohort%pft - write(fates_log(),*) 'coh n:',currentCohort%n - write(fates_log(),*) 'coh carea:',currentCohort%c_area - ipft=currentCohort%pft - write(fates_log(),*) 'maxh:',prt_params%allom_dbh_maxheight(ipft) - write(fates_log(),*) 'lmode: ',prt_params%allom_lmode(ipft) - write(fates_log(),*) 'd2bl2: ',prt_params%allom_d2bl2(ipft) - write(fates_log(),*) 'd2bl_ediff: ',prt_params%allom_blca_expnt_diff(ipft) - write(fates_log(),*) 'd2ca_min: ',prt_params%allom_d2ca_coefficient_min(ipft) - write(fates_log(),*) 'd2ca_max: ',prt_params%allom_d2ca_coefficient_max(ipft) - currentCohort => currentCohort%shorter - enddo - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - enddo ! do while(area_not_balanced) - - - ! Set current canopy layer occupancy indicator. - currentPatch%NCL_p = min(nclmax,z) - - ! ------------------------------------------------------------------------------------------- - ! if we are using "strict PPA", then calculate a z_star value as - ! the height of the smallest tree in the canopy - ! loop from top to bottom and locate the shortest cohort in level 1 whose shorter - ! neighbor is in level 2 set zstar as the ehight of that shortest level 1 cohort - ! ------------------------------------------------------------------------------------------- - - if ( ED_val_comp_excln .lt. 0.0_r8) then - currentPatch%zstar = 0._r8 - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if(currentCohort%canopy_layer .eq. 2)then - if (associated(currentCohort%taller)) then - if (currentCohort%taller%canopy_layer .eq. 1 ) then - currentPatch%zstar = currentCohort%taller%hite - endif - endif - endif - currentCohort => currentCohort%shorter - enddo - endif - - currentPatch => currentPatch%younger - enddo !patch - - return - end subroutine canopy_structure - - - ! ============================================================================================== - - - subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr) - - use EDParamsMod, only : ED_val_comp_excln - use SFParamsMod, only : SF_val_CWD_frac - - ! !ARGUMENTS - type(ed_site_type), intent(inout), target :: currentSite - type(ed_patch_type), intent(inout), target :: currentPatch - integer, intent(in) :: i_lyr ! Current canopy layer of interest - - ! !LOCAL VARIABLES: - type(ed_cohort_type), pointer :: currentCohort - type(ed_cohort_type), pointer :: copyc - type(ed_cohort_type), pointer :: nextc ! The next cohort in line - integer :: i_cwd ! Index for CWD pool - real(r8) :: cc_loss ! cohort crown area loss in demotion (m2) - real(r8) :: leaf_c ! leaf carbon [kg] - real(r8) :: fnrt_c ! fineroot carbon [kg] - real(r8) :: sapw_c ! sapwood carbon [kg] - real(r8) :: store_c ! storage carbon [kg] - real(r8) :: struct_c ! structure carbon [kg] - real(r8) :: scale_factor ! for prob. exclusion - scales weight to a fraction - real(r8) :: scale_factor_min ! "" minimum before exeedance of 1 - real(r8) :: scale_factor_res ! "" applied to residual areas - real(r8) :: area_res ! residual area to demote after weakest cohort hits max - real(r8) :: newarea - real(r8) :: demote_area - real(r8) :: sumweights - real(r8) :: sumequal ! for rank-ordered same-size cohorts - ! this tallies their excluded area - real(r8) :: arealayer ! the area of the current canopy layer - logical :: tied_size_with_neighbors - real(r8) :: total_crownarea_of_tied_cohorts - - ! First, determine how much total canopy area we have in this layer - call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr,arealayer) - - demote_area = arealayer - currentPatch%area - - if ( demote_area > area_target_precision ) then - - ! Is this layer currently over-occupied? - ! In that case, we need to work out which cohorts to demote. - ! We go in order from shortest to tallest for ranked demotion - - sumweights = 0.0_r8 - currentCohort => currentPatch%shortest - do while (associated(currentCohort)) - call carea_allom(currentCohort%dbh,currentCohort%n, & - currentSite%spread,currentCohort%pft,currentCohort%c_area) - - if(debug) then - if(currentCohort%c_area<0._r8)then - write(fates_log(),*) 'negative c_area stage 1d: ',currentCohort%dbh,i_lyr,currentCohort%n, & - currentSite%spread,currentCohort%pft,currentCohort%c_area - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - if( currentCohort%canopy_layer == i_lyr)then - - if (ED_val_comp_excln .ge. 0.0_r8 ) then - - ! ---------------------------------------------------------- - ! Stochastic method. - ! Weight cohort demotion by inverse size to a constant power. - ! In this hypothesis, it is assumed that even the tallest - ! cohorts have a chance (although smaller) of being forced - ! to the understory. - ! ---------------------------------------------------------- - - currentCohort%excl_weight = 1._r8 / (currentCohort%hite**ED_val_comp_excln) - sumweights = sumweights + currentCohort%excl_weight - - else - - ! ----------------------------------------------------------- - ! Rank ordered deterministic method - ! ----------------------------------------------------------- - ! If there are cohorts that have the exact same height (which is possible, really) - ! we don't want to unilaterally promote/demote one before the others. - ! So we <>mote them as a unit - ! now we need to go through and figure out how many equal-size cohorts there are. - ! then we need to go through, add up the collective crown areas of all equal-sized - ! and equal-canopy-layer cohorts, - ! and then demote from each as if they were a single group - - total_crownarea_of_tied_cohorts = currentCohort%c_area - - tied_size_with_neighbors = .false. - nextc => currentCohort%taller - do while (associated(nextc)) - if ( abs(nextc%hite - currentCohort%hite) < similar_height_tol ) then - if( nextc%canopy_layer .eq. currentCohort%canopy_layer ) then - tied_size_with_neighbors = .true. - total_crownarea_of_tied_cohorts = & - total_crownarea_of_tied_cohorts + nextc%c_area - end if - else - exit - endif - nextc => nextc%taller - end do - - if ( tied_size_with_neighbors ) then - - currentCohort%excl_weight = & - max(0.0_r8,min(currentCohort%c_area, & - (currentCohort%c_area/total_crownarea_of_tied_cohorts) * & - (demote_area - sumweights) )) - - sumequal = currentCohort%excl_weight - - nextc => currentCohort%taller - do while (associated(nextc)) - if ( abs(nextc%hite - currentCohort%hite) < similar_height_tol ) then - if (nextc%canopy_layer .eq. currentCohort%canopy_layer ) then - ! now we know the total crown area of all equal-sized, - ! equal-canopy-layer cohorts - nextc%excl_weight = & - max(0.0_r8,min(nextc%c_area, & - (nextc%c_area/total_crownarea_of_tied_cohorts) * & - (demote_area - sumweights) )) - sumequal = sumequal + nextc%excl_weight - end if - else - exit - endif - nextc => nextc%taller - end do - - ! Update the current cohort pointer to the last similar cohort - ! Its ok if this is not in the right layer - if(associated(nextc))then - currentCohort => nextc%shorter - else - currentCohort => currentPatch%tallest - end if - sumweights = sumweights + sumequal - - else - currentCohort%excl_weight = & - max(min(currentCohort%c_area, demote_area - sumweights ), 0._r8) - sumweights = sumweights + currentCohort%excl_weight - end if - - endif - endif - currentCohort => currentCohort%taller - enddo - - ! If this is probabalistic demotion, we need to do a round of normalization. - ! And then a few rounds where we pre-calculate the demotion areas - ! and adjust things if the demoted area wants to be greater than - ! what is available. The math is too hard to explain here, see - ! the tech note section on promotion/demotion. - - if (ED_val_comp_excln .ge. 0.0_r8 ) then - - scale_factor_min = 1.e10_r8 - scale_factor = 0._r8 - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - - if(currentCohort%canopy_layer == i_lyr) then - - currentCohort%excl_weight = currentCohort%excl_weight/sumweights - if( 1._r8/currentCohort%excl_weight < scale_factor_min ) & - scale_factor_min = 1._r8/currentCohort%excl_weight - - scale_factor = scale_factor + currentCohort%excl_weight * currentCohort%c_area - - endif - currentCohort => currentCohort%shorter - enddo - - ! This is the factor by which we need to multiply - ! the demotion probabilities, so the sum result equals - ! the total amount to demote - - scale_factor = demote_area/scale_factor - - if(scale_factor <= scale_factor_min) then - - ! Trivial case, all of the demotion fractions are less than 1. - - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if(currentCohort%canopy_layer == i_lyr) then - currentCohort%excl_weight = currentCohort%c_area * currentCohort%excl_weight * scale_factor - - if(debug) then - if((currentCohort%excl_weight > (currentCohort%c_area+area_target_precision)) .or. & - (currentCohort%excl_weight < 0._r8) ) then - write(fates_log(),*) 'exclusion area too big (1)' - write(fates_log(),*) 'currentCohort%c_area: ',currentCohort%c_area - write(fates_log(),*) 'dbh: ',currentCohort%dbh - write(fates_log(),*) 'n: ',currentCohort%n - write(fates_log(),*) 'spread: ',currentSite%spread - write(fates_log(),*) 'pft: ',currentCohort%pft - write(fates_log(),*) 'currentCohort%excl_weight: ',currentCohort%excl_weight - write(fates_log(),*) 'excess: ',currentCohort%excl_weight - currentCohort%c_area - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - endif - currentCohort => currentCohort%shorter - enddo - - else - - - ! Non-trivial case, at least 1 cohort's demotion - ! rate would exceed its area, given the trivial scale factor - - area_res = 0._r8 - scale_factor_res = 0._r8 - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if(currentCohort%canopy_layer == i_lyr) then - area_res = area_res + & - currentCohort%c_area * currentCohort%excl_weight * & - scale_factor_min - scale_factor_res = scale_factor_res + & - currentCohort%c_area * & - (1._r8 - (currentCohort%excl_weight * scale_factor_min)) - endif - currentCohort => currentCohort%shorter - enddo - - area_res = demote_area - area_res - - scale_factor_res = area_res / scale_factor_res - - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if(currentCohort%canopy_layer == i_lyr) then - - currentCohort%excl_weight = currentCohort%c_area * & - (currentCohort%excl_weight * scale_factor_min + & - (1._r8 - (currentCohort%excl_weight*scale_factor_min) ) * scale_factor_res) - - if(debug)then - if((currentCohort%excl_weight > & - (currentCohort%c_area+area_target_precision)) .or. & - (currentCohort%excl_weight < 0._r8) ) then - write(fates_log(),*) 'exclusion area error (2)' + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == (i_lyr+1)) then + + currentCohort%prom_weight = currentCohort%c_area * & + (currentCohort%prom_weight * scale_factor_min + & + (1._r8 - (currentCohort%prom_weight*scale_factor_min) ) * & + scale_factor_res) + + if(debug)then + if((currentCohort%prom_weight > & + (currentCohort%c_area+area_target_precision)) .or. & + (currentCohort%prom_weight < 0._r8) ) then + write(fates_log(),*) 'promotion area error (2)' write(fates_log(),*) 'currentCohort%c_area: ',currentCohort%c_area - write(fates_log(),*) 'currentCohort%excl_weight: ', & - currentCohort%excl_weight + write(fates_log(),*) 'currentCohort%prom_weight: ', & + currentCohort%prom_weight write(fates_log(),*) 'excess: ', & - currentCohort%excl_weight - currentCohort%c_area + currentCohort%prom_weight - currentCohort%c_area call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - endif - currentCohort => currentCohort%shorter - enddo - - end if - - end if - - - ! perform a check and see if the demotions meet the demand - sumweights = 0._r8 - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if(currentCohort%canopy_layer == i_lyr) then - sumweights = sumweights + currentCohort%excl_weight - end if - currentCohort => currentCohort%shorter - end do - - if (abs(sumweights - demote_area) > area_check_precision ) then - write(fates_log(),*) 'demotions dont add up' - write(fates_log(),*) 'sum demotions: ',sumweights - write(fates_log(),*) 'area needed to be demoted: ',demote_area - write(fates_log(),*) 'excess: ',sumweights - demote_area - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - - ! Weights have been calculated. Now move them to the lower layer - - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - - if(currentCohort%canopy_layer == i_lyr )then - - cc_loss = currentCohort%excl_weight - leaf_c = currentCohort%prt%GetState(leaf_organ,all_carbon_elements) - store_c = currentCohort%prt%GetState(store_organ,all_carbon_elements) - fnrt_c = currentCohort%prt%GetState(fnrt_organ,all_carbon_elements) - sapw_c = currentCohort%prt%GetState(sapw_organ,all_carbon_elements) - struct_c = currentCohort%prt%GetState(struct_organ,all_carbon_elements) - - if ( (cc_loss-currentCohort%c_area) > -nearzero .and. & - (cc_loss-currentCohort%c_area) < area_target_precision ) then - - ! If the whole cohort is being demoted, just change its - ! layer index - - currentCohort%canopy_layer = i_lyr+1 - - ! keep track of number and biomass of demoted cohort - currentSite%demotion_rate(currentCohort%size_class) = & - currentSite%demotion_rate(currentCohort%size_class) + currentCohort%n - currentSite%demotion_carbonflux = currentSite%demotion_carbonflux + & - (leaf_c + store_c + fnrt_c + sapw_c + struct_c) * currentCohort%n - - elseif( (cc_loss < currentCohort%c_area) .and. & - (cc_loss > area_target_precision) ) then - - ! If only part of the cohort is demoted - ! then it must be split (little more complicated) - - ! Make a copy of the current cohort. The copy and the original - ! conserve total number density of the original. The copy - ! remains in the upper-story. The original is the one - ! demoted to the understory - - - allocate(copyc) - - ! Initialize the PARTEH object and point to the - ! correct boundary condition fields - copyc%prt => null() - call InitPRTObject(copyc%prt) - call InitPRTBoundaryConditions(copyc) - - if( hlm_use_planthydro.eq.itrue ) then - call InitHydrCohort(currentSite,copyc) - endif - - call copy_cohort(currentCohort, copyc) - - newarea = currentCohort%c_area - cc_loss - copyc%n = currentCohort%n*newarea/currentCohort%c_area - currentCohort%n = currentCohort%n - copyc%n - - copyc%canopy_layer = i_lyr !the taller cohort is the copy - - ! Demote the current cohort to the understory. - currentCohort%canopy_layer = i_lyr + 1 - - ! keep track of number and biomass of demoted cohort - currentSite%demotion_rate(currentCohort%size_class) = & - currentSite%demotion_rate(currentCohort%size_class) + currentCohort%n - currentSite%demotion_carbonflux = currentSite%demotion_carbonflux + & - (leaf_c + store_c + fnrt_c + sapw_c + struct_c) * currentCohort%n - - call carea_allom(copyc%dbh,copyc%n,currentSite%spread,copyc%pft,copyc%c_area) - call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & - currentCohort%pft,currentCohort%c_area) - - !----------- Insert copy into linked list ------------------------! - copyc%shorter => currentCohort - if(associated(currentCohort%taller))then - copyc%taller => currentCohort%taller - currentCohort%taller%shorter => copyc - else - currentPatch%tallest => copyc - copyc%taller => null() - endif - currentCohort%taller => copyc - - elseif(cc_loss > currentCohort%c_area)then - - write(fates_log(),*) 'more area than the cohort has is being demoted' - write(fates_log(),*) 'loss:',cc_loss - write(fates_log(),*) 'existing area:',currentCohort%c_area - write(fates_log(),*) 'excess: ',cc_loss - currentCohort%c_area - call endrun(msg=errMsg(sourcefile, __LINE__)) - - end if - - ! kill the ones which go into canopy layers that are not allowed - - if(currentCohort%canopy_layer>nclmax )then - - ! put the litter from the terminated cohorts - ! straight into the fragmenting pools - call SendCohortToLitter(currentSite,currentPatch, & - currentCohort,currentCohort%n) - - currentCohort%n = 0.0_r8 - currentCohort%c_area = 0.0_r8 - currentCohort%canopy_layer = i_lyr - - end if - - call carea_allom(currentCohort%dbh,currentCohort%n, & - currentSite%spread,currentCohort%pft,currentCohort%c_area) - - endif !canopy layer = i_ly - - currentCohort => currentCohort%shorter - enddo !currentCohort - - - ! Update the area calculations of the current layer - ! And the layer below that may or may not had recieved - ! Demotions - - call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr,arealayer) - - if ( (abs(arealayer - currentPatch%area)/arealayer > area_check_rel_precision ) .or. & - (abs(arealayer - currentPatch%area) > area_check_precision) ) then - write(fates_log(),*) 'demotion did not trim area within tolerance' - write(fates_log(),*) 'arealayer:',arealayer - write(fates_log(),*) 'patch%area:',currentPatch%area - write(fates_log(),*) 'ilayer: ',i_lyr - write(fates_log(),*) 'bias:',arealayer - currentPatch%area - write(fates_log(),*) 'rel bias:',(arealayer - currentPatch%area)/arealayer - write(fates_log(),*) 'demote_area:',demote_area - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - - end if - - return - end subroutine DemoteFromLayer - - ! ============================================================================================== - - subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) - - ! ------------------------------------------------------------------------------------------- - ! Check whether the intended 'full' layers are actually filling all the space. - ! If not, promote some fraction of cohorts upwards. - ! THIS SECTION MIGHT BE TRIGGERED BY A FIRE OR MORTALITY EVENT, FOLLOWED BY A PATCH FUSION, - ! SO THE TOP LAYER IS NO LONGER FULL. - ! ------------------------------------------------------------------------------------------- - - use EDParamsMod, only : ED_val_comp_excln - - ! !ARGUMENTS - type(ed_site_type), intent(inout), target :: currentSite - type(ed_patch_type), intent(inout), target :: currentPatch - integer, intent(in) :: i_lyr ! Current canopy layer of interest - - ! !LOCAL VARIABLES: - type(ed_cohort_type), pointer :: currentCohort - type(ed_cohort_type), pointer :: copyc - type(ed_cohort_type), pointer :: nextc ! the next cohort, or used for looping - ! cohorts against the current - - real(r8) :: scale_factor ! for prob. exclusion - scales weight to a fraction - real(r8) :: scale_factor_min ! "" minimum before exeedance of 1 - real(r8) :: scale_factor_res ! "" applied to residual areas - real(r8) :: area_res ! residual area to demote after weakest cohort hits max - real(r8) :: promote_area - real(r8) :: newarea - real(r8) :: sumweights - real(r8) :: sumequal ! for tied cohorts, the sum of weights in - ! their group - real(r8) :: cc_gain ! cohort crown area gain in promotion (m2) - real(r8) :: arealayer_current ! area (m2) of the current canopy layer - real(r8) :: arealayer_below ! area (m2) of the layer below the current layer - real(r8) :: leaf_c ! leaf carbon [kg] - real(r8) :: fnrt_c ! fineroot carbon [kg] - real(r8) :: sapw_c ! sapwood carbon [kg] - real(r8) :: store_c ! storage carbon [kg] - real(r8) :: struct_c ! structure carbon [kg] - - logical :: tied_size_with_neighbors - real(r8) :: total_crownarea_of_tied_cohorts - - call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr,arealayer_current) - call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr+1,arealayer_below) - - - ! how much do we need to gain? - promote_area = currentPatch%area - arealayer_current - - if( promote_area > area_target_precision ) then - - if(arealayer_below <= promote_area ) then - - ! --------------------------------------------------------------------------- - ! Promote all cohorts from layer below if that whole layer has area smaller - ! than the tolerance on the gains needed into current layer - ! --------------------------------------------------------------------------- - - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - !look at the cohorts in the canopy layer below... - if(currentCohort%canopy_layer == i_lyr+1)then - - leaf_c = currentCohort%prt%GetState(leaf_organ,all_carbon_elements) - store_c = currentCohort%prt%GetState(store_organ,all_carbon_elements) - fnrt_c = currentCohort%prt%GetState(fnrt_organ,all_carbon_elements) - sapw_c = currentCohort%prt%GetState(sapw_organ,all_carbon_elements) - struct_c = currentCohort%prt%GetState(struct_organ,all_carbon_elements) - - currentCohort%canopy_layer = i_lyr - call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & + end if + end if + + endif + currentCohort => currentCohort%shorter + enddo + + end if + + end if + + + ! lets perform a check and see if the promotions meet the demand + sumweights = 0._r8 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == (i_lyr+1)) then + sumweights = sumweights + currentCohort%prom_weight + end if + currentCohort => currentCohort%shorter + end do + + if(debug)then + if (abs(sumweights - promote_area) > area_check_precision ) then + write(fates_log(),*) 'promotions dont add up' + write(fates_log(),*) 'sum promotions: ',sumweights + write(fates_log(),*) 'area needed to be promoted: ',promote_area + write(fates_log(),*) 'excess: ',sumweights - promote_area + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + + + !All the trees in this layer need to promote some area upwards... + if( (currentCohort%canopy_layer == i_lyr+1) ) then + + cc_gain = currentCohort%prom_weight + leaf_c = currentCohort%prt%GetState(leaf_organ,all_carbon_elements) + store_c = currentCohort%prt%GetState(store_organ,all_carbon_elements) + fnrt_c = currentCohort%prt%GetState(fnrt_organ,all_carbon_elements) + sapw_c = currentCohort%prt%GetState(sapw_organ,all_carbon_elements) + struct_c = currentCohort%prt%GetState(struct_organ,all_carbon_elements) + + if ( (cc_gain-currentCohort%c_area) > -nearzero .and. & + (cc_gain-currentCohort%c_area) < area_target_precision ) then + + currentCohort%canopy_layer = i_lyr + + ! keep track of number and biomass of promoted cohort + currentSite%promotion_rate(currentCohort%size_class) = & + currentSite%promotion_rate(currentCohort%size_class) + currentCohort%n + + currentSite%promotion_carbonflux = currentSite%promotion_carbonflux + & + (leaf_c + fnrt_c + store_c + sapw_c + struct_c) * currentCohort%n + + elseif ( (cc_gain < currentCohort%c_area) .and. & + (cc_gain > area_target_precision) ) then + + allocate(copyc) + + ! Initialize the PARTEH object and point to the + ! correct boundary condition fields + copyc%prt => null() + call InitPRTObject(copyc%prt) + call InitPRTBoundaryConditions(copyc) + + if( hlm_use_planthydro.eq.itrue ) then + call InitHydrCohort(CurrentSite,copyc) + endif + call copy_cohort(currentCohort, copyc) !makes an identical copy... + + newarea = currentCohort%c_area - cc_gain !new area of existing cohort + + call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & + currentCohort%pft,currentCohort%c_area) + + ! number of individuals in promoted cohort. + copyc%n = currentCohort%n*cc_gain/currentCohort%c_area + + ! number of individuals in cohort remaining in understorey + currentCohort%n = currentCohort%n - copyc%n + + currentCohort%canopy_layer = i_lyr + 1 ! keep current cohort in the understory. + copyc%canopy_layer = i_lyr ! promote copy to the higher canopy layer. + + ! keep track of number and biomass of promoted cohort + currentSite%promotion_rate(copyc%size_class) = & + currentSite%promotion_rate(copyc%size_class) + copyc%n + + currentSite%promotion_carbonflux = currentSite%promotion_carbonflux + & + (leaf_c + fnrt_c + store_c + sapw_c + struct_c) * copyc%n + + call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & currentCohort%pft,currentCohort%c_area) - ! keep track of number and biomass of promoted cohort - currentSite%promotion_rate(currentCohort%size_class) = & - currentSite%promotion_rate(currentCohort%size_class) + currentCohort%n - currentSite%promotion_carbonflux = currentSite%promotion_carbonflux + & - (leaf_c + fnrt_c + store_c + sapw_c + struct_c) * currentCohort%n - - endif - currentCohort => currentCohort%shorter - enddo - - else - - ! --------------------------------------------------------------------------- - ! This is the non-trivial case where the lower layer can accomodate - ! more than what is necessary. - ! --------------------------------------------------------------------------- - - - ! figure out with what weighting we need to promote cohorts. - ! This is the opposite of the demotion weighting... - - sumweights = 0.0_r8 - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & - currentCohort%pft,currentCohort%c_area) - if(currentCohort%canopy_layer == i_lyr+1)then !look at the cohorts in the canopy layer below... - - if (ED_val_comp_excln .ge. 0.0_r8 ) then - - ! ------------------------------------------------------------------ - ! Stochastic case, as above (in demotion portion of code) - ! ------------------------------------------------------------------ - - currentCohort%prom_weight = currentCohort%hite**ED_val_comp_excln - sumweights = sumweights + currentCohort%prom_weight - else - - ! ------------------------------------------------------------------ - ! Rank ordered deterministic method - ! If there are cohorts that have the exact same height (which is possible, really) - ! we don't want to unilaterally promote/demote one before the others. - ! So we <>mote them as a unit - ! now we need to go through and figure out how many equal-size cohorts there are. - ! then we need to go through, add up the collective crown areas of all equal-sized - ! and equal-canopy-layer cohorts, - ! and then demote from each as if they were a single group - ! ------------------------------------------------------------------ - - total_crownarea_of_tied_cohorts = currentCohort%c_area - tied_size_with_neighbors = .false. - nextc => currentCohort%shorter - do while (associated(nextc)) - if ( abs(nextc%hite - currentCohort%hite) < similar_height_tol ) then - if( nextc%canopy_layer .eq. currentCohort%canopy_layer ) then - tied_size_with_neighbors = .true. - total_crownarea_of_tied_cohorts = & - total_crownarea_of_tied_cohorts + nextc%c_area - end if - else - exit - endif - nextc => nextc%shorter - end do - - if ( tied_size_with_neighbors ) then - - currentCohort%prom_weight = & - max(0.0_r8,min(currentCohort%c_area, & - (currentCohort%c_area/total_crownarea_of_tied_cohorts) * & - (promote_area - sumweights) )) - sumequal = currentCohort%prom_weight - - nextc => currentCohort%shorter - do while (associated(nextc)) - if ( abs(nextc%hite - currentCohort%hite) < similar_height_tol ) then - if (nextc%canopy_layer .eq. currentCohort%canopy_layer ) then - ! now we know the total crown area of all equal-sized, - ! equal-canopy-layer cohorts - nextc%prom_weight = & - max(0.0_r8,min(nextc%c_area, & - (nextc%c_area/total_crownarea_of_tied_cohorts) * & - (promote_area - sumweights) )) - sumequal = sumequal + nextc%prom_weight - end if - else - exit - endif - nextc => nextc%shorter - end do - - ! Update the current cohort pointer to the last similar cohort - ! Its ok if this is not in the right layer - if(associated(nextc))then - currentCohort => nextc%taller - else - currentCohort => currentPatch%shortest - end if - sumweights = sumweights + sumequal - - else - currentCohort%prom_weight = & - max(min(currentCohort%c_area, promote_area - sumweights ), 0._r8) - sumweights = sumweights + currentCohort%prom_weight - - end if - - endif - endif - currentCohort => currentCohort%shorter - enddo !currentCohort - - - ! If this is probabalistic promotion, we need to do a round of normalization. - ! And then a few rounds where we pre-calculate the promotion areas - ! and adjust things if the promoted area wants to be greater than - ! what is available. - - if (ED_val_comp_excln .ge. 0.0_r8 ) then - - scale_factor_min = 1.e10_r8 - scale_factor = 0._r8 - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - - if(currentCohort%canopy_layer == (i_lyr+1) ) then - - currentCohort%prom_weight = currentCohort%prom_weight/sumweights - if( 1._r8/currentCohort%prom_weight < scale_factor_min ) & - scale_factor_min = 1._r8/currentCohort%prom_weight - - scale_factor = scale_factor + currentCohort%prom_weight * currentCohort%c_area - - endif - currentCohort => currentCohort%shorter - enddo - - ! This is the factor by which we need to multiply - ! the demotion probabilities, so the sum result equals - ! the total amount to demote - scale_factor = promote_area/scale_factor - - - if(scale_factor <= scale_factor_min) then - - ! Trivial case, all of the demotion fractions - ! are less than 1. - - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if(currentCohort%canopy_layer == (i_lyr+1) ) then - currentCohort%prom_weight = currentCohort%c_area * & - currentCohort%prom_weight * scale_factor - - if(debug)then - if((currentCohort%prom_weight > & - (currentCohort%c_area+area_target_precision)) .or. & - (currentCohort%prom_weight < 0._r8) ) then - write(fates_log(),*) 'promotion area too big (1)' - write(fates_log(),*) 'currentCohort%c_area: ',currentCohort%c_area - write(fates_log(),*) 'currentCohort%prom_weight: ', & - currentCohort%prom_weight - write(fates_log(),*) 'excess: ', & - currentCohort%prom_weight - currentCohort%c_area - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - endif - currentCohort => currentCohort%shorter - enddo - - else - - ! Non-trivial case, at least 1 cohort's promotion - ! rate would exceed its area, given the trivial scale factor - - area_res = 0._r8 - scale_factor_res = 0._r8 - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if(currentCohort%canopy_layer == (i_lyr+1) ) then - area_res = area_res + & - currentCohort%c_area*currentCohort%prom_weight*scale_factor_min - scale_factor_res = scale_factor_res + & - currentCohort%c_area * & - (1._r8 - (currentCohort%prom_weight * scale_factor_min)) - endif - currentCohort => currentCohort%shorter - enddo - - area_res = promote_area - area_res - - scale_factor_res = area_res / scale_factor_res - - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if(currentCohort%canopy_layer == (i_lyr+1)) then - - currentCohort%prom_weight = currentCohort%c_area * & - (currentCohort%prom_weight * scale_factor_min + & - (1._r8 - (currentCohort%prom_weight*scale_factor_min) ) * & - scale_factor_res) - - if(debug)then - if((currentCohort%prom_weight > & - (currentCohort%c_area+area_target_precision)) .or. & - (currentCohort%prom_weight < 0._r8) ) then - write(fates_log(),*) 'promotion area error (2)' - write(fates_log(),*) 'currentCohort%c_area: ',currentCohort%c_area - write(fates_log(),*) 'currentCohort%prom_weight: ', & - currentCohort%prom_weight - write(fates_log(),*) 'excess: ', & - currentCohort%prom_weight - currentCohort%c_area - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - endif - currentCohort => currentCohort%shorter - enddo - - end if - - end if - - - ! lets perform a check and see if the promotions meet the demand - sumweights = 0._r8 - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if(currentCohort%canopy_layer == (i_lyr+1)) then - sumweights = sumweights + currentCohort%prom_weight - end if - currentCohort => currentCohort%shorter - end do - - if(debug)then - if (abs(sumweights - promote_area) > area_check_precision ) then - write(fates_log(),*) 'promotions dont add up' - write(fates_log(),*) 'sum promotions: ',sumweights - write(fates_log(),*) 'area needed to be promoted: ',promote_area - write(fates_log(),*) 'excess: ',sumweights - promote_area - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - - - !All the trees in this layer need to promote some area upwards... - if( (currentCohort%canopy_layer == i_lyr+1) ) then - - cc_gain = currentCohort%prom_weight - leaf_c = currentCohort%prt%GetState(leaf_organ,all_carbon_elements) - store_c = currentCohort%prt%GetState(store_organ,all_carbon_elements) - fnrt_c = currentCohort%prt%GetState(fnrt_organ,all_carbon_elements) - sapw_c = currentCohort%prt%GetState(sapw_organ,all_carbon_elements) - struct_c = currentCohort%prt%GetState(struct_organ,all_carbon_elements) - - if ( (cc_gain-currentCohort%c_area) > -nearzero .and. & - (cc_gain-currentCohort%c_area) < area_target_precision ) then - - currentCohort%canopy_layer = i_lyr - - ! keep track of number and biomass of promoted cohort - currentSite%promotion_rate(currentCohort%size_class) = & - currentSite%promotion_rate(currentCohort%size_class) + currentCohort%n - - currentSite%promotion_carbonflux = currentSite%promotion_carbonflux + & - (leaf_c + fnrt_c + store_c + sapw_c + struct_c) * currentCohort%n - - elseif ( (cc_gain < currentCohort%c_area) .and. & - (cc_gain > area_target_precision) ) then - - allocate(copyc) - - ! Initialize the PARTEH object and point to the - ! correct boundary condition fields - copyc%prt => null() - call InitPRTObject(copyc%prt) - call InitPRTBoundaryConditions(copyc) - - if( hlm_use_planthydro.eq.itrue ) then - call InitHydrCohort(CurrentSite,copyc) - endif - call copy_cohort(currentCohort, copyc) !makes an identical copy... - - newarea = currentCohort%c_area - cc_gain !new area of existing cohort - - call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & - currentCohort%pft,currentCohort%c_area) - - ! number of individuals in promoted cohort. - copyc%n = currentCohort%n*cc_gain/currentCohort%c_area - - ! number of individuals in cohort remaining in understorey - currentCohort%n = currentCohort%n - copyc%n - - currentCohort%canopy_layer = i_lyr + 1 ! keep current cohort in the understory. - copyc%canopy_layer = i_lyr ! promote copy to the higher canopy layer. - - ! keep track of number and biomass of promoted cohort - currentSite%promotion_rate(copyc%size_class) = & - currentSite%promotion_rate(copyc%size_class) + copyc%n - - currentSite%promotion_carbonflux = currentSite%promotion_carbonflux + & - (leaf_c + fnrt_c + store_c + sapw_c + struct_c) * copyc%n - - call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & - currentCohort%pft,currentCohort%c_area) - call carea_allom(copyc%dbh,copyc%n,currentSite%spread,copyc%pft,copyc%c_area) - - !----------- Insert copy into linked list ------------------------! - copyc%shorter => currentCohort - if(associated(currentCohort%taller))then - copyc%taller => currentCohort%taller - currentCohort%taller%shorter => copyc - else - currentPatch%tallest => copyc - copyc%taller => null() - endif - currentCohort%taller => copyc - - elseif(cc_gain > currentCohort%c_area)then - - write(fates_log(),*) 'more area than the cohort has is being promoted' - write(fates_log(),*) 'loss:',cc_gain - write(fates_log(),*) 'existing area:',currentCohort%c_area - call endrun(msg=errMsg(sourcefile, __LINE__)) - - endif - - endif ! if(currentCohort%canopy_layer == i_lyr+1) then - currentCohort => currentCohort%shorter - enddo !currentCohort - - call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr,arealayer_current) - - if ((abs(arealayer_current - currentPatch%area)/arealayer_current > & - area_check_rel_precision ) .or. & - (abs(arealayer_current - currentPatch%area) > area_check_precision) ) then - write(fates_log(),*) 'promotion did not bring area within tolerance' - write(fates_log(),*) 'arealayer:',arealayer_current - write(fates_log(),*) 'patch%area:',currentPatch%area - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - end if - - end if - - return - end subroutine PromoteIntoLayer + call carea_allom(copyc%dbh,copyc%n,currentSite%spread,copyc%pft,copyc%c_area) + + !----------- Insert copy into linked list ------------------------! + copyc%shorter => currentCohort + if(associated(currentCohort%taller))then + copyc%taller => currentCohort%taller + currentCohort%taller%shorter => copyc + else + currentPatch%tallest => copyc + copyc%taller => null() + endif + currentCohort%taller => copyc + + elseif(cc_gain > currentCohort%c_area)then + + write(fates_log(),*) 'more area than the cohort has is being promoted' + write(fates_log(),*) 'loss:',cc_gain + write(fates_log(),*) 'existing area:',currentCohort%c_area + call endrun(msg=errMsg(sourcefile, __LINE__)) + + endif + + endif ! if(currentCohort%canopy_layer == i_lyr+1) then + currentCohort => currentCohort%shorter + enddo !currentCohort + + call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr,arealayer_current) + + if ((abs(arealayer_current - currentPatch%area)/arealayer_current > & + area_check_rel_precision ) .or. & + (abs(arealayer_current - currentPatch%area) > area_check_precision) ) then + write(fates_log(),*) 'promotion did not bring area within tolerance' + write(fates_log(),*) 'arealayer:',arealayer_current + write(fates_log(),*) 'patch%area:',currentPatch%area + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + end if + + end if + + return + end subroutine PromoteIntoLayer ! ============================================================================ @@ -1220,9 +1220,9 @@ subroutine canopy_spread( currentSite ) currentCohort => currentPatch%tallest do while (associated(currentCohort)) call carea_allom(currentCohort%dbh,currentCohort%n, & - currentSite%spread,currentCohort%pft,currentCohort%c_area) + currentSite%spread,currentCohort%pft,currentCohort%c_area) if( ( int(prt_params%woody(currentCohort%pft)) .eq. itrue ) .and. & - (currentCohort%canopy_layer .eq. 1 ) ) then + (currentCohort%canopy_layer .eq. 1 ) ) then sitelevel_canopyarea = sitelevel_canopyarea + currentCohort%c_area endif currentCohort => currentCohort%shorter @@ -1250,9 +1250,9 @@ end subroutine canopy_spread subroutine canopy_summarization( nsites, sites, bc_in ) - ! ---------------------------------------------------------------------------------- - ! Much of this routine was once ed_clm_link minus all the IO and history stuff - ! --------------------------------------------------------------------------------- + ! ---------------------------------------------------------------------------------- + ! Much of this routine was once ed_clm_link minus all the IO and history stuff + ! --------------------------------------------------------------------------------- use FatesInterfaceTypesMod , only : bc_in_type use FatesInterfaceTypesMod , only : hlm_use_cohort_age_tracking @@ -1282,13 +1282,13 @@ subroutine canopy_summarization( nsites, sites, bc_in ) real(r8) :: struct_c ! structure carbon [kg] !---------------------------------------------------------------------- - + if ( debug ) then write(fates_log(),*) 'in canopy_summarization' endif do s = 1,nsites - + ! -------------------------------------------------------------------------------- ! Set the patch indices (this is usefull mostly for communicating with a host or ! driving model. Loops through all patches and sets cpatch%patchno to the integer @@ -1299,16 +1299,16 @@ subroutine canopy_summarization( nsites, sites, bc_in ) currentPatch => sites(s)%oldest_patch do while(associated(currentPatch)) - + !zero cohort-summed variables. currentPatch%total_canopy_area = 0.0_r8 currentPatch%total_tree_area = 0.0_r8 canopy_leaf_area = 0.0_r8 - + !update cohort quantitie s currentCohort => currentPatch%shortest do while(associated(currentCohort)) - + ft = currentCohort%pft @@ -1317,27 +1317,27 @@ subroutine canopy_summarization( nsites, sites, bc_in ) struct_c = currentCohort%prt%GetState(struct_organ, all_carbon_elements) fnrt_c = currentCohort%prt%GetState(fnrt_organ, all_carbon_elements) store_c = currentCohort%prt%GetState(store_organ, all_carbon_elements) - + ! Update the cohort's index within the size bin classes ! Update the cohort's index within the SCPF classification system call sizetype_class_index(currentCohort%dbh,currentCohort%pft, & currentCohort%size_class,currentCohort%size_by_pft_class) if (hlm_use_cohort_age_tracking .eq. itrue) then - call coagetype_class_index(currentCohort%coage,currentCohort%pft, & - currentCohort%coage_class,currentCohort%coage_by_pft_class) - end if + call coagetype_class_index(currentCohort%coage,currentCohort%pft, & + currentCohort%coage_class,currentCohort%coage_by_pft_class) + end if - if(hlm_use_sp.eq.ifalse)then - call carea_allom(currentCohort%dbh,currentCohort%n,sites(s)%spread,& - currentCohort%pft,currentCohort%c_area) - endif + if(hlm_use_sp.eq.ifalse)then + call carea_allom(currentCohort%dbh,currentCohort%n,sites(s)%spread,& + currentCohort%pft,currentCohort%c_area) + endif currentCohort%treelai = tree_lai(leaf_c, & currentCohort%pft, currentCohort%c_area, currentCohort%n, & currentCohort%canopy_layer, currentPatch%canopy_layer_tlai,currentCohort%vcmax25top ) canopy_leaf_area = canopy_leaf_area + currentCohort%treelai *currentCohort%c_area - + if(currentCohort%canopy_layer==1)then currentPatch%total_canopy_area = currentPatch%total_canopy_area + currentCohort%c_area if( int(prt_params%woody(ft))==itrue)then @@ -1353,40 +1353,40 @@ subroutine canopy_summarization( nsites, sites, bc_in ) if(hlm_use_sp.eq.itrue)then - if(associated(currentPatch%tallest%shorter))then - write(fates_log(),*) 'more than one cohort in SP mode',s,currentPatch%nocomp_pft_label - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if + if(associated(currentPatch%tallest%shorter))then + write(fates_log(),*) 'more than one cohort in SP mode',s,currentPatch%nocomp_pft_label + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if - if(currentPatch%total_canopy_area-currentPatch%area.gt.1.0e-16)then - write(fates_log(),*) 'too much canopy in summary',s, & - currentPatch%nocomp_pft_label, currentPatch%total_canopy_area-currentPatch%area - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if + if(currentPatch%total_canopy_area-currentPatch%area.gt.1.0e-16)then + write(fates_log(),*) 'too much canopy in summary',s, & + currentPatch%nocomp_pft_label, currentPatch%total_canopy_area-currentPatch%area + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if end if !sp mode ! Check for erroneous zero values. if(currentCohort%dbh <= 0._r8 .or. currentCohort%n == 0._r8)then write(fates_log(),*) 'FATES: dbh or n is zero in canopy_summarization', & - currentCohort%dbh,currentCohort%n + currentCohort%dbh,currentCohort%n call endrun(msg=errMsg(sourcefile, __LINE__)) endif if(currentCohort%pft == 0.or.currentCohort%canopy_trim <= 0._r8)then write(fates_log(),*) 'FATES: PFT or trim is zero in canopy_summarization', & - currentCohort%pft,currentCohort%canopy_trim + currentCohort%pft,currentCohort%canopy_trim call endrun(msg=errMsg(sourcefile, __LINE__)) endif if( (sapw_c + leaf_c + fnrt_c) <= 0._r8)then write(fates_log(),*) 'FATES: alive biomass is zero in canopy_summarization', & - sapw_c + leaf_c + fnrt_c + sapw_c + leaf_c + fnrt_c call endrun(msg=errMsg(sourcefile, __LINE__)) endif currentCohort => currentCohort%taller - + enddo ! ends 'do while(associated(currentCohort)) - + if ( currentPatch%total_canopy_area>currentPatch%area ) then if ( currentPatch%total_canopy_area-currentPatch%area > 0.001_r8 ) then write(fates_log(),*) 'FATES: canopy area bigger than area', & @@ -1400,18 +1400,18 @@ subroutine canopy_summarization( nsites, sites, bc_in ) currentPatch => currentPatch%younger end do !patch loop - + call leaf_area_profile(sites(s),bc_in(s)%snow_depth_si,bc_in(s)%frac_sno_eff_si) - + end do ! site loop - + return end subroutine canopy_summarization - - ! ===================================================================================== - subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) - + ! ===================================================================================== + + subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) + ! ----------------------------------------------------------------------------------- ! This subroutine calculates how leaf and stem areas are distributed ! in vertical and horizontal space. @@ -1448,7 +1448,7 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) ! !USES: use EDtypesMod , only : area, dinc_ed, hitemax, n_hite_bins - + ! ! !ARGUMENTS type(ed_site_type) , intent(inout) :: currentSite @@ -1478,7 +1478,7 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) real(r8) :: lai ! summed lai for checking m2 m-2 real(r8) :: snow_depth_avg ! avg snow over whole site real(r8) :: leaf_c ! leaf carbon [kg] - + !---------------------------------------------------------------------- @@ -1489,7 +1489,7 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) ! We assume that each point in the canopy recieved the light attenuated by the average ! leaf area index above it, irrespective of PFT identity... ! Each leaf is defined by how deep in the canopy it is, in terms of LAI units. (FIX(RF,032414), GB) - + currentPatch => currentSite%oldest_patch do while(associated(currentPatch)) @@ -1514,166 +1514,166 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) ! It is remotely possible that in deserts we will not have any canopy ! area, ie not plants at all... ! ------------------------------------------------------------------------------ - + if (currentPatch%total_canopy_area > nearzero ) then - currentCohort => currentPatch%tallest - do while(associated(currentCohort)) + currentCohort => currentPatch%tallest + do while(associated(currentCohort)) - ft = currentCohort%pft - cl = currentCohort%canopy_layer + ft = currentCohort%pft + cl = currentCohort%canopy_layer - ! Calculate LAI of layers above - ! Note that the canopy_layer_lai is also calculated in this loop - ! but since we go top down in terms of plant size, we should be okay + ! Calculate LAI of layers above + ! Note that the canopy_layer_lai is also calculated in this loop + ! but since we go top down in terms of plant size, we should be okay - leaf_c = currentCohort%prt%GetState(leaf_organ,all_carbon_elements) + leaf_c = currentCohort%prt%GetState(leaf_organ,all_carbon_elements) - currentCohort%treelai = tree_lai(leaf_c, currentCohort%pft, currentCohort%c_area, & - currentCohort%n, currentCohort%canopy_layer, & - currentPatch%canopy_layer_tlai,currentCohort%vcmax25top ) + currentCohort%treelai = tree_lai(leaf_c, currentCohort%pft, currentCohort%c_area, & + currentCohort%n, currentCohort%canopy_layer, & + currentPatch%canopy_layer_tlai,currentCohort%vcmax25top ) - currentCohort%treesai = tree_sai(currentCohort%pft, currentCohort%dbh, currentCohort%canopy_trim, & - currentCohort%c_area, currentCohort%n, currentCohort%canopy_layer, & - currentPatch%canopy_layer_tlai, currentCohort%treelai , & - currentCohort%vcmax25top,4) + currentCohort%treesai = tree_sai(currentCohort%pft, currentCohort%dbh, currentCohort%canopy_trim, & + currentCohort%c_area, currentCohort%n, currentCohort%canopy_layer, & + currentPatch%canopy_layer_tlai, currentCohort%treelai , & + currentCohort%vcmax25top,4) - currentCohort%lai = currentCohort%treelai *currentCohort%c_area/currentPatch%total_canopy_area - currentCohort%sai = currentCohort%treesai *currentCohort%c_area/currentPatch%total_canopy_area + currentCohort%lai = currentCohort%treelai *currentCohort%c_area/currentPatch%total_canopy_area + currentCohort%sai = currentCohort%treesai *currentCohort%c_area/currentPatch%total_canopy_area - ! Number of actual vegetation layers in this cohort's crown - currentCohort%nv = ceiling((currentCohort%treelai+currentCohort%treesai)/dinc_ed) + ! Number of actual vegetation layers in this cohort's crown + currentCohort%nv = ceiling((currentCohort%treelai+currentCohort%treesai)/dinc_ed) - currentPatch%ncan(cl,ft) = max(currentPatch%ncan(cl,ft),currentCohort%NV) + currentPatch%ncan(cl,ft) = max(currentPatch%ncan(cl,ft),currentCohort%NV) - patch_lai = patch_lai + currentCohort%lai + patch_lai = patch_lai + currentCohort%lai - currentPatch%canopy_layer_tlai(cl) = currentPatch%canopy_layer_tlai(cl) + currentCohort%lai + currentPatch%canopy_layer_tlai(cl) = currentPatch%canopy_layer_tlai(cl) + currentCohort%lai - currentCohort => currentCohort%shorter - - enddo !currentCohort + currentCohort => currentCohort%shorter - if(smooth_leaf_distribution == 1)then + enddo !currentCohort - ! ----------------------------------------------------------------------------- - ! we are going to ignore the concept of canopy layers, and put all of the leaf - ! area into height banded bins. using the same domains as we had before, except - ! that CL always = 1 - ! ----------------------------------------------------------------------------- - - ! this is a crude way of dividing up the bins. Should it be a function of actual maximum height? - dh = 1.0_r8*(HITEMAX/N_HITE_BINS) - do iv = 1,N_HITE_BINS - if (iv == 1) then - minh(iv) = 0.0_r8 - maxh(iv) = dh - else - minh(iv) = (iv-1)*dh - maxh(iv) = (iv)*dh - endif - enddo - - currentCohort => currentPatch%shortest - do while(associated(currentCohort)) - ft = currentCohort%pft - min_chite = currentCohort%hite - currentCohort%hite * EDPftvarcon_inst%crown(ft) - max_chite = currentCohort%hite + if(smooth_leaf_distribution == 1)then + + ! ----------------------------------------------------------------------------- + ! we are going to ignore the concept of canopy layers, and put all of the leaf + ! area into height banded bins. using the same domains as we had before, except + ! that CL always = 1 + ! ----------------------------------------------------------------------------- + + ! this is a crude way of dividing up the bins. Should it be a function of actual maximum height? + dh = 1.0_r8*(HITEMAX/N_HITE_BINS) do iv = 1,N_HITE_BINS - frac_canopy(iv) = 0.0_r8 - ! this layer is in the middle of the canopy - if(max_chite > maxh(iv).and.min_chite < minh(iv))then - frac_canopy(iv)= min(1.0_r8,dh / (currentCohort%hite*EDPftvarcon_inst%crown(ft))) - ! this is the layer with the bottom of the canopy in it. - elseif(min_chite < maxh(iv).and.min_chite > minh(iv).and.max_chite > maxh(iv))then - frac_canopy(iv) = (maxh(iv) -min_chite ) / (currentCohort%hite*EDPftvarcon_inst%crown(ft)) - ! this is the layer with the top of the canopy in it. - elseif(max_chite > minh(iv).and.max_chite < maxh(iv).and.min_chite < minh(iv))then - frac_canopy(iv) = (max_chite - minh(iv)) / (currentCohort%hite*EDPftvarcon_inst%crown(ft)) - elseif(max_chite < maxh(iv).and.min_chite > minh(iv))then !the whole cohort is within this layer. - frac_canopy(iv) = 1.0_r8 - endif - - ! no m2 of leaf per m2 of ground in each height class - currentPatch%tlai_profile(1,ft,iv) = currentPatch%tlai_profile(1,ft,iv) + frac_canopy(iv) * & - currentCohort%lai - currentPatch%tsai_profile(1,ft,iv) = currentPatch%tsai_profile(1,ft,iv) + frac_canopy(iv) * & - currentCohort%sai - - !snow burial - !write(fates_log(), *) 'calc snow' - snow_depth_avg = snow_depth_si * frac_sno_eff_si - if(snow_depth_avg > maxh(iv))then - fraction_exposed = 0._r8 - endif - if(snow_depth_avg < minh(iv))then - fraction_exposed = 1._r8 - endif - if(snow_depth_avg>= minh(iv).and.snow_depth_avg <= maxh(iv))then !only partly hidden... - fraction_exposed = max(0._r8,(min(1.0_r8,(snow_depth_avg-minh(iv))/dh))) + if (iv == 1) then + minh(iv) = 0.0_r8 + maxh(iv) = dh + else + minh(iv) = (iv-1)*dh + maxh(iv) = (iv)*dh endif - fraction_exposed = 1.0_r8 - ! no m2 of leaf per m2 of ground in each height class - ! FIX(SPM,032414) these should be uncommented this and double check - - if ( debug ) write(fates_log(), *) 'leaf_area_profile()', currentPatch%elai_profile(1,ft,iv) - - currentPatch%elai_profile(1,ft,iv) = currentPatch%tlai_profile(1,ft,iv) * fraction_exposed - currentPatch%esai_profile(1,ft,iv) = currentPatch%tsai_profile(1,ft,iv) * fraction_exposed - - if ( debug ) write(fates_log(), *) 'leaf_area_profile()', currentPatch%elai_profile(1,ft,iv) - - enddo ! (iv) hite bins - - currentCohort => currentCohort%taller - - enddo !currentCohort - - ! ----------------------------------------------------------------------------- - ! Perform a leaf area conservation check on the LAI profile - lai = 0.0_r8 - do ft = 1,numpft - lai = lai+ sum(currentPatch%tlai_profile(1,ft,:)) - enddo - - if(lai > patch_lai)then - write(fates_log(), *) 'FATES: problem with lai assignments' - call endrun(msg=errMsg(sourcefile, __LINE__)) - endif - - - else ! smooth leaf distribution + enddo + + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + ft = currentCohort%pft + min_chite = currentCohort%hite - currentCohort%hite * EDPftvarcon_inst%crown(ft) + max_chite = currentCohort%hite + do iv = 1,N_HITE_BINS + frac_canopy(iv) = 0.0_r8 + ! this layer is in the middle of the canopy + if(max_chite > maxh(iv).and.min_chite < minh(iv))then + frac_canopy(iv)= min(1.0_r8,dh / (currentCohort%hite*EDPftvarcon_inst%crown(ft))) + ! this is the layer with the bottom of the canopy in it. + elseif(min_chite < maxh(iv).and.min_chite > minh(iv).and.max_chite > maxh(iv))then + frac_canopy(iv) = (maxh(iv) -min_chite ) / (currentCohort%hite*EDPftvarcon_inst%crown(ft)) + ! this is the layer with the top of the canopy in it. + elseif(max_chite > minh(iv).and.max_chite < maxh(iv).and.min_chite < minh(iv))then + frac_canopy(iv) = (max_chite - minh(iv)) / (currentCohort%hite*EDPftvarcon_inst%crown(ft)) + elseif(max_chite < maxh(iv).and.min_chite > minh(iv))then !the whole cohort is within this layer. + frac_canopy(iv) = 1.0_r8 + endif + + ! no m2 of leaf per m2 of ground in each height class + currentPatch%tlai_profile(1,ft,iv) = currentPatch%tlai_profile(1,ft,iv) + frac_canopy(iv) * & + currentCohort%lai + currentPatch%tsai_profile(1,ft,iv) = currentPatch%tsai_profile(1,ft,iv) + frac_canopy(iv) * & + currentCohort%sai + + !snow burial + !write(fates_log(), *) 'calc snow' + snow_depth_avg = snow_depth_si * frac_sno_eff_si + if(snow_depth_avg > maxh(iv))then + fraction_exposed = 0._r8 + endif + if(snow_depth_avg < minh(iv))then + fraction_exposed = 1._r8 + endif + if(snow_depth_avg>= minh(iv).and.snow_depth_avg <= maxh(iv))then !only partly hidden... + fraction_exposed = max(0._r8,(min(1.0_r8,(snow_depth_avg-minh(iv))/dh))) + endif + fraction_exposed = 1.0_r8 + ! no m2 of leaf per m2 of ground in each height class + ! FIX(SPM,032414) these should be uncommented this and double check + + if ( debug ) write(fates_log(), *) 'leaf_area_profile()', currentPatch%elai_profile(1,ft,iv) + + currentPatch%elai_profile(1,ft,iv) = currentPatch%tlai_profile(1,ft,iv) * fraction_exposed + currentPatch%esai_profile(1,ft,iv) = currentPatch%tsai_profile(1,ft,iv) * fraction_exposed + + if ( debug ) write(fates_log(), *) 'leaf_area_profile()', currentPatch%elai_profile(1,ft,iv) + + enddo ! (iv) hite bins + + currentCohort => currentCohort%taller + + enddo !currentCohort + + ! ----------------------------------------------------------------------------- + ! Perform a leaf area conservation check on the LAI profile + lai = 0.0_r8 + do ft = 1,numpft + lai = lai+ sum(currentPatch%tlai_profile(1,ft,:)) + enddo + + if(lai > patch_lai)then + write(fates_log(), *) 'FATES: problem with lai assignments' + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + + + else ! smooth leaf distribution + + ! ----------------------------------------------------------------------------- + ! Standard canopy layering model. + ! Go through all cohorts and add their leaf area + ! and canopy area to the accumulators. + ! ----------------------------------------------------------------------------- - ! ----------------------------------------------------------------------------- - ! Standard canopy layering model. - ! Go through all cohorts and add their leaf area - ! and canopy area to the accumulators. - ! ----------------------------------------------------------------------------- - currentCohort => currentPatch%shortest do while(associated(currentCohort)) ft = currentCohort%pft cl = currentCohort%canopy_layer - + ! ---------------------------------------------------------------- ! How much of each tree is stem area index? Assuming that there is ! This may indeed be zero if there is a sensecent grass ! ---------------------------------------------------------------- - + if( (currentCohort%treelai+currentCohort%treesai) > 0._r8)then fleaf = currentCohort%lai / (currentCohort%lai + currentCohort%sai) else fleaf = 0._r8 endif - + ! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX ! SNOW BURIAL IS CURRENTLY TURNED OFF ! WHEN IT IS TURNED ON, IT WILL HAVE TO BE COMPARED ! WITH SNOW HEIGHTS CALCULATED BELOW. ! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - + currentPatch%nrad(cl,ft) = currentPatch%ncan(cl,ft) if (currentPatch%nrad(cl,ft) > nlevleaf ) then @@ -1691,22 +1691,22 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) ! Whole layers. Make a weighted average of the leaf area in each layer ! before dividing it by the total area. Fill up layer for whole layers. ! -------------------------------------------------------------------------- - + do iv = 1,currentCohort%NV - + ! This loop builds the arrays that define the effective (not snow covered) ! and total (includes snow covered) area indices for leaves and stems ! We calculate the absolute elevation of each layer to help determine if the layer ! is obscured by snow. - + layer_top_hite = currentCohort%hite - & - ( real(iv-1,r8)/currentCohort%NV * currentCohort%hite * & - EDPftvarcon_inst%crown(currentCohort%pft) ) - + ( real(iv-1,r8)/currentCohort%NV * currentCohort%hite * & + EDPftvarcon_inst%crown(currentCohort%pft) ) + layer_bottom_hite = currentCohort%hite - & - ( real(iv,r8)/currentCohort%NV * currentCohort%hite * & - EDPftvarcon_inst%crown(currentCohort%pft) ) - + ( real(iv,r8)/currentCohort%NV * currentCohort%hite * & + EDPftvarcon_inst%crown(currentCohort%pft) ) + fraction_exposed = 1.0_r8 snow_depth_avg = snow_depth_si * frac_sno_eff_si if(snow_depth_avg > layer_top_hite)then @@ -1716,61 +1716,61 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) fraction_exposed = 1._r8 endif if( snow_depth_avg>= layer_bottom_hite .and. & - snow_depth_avg <= layer_top_hite) then !only partly hidden... + snow_depth_avg <= layer_top_hite) then !only partly hidden... fraction_exposed = max(0._r8,(min(1.0_r8,(snow_depth_avg-layer_bottom_hite)/ & - (layer_top_hite-layer_bottom_hite )))) + (layer_top_hite-layer_bottom_hite )))) endif - + ! =========== OVER-WRITE ================= fraction_exposed= 1.0_r8 ! =========== OVER-WRITE ================= - + if(iv==currentCohort%NV) then remainder = (currentCohort%treelai + currentCohort%treesai) - & - (dinc_ed*real(currentCohort%nv-1,r8)) + (dinc_ed*real(currentCohort%nv-1,r8)) if(remainder > dinc_ed )then write(fates_log(), *)'ED: issue with remainder', & - currentCohort%treelai,currentCohort%treesai,dinc_ed, & - currentCohort%NV,remainder + currentCohort%treelai,currentCohort%treesai,dinc_ed, & + currentCohort%NV,remainder call endrun(msg=errMsg(sourcefile, __LINE__)) endif else remainder = dinc_ed end if - + currentPatch%tlai_profile(cl,ft,iv) = currentPatch%tlai_profile(cl,ft,iv) + & - remainder * fleaf * currentCohort%c_area/currentPatch%total_canopy_area - + remainder * fleaf * currentCohort%c_area/currentPatch%total_canopy_area + currentPatch%elai_profile(cl,ft,iv) = currentPatch%elai_profile(cl,ft,iv) + & - remainder * fleaf * currentCohort%c_area/currentPatch%total_canopy_area * & - fraction_exposed - + remainder * fleaf * currentCohort%c_area/currentPatch%total_canopy_area * & + fraction_exposed + currentPatch%tsai_profile(cl,ft,iv) = currentPatch%tsai_profile(cl,ft,iv) + & - remainder * (1._r8 - fleaf) * currentCohort%c_area/currentPatch%total_canopy_area - + remainder * (1._r8 - fleaf) * currentCohort%c_area/currentPatch%total_canopy_area + currentPatch%esai_profile(cl,ft,iv) = currentPatch%esai_profile(cl,ft,iv) + & - remainder * (1._r8 - fleaf) * currentCohort%c_area/currentPatch%total_canopy_area * & - fraction_exposed - + remainder * (1._r8 - fleaf) * currentCohort%c_area/currentPatch%total_canopy_area * & + fraction_exposed + currentPatch%canopy_area_profile(cl,ft,iv) = currentPatch%canopy_area_profile(cl,ft,iv) + & - currentCohort%c_area/currentPatch%total_canopy_area - + currentCohort%c_area/currentPatch%total_canopy_area + currentPatch%layer_height_profile(cl,ft,iv) = currentPatch%layer_height_profile(cl,ft,iv) + & - (remainder * fleaf * currentCohort%c_area/currentPatch%total_canopy_area * & - (layer_top_hite+layer_bottom_hite)/2.0_r8) !average height of layer. - + (remainder * fleaf * currentCohort%c_area/currentPatch%total_canopy_area * & + (layer_top_hite+layer_bottom_hite)/2.0_r8) !average height of layer. + end do - + currentCohort => currentCohort%taller - + enddo !cohort - + ! -------------------------------------------------------------------------- - + ! If there is an upper-story, the top canopy layer ! should have a value of exactly 1.0 in its top leaf layer ! -------------------------------------------------------------------------- - + if ( (currentPatch%NCL_p > 1) .and. & (sum(currentPatch%canopy_area_profile(1,:,1)) < 0.9999 )) then write(fates_log(), *) 'FATES: canopy_area_profile was less than 1 at the canopy top' @@ -1789,9 +1789,9 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) currentCohort => currentCohort%taller enddo !currentCohort call endrun(msg=errMsg(sourcefile, __LINE__)) - + end if - + ! -------------------------------------------------------------------------- ! In the following loop we are now normalizing the effective and @@ -1806,57 +1806,57 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) do cl = 1,currentPatch%NCL_p do iv = 1,currentPatch%ncan(cl,ft) - + if( debug .and. sum(currentPatch%canopy_area_profile(cl,:,iv)) > 1.0001_r8 ) then - + write(fates_log(), *) 'FATES: A canopy_area_profile exceeded 1.0' write(fates_log(), *) 'cl: ',cl write(fates_log(), *) 'iv: ',iv write(fates_log(), *) 'sum(cpatch%canopy_area_profile(cl,:,iv)): ', & - sum(currentPatch%canopy_area_profile(cl,:,iv)) - currentCohort => currentPatch%shortest - do while(associated(currentCohort)) - if(currentCohort%canopy_layer==cl)then - write(fates_log(), *) 'FATES: cohorts in layer cl = ',cl, & - currentCohort%dbh,currentCohort%c_area, & - currentPatch%total_canopy_area,currentPatch%area - write(fates_log(), *) 'ED: fracarea', currentCohort%pft, & - currentCohort%c_area/currentPatch%total_canopy_area - endif - currentCohort => currentCohort%taller - enddo !currentCohort - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end do - + sum(currentPatch%canopy_area_profile(cl,:,iv)) + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + if(currentCohort%canopy_layer==cl)then + write(fates_log(), *) 'FATES: cohorts in layer cl = ',cl, & + currentCohort%dbh,currentCohort%c_area, & + currentPatch%total_canopy_area,currentPatch%area + write(fates_log(), *) 'ED: fracarea', currentCohort%pft, & + currentCohort%c_area/currentPatch%total_canopy_area + endif + currentCohort => currentCohort%taller + enddo !currentCohort + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end do + do ft = 1,numpft do iv = 1,currentPatch%ncan(cl,ft) if( currentPatch%canopy_area_profile(cl,ft,iv) > nearzero ) then - + currentPatch%tlai_profile(cl,ft,iv) = currentPatch%tlai_profile(cl,ft,iv) / & - currentPatch%canopy_area_profile(cl,ft,iv) - + currentPatch%canopy_area_profile(cl,ft,iv) + currentPatch%tsai_profile(cl,ft,iv) = currentPatch%tsai_profile(cl,ft,iv) / & - currentPatch%canopy_area_profile(cl,ft,iv) - + currentPatch%canopy_area_profile(cl,ft,iv) + currentPatch%elai_profile(cl,ft,iv) = currentPatch%elai_profile(cl,ft,iv) / & - currentPatch%canopy_area_profile(cl,ft,iv) - + currentPatch%canopy_area_profile(cl,ft,iv) + currentPatch%esai_profile(cl,ft,iv) = currentPatch%esai_profile(cl,ft,iv) / & - currentPatch%canopy_area_profile(cl,ft,iv) + currentPatch%canopy_area_profile(cl,ft,iv) end if - + if(currentPatch%tlai_profile(cl,ft,iv)>nearzero )then currentPatch%layer_height_profile(cl,ft,iv) = currentPatch%layer_height_profile(cl,ft,iv) & - /currentPatch%tlai_profile(cl,ft,iv) + /currentPatch%tlai_profile(cl,ft,iv) end if - + enddo - + enddo enddo - + ! -------------------------------------------------------------------------- ! Set the mask that identifies which PFT x can-layer combinations have ! scattering elements in them. @@ -1871,183 +1871,183 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) end do !iv enddo !ft enddo ! loop over cl - + endif !leaf distribution - + end if - + currentPatch => currentPatch%younger - + enddo !patch - + return - end subroutine leaf_area_profile + end subroutine leaf_area_profile - ! ====================================================================================== + ! ====================================================================================== subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) - ! ---------------------------------------------------------------------------------- - ! The purpose of this routine is to package output boundary conditions related - ! to vegetation coverage to the host land model. - ! ---------------------------------------------------------------------------------- - - use EDTypesMod , only : ed_patch_type, ed_cohort_type, & - ed_site_type, AREA - use FatesInterfaceTypesMod , only : bc_out_type - - ! - ! !ARGUMENTS - integer, intent(in) :: nsites - type(ed_site_type), intent(inout), target :: sites(nsites) - integer, intent(in) :: fcolumn(nsites) - type(bc_out_type), intent(inout) :: bc_out(nsites) - - ! Locals - type (ed_cohort_type) , pointer :: currentCohort - integer :: s, ifp, c, p - type (ed_patch_type) , pointer :: currentPatch - real(r8) :: bare_frac_area - real(r8) :: total_patch_area - real(r8) :: total_canopy_area - real(r8) :: weight ! Weighting for cohort variables in patch - - - do s = 1,nsites - - ifp = 0 - total_patch_area = 0._r8 - total_canopy_area = 0._r8 - bc_out(s)%canopy_fraction_pa(:) = 0._r8 - currentPatch => sites(s)%oldest_patch - c = fcolumn(s) - do while(associated(currentPatch)) + ! ---------------------------------------------------------------------------------- + ! The purpose of this routine is to package output boundary conditions related + ! to vegetation coverage to the host land model. + ! ---------------------------------------------------------------------------------- + + use EDTypesMod , only : ed_patch_type, ed_cohort_type, & + ed_site_type, AREA + use FatesInterfaceTypesMod , only : bc_out_type + + ! + ! !ARGUMENTS + integer, intent(in) :: nsites + type(ed_site_type), intent(inout), target :: sites(nsites) + integer, intent(in) :: fcolumn(nsites) + type(bc_out_type), intent(inout) :: bc_out(nsites) + + ! Locals + type (ed_cohort_type) , pointer :: currentCohort + integer :: s, ifp, c, p + type (ed_patch_type) , pointer :: currentPatch + real(r8) :: bare_frac_area + real(r8) :: total_patch_area + real(r8) :: total_canopy_area + real(r8) :: weight ! Weighting for cohort variables in patch + + + do s = 1,nsites + + ifp = 0 + total_patch_area = 0._r8 + total_canopy_area = 0._r8 + bc_out(s)%canopy_fraction_pa(:) = 0._r8 + currentPatch => sites(s)%oldest_patch + c = fcolumn(s) + do while(associated(currentPatch)) if(currentPatch%nocomp_pft_label.ne.0)then - ! only increase ifp for veg patches, not bareground (in SP mode) - ifp = ifp+1 - endif ! stay with ifp=0 for bareground patch. - if ( currentPatch%total_canopy_area-currentPatch%area > 0.000001_r8 ) then - write(fates_log(),*) 'ED: canopy area bigger than area',currentPatch%total_canopy_area ,currentPatch%area - currentPatch%total_canopy_area = currentPatch%area - endif - - - if (associated(currentPatch%tallest)) then - bc_out(s)%htop_pa(ifp) = currentPatch%tallest%hite - else - ! FIX(RF,040113) - should this be a parameter for the minimum possible vegetation height? - bc_out(s)%htop_pa(ifp) = 0.1_r8 - endif - - bc_out(s)%hbot_pa(ifp) = max(0._r8, min(0.2_r8, bc_out(s)%htop_pa(ifp)- 1.0_r8)) - ! Use leaf area weighting for all cohorts in the patch to define the characteristic - ! leaf width used by the HLM - ! ---------------------------------------------------------------------------- -! bc_out(s)%dleaf_pa(ifp) = 0.0_r8 -! if(currentPatch%lai>1.0e-9_r8) then -! currentCohort => currentPatch%shortest -! do while(associated(currentCohort)) -! weight = min(1.0_r8,currentCohort%lai/currentPatch%lai) -! bc_out(s)%dleaf_pa(ifp) = bc_out(s)%dleaf_pa(ifp) + & -! EDPftvarcon_inst%dleaf(currentCohort%pft)*weight -! currentCohort => currentCohort%taller -! enddo -! end if - - ! Roughness length and displacement height are not PFT properties, they are - ! properties of the canopy assemblage. Defining this needs an appropriate model. - ! Right now z0 and d are pft level parameters. For the time being we will just - ! use the 1st index until a suitable model is defined. (RGK 04-2017) - ! ----------------------------------------------------------------------------- - bc_out(s)%z0m_pa(ifp) = EDPftvarcon_inst%z0mr(1) * bc_out(s)%htop_pa(ifp) - bc_out(s)%displa_pa(ifp) = EDPftvarcon_inst%displar(1) * bc_out(s)%htop_pa(ifp) - bc_out(s)%dleaf_pa(ifp) = EDPftvarcon_inst%dleaf(1) - - ! We are assuming here that grass is all located underneath tree canopies. - ! The alternative is to assume it is all spatial distinct from tree canopies. - ! In which case, the bare area would have to be reduced by the grass area... - ! currentPatch%total_canopy_area/currentPatch%area is fraction of this patch cover by plants - ! currentPatch%area/AREA is the fraction of the soil covered by this patch. - if(currentPatch%area.gt.0.0_r8)then - bc_out(s)%canopy_fraction_pa(ifp) = & - min(1.0_r8,currentPatch%total_canopy_area/currentPatch%area)*(currentPatch%area/AREA) - else - bc_out(s)%canopy_fraction_pa(ifp) = 0.0_r8 - endif - - bare_frac_area = (1.0_r8 - min(1.0_r8,currentPatch%total_canopy_area/currentPatch%area)) * & - (currentPatch%area/AREA) - - total_patch_area = total_patch_area + bc_out(s)%canopy_fraction_pa(ifp) + bare_frac_area - - total_canopy_area = total_canopy_area + bc_out(s)%canopy_fraction_pa(ifp) - - bc_out(s)%nocomp_pft_label_pa(ifp) = currentPatch%nocomp_pft_label - - ! Calculate area indices for output boundary to HLM - ! It is assumed that cpatch%canopy_area_profile and cpat%xai_profiles - ! have been updated (ie ed_leaf_area_profile has been called since dynamics has been called) - - bc_out(s)%elai_pa(ifp) = calc_areaindex(currentPatch,'elai') - bc_out(s)%tlai_pa(ifp) = calc_areaindex(currentPatch,'tlai') - bc_out(s)%esai_pa(ifp) = calc_areaindex(currentPatch,'esai') - bc_out(s)%tsai_pa(ifp) = calc_areaindex(currentPatch,'tsai') - - ! Fraction of vegetation free of snow. This is used to flag those - ! patches which shall under-go photosynthesis - ! INTERF-TODO: we may want to stop using frac_veg_nosno_alb and let - ! FATES internal variables decide if photosynthesis is possible - ! we are essentially calculating it inside FATES to tell the - ! host to tell itself when to do things (circuitous). Just have - ! to determine where else it is used - - if ((bc_out(s)%elai_pa(ifp) + bc_out(s)%esai_pa(ifp)) > 0._r8) then - bc_out(s)%frac_veg_nosno_alb_pa(ifp) = 1.0_r8 - else - bc_out(s)%frac_veg_nosno_alb_pa(ifp) = 0.0_r8 - end if - currentPatch => currentPatch%younger - end do - - - ! Apply patch and canopy area corrections - ! If the difference is above reasonable math precision, apply a fix - ! If the difference is way above reasonable math precision, gracefully exit - - if(abs(total_patch_area-1.0_r8) > rsnbl_math_prec ) then - - if(abs(total_patch_area-1.0_r8) > 1.0e-8_r8 )then - write(fates_log(),*) 'total area is wrong in update_hlm_dynamics',total_patch_area - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - if(debug) then - write(fates_log(),*) 'imprecise patch areas in update_hlm_dynamics',total_patch_area - end if - - currentPatch => sites(s)%oldest_patch - ifp = 0 - do while(associated(currentPatch)) - if(currentPatch%nocomp_pft_label.ne.0)then ! for vegetated patches only - ifp = ifp+1 - bc_out(s)%canopy_fraction_pa(ifp) = bc_out(s)%canopy_fraction_pa(ifp)/total_patch_area + ! only increase ifp for veg patches, not bareground (in SP mode) + ifp = ifp+1 + endif ! stay with ifp=0 for bareground patch. + if ( currentPatch%total_canopy_area-currentPatch%area > 0.000001_r8 ) then + write(fates_log(),*) 'ED: canopy area bigger than area',currentPatch%total_canopy_area ,currentPatch%area + currentPatch%total_canopy_area = currentPatch%area + endif + + + if (associated(currentPatch%tallest)) then + bc_out(s)%htop_pa(ifp) = currentPatch%tallest%hite + else + ! FIX(RF,040113) - should this be a parameter for the minimum possible vegetation height? + bc_out(s)%htop_pa(ifp) = 0.1_r8 + endif + + bc_out(s)%hbot_pa(ifp) = max(0._r8, min(0.2_r8, bc_out(s)%htop_pa(ifp)- 1.0_r8)) + ! Use leaf area weighting for all cohorts in the patch to define the characteristic + ! leaf width used by the HLM + ! ---------------------------------------------------------------------------- + ! bc_out(s)%dleaf_pa(ifp) = 0.0_r8 + ! if(currentPatch%lai>1.0e-9_r8) then + ! currentCohort => currentPatch%shortest + ! do while(associated(currentCohort)) + ! weight = min(1.0_r8,currentCohort%lai/currentPatch%lai) + ! bc_out(s)%dleaf_pa(ifp) = bc_out(s)%dleaf_pa(ifp) + & + ! EDPftvarcon_inst%dleaf(currentCohort%pft)*weight + ! currentCohort => currentCohort%taller + ! enddo + ! end if + + ! Roughness length and displacement height are not PFT properties, they are + ! properties of the canopy assemblage. Defining this needs an appropriate model. + ! Right now z0 and d are pft level parameters. For the time being we will just + ! use the 1st index until a suitable model is defined. (RGK 04-2017) + ! ----------------------------------------------------------------------------- + bc_out(s)%z0m_pa(ifp) = EDPftvarcon_inst%z0mr(1) * bc_out(s)%htop_pa(ifp) + bc_out(s)%displa_pa(ifp) = EDPftvarcon_inst%displar(1) * bc_out(s)%htop_pa(ifp) + bc_out(s)%dleaf_pa(ifp) = EDPftvarcon_inst%dleaf(1) + + ! We are assuming here that grass is all located underneath tree canopies. + ! The alternative is to assume it is all spatial distinct from tree canopies. + ! In which case, the bare area would have to be reduced by the grass area... + ! currentPatch%total_canopy_area/currentPatch%area is fraction of this patch cover by plants + ! currentPatch%area/AREA is the fraction of the soil covered by this patch. + if(currentPatch%area.gt.0.0_r8)then + bc_out(s)%canopy_fraction_pa(ifp) = & + min(1.0_r8,currentPatch%total_canopy_area/currentPatch%area)*(currentPatch%area/AREA) + else + bc_out(s)%canopy_fraction_pa(ifp) = 0.0_r8 + endif + + bare_frac_area = (1.0_r8 - min(1.0_r8,currentPatch%total_canopy_area/currentPatch%area)) * & + (currentPatch%area/AREA) + + total_patch_area = total_patch_area + bc_out(s)%canopy_fraction_pa(ifp) + bare_frac_area + + total_canopy_area = total_canopy_area + bc_out(s)%canopy_fraction_pa(ifp) + + bc_out(s)%nocomp_pft_label_pa(ifp) = currentPatch%nocomp_pft_label + + ! Calculate area indices for output boundary to HLM + ! It is assumed that cpatch%canopy_area_profile and cpat%xai_profiles + ! have been updated (ie ed_leaf_area_profile has been called since dynamics has been called) + + bc_out(s)%elai_pa(ifp) = calc_areaindex(currentPatch,'elai') + bc_out(s)%tlai_pa(ifp) = calc_areaindex(currentPatch,'tlai') + bc_out(s)%esai_pa(ifp) = calc_areaindex(currentPatch,'esai') + bc_out(s)%tsai_pa(ifp) = calc_areaindex(currentPatch,'tsai') + + ! Fraction of vegetation free of snow. This is used to flag those + ! patches which shall under-go photosynthesis + ! INTERF-TODO: we may want to stop using frac_veg_nosno_alb and let + ! FATES internal variables decide if photosynthesis is possible + ! we are essentially calculating it inside FATES to tell the + ! host to tell itself when to do things (circuitous). Just have + ! to determine where else it is used + + if ((bc_out(s)%elai_pa(ifp) + bc_out(s)%esai_pa(ifp)) > 0._r8) then + bc_out(s)%frac_veg_nosno_alb_pa(ifp) = 1.0_r8 + else + bc_out(s)%frac_veg_nosno_alb_pa(ifp) = 0.0_r8 + end if + currentPatch => currentPatch%younger + end do + + + ! Apply patch and canopy area corrections + ! If the difference is above reasonable math precision, apply a fix + ! If the difference is way above reasonable math precision, gracefully exit + + if(abs(total_patch_area-1.0_r8) > rsnbl_math_prec ) then + + if(abs(total_patch_area-1.0_r8) > 1.0e-8_r8 )then + write(fates_log(),*) 'total area is wrong in update_hlm_dynamics',total_patch_area + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if(debug) then + write(fates_log(),*) 'imprecise patch areas in update_hlm_dynamics',total_patch_area + end if + + currentPatch => sites(s)%oldest_patch + ifp = 0 + do while(associated(currentPatch)) + if(currentPatch%nocomp_pft_label.ne.0)then ! for vegetated patches only + ifp = ifp+1 + bc_out(s)%canopy_fraction_pa(ifp) = bc_out(s)%canopy_fraction_pa(ifp)/total_patch_area else ! for the bareground patch (in SP mode). - bc_out(s)%canopy_fraction_pa(ifp) =0.0_r8 + bc_out(s)%canopy_fraction_pa(ifp) =0.0_r8 endif ! veg patch - currentPatch => currentPatch%younger - end do - - endif - - end do + currentPatch => currentPatch%younger + end do - ! If hydraulics is turned on, update the amount of water bound in vegetation - if (hlm_use_planthydro.eq.itrue) then - call RecruitWaterStorage(nsites,sites,bc_out) - call UpdateH2OVeg(nsites,sites,bc_out) - end if + endif + + end do + + ! If hydraulics is turned on, update the amount of water bound in vegetation + if (hlm_use_planthydro.eq.itrue) then + call RecruitWaterStorage(nsites,sites,bc_out) + call UpdateH2OVeg(nsites,sites,bc_out) + end if end subroutine update_hlm_dynamics @@ -2056,151 +2056,151 @@ end subroutine update_hlm_dynamics function calc_areaindex(cpatch,ai_type) result(ai) - ! ---------------------------------------------------------------------------------- - ! This subroutine calculates the exposed leaf area index of a patch - ! this is the square meters of leaf per square meter of ground area - ! It does so by integrating over the depth and functional type profile of leaf area - ! which are per area of crown. This value has to be scaled by crown area to convert - ! to ground area. - ! ---------------------------------------------------------------------------------- - - ! Arguments - type(ed_patch_type),intent(in), target :: cpatch - character(len=*),intent(in) :: ai_type - - integer :: cl,ft - real(r8) :: ai - ! TODO: THIS MIN LAI IS AN ARTIFACT FROM TESTING LONG-AGO AND SHOULD BE REMOVED - ! THIS HAS BEEN KEPT THUS FAR TO MAINTAIN B4B IN TESTING OTHER COMMITS - real(r8),parameter :: ai_min = 0.1_r8 - real(r8),pointer :: ai_profile - - ai = 0._r8 - if (trim(ai_type) == 'elai') then - do cl = 1,cpatch%NCL_p - do ft = 1,numpft - ai = ai + sum(cpatch%canopy_area_profile(cl,ft,1:cpatch%nrad(cl,ft)) * & - cpatch%elai_profile(cl,ft,1:cpatch%nrad(cl,ft))) - enddo - enddo - elseif (trim(ai_type) == 'tlai') then - do cl = 1,cpatch%NCL_p - do ft = 1,numpft - ai = ai + sum(cpatch%canopy_area_profile(cl,ft,1:cpatch%nrad(cl,ft)) * & - cpatch%tlai_profile(cl,ft,1:cpatch%nrad(cl,ft))) - enddo - enddo - - elseif (trim(ai_type) == 'esai') then - do cl = 1,cpatch%NCL_p - do ft = 1,numpft - ai = ai + sum(cpatch%canopy_area_profile(cl,ft,1:cpatch%nrad(cl,ft)) * & - cpatch%esai_profile(cl,ft,1:cpatch%nrad(cl,ft))) - enddo - enddo - elseif (trim(ai_type) == 'tsai') then - do cl = 1,cpatch%NCL_p - do ft = 1,numpft - ai = ai + sum(cpatch%canopy_area_profile(cl,ft,1:cpatch%nrad(cl,ft)) * & - cpatch%tsai_profile(cl,ft,1:cpatch%nrad(cl,ft))) - enddo - enddo - else - - write(fates_log(),*) 'Unsupported area index sent to calc_areaindex' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - ai = max(ai_min,ai) - - return + ! ---------------------------------------------------------------------------------- + ! This subroutine calculates the exposed leaf area index of a patch + ! this is the square meters of leaf per square meter of ground area + ! It does so by integrating over the depth and functional type profile of leaf area + ! which are per area of crown. This value has to be scaled by crown area to convert + ! to ground area. + ! ---------------------------------------------------------------------------------- + + ! Arguments + type(ed_patch_type),intent(in), target :: cpatch + character(len=*),intent(in) :: ai_type + + integer :: cl,ft + real(r8) :: ai + ! TODO: THIS MIN LAI IS AN ARTIFACT FROM TESTING LONG-AGO AND SHOULD BE REMOVED + ! THIS HAS BEEN KEPT THUS FAR TO MAINTAIN B4B IN TESTING OTHER COMMITS + real(r8),parameter :: ai_min = 0.1_r8 + real(r8),pointer :: ai_profile + + ai = 0._r8 + if (trim(ai_type) == 'elai') then + do cl = 1,cpatch%NCL_p + do ft = 1,numpft + ai = ai + sum(cpatch%canopy_area_profile(cl,ft,1:cpatch%nrad(cl,ft)) * & + cpatch%elai_profile(cl,ft,1:cpatch%nrad(cl,ft))) + enddo + enddo + elseif (trim(ai_type) == 'tlai') then + do cl = 1,cpatch%NCL_p + do ft = 1,numpft + ai = ai + sum(cpatch%canopy_area_profile(cl,ft,1:cpatch%nrad(cl,ft)) * & + cpatch%tlai_profile(cl,ft,1:cpatch%nrad(cl,ft))) + enddo + enddo + + elseif (trim(ai_type) == 'esai') then + do cl = 1,cpatch%NCL_p + do ft = 1,numpft + ai = ai + sum(cpatch%canopy_area_profile(cl,ft,1:cpatch%nrad(cl,ft)) * & + cpatch%esai_profile(cl,ft,1:cpatch%nrad(cl,ft))) + enddo + enddo + elseif (trim(ai_type) == 'tsai') then + do cl = 1,cpatch%NCL_p + do ft = 1,numpft + ai = ai + sum(cpatch%canopy_area_profile(cl,ft,1:cpatch%nrad(cl,ft)) * & + cpatch%tsai_profile(cl,ft,1:cpatch%nrad(cl,ft))) + enddo + enddo + else + + write(fates_log(),*) 'Unsupported area index sent to calc_areaindex' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + ai = max(ai_min,ai) + + return end function calc_areaindex ! =============================================================================================== - + subroutine CanopyLayerArea(currentPatch,site_spread,layer_index,layer_area) - - ! -------------------------------------------------------------------------------------------- - ! This function calculates the total crown area footprint for a desired layer of the canopy - ! within a patch. - ! The return units are the same as patch%area, which is m2 - ! --------------------------------------------------------------------------------------------- - - ! Arguments - type(ed_patch_type),intent(inout), target :: currentPatch - real(r8),intent(in) :: site_spread - integer,intent(in) :: layer_index - real(r8),intent(inout) :: layer_area - - type(ed_cohort_type), pointer :: currentCohort - - - layer_area = 0.0_r8 - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - call carea_allom(currentCohort%dbh,currentCohort%n,site_spread, & - currentCohort%pft,currentCohort%c_area) - if (currentCohort%canopy_layer .eq. layer_index) then - layer_area = layer_area + currentCohort%c_area - end if - currentCohort => currentCohort%shorter - enddo - return + + ! -------------------------------------------------------------------------------------------- + ! This function calculates the total crown area footprint for a desired layer of the canopy + ! within a patch. + ! The return units are the same as patch%area, which is m2 + ! --------------------------------------------------------------------------------------------- + + ! Arguments + type(ed_patch_type),intent(inout), target :: currentPatch + real(r8),intent(in) :: site_spread + integer,intent(in) :: layer_index + real(r8),intent(inout) :: layer_area + + type(ed_cohort_type), pointer :: currentCohort + + + layer_area = 0.0_r8 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + call carea_allom(currentCohort%dbh,currentCohort%n,site_spread, & + currentCohort%pft,currentCohort%c_area) + if (currentCohort%canopy_layer .eq. layer_index) then + layer_area = layer_area + currentCohort%c_area + end if + currentCohort => currentCohort%shorter + enddo + return end subroutine CanopyLayerArea ! =============================================================================================== - + function NumPotentialCanopyLayers(currentPatch,site_spread,include_substory) result(z) - ! -------------------------------------------------------------------------------------------- - ! Calculate the number of canopy layers in this patch. - ! This simple call only determines total layering by querying the cohorts - ! which layer they are in, it doesn't do any size evaluation. - ! It may also, optionally, account for the temporary "substory", which is the imaginary - ! layer below the understory which will be needed to temporarily accomodate demotions from - ! the understory in the event the understory has reached maximum allowable area. - ! -------------------------------------------------------------------------------------------- - - type(ed_patch_type),target :: currentPatch - real(r8),intent(in) :: site_spread - logical :: include_substory - - type(ed_cohort_type),pointer :: currentCohort - - integer :: z - real(r8) :: c_area - real(r8) :: arealayer - - z = 1 - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - z = max(z,currentCohort%canopy_layer) - currentCohort => currentCohort%shorter - enddo - - if(include_substory)then - arealayer = 0.0 - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if(currentCohort%canopy_layer == z) then - call carea_allom(currentCohort%dbh,currentCohort%n,site_spread,currentCohort%pft,c_area) - arealayer = arealayer + c_area - end if - currentCohort => currentCohort%shorter - enddo - - ! Does the bottom layer have more than a full canopy? - ! If so we need to make another layer. - if(arealayer > currentPatch%area)then - z = z + 1 - if(hlm_use_sp)then - write(fates_log(),*) 'SPmode, canopy_layer full:',arealayer,currentPatch%area - end if - - endif - end if - + ! -------------------------------------------------------------------------------------------- + ! Calculate the number of canopy layers in this patch. + ! This simple call only determines total layering by querying the cohorts + ! which layer they are in, it doesn't do any size evaluation. + ! It may also, optionally, account for the temporary "substory", which is the imaginary + ! layer below the understory which will be needed to temporarily accomodate demotions from + ! the understory in the event the understory has reached maximum allowable area. + ! -------------------------------------------------------------------------------------------- + + type(ed_patch_type),target :: currentPatch + real(r8),intent(in) :: site_spread + logical :: include_substory + + type(ed_cohort_type),pointer :: currentCohort + + integer :: z + real(r8) :: c_area + real(r8) :: arealayer + + z = 1 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + z = max(z,currentCohort%canopy_layer) + currentCohort => currentCohort%shorter + enddo + + if(include_substory)then + arealayer = 0.0 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == z) then + call carea_allom(currentCohort%dbh,currentCohort%n,site_spread,currentCohort%pft,c_area) + arealayer = arealayer + c_area + end if + currentCohort => currentCohort%shorter + enddo + + ! Does the bottom layer have more than a full canopy? + ! If so we need to make another layer. + if(arealayer > currentPatch%area)then + z = z + 1 + if(hlm_use_sp)then + write(fates_log(),*) 'SPmode, canopy_layer full:',arealayer,currentPatch%area + end if + + endif + end if + end function NumPotentialCanopyLayers end module EDCanopyStructureMod From 627b962d487bb08bf08ba1988626985c33943c46 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 25 Nov 2020 08:22:20 -0700 Subject: [PATCH 148/209] indenting all of EDInit --- main/EDInitMod.F90 | 887 ++++++++++++++++++++++----------------------- 1 file changed, 443 insertions(+), 444 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 1a4ebf89b5..ffe56889bc 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -84,7 +84,7 @@ module EDInitMod logical :: debug = .false. character(len=*), parameter, private :: sourcefile = & - __FILE__ + __FILE__ public :: zero_site public :: init_site_vars @@ -125,7 +125,7 @@ subroutine init_site_vars( site_in, bc_in ) allocate(site_in%growthflux_fusion(1:nlevsclass,1:numpft)) allocate(site_in%mass_balance(1:num_elements)) allocate(site_in%flux_diags(1:num_elements)) - + site_in%nlevsoil = bc_in%nlevsoil allocate(site_in%rootfrac_scr(site_in%nlevsoil)) allocate(site_in%zi_soil(0:site_in%nlevsoil)) @@ -141,25 +141,25 @@ subroutine init_site_vars( site_in, bc_in ) allocate(site_in%sp_htop(1:numpft)) do el=1,num_elements - allocate(site_in%flux_diags(el)%leaf_litter_input(1:numpft)) - allocate(site_in%flux_diags(el)%root_litter_input(1:numpft)) - allocate(site_in%flux_diags(el)%nutrient_efflux_scpf(nlevsclass*numpft)) - allocate(site_in%flux_diags(el)%nutrient_uptake_scpf(nlevsclass*numpft)) - allocate(site_in%flux_diags(el)%nutrient_needgrow_scpf(nlevsclass*numpft)) - allocate(site_in%flux_diags(el)%nutrient_needmax_scpf(nlevsclass*numpft)) + allocate(site_in%flux_diags(el)%leaf_litter_input(1:numpft)) + allocate(site_in%flux_diags(el)%root_litter_input(1:numpft)) + allocate(site_in%flux_diags(el)%nutrient_efflux_scpf(nlevsclass*numpft)) + allocate(site_in%flux_diags(el)%nutrient_uptake_scpf(nlevsclass*numpft)) + allocate(site_in%flux_diags(el)%nutrient_needgrow_scpf(nlevsclass*numpft)) + allocate(site_in%flux_diags(el)%nutrient_needmax_scpf(nlevsclass*numpft)) end do ! Initialize the static soil ! arrays from the boundary (initial) condition - + site_in%zi_soil(:) = bc_in%zi_sisl(:) site_in%dz_soil(:) = bc_in%dz_sisl(:) site_in%z_soil(:) = bc_in%z_sisl(:) - + ! - end subroutine init_site_vars + end subroutine init_site_vars ! ============================================================================ subroutine zero_site( site_in ) @@ -178,7 +178,7 @@ subroutine zero_site( site_in ) site_in%oldest_patch => null() ! pointer to oldest patch at the site site_in%youngest_patch => null() ! pointer to yngest patch at the site - + ! PHENOLOGY @@ -206,7 +206,7 @@ subroutine zero_site( site_in ) call site_in%mass_balance(el)%ZeroMassBalFlux() call site_in%flux_diags(el)%ZeroFluxDiags() end do - + ! termination and recruitment info site_in%term_nindivs_canopy(:,:) = 0._r8 @@ -231,7 +231,7 @@ subroutine zero_site( site_in ) site_in%demotion_carbonflux = 0._r8 site_in%promotion_rate(:) = 0._r8 site_in%promotion_carbonflux = 0._r8 - + ! Resources management (logging/harvesting, etc) site_in%resources_management%trunk_product_site = 0.0_r8 @@ -293,95 +293,94 @@ subroutine set_site_properties( nsites, sites,bc_in ) do s = 1,nsites sites(s)%nchilldays = 0 sites(s)%ncolddays = 0 ! recalculated in phenology - ! immediately, so yes this - ! is memory-less, but needed - ! for first value in history file + ! immediately, so yes this + ! is memory-less, but needed + ! for first value in history file sites(s)%cleafondate = cleafon sites(s)%cleafoffdate = cleafoff sites(s)%dleafoffdate = dleafoff sites(s)%dleafondate = dleafon sites(s)%grow_deg_days = GDD - + sites(s)%water_memory(1:numWaterMem) = watermem sites(s)%vegtemp_memory(1:num_vegtemp_mem) = 0._r8 - + sites(s)%cstatus = cstat sites(s)%dstatus = dstat - + sites(s)%acc_NI = acc_NI sites(s)%NF = 0.0_r8 sites(s)%frac_burnt = 0.0_r8 - + if(hlm_use_fixed_biogeog.eq.itrue)then - ! MAPPING OF FATES PFTs on to HLM_PFTs - ! add up the area associated with each FATES PFT - ! where pft_areafrac is the area of land in each HLM PFT and (from surface dataset) - ! hlm_pft_map is the area of that land in each FATES PFT (from param file) - - sites(s)%area_pft(1:numpft) = 0._r8 - do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) - do fates_pft = 1,numpft ! loop round all fates pfts for all hlm pfts - sites(s)%area_pft(fates_pft) = sites(s)%area_pft(fates_pft) + & - EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft) * bc_in(s)%pft_areafrac(hlm_pft) - end do - end do !hlm_pft - - sumarea = sum(sites(s)%area_pft(1:numpft)) - do ft = 1,numpft - if(sites(s)%area_pft(ft).lt.0.01_r8.and.sites(s)%area_pft(ft).gt.0.0_r8)then - write(fates_log(),*) 'removing small pft patches',s,ft,sites(s)%area_pft(ft) - sites(s)%area_pft(ft)=0.0_r8 - ! remove tiny patches to prevent numerical errors in terminate patches + ! MAPPING OF FATES PFTs on to HLM_PFTs + ! add up the area associated with each FATES PFT + ! where pft_areafrac is the area of land in each HLM PFT and (from surface dataset) + ! hlm_pft_map is the area of that land in each FATES PFT (from param file) + + sites(s)%area_pft(1:numpft) = 0._r8 + do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) + do fates_pft = 1,numpft ! loop round all fates pfts for all hlm pfts + sites(s)%area_pft(fates_pft) = sites(s)%area_pft(fates_pft) + & + EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft) * bc_in(s)%pft_areafrac(hlm_pft) + end do + end do !hlm_pft + + do ft = 1,numpft + if(sites(s)%area_pft(ft).lt.0.01_r8.and.sites(s)%area_pft(ft).gt.0.0_r8)then + write(fates_log(),*) 'removing small pft patches',s,ft,sites(s)%area_pft(ft) + sites(s)%area_pft(ft)=0.0_r8 + ! remove tiny patches to prevent numerical errors in terminate patches endif - if(sites(s)%area_pft(ft).lt.0._r8)then - write(fates_log(),*) 'negative area',s,ft,sites(s)%area_pft(ft) - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - sites(s)%area_pft(ft)= sites(s)%area_pft(ft) * AREA ! rescale units to m2. - end do - - ! re-normalize PFT area to ensure it sums to one. - ! note that in areas of 'bare ground' (PFT 0 in CLM/ELM) - ! the bare ground will no longer be proscribed and should emerge from FATES - ! this may or may not be the right way to deal with this? - - if(hlm_use_sp.eq.ifalse)then ! when not in SP mode, subsume bare ground evenly into the existing patches. - !n.b. that it might be better if nocomp mode used the same bare groud logic as SP mode. - sumarea = sum(sites(s)%area_pft(1:numpft)) - do ft = 1,numpft - if(sumarea.gt.0._r8)then - sites(s)%area_pft(ft) = area * sites(s)%area_pft(ft)/sumarea - else - sites(s)%area_pft(ft) = area/numpft - ! in nocomp mode where there is only bare ground, we assign equal area to - ! all pfts and let the model figure out whether land should be bare or not. + if(sites(s)%area_pft(ft).lt.0._r8)then + write(fates_log(),*) 'negative area',s,ft,sites(s)%area_pft(ft) + call endrun(msg=errMsg(sourcefile, __LINE__)) end if - end do !ft - else ! for sp mode, assert a bare ground patch + sites(s)%area_pft(ft)= sites(s)%area_pft(ft) * AREA ! rescale units to m2. + end do + + ! re-normalize PFT area to ensure it sums to one. + ! note that in areas of 'bare ground' (PFT 0 in CLM/ELM) + ! the bare ground will no longer be proscribed and should emerge from FATES + ! this may or may not be the right way to deal with this? + + if(hlm_use_sp.eq.ifalse)then ! when not in SP mode, subsume bare ground evenly into the existing patches. + !n.b. that it might be better if nocomp mode used the same bare groud logic as SP mode. + sumarea = sum(sites(s)%area_pft(1:numpft)) + do ft = 1,numpft + if(sumarea.gt.0._r8)then + sites(s)%area_pft(ft) = area * sites(s)%area_pft(ft)/sumarea + else + sites(s)%area_pft(ft) = area/numpft + ! in nocomp mode where there is only bare ground, we assign equal area to + ! all pfts and let the model figure out whether land should be bare or not. + end if + end do !ft + else ! for sp mode, assert a bare ground patch sumarea = sum(sites(s)%area_pft(1:numpft)) if(sumarea.lt.area)then !make some bare ground - sites(s)%area_bareground = area - sumarea + sites(s)%area_bareground = area - sumarea else - sites(s)%area_bareground = 0.0_r8 + sites(s)%area_bareground = 0.0_r8 end if - end if !sp mode - end if !fixed biogeog - - do ft = 1,numpft - sites(s)%use_this_pft(ft) = itrue - if(hlm_use_fixed_biogeog.eq.itrue)then - if(sites(s)%area_pft(ft).gt.0.0_r8)then - sites(s)%use_this_pft(ft) = itrue - else - sites(s)%use_this_pft(ft) = ifalse - end if !area - end if !SBG - end do !ft + end if !sp mode + end if !fixed biogeog + + do ft = 1,numpft + sites(s)%use_this_pft(ft) = itrue + if(hlm_use_fixed_biogeog.eq.itrue)then + if(sites(s)%area_pft(ft).gt.0.0_r8)then + sites(s)%use_this_pft(ft) = itrue + else + sites(s)%use_this_pft(ft) = ifalse + end if !area + end if !SBG + end do !ft end do !site loop - end if !restart + end if !restart return end subroutine set_site_properties @@ -389,226 +388,226 @@ end subroutine set_site_properties ! ============================================================================ subroutine init_patches( nsites, sites, bc_in) - ! - ! !DESCRIPTION: - ! initialize patches - ! This may be call a near bare ground initialization, or it may - ! load patches from an inventory. - - ! - - - use FatesPlantHydraulicsMod, only : updateSizeDepRhizHydProps - use FatesInventoryInitMod, only : initialize_sites_by_inventory - - ! - ! !ARGUMENTS - integer, intent(in) :: nsites - type(ed_site_type) , intent(inout), target :: sites(nsites) - type(bc_in_type), intent(in) :: bc_in(nsites) - ! - ! !LOCAL VARIABLES: - integer :: s - integer :: el - real(r8) :: age !notional age of this patch - - ! dummy locals - real(r8) :: biomass_stock - real(r8) :: litter_stock - real(r8) :: seed_stock - integer :: n - integer :: start_patch - integer :: num_new_patches - integer :: nocomp_pft - real(r8) :: newparea - real(r8) :: tota !check on area - integer :: is_first_patch - - type(ed_site_type), pointer :: sitep - type(ed_patch_type), pointer :: newppft(:) - type(ed_patch_type), pointer :: newp - type(ed_patch_type), pointer :: recall_older_patch - - ! List out some nominal patch values that are used for Near Bear Ground initializations - ! as well as initializing inventory - age = 0.0_r8 - ! --------------------------------------------------------------------------------------------- - - ! --------------------------------------------------------------------------------------------- - ! Two primary options, either a Near Bear Ground (NBG) or Inventory based cold-start - ! --------------------------------------------------------------------------------------------- - - if ( hlm_use_inventory_init.eq.itrue ) then - - ! Initialize the site-level crown area spread factor (0-1) - ! It is likely that closed canopy forest inventories - ! have smaller spread factors than bare ground (they are crowded) - do s = 1, nsites - sites(s)%spread = init_spread_inventory - enddo - - call initialize_sites_by_inventory(nsites,sites,bc_in) - - - ! For carbon balance checks, we need to initialize the - ! total carbon stock - do s = 1, nsites - do el=1,num_elements - call SiteMassStock(sites(s),el,sites(s)%mass_balance(el)%old_stock, & - biomass_stock,litter_stock,seed_stock) - end do - enddo - - else - - allocate(recall_older_patch) - do s = 1, nsites + ! + ! !DESCRIPTION: + ! initialize patches + ! This may be call a near bare ground initialization, or it may + ! load patches from an inventory. + + ! + + + use FatesPlantHydraulicsMod, only : updateSizeDepRhizHydProps + use FatesInventoryInitMod, only : initialize_sites_by_inventory + + ! + ! !ARGUMENTS + integer, intent(in) :: nsites + type(ed_site_type) , intent(inout), target :: sites(nsites) + type(bc_in_type), intent(in) :: bc_in(nsites) + ! + ! !LOCAL VARIABLES: + integer :: s + integer :: el + real(r8) :: age !notional age of this patch + + ! dummy locals + real(r8) :: biomass_stock + real(r8) :: litter_stock + real(r8) :: seed_stock + integer :: n + integer :: start_patch + integer :: num_new_patches + integer :: nocomp_pft + real(r8) :: newparea + real(r8) :: tota !check on area + integer :: is_first_patch + + type(ed_site_type), pointer :: sitep + type(ed_patch_type), pointer :: newppft(:) + type(ed_patch_type), pointer :: newp + type(ed_patch_type), pointer :: recall_older_patch + + ! List out some nominal patch values that are used for Near Bear Ground initializations + ! as well as initializing inventory + age = 0.0_r8 + ! --------------------------------------------------------------------------------------------- + + ! --------------------------------------------------------------------------------------------- + ! Two primary options, either a Near Bear Ground (NBG) or Inventory based cold-start + ! --------------------------------------------------------------------------------------------- + + if ( hlm_use_inventory_init.eq.itrue ) then + + ! Initialize the site-level crown area spread factor (0-1) + ! It is likely that closed canopy forest inventories + ! have smaller spread factors than bare ground (they are crowded) + do s = 1, nsites + sites(s)%spread = init_spread_inventory + enddo + + call initialize_sites_by_inventory(nsites,sites,bc_in) + + + ! For carbon balance checks, we need to initialize the + ! total carbon stock + do s = 1, nsites + do el=1,num_elements + call SiteMassStock(sites(s),el,sites(s)%mass_balance(el)%old_stock, & + biomass_stock,litter_stock,seed_stock) + end do + enddo + + else + + allocate(recall_older_patch) + do s = 1, nsites sites(s)%sp_tlai(:) = 0._r8 sites(s)%sp_tsai(:) = 0._r8 sites(s)%sp_htop(:) = 0._r8 - ! Initialize the site-level crown area spread factor (0-1) - ! It is likely that closed canopy forest inventories - ! have smaller spread factors than bare ground (they are crowded) - sites(s)%spread = init_spread_near_bare_ground + ! Initialize the site-level crown area spread factor (0-1) + ! It is likely that closed canopy forest inventories + ! have smaller spread factors than bare ground (they are crowded) + sites(s)%spread = init_spread_near_bare_ground start_patch = 1 ! start at the first vegetated patch if(hlm_use_nocomp.eq.itrue)then - num_new_patches = numpft - if(hlm_use_sp.eq.itrue)then - num_new_patches = numpft + 1 ! bare ground patch in SP mode. - start_patch = 0 ! start at the bare ground patch - endif -! allocate(newppft(numpft)) + num_new_patches = numpft + if(hlm_use_sp.eq.itrue)then + num_new_patches = numpft + 1 ! bare ground patch in SP mode. + start_patch = 0 ! start at the bare ground patch + endif + ! allocate(newppft(numpft)) else !default - num_new_patches = 1 - newparea = area + num_new_patches = 1 + newparea = area end if !nocomp - is_first_patch = itrue + is_first_patch = itrue do n = start_patch, num_new_patches - ! set the PFT index for patches if in nocomp mode. - if(hlm_use_nocomp.eq.itrue)then - nocomp_pft = n - else - nocomp_pft = fates_unset_int - end if - - if(hlm_use_nocomp.eq.itrue)then - ! In no competition mode, if we are using the fixed_biogeog filter - ! then each PFT has the area dictated by the surface dataset. - ! If not, each PFT gets the same area. - if(hlm_use_fixed_biogeog.eq.itrue)then - newparea = sites(s)%area_pft(nocomp_pft) - else - newparea = area / numpft - end if - else ! The default case is initialized w/ one patch with the area of the whole site. - newparea = area - end if !nocomp mode - - if(hlm_use_sp.eq.itrue.and.n.eq.0)then ! bare ground patch - newparea = sites(s)%area_bareground - nocomp_pft = 0 - end if - - if(newparea.gt.0._r8)then ! Stop patches being initilialized when PFT not present in nocomop mode - allocate(newp) - - call create_patch(sites(s), newp, age, newparea, primaryforest, nocomp_pft) - - if(is_first_patch.eq.itrue)then !is this the first patch? - ! set poointers for first patch (or only patch, if nocomp is false) - newp%patchno = 1 - newp%younger => null() - newp%older => null() - sites(s)%youngest_patch => newp - sites(s)%oldest_patch => newp - is_first_patch = ifalse - else ! the new patch is the 'oldest' one, arbitrarily. - ! 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 => recall_older_patch - newp%younger => null() - recall_older_patch%younger => newp - sites(s)%youngest_patch => newp - end if - recall_older_patch => newp ! remember this patch for the next one to point at. - - ! Initialize the litter pools to zero, these - ! pools will be populated by looping over the existing patches - ! and transfering in mass - do el=1,num_elements - call newp%litter(el)%InitConditions(init_leaf_fines=0._r8, & - init_root_fines=0._r8, & - init_ag_cwd=0._r8, & - init_bg_cwd=0._r8, & - init_seed=0._r8, & - init_seed_germ=0._r8) - end do + ! set the PFT index for patches if in nocomp mode. + if(hlm_use_nocomp.eq.itrue)then + nocomp_pft = n + else + nocomp_pft = fates_unset_int + end if - 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)) + if(hlm_use_nocomp.eq.itrue)then + ! In no competition mode, if we are using the fixed_biogeog filter + ! then each PFT has the area dictated by the surface dataset. + ! If not, each PFT gets the same area. + if(hlm_use_fixed_biogeog.eq.itrue)then + newparea = sites(s)%area_pft(nocomp_pft) + else + newparea = area / numpft end if - else ! normal non SP case always call init cohorts - call init_cohorts(sitep, newp, bc_in(s)) - end if - end if - end do !no new patches - - !check if the total area adds to the same as site area - tota = 0.0_r8 - newp => sites(s)%oldest_patch - do while (associated(newp)) - tota=tota+newp%area - newp=>newp%younger - end do - - if(abs(tota-area).gt.nearzero*area)then - if(abs(tota-area).lt.1.0e-10_r8)then ! this is a precision error - if(sites(s)%oldest_patch%area.gt.(tota-area+nearzero))then - ! remove or add extra area - ! if the oldest patch has enough area, use that - sites(s)%oldest_patch%area = sites(s)%oldest_patch%area - (tota-area) - write(*,*) 'fixing patch precision - oldest',s, tota-area - else ! or otherwise take the area from the youngest patch. - sites(s)%youngest_patch%area = sites(s)%oldest_patch%area - (tota-area) - write(*,*) 'fixing patch precision -youngest ',s, tota-area - endif - else !this is a big error not just a precision error. - write(*,*) 'issue with patch area in EDinit',tota-area,tota - call endrun(msg=errMsg(sourcefile, __LINE__)) - endif ! big error - end if ! too much patch area + else ! The default case is initialized w/ one patch with the area of the whole site. + newparea = area + end if !nocomp mode + + if(hlm_use_sp.eq.itrue.and.n.eq.0)then ! bare ground patch + newparea = sites(s)%area_bareground + nocomp_pft = 0 + end if + + if(newparea.gt.0._r8)then ! Stop patches being initilialized when PFT not present in nocomop mode + allocate(newp) + + call create_patch(sites(s), newp, age, newparea, primaryforest, nocomp_pft) + + if(is_first_patch.eq.itrue)then !is this the first patch? + ! set poointers for first patch (or only patch, if nocomp is false) + newp%patchno = 1 + newp%younger => null() + newp%older => null() + sites(s)%youngest_patch => newp + sites(s)%oldest_patch => newp + is_first_patch = ifalse + else ! the new patch is the 'oldest' one, arbitrarily. + ! 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 => recall_older_patch + newp%younger => null() + recall_older_patch%younger => newp + sites(s)%youngest_patch => newp + end if + recall_older_patch => newp ! remember this patch for the next one to point at. + + ! Initialize the litter pools to zero, these + ! pools will be populated by looping over the existing patches + ! and transfering in mass + do el=1,num_elements + call newp%litter(el)%InitConditions(init_leaf_fines=0._r8, & + init_root_fines=0._r8, & + init_ag_cwd=0._r8, & + init_bg_cwd=0._r8, & + init_seed=0._r8, & + init_seed_germ=0._r8) + end do + + sitep => sites(s) + if(hlm_use_sp.eq.itrue)then + if(nocomp_pft.ne.0)then !don't initialize cohorts for SP bare ground patch + call init_cohorts(sitep, newp, bc_in(s)) + end if + else ! normal non SP case always call init cohorts + call init_cohorts(sitep, newp, bc_in(s)) + end if + end if + end do !no new patches + + !check if the total area adds to the same as site area + tota = 0.0_r8 + newp => sites(s)%oldest_patch + do while (associated(newp)) + tota=tota+newp%area + newp=>newp%younger + end do + + if(abs(tota-area).gt.nearzero*area)then + if(abs(tota-area).lt.1.0e-10_r8)then ! this is a precision error + if(sites(s)%oldest_patch%area.gt.(tota-area+nearzero))then + ! remove or add extra area + ! if the oldest patch has enough area, use that + sites(s)%oldest_patch%area = sites(s)%oldest_patch%area - (tota-area) + write(*,*) 'fixing patch precision - oldest',s, tota-area + else ! or otherwise take the area from the youngest patch. + sites(s)%youngest_patch%area = sites(s)%oldest_patch%area - (tota-area) + write(*,*) 'fixing patch precision -youngest ',s, tota-area + endif + else !this is a big error not just a precision error. + write(*,*) 'issue with patch area in EDinit',tota-area,tota + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif ! big error + end if ! too much patch area ! For carbon balance checks, we need to initialize the ! total carbon stock do el=1,num_elements call SiteMassStock(sites(s),el,sites(s)%mass_balance(el)%old_stock, & - biomass_stock,litter_stock,seed_stock) + biomass_stock,litter_stock,seed_stock) end do call set_patchno(sites(s)) - enddo !s - end if - - ! This sets the rhizosphere shells based on the plant initialization - ! The initialization of the plant-relevant hydraulics variables - ! were set from a call inside of the init_cohorts()->create_cohort() subroutine - if (hlm_use_planthydro.eq.itrue) then - do s = 1, nsites - sitep => sites(s) - call updateSizeDepRhizHydProps(sitep, bc_in(s)) - end do - deallocate(recall_older_patch) - end if - - return + enddo !s + end if + + ! This sets the rhizosphere shells based on the plant initialization + ! The initialization of the plant-relevant hydraulics variables + ! were set from a call inside of the init_cohorts()->create_cohort() subroutine + if (hlm_use_planthydro.eq.itrue) then + do s = 1, nsites + sitep => sites(s) + call updateSizeDepRhizHydProps(sitep, bc_in(s)) + end do + deallocate(recall_older_patch) + end if + + return end subroutine init_patches ! ============================================================================ @@ -665,186 +664,186 @@ subroutine init_cohorts( site_in, patch_in, bc_in) ! 4. biogeog = true. nocomp = true : patch and site level filter ! in principle this could be a patch level variable. do pft = 1,numpft - ! Turn every PFT ON, unless we are in a special case. - use_pft_local(pft) = itrue ! Case 1 - if(hlm_use_fixed_biogeog.eq.itrue)then !filter geographically - use_pft_local(pft) = site_in%use_this_pft(pft) ! Case 2 - if(hlm_use_nocomp.eq.itrue.and.pft.ne.patch_in%nocomp_pft_label)then - ! Having set the biogeog filter as on or off, turn off all PFTs - ! whose identiy does not correspond to this patch label. - use_pft_local(pft) = ifalse ! Case 3 - endif - else - if(hlm_use_nocomp.eq.itrue.and.pft.ne.patch_in%nocomp_pft_label)then - ! This case has all PFTs on their own patch everywhere. - use_pft_local(pft) = ifalse ! Case 4 - endif - endif + ! Turn every PFT ON, unless we are in a special case. + use_pft_local(pft) = itrue ! Case 1 + if(hlm_use_fixed_biogeog.eq.itrue)then !filter geographically + use_pft_local(pft) = site_in%use_this_pft(pft) ! Case 2 + if(hlm_use_nocomp.eq.itrue.and.pft.ne.patch_in%nocomp_pft_label)then + ! Having set the biogeog filter as on or off, turn off all PFTs + ! whose identiy does not correspond to this patch label. + use_pft_local(pft) = ifalse ! Case 3 + endif + else + if(hlm_use_nocomp.eq.itrue.and.pft.ne.patch_in%nocomp_pft_label)then + ! This case has all PFTs on their own patch everywhere. + use_pft_local(pft) = ifalse ! Case 4 + endif + endif end do do pft = 1,numpft - if(use_pft_local(pft).eq.itrue)then - if(EDPftvarcon_inst%initd(pft)>nearzero) then - - allocate(temp_cohort) ! temporary cohort - - temp_cohort%pft = pft - temp_cohort%n = EDPftvarcon_inst%initd(pft) * patch_in%area - if(hlm_use_nocomp.eq.itrue)then !in nocomp mode we only have one PFT per patch - ! as opposed to numpft's. So we should up the initial density - ! to compensate (otherwise runs are very hard to compare) - ! this multiplies it by the number of PFTs there would have been in - ! the single shared patch in competition mode. - ! n.b. that this is the same as currentcohort%n = %initd(pft) &AREA - temp_cohort%n = temp_cohort%n * sum(site_in%use_this_pft) - endif + if(use_pft_local(pft).eq.itrue)then + if(EDPftvarcon_inst%initd(pft)>nearzero) then + + allocate(temp_cohort) ! temporary cohort + + temp_cohort%pft = pft + temp_cohort%n = EDPftvarcon_inst%initd(pft) * patch_in%area + if(hlm_use_nocomp.eq.itrue)then !in nocomp mode we only have one PFT per patch + ! as opposed to numpft's. So we should up the initial density + ! to compensate (otherwise runs are very hard to compare) + ! this multiplies it by the number of PFTs there would have been in + ! the single shared patch in competition mode. + ! n.b. that this is the same as currentcohort%n = %initd(pft) &AREA + temp_cohort%n = temp_cohort%n * sum(site_in%use_this_pft) + endif + + temp_cohort%canopy_trim = 1.0_r8 + + ! h,dbh,leafc,n from SP values or from small initial size. + + if(hlm_use_sp.eq.itrue)then + init = itrue + call assign_cohort_SP_properties(temp_cohort, 0.5_r8,0.2_r8, 0.1_r8,patch_in%area,init,c_leaf) + + else + temp_cohort%hite = EDPftvarcon_inst%hgt_min(pft) + + ! Calculate the plant diameter from height + call h2d_allom(temp_cohort%hite,pft,temp_cohort%dbh) + + ! Calculate the leaf biomass from allometry + ! (calculates a maximum first, then applies canopy trim) + call bleaf(temp_cohort%dbh,pft,temp_cohort%canopy_trim,c_leaf) + end if ! sp mode + + ! Calculate total above-ground biomass from allometry + call bagw_allom(temp_cohort%dbh,pft,c_agw) + + ! Calculate coarse root biomass from allometry + call bbgw_allom(temp_cohort%dbh,pft,c_bgw) + + ! Calculate fine root biomass from allometry + ! (calculates a maximum and then trimming value) + call bfineroot(temp_cohort%dbh,pft,temp_cohort%canopy_trim,c_fnrt) + + ! Calculate sapwood biomass + call bsap_allom(temp_cohort%dbh,pft,temp_cohort%canopy_trim,a_sapw,c_sapw) + + call bdead_allom( c_agw, c_bgw, c_sapw, pft, c_struct ) + + call bstore_allom(temp_cohort%dbh, pft, temp_cohort%canopy_trim, c_store) + + temp_cohort%laimemory = 0._r8 + temp_cohort%sapwmemory = 0._r8 + temp_cohort%structmemory = 0._r8 + cstatus = leaves_on + + stem_drop_fraction = EDPftvarcon_inst%phen_stem_drop_fraction(temp_cohort%pft) + + + if(hlm_use_sp.eq.ifalse)then ! do not override SP vales with phenology + if ( prt_params%stress_decid(pft) == itrue .and. & + any(site_in%dstatus == [phen_dstat_timeoff,phen_dstat_moistoff])) then + temp_cohort%laimemory = c_leaf + temp_cohort%sapwmemory = c_sapw * stem_drop_fraction + temp_cohort%structmemory = c_struct * stem_drop_fraction + c_leaf = 0._r8 + c_sapw = (1.0_r8-stem_drop_fraction) * c_sapw + c_struct = (1.0_r8-stem_drop_fraction) * c_struct + cstatus = leaves_off + endif + end if ! SP mode + + if ( debug ) write(fates_log(),*) 'EDInitMod.F90 call create_cohort ' + + temp_cohort%coage = 0.0_r8 + + + ! -------------------------------------------------------------------------------- + ! Initialize the mass of every element in every organ of the organ + ! -------------------------------------------------------------------------------- + + prt_obj => null() + call InitPRTObject(prt_obj) + + do el = 1,num_elements + + element_id = element_list(el) + + ! If this is carbon12, then the initialization is straight forward + ! otherwise, we use stoichiometric ratios + select case(element_id) + case(carbon12_element) + + m_struct = c_struct + m_leaf = c_leaf + m_fnrt = c_fnrt + m_sapw = c_sapw + m_store = c_store + m_repro = 0._r8 + + case(nitrogen_element) + + m_struct = c_struct*prt_params%nitr_stoich_p2(pft,struct_organ) + m_leaf = c_leaf*prt_params%nitr_stoich_p2(pft,leaf_organ) + m_fnrt = c_fnrt*prt_params%nitr_stoich_p2(pft,fnrt_organ) + m_sapw = c_sapw*prt_params%nitr_stoich_p2(pft,sapw_organ) + m_store = c_store*prt_params%nitr_stoich_p2(pft,store_organ) + m_repro = 0._r8 + + case(phosphorus_element) + + m_struct = c_struct*prt_params%phos_stoich_p2(pft,struct_organ) + m_leaf = c_leaf*prt_params%phos_stoich_p2(pft,leaf_organ) + m_fnrt = c_fnrt*prt_params%phos_stoich_p2(pft,fnrt_organ) + m_sapw = c_sapw*prt_params%phos_stoich_p2(pft,sapw_organ) + m_store = c_store*prt_params%phos_stoich_p2(pft,store_organ) + m_repro = 0._r8 + end select + + select case(hlm_parteh_mode) + case (prt_carbon_allom_hyp,prt_cnp_flex_allom_hyp ) + + ! Put all of the leaf mass into the first bin + call SetState(prt_obj,leaf_organ, element_id,m_leaf,1) + do iage = 2,nleafage + call SetState(prt_obj,leaf_organ, element_id,0._r8,iage) + end do + + call SetState(prt_obj,fnrt_organ, element_id, m_fnrt) + call SetState(prt_obj,sapw_organ, element_id, m_sapw) + call SetState(prt_obj,store_organ, element_id, m_store) + call SetState(prt_obj,struct_organ, element_id, m_struct) + call SetState(prt_obj,repro_organ, element_id, m_repro) + + case default + write(fates_log(),*) 'Unspecified PARTEH module during create_cohort' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end select - temp_cohort%canopy_trim = 1.0_r8 - - ! h,dbh,leafc,n from SP values or from small initial size. - - if(hlm_use_sp.eq.itrue)then - init = itrue - call assign_cohort_SP_properties(temp_cohort, 0.5_r8,0.2_r8, 0.1_r8,patch_in%area,init,c_leaf) - - else - temp_cohort%hite = EDPftvarcon_inst%hgt_min(pft) - - ! Calculate the plant diameter from height - call h2d_allom(temp_cohort%hite,pft,temp_cohort%dbh) - - ! Calculate the leaf biomass from allometry - ! (calculates a maximum first, then applies canopy trim) - call bleaf(temp_cohort%dbh,pft,temp_cohort%canopy_trim,c_leaf) - end if ! sp mode - - ! Calculate total above-ground biomass from allometry - call bagw_allom(temp_cohort%dbh,pft,c_agw) - - ! Calculate coarse root biomass from allometry - call bbgw_allom(temp_cohort%dbh,pft,c_bgw) - - ! Calculate fine root biomass from allometry - ! (calculates a maximum and then trimming value) - call bfineroot(temp_cohort%dbh,pft,temp_cohort%canopy_trim,c_fnrt) - - ! Calculate sapwood biomass - call bsap_allom(temp_cohort%dbh,pft,temp_cohort%canopy_trim,a_sapw,c_sapw) - - call bdead_allom( c_agw, c_bgw, c_sapw, pft, c_struct ) - - call bstore_allom(temp_cohort%dbh, pft, temp_cohort%canopy_trim, c_store) - - temp_cohort%laimemory = 0._r8 - temp_cohort%sapwmemory = 0._r8 - temp_cohort%structmemory = 0._r8 - cstatus = leaves_on - - stem_drop_fraction = EDPftvarcon_inst%phen_stem_drop_fraction(temp_cohort%pft) - - - if(hlm_use_sp.eq.ifalse)then ! do not override SP vales with phenology - if ( prt_params%stress_decid(pft) == itrue .and. & - any(site_in%dstatus == [phen_dstat_timeoff,phen_dstat_moistoff])) then - temp_cohort%laimemory = c_leaf - temp_cohort%sapwmemory = c_sapw * stem_drop_fraction - temp_cohort%structmemory = c_struct * stem_drop_fraction - c_leaf = 0._r8 - c_sapw = (1.0_r8-stem_drop_fraction) * c_sapw - c_struct = (1.0_r8-stem_drop_fraction) * c_struct - cstatus = leaves_off - endif - end if ! SP mode - - if ( debug ) write(fates_log(),*) 'EDInitMod.F90 call create_cohort ' - - temp_cohort%coage = 0.0_r8 - - - ! -------------------------------------------------------------------------------- - ! Initialize the mass of every element in every organ of the organ - ! -------------------------------------------------------------------------------- - - prt_obj => null() - call InitPRTObject(prt_obj) - - do el = 1,num_elements - - element_id = element_list(el) - - ! If this is carbon12, then the initialization is straight forward - ! otherwise, we use stoichiometric ratios - select case(element_id) - case(carbon12_element) - - m_struct = c_struct - m_leaf = c_leaf - m_fnrt = c_fnrt - m_sapw = c_sapw - m_store = c_store - m_repro = 0._r8 - - case(nitrogen_element) - - m_struct = c_struct*prt_params%nitr_stoich_p2(pft,struct_organ) - m_leaf = c_leaf*prt_params%nitr_stoich_p2(pft,leaf_organ) - m_fnrt = c_fnrt*prt_params%nitr_stoich_p2(pft,fnrt_organ) - m_sapw = c_sapw*prt_params%nitr_stoich_p2(pft,sapw_organ) - m_store = c_store*prt_params%nitr_stoich_p2(pft,store_organ) - m_repro = 0._r8 - - case(phosphorus_element) - - m_struct = c_struct*prt_params%phos_stoich_p2(pft,struct_organ) - m_leaf = c_leaf*prt_params%phos_stoich_p2(pft,leaf_organ) - m_fnrt = c_fnrt*prt_params%phos_stoich_p2(pft,fnrt_organ) - m_sapw = c_sapw*prt_params%phos_stoich_p2(pft,sapw_organ) - m_store = c_store*prt_params%phos_stoich_p2(pft,store_organ) - m_repro = 0._r8 - end select - - select case(hlm_parteh_mode) - case (prt_carbon_allom_hyp,prt_cnp_flex_allom_hyp ) - - ! Put all of the leaf mass into the first bin - call SetState(prt_obj,leaf_organ, element_id,m_leaf,1) - do iage = 2,nleafage - call SetState(prt_obj,leaf_organ, element_id,0._r8,iage) end do - - call SetState(prt_obj,fnrt_organ, element_id, m_fnrt) - call SetState(prt_obj,sapw_organ, element_id, m_sapw) - call SetState(prt_obj,store_organ, element_id, m_store) - call SetState(prt_obj,struct_organ, element_id, m_struct) - call SetState(prt_obj,repro_organ, element_id, m_repro) - - case default - write(fates_log(),*) 'Unspecified PARTEH module during create_cohort' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end select - - end do - call prt_obj%CheckInitialConditions() + call prt_obj%CheckInitialConditions() - call create_cohort(site_in, patch_in, pft, temp_cohort%n, temp_cohort%hite, & - temp_cohort%coage, temp_cohort%dbh, prt_obj, temp_cohort%laimemory, & - temp_cohort%sapwmemory, temp_cohort%structmemory, cstatus, rstatus, & - temp_cohort%canopy_trim, temp_cohort%c_area,1, site_in%spread, bc_in) + call create_cohort(site_in, patch_in, pft, temp_cohort%n, temp_cohort%hite, & + temp_cohort%coage, temp_cohort%dbh, prt_obj, temp_cohort%laimemory, & + temp_cohort%sapwmemory, temp_cohort%structmemory, cstatus, rstatus, & + temp_cohort%canopy_trim, temp_cohort%c_area,1, site_in%spread, bc_in) - deallocate(temp_cohort) ! get rid of temporary cohort + deallocate(temp_cohort) ! get rid of temporary cohort - endif - endif !use_this_pft + endif + endif !use_this_pft enddo !numpft ! Zero the mass flux pools of the new cohorts -! temp_cohort => patch_in%tallest -! do while(associated(temp_cohort)) -! call temp_cohort%prt%ZeroRates() -! temp_cohort => temp_cohort%shorter -! end do + ! temp_cohort => patch_in%tallest + ! do while(associated(temp_cohort)) + ! call temp_cohort%prt%ZeroRates() + ! temp_cohort => temp_cohort%shorter + ! end do call fuse_cohorts(site_in, patch_in,bc_in) call sort_cohorts(patch_in) From 125c850461e05c503bacf915af2a0bbc16a5c8a3 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 25 Nov 2020 08:38:34 -0700 Subject: [PATCH 149/209] editing comments for clarity from CDK/HT review --- biogeochem/FatesAllometryMod.F90 | 4 ++-- main/EDInitMod.F90 | 15 ++++++++++++++- 2 files changed, 16 insertions(+), 3 deletions(-) diff --git a/biogeochem/FatesAllometryMod.F90 b/biogeochem/FatesAllometryMod.F90 index 00ded88348..dbdd445693 100644 --- a/biogeochem/FatesAllometryMod.F90 +++ b/biogeochem/FatesAllometryMod.F90 @@ -762,8 +762,8 @@ end function tree_sai real(r8) function leafc_from_treelai( treelai, pft, c_area, nplant, cl, vcmax25top) ! ----------------------------------------------------------------------------------- - ! LAI of individual trees is a function of the total leaf area and the total - ! canopy area. + ! Calculates the amount of leaf carbon which is needed to generate a given treelai. + ! iss the inverse of the 'tree_lai function. ! ---------------------------------------------------------------------------------- ! !ARGUMENTS diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index ffe56889bc..f010574ac8 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -361,6 +361,16 @@ subroutine set_site_properties( nsites, sites,bc_in ) else ! for sp mode, assert a bare ground patch sumarea = sum(sites(s)%area_pft(1:numpft)) + ! In all the other FATES modes, bareground is the area in which plants + ! do not grow of their own accord. In SP mod wweassert that the canopy is full for + ! each PFT patche. Thus, we also need to assert a bare ground area in + ! order to not have all of the ground filled by leaves. + + ! Further to that, one could calculate bare ground as the remaining area when + ! all fhe canopies are accounted for, but this means we don't pass balance checks + ! on canopy are inside FATES, and so in SP mode, we define the bare groud + ! patch as having a PFT identifier as zero. + if(sumarea.lt.area)then !make some bare ground sites(s)%area_bareground = area - sumarea else @@ -497,7 +507,10 @@ subroutine init_patches( nsites, sites, bc_in) if(hlm_use_nocomp.eq.itrue)then ! In no competition mode, if we are using the fixed_biogeog filter ! then each PFT has the area dictated by the surface dataset. - ! If not, each PFT gets the same area. + + ! If we are not using fixed biogeog model, each PFT gets the same area. + ! i.e. each grid cell is divided exactly into the number of FATES PFTs. + if(hlm_use_fixed_biogeog.eq.itrue)then newparea = sites(s)%area_pft(nocomp_pft) else From 1d3f4c010529d3135f8cd22d8c056f18ea023d56 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 25 Nov 2020 08:43:42 -0700 Subject: [PATCH 150/209] indenting and comments in EDSurfaceAlbedoMod.F90 --- biogeophys/EDSurfaceAlbedoMod.F90 | 2164 +++++++++++++++-------------- 1 file changed, 1085 insertions(+), 1079 deletions(-) diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index 60a8f69ecf..c59f81b47f 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -1,15 +1,15 @@ module EDSurfaceRadiationMod - - !------------------------------------------------------------------------------------- - ! EDSurfaceRadiation - ! - ! This module contains function and type definitions for all things related - ! to radiative transfer in ED modules at the land surface. - ! - !------------------------------------------------------------------------------------- + + !------------------------------------------------------------------------------------- + ! EDSurfaceRadiation + ! + ! This module contains function and type definitions for all things related + ! to radiative transfer in ED modules at the land surface. + ! + !------------------------------------------------------------------------------------- #include "shr_assert.h" - + use EDTypesMod , only : ed_patch_type, ed_site_type use EDTypesMod , only : maxPatchesPerSite use EDTypesMod , only : maxpft @@ -42,132 +42,135 @@ module EDSurfaceRadiationMod public :: ED_Norman_Radiation ! Surface albedo and two-stream fluxes public :: PatchNormanRadiation public :: ED_SunShadeFracs - + logical :: debug = .false. ! for debugging this module - + real(r8), public :: albice(maxSWb) = & ! albedo land ice by waveband (1=vis, 2=nir) - (/ 0.80_r8, 0.55_r8 /) + (/ 0.80_r8, 0.55_r8 /) contains - + subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) - ! - - ! - ! !USES: - use EDPftvarcon , only : EDPftvarcon_inst - use EDtypesMod , only : ed_patch_type - use EDTypesMod , only : ed_site_type - - - ! !ARGUMENTS: - - integer, intent(in) :: nsites - type(ed_site_type), intent(inout), target :: sites(nsites) ! FATES site vector - type(bc_in_type), intent(in) :: bc_in(nsites) - type(bc_out_type), intent(inout) :: bc_out(nsites) - - - ! !LOCAL VARIABLES: - integer :: s ! site loop counter - integer :: ifp ! patch loop counter - integer :: ib ! radiation broad band counter - type(ed_patch_type), pointer :: currentPatch ! patch pointer - - !----------------------------------------------------------------------- - ! ------------------------------------------------------------------------------- - ! TODO (mv, 2014-10-29) the filter here is different than below - ! this is needed to have the VOC's be bfb - this needs to be - ! re-examined int he future - ! RGK,2016-08-06: FATES is still incompatible with VOC emission module - ! ------------------------------------------------------------------------------- - - - do s = 1, nsites - - ifp = 0 - currentpatch => sites(s)%oldest_patch - do while (associated(currentpatch)) - if(currentpatch%nocomp_pft_label.ne.0)then - ifp = ifp+1 - - currentPatch%f_sun (:,:,:) = 0._r8 - currentPatch%fabd_sun_z (:,:,:) = 0._r8 - currentPatch%fabd_sha_z (:,:,:) = 0._r8 - currentPatch%fabi_sun_z (:,:,:) = 0._r8 - currentPatch%fabi_sha_z (:,:,:) = 0._r8 - currentPatch%fabd (:) = 0._r8 - currentPatch%fabi (:) = 0._r8 - - ! zero diagnostic radiation profiles - currentPatch%nrmlzd_parprof_pft_dir_z(:,:,:,:) = 0._r8 - currentPatch%nrmlzd_parprof_pft_dif_z(:,:,:,:) = 0._r8 - currentPatch%nrmlzd_parprof_dir_z(:,:,:) = 0._r8 - currentPatch%nrmlzd_parprof_dif_z(:,:,:) = 0._r8 - - currentPatch%solar_zenith_flag = bc_in(s)%filter_vegzen_pa(ifp) - currentPatch%solar_zenith_angle = bc_in(s)%coszen_pa(ifp) - currentPatch%gnd_alb_dif(1:hlm_numSWb) = bc_in(s)%albgr_dif_rb(1:hlm_numSWb) - currentPatch%gnd_alb_dir(1:hlm_numSWb) = bc_in(s)%albgr_dir_rb(1:hlm_numSWb) - - if(currentPatch%solar_zenith_flag )then - - bc_out(s)%albd_parb(ifp,:) = 0._r8 ! output HLM - bc_out(s)%albi_parb(ifp,:) = 0._r8 ! output HLM - bc_out(s)%fabi_parb(ifp,:) = 0._r8 ! output HLM - bc_out(s)%fabd_parb(ifp,:) = 0._r8 ! output HLM - bc_out(s)%ftdd_parb(ifp,:) = 1._r8 ! output HLM - bc_out(s)%ftid_parb(ifp,:) = 1._r8 ! output HLM - bc_out(s)%ftii_parb(ifp,:) = 1._r8 ! output HLM - - if (maxval(currentPatch%nrad(1,:))==0)then - !there are no leaf layers in this patch. it is effectively bare ground. - ! no radiation is absorbed - bc_out(s)%fabd_parb(ifp,:) = 0.0_r8 - bc_out(s)%fabi_parb(ifp,:) = 0.0_r8 - do ib = 1,hlm_numSWb - bc_out(s)%albd_parb(ifp,ib) = bc_in(s)%albgr_dir_rb(ib) - bc_out(s)%albi_parb(ifp,ib) = bc_in(s)%albgr_dif_rb(ib) - bc_out(s)%ftdd_parb(ifp,ib)= 1.0_r8 - bc_out(s)%ftid_parb(ifp,ib)= 1.0_r8 - bc_out(s)%ftii_parb(ifp,ib)= 1.0_r8 - enddo - - else - - call PatchNormanRadiation (currentPatch, & - bc_out(s)%albd_parb(ifp,:), & - bc_out(s)%albi_parb(ifp,:), & - bc_out(s)%fabd_parb(ifp,:), & - bc_out(s)%fabi_parb(ifp,:), & - bc_out(s)%ftdd_parb(ifp,:), & - bc_out(s)%ftid_parb(ifp,:), & - bc_out(s)%ftii_parb(ifp,:)) - - - endif ! is there vegetation? - - end if ! if the vegetation and zenith filter is active - endif ! not bare ground - currentPatch => currentPatch%younger - end do ! Loop linked-list patches - enddo ! Loop Sites - - return - end subroutine ED_Norman_Radiation - - - ! ====================================================================================== + ! + + ! + ! !USES: + use EDPftvarcon , only : EDPftvarcon_inst + use EDtypesMod , only : ed_patch_type + use EDTypesMod , only : ed_site_type + + + ! !ARGUMENTS: + + integer, intent(in) :: nsites + type(ed_site_type), intent(inout), target :: sites(nsites) ! FATES site vector + type(bc_in_type), intent(in) :: bc_in(nsites) + type(bc_out_type), intent(inout) :: bc_out(nsites) + + + ! !LOCAL VARIABLES: + integer :: s ! site loop counter + integer :: ifp ! patch loop counter + integer :: ib ! radiation broad band counter + type(ed_patch_type), pointer :: currentPatch ! patch pointer + + !----------------------------------------------------------------------- + ! ------------------------------------------------------------------------------- + ! TODO (mv, 2014-10-29) the filter here is different than below + ! this is needed to have the VOC's be bfb - this needs to be + ! re-examined int he future + ! RGK,2016-08-06: FATES is still incompatible with VOC emission module + ! ------------------------------------------------------------------------------- + + + do s = 1, nsites + + ifp = 0 + currentpatch => sites(s)%oldest_patch + do while (associated(currentpatch)) + if(currentpatch%nocomp_pft_label.ne.0)then + ! do not do albedo calculations for bare ground patch in SP mode + ! and (more impotantly) do not iterate ifp or it will mess up the indexing wherein + ! ifp=1 is the first vegetated patch. + ifp = ifp+1 + + currentPatch%f_sun (:,:,:) = 0._r8 + currentPatch%fabd_sun_z (:,:,:) = 0._r8 + currentPatch%fabd_sha_z (:,:,:) = 0._r8 + currentPatch%fabi_sun_z (:,:,:) = 0._r8 + currentPatch%fabi_sha_z (:,:,:) = 0._r8 + currentPatch%fabd (:) = 0._r8 + currentPatch%fabi (:) = 0._r8 + + ! zero diagnostic radiation profiles + currentPatch%nrmlzd_parprof_pft_dir_z(:,:,:,:) = 0._r8 + currentPatch%nrmlzd_parprof_pft_dif_z(:,:,:,:) = 0._r8 + currentPatch%nrmlzd_parprof_dir_z(:,:,:) = 0._r8 + currentPatch%nrmlzd_parprof_dif_z(:,:,:) = 0._r8 + + currentPatch%solar_zenith_flag = bc_in(s)%filter_vegzen_pa(ifp) + currentPatch%solar_zenith_angle = bc_in(s)%coszen_pa(ifp) + currentPatch%gnd_alb_dif(1:hlm_numSWb) = bc_in(s)%albgr_dif_rb(1:hlm_numSWb) + currentPatch%gnd_alb_dir(1:hlm_numSWb) = bc_in(s)%albgr_dir_rb(1:hlm_numSWb) + + if(currentPatch%solar_zenith_flag )then + + bc_out(s)%albd_parb(ifp,:) = 0._r8 ! output HLM + bc_out(s)%albi_parb(ifp,:) = 0._r8 ! output HLM + bc_out(s)%fabi_parb(ifp,:) = 0._r8 ! output HLM + bc_out(s)%fabd_parb(ifp,:) = 0._r8 ! output HLM + bc_out(s)%ftdd_parb(ifp,:) = 1._r8 ! output HLM + bc_out(s)%ftid_parb(ifp,:) = 1._r8 ! output HLM + bc_out(s)%ftii_parb(ifp,:) = 1._r8 ! output HLM + + if (maxval(currentPatch%nrad(1,:))==0)then + !there are no leaf layers in this patch. it is effectively bare ground. + ! no radiation is absorbed + bc_out(s)%fabd_parb(ifp,:) = 0.0_r8 + bc_out(s)%fabi_parb(ifp,:) = 0.0_r8 + do ib = 1,hlm_numSWb + bc_out(s)%albd_parb(ifp,ib) = bc_in(s)%albgr_dir_rb(ib) + bc_out(s)%albi_parb(ifp,ib) = bc_in(s)%albgr_dif_rb(ib) + bc_out(s)%ftdd_parb(ifp,ib)= 1.0_r8 + bc_out(s)%ftid_parb(ifp,ib)= 1.0_r8 + bc_out(s)%ftii_parb(ifp,ib)= 1.0_r8 + enddo + + else + + call PatchNormanRadiation (currentPatch, & + bc_out(s)%albd_parb(ifp,:), & + bc_out(s)%albi_parb(ifp,:), & + bc_out(s)%fabd_parb(ifp,:), & + bc_out(s)%fabi_parb(ifp,:), & + bc_out(s)%ftdd_parb(ifp,:), & + bc_out(s)%ftid_parb(ifp,:), & + bc_out(s)%ftii_parb(ifp,:)) + + + endif ! is there vegetation? + + end if ! if the vegetation and zenith filter is active + endif ! not bare ground + currentPatch => currentPatch%younger + end do ! Loop linked-list patches + enddo ! Loop Sites + + return + end subroutine ED_Norman_Radiation + + + ! ====================================================================================== subroutine PatchNormanRadiation (currentPatch, & - albd_parb_out, & ! (ifp,ib) - albi_parb_out, & ! (ifp,ib) - fabd_parb_out, & ! (ifp,ib) - fabi_parb_out, & ! (ifp,ib) - ftdd_parb_out, & ! (ifp,ib) - ftid_parb_out, & ! (ifp,ib) - ftii_parb_out) ! (ifp,ib) + albd_parb_out, & ! (ifp,ib) + albi_parb_out, & ! (ifp,ib) + fabd_parb_out, & ! (ifp,ib) + fabi_parb_out, & ! (ifp,ib) + ftdd_parb_out, & ! (ifp,ib) + ftid_parb_out, & ! (ifp,ib) + ftii_parb_out) ! (ifp,ib) ! ----------------------------------------------------------------------------------- ! @@ -183,7 +186,7 @@ subroutine PatchNormanRadiation (currentPatch, & ! ----------------------------------------------------------------------------------- ! !ARGUMENTS: ! ----------------------------------------------------------------------------------- - + type(ed_patch_type), intent(inout), target :: currentPatch real(r8), intent(inout) :: albd_parb_out(hlm_numSWb) real(r8), intent(inout) :: albi_parb_out(hlm_numSWb) @@ -227,28 +230,28 @@ subroutine PatchNormanRadiation (currentPatch, & real(r8) :: phi2b(maxpft) real(r8) :: laisum ! cumulative lai+sai for canopy layer (at middle of layer) real(r8) :: angle - + real(r8),parameter :: tolerance = 0.000000001_r8 - - + + integer, parameter :: max_diag_nlevleaf = 4 integer, parameter :: diag_nlevleaf = min(nlevleaf,max_diag_nlevleaf) ! for diagnostics, write a small number of leaf layers - + real(r8) :: denom real(r8) :: lai_reduction(nclmax) - + integer :: fp,iv,s ! array indices integer :: ib ! waveband number real(r8) :: cosz ! 0.001 <= coszen <= 1.000 real(r8) :: chil real(r8) :: gdir - + real(r8), parameter :: forc_dir(n_rad_stream_types) = (/ 1.0_r8, 0.0_r8 /) ! These are binary switches used real(r8), parameter :: forc_dif(n_rad_stream_types) = (/ 0.0_r8, 1.0_r8 /) ! to turn off and on radiation streams - + associate(& rhol => EDPftvarcon_inst%rhol , & ! Input: [real(r8) (:) ] leaf reflectance: 1=vis, 2=nir rhos => EDPftvarcon_inst%rhos , & ! Input: [real(r8) (:) ] stem reflectance: 1=vis, 2=nir @@ -260,955 +263,958 @@ subroutine PatchNormanRadiation (currentPatch, & ! Initialize local arrays - weighted_dir_tr(:) = 0._r8 - weighted_dif_down(:) = 0._r8 - weighted_dif_up(:) = 0._r8 - - tr_dir_z(:,:,:) = 0._r8 - tr_dif_z(:,:,:) = 0._r8 - lai_change(:,:,:) = 0._r8 - Dif_up(:,:,:) = 0._r8 - Dif_dn(:,:,:) = 0._r8 - refl_dif(:,:,:,:) = 0.0_r8 - tran_dif(:,:,:,:) = 0.0_r8 - dif_ratio(:,:,:,:) = 0.0_r8 - - - ! Initialize the ouput arrays - ! --------------------------------------------------------------------------------- - albd_parb_out(1:hlm_numSWb) = 0.0_r8 - albi_parb_out(1:hlm_numSWb) = 0.0_r8 - fabd_parb_out(1:hlm_numSWb) = 0.0_r8 - fabi_parb_out(1:hlm_numSWb) = 0.0_r8 - ftdd_parb_out(1:hlm_numSWb) = 1.0_r8 - ftid_parb_out(1:hlm_numSWb) = 1.0_r8 - ftii_parb_out(1:hlm_numSWb) = 1.0_r8 - - ! Is this pft/canopy layer combination present in this patch? - - do L = 1,nclmax - do ft = 1,numpft - currentPatch%canopy_mask(L,ft) = 0 - do iv = 1, currentPatch%nrad(L,ft) - if (currentPatch%canopy_area_profile(L,ft,iv) > 0._r8)then - currentPatch%canopy_mask(L,ft) = 1 - !I think 'present' is only used here... - endif - end do !iv - end do !ft - end do !L - - - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! Direct beam extinction coefficient, k_dir. PFT specific. - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - cosz = max(0.001_r8, currentPatch%solar_zenith_angle ) !copied from previous radiation code... - do ft = 1,numpft - sb = (90._r8 - (acos(cosz)*180._r8/pi_const)) * (pi_const / 180._r8) - chil = xl(ft) !min(max(xl(ft), -0.4_r8), 0.6_r8 ) - if ( abs(chil) <= 0.01_r8) then - chil = 0.01_r8 - end if - phi1b(ft) = 0.5_r8 - 0.633_r8*chil - 0.330_r8*chil*chil - phi2b(ft) = 0.877_r8 * (1._r8 - 2._r8*phi1b(ft)) !0 = horiz leaves, 1 - vert leaves. - gdir = phi1b(ft) + phi2b(ft) * sin(sb) - !how much direct light penetrates a singleunit of lai? - k_dir(ft) = clumping_index(ft) * gdir / sin(sb) - end do !FT - - - - - !do this once for one unit of diffuse, and once for one unit of direct radiation - do radtype = 1, n_rad_stream_types - - ! Extract information that needs to be provided by ED into local array. - ! RGK: NOT SURE WHY WE NEED FTWEIGHT ... - ! ------------------------------------------------------------------------------ - - ftweight(:,:,:) = 0._r8 - do L = 1,currentPatch%NCL_p - do ft = 1,numpft - do iv = 1, currentPatch%nrad(L,ft) - !this is already corrected for area in CLAP - ftweight(L,ft,iv) = currentPatch%canopy_area_profile(L,ft,iv) - end do !iv - end do !ft1 - end do !L - if (sum(ftweight(1,:,1))<0.999_r8)then - write(fates_log(),*) 'canopy not full',ftweight(1,:,1) - endif - if (sum(ftweight(1,:,1))>1.0001_r8)then - write(fates_log(),*) 'canopy too full',ftweight(1,:,1) - endif - - do L = 1,currentPatch%NCL_p !start at the top canopy layer (1 is the top layer.) - - weighted_dir_tr(L) = 0.0_r8 - weighted_fsun(L) = 0._r8 - weighted_dif_ratio(L,1:hlm_numSWb) = 0._r8 - - !Each canopy layer (canopy, understorey) has multiple 'parallel' pft's - - do ft =1,numpft - - if (currentPatch%canopy_mask(L,ft) == 1)then !only do calculation if there are the appropriate leaves. - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! Diffuse transmittance, tr_dif, do each layer with thickness elai_z. - ! Estimated do nine sky angles in increments of 10 degrees - ! PFT specific... - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - tr_dif_z(L,ft,:) = 0._r8 - do iv = 1,currentPatch%nrad(L,ft) - do j = 1,9 - angle = (5._r8 + real(j - 1,r8) * 10._r8) * pi_const / 180._r8 - gdir = phi1b(ft) + phi2b(ft) * sin(angle) - tr_dif_z(L,ft,iv) = tr_dif_z(L,ft,iv) + exp(-clumping_index(ft) * & - gdir / sin(angle) * & - (currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv))) * & - sin(angle)*cos(angle) - end do - - tr_dif_z(L,ft,iv) = tr_dif_z(L,ft,iv) * 2._r8 * (10._r8 * pi_const / 180._r8) - - end do - - - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! Direct beam transmittance, tr_dir_z, uses cumulative LAI above layer J to give - ! unscattered direct beam onto layer J. do each PFT section. - ! This is just an decay curve based on k_dir. (leaf & sun angle) - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - if (L==1)then - tr_dir_z(L,ft,1) = 1._r8 - else - tr_dir_z(L,ft,1) = weighted_dir_tr(L-1) - endif - laisum = 0.00_r8 - !total direct beam getting to the bottom of the top canopy. - do iv = 1,currentPatch%nrad(L,ft) - laisum = laisum + currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv) - lai_change(L,ft,iv) = 0.0_r8 - if (( ftweight(L,ft,iv+1) > 0.0_r8 ) .and. ( ftweight(L,ft,iv+1) < ftweight(L,ft,iv) ))then - !where there is a partly empty leaf layer, some fluxes go straight through. - lai_change(L,ft,iv) = ftweight(L,ft,iv)-ftweight(L,ft,iv+1) - endif - if (ftweight(L,ft,iv+1) - ftweight(L,ft,iv) > 1.e-10_r8)then - write(fates_log(),*) 'lower layer has more coverage. This is wrong' , & - ftweight(L,ft,iv),ftweight(L,ft,iv+1),ftweight(L,ft,iv+1)-ftweight(L,ft,iv) - endif - - !n.b. in theory lai_change could be calculated daily in the ED code. - !This is light coming striaght through the canopy. - if (L==1)then - tr_dir_z(L,ft,iv+1) = exp(-k_dir(ft) * laisum)* & - (ftweight(L,ft,iv)/ftweight(L,ft,1)) - else - tr_dir_z(L,ft,iv+1) = weighted_dir_tr(L-1)*exp(-k_dir(ft) * laisum)* & - (ftweight(L,ft,iv)/ftweight(L,ft,1)) - endif - - if (iv == 1)then - !this is the top layer. - tr_dir_z(L,ft,iv+1) = tr_dir_z(L,ft,iv+1) + tr_dir_z(L,ft,iv) * & - ((ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1)) - else - !the lai_change(iv) affects the light incident on layer iv+2 not iv+1 - ! light coming from the layer above (iv-1) goes through iv and onto iv+1. - if (lai_change(L,ft,iv-1) > 0.0_r8)then - tr_dir_z(L,ft,iv+1) = tr_dir_z(L,ft,iv+1) + tr_dir_z(L,ft,iv)* & - lai_change(L,ft,iv-1) / ftweight(L,ft,1) - tr_dir_z(L,ft,iv+1) = tr_dir_z(L,ft,iv+1) + tr_dir_z(L,ft,iv-1)* & - (ftweight(L,ft,1)-ftweight(L,ft,iv-1))/ftweight(L,ft,1) - else - !account fot the light that comes striaght down from unfilled layers above. - tr_dir_z(L,ft,iv+1) = tr_dir_z(L,ft,iv+1) + tr_dir_z(L,ft,iv) * & - ((ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1)) - endif - endif - - end do - - !add up all the weighted contributions from the different PFT columns. - weighted_dir_tr(L) = weighted_dir_tr(L) + tr_dir_z(L,ft,currentPatch%nrad(L,ft)+1)*ftweight(L,ft,1) - - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! Sunlit and shaded fraction of leaf layer - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - - !laisum = 0._r8 - do iv = 1,currentPatch%nrad(L,ft) - ! Cumulative leaf area. Original code uses cumulative lai do layer. - ! Now use cumulative lai at center of layer. - ! Same as tr_dir_z calcualtions, but in the middle of the layer? FIX(RF,032414)-WHY? - if (iv == 1) then - laisum = 0.5_r8 * (currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv)) - else - laisum = laisum + currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv) - end if - - - if (L == 1)then !top canopy layer - currentPatch%f_sun(L,ft,iv) = exp(-k_dir(ft) * laisum)* & - (ftweight(L,ft,iv)/ftweight(L,ft,1)) - else - currentPatch%f_sun(L,ft,iv) = weighted_fsun(L-1)* exp(-k_dir(ft) * laisum)* & - (ftweight(L,ft,iv)/ftweight(L,ft,1)) - endif - - if ( iv > 1 ) then ! becasue we are looking at this layer (not the next) - ! we only ever add fluxes if iv>1 - if (lai_change(L,ft,iv-1) > 0.0_r8)then - currentPatch%f_sun(L,ft,iv) = currentPatch%f_sun(L,ft,iv) + & - currentPatch%f_sun(L,ft,iv) * & - lai_change(L,ft,iv-1)/ftweight(L,ft,1) - currentPatch%f_sun(L,ft,iv) = currentPatch%f_sun(L,ft,iv) + & - currentPatch%f_sun(L,ft,iv-1) * & - (ftweight(L,ft,1)-ftweight(L,ft,iv-1))/ftweight(L,ft,1) - else - currentPatch%f_sun(L,ft,iv) = currentPatch%f_sun(L,ft,iv) + & - currentPatch%f_sun(L,ft,iv-1) * & - (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) - endif - endif - - end do !iv - - weighted_fsun(L) = weighted_fsun(L) + currentPatch%f_sun(L,ft,currentPatch%nrad(L,ft))* & - ftweight(L,ft,1) - - ! instance where the first layer ftweight is used a proxy for the whole column. FTWA - ! this is possibly a source of slight error. If we use the ftweight at the top of the PFT column, - ! then we willl underestimate fsun, but if we use ftweight at the bottom of the column, we will - ! underestimate it. Really, we should be tracking the release of direct light from the column as it tapers - ! towards the ground. Is that necessary to get energy closure? It would be quite hard... - endif !present. - end do!pft loop - end do !L - - - do L = currentPatch%NCL_p,1, -1 !start at the bottom and work up. - do ft = 1,numpft - if (currentPatch%canopy_mask(L,ft) == 1)then - - !==============================================================================! - ! Iterative solution do scattering - !==============================================================================! - - do ib = 1,hlm_numSWb !vis, nir - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! Leaf scattering coefficient and terms do diffuse radiation reflected - ! and transmitted by a layer - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - f_not_abs(ft,ib) = rhol(ft,ib) + taul(ft,ib) !leaf level fraction NOT absorbed. - !tr_dif_z is a term that uses the LAI in each layer, whereas rhol and taul do not, - !because they are properties of leaf surfaces and not of the leaf matrix. - do iv = 1,currentPatch%nrad(L,ft) - !How much diffuse light is intercepted and then reflected? - refl_dif(L,ft,iv,ib) = (1._r8 - tr_dif_z(L,ft,iv)) * rhol(ft,ib) - !How much diffuse light in this layer is transmitted? - tran_dif(L,ft,iv,ib) = (1._r8 - tr_dif_z(L,ft,iv)) * & - taul(ft,ib) + tr_dif_z(L,ft,iv) - end do - - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! Ratio of upward to forward diffuse fluxes, dif_ratio - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! Soil diffuse reflectance (ratio of down to up radiation). - iv = currentPatch%nrad(L,ft) + 1 - if (L == currentPatch%NCL_p)then !nearest the soil - dif_ratio(L,ft,iv,ib) = currentPatch%gnd_alb_dif(ib) !bc_in(s)%albgr_dif_rb(ib) - else - dif_ratio(L,ft,iv,ib) = weighted_dif_ratio(L+1,ib) - end if - ! Canopy layers, working upwardfrom soil with dif_ratio(iv+1) known - ! FIX(RF,032414) ray tracing eqution - need to find derivation of this... - ! for each unit going down, there are x units going up. - do iv = currentPatch%nrad(L,ft),1, -1 - dif_ratio(L,ft,iv,ib) = dif_ratio(L,ft,iv+1,ib) * & - tran_dif(L,ft,iv,ib)*tran_dif(L,ft,iv,ib) / & - (1._r8 - dif_ratio(L,ft,iv+1,ib) * refl_dif(L,ft,iv,ib)) & - + refl_dif(L,ft,iv,ib) - dif_ratio(L,ft,iv,ib) = dif_ratio(L,ft,iv,ib) * & - ftweight(L,ft,iv)/ftweight(L,ft,1) - dif_ratio(L,ft,iv,ib) = dif_ratio(L,ft,iv,ib) + dif_ratio(L,ft,iv+1,ib) * & - (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) - end do - weighted_dif_ratio(L,ib) = weighted_dif_ratio(L,ib) + & - dif_ratio(L,ft,1,ib) * ftweight(L,ft,1) - !instance where the first layer ftweight is used a proxy for the whole column. FTWA - end do!hlm_numSWb - endif ! currentPatch%canopy_mask - end do!ft - end do!L - - - do ib = 1,hlm_numSWb - Dif_dn(:,:,:) = 0.00_r8 - Dif_up(:,:,:) = 0.00_r8 - do L = 1, currentPatch%NCL_p !work down from the top of the canopy. - weighted_dif_down(L) = 0._r8 - do ft = 1, numpft - if (currentPatch%canopy_mask(L,ft) == 1)then - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! First estimates do downward and upward diffuse flux - ! - ! Dif_dn = forward diffuse flux onto layer J - ! Dif_up = Upward diffuse flux above layer J - ! - ! Solved here without direct beam radiation and using dif_ratio = Dif_up / Dif_dn - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! downward diffuse flux onto the top surface of the canopy - - if (L == 1)then - Dif_dn(L,ft,1) = forc_dif(radtype) - else - Dif_dn(L,ft,1) = weighted_dif_down(L-1) - end if - ! forward diffuse flux within the canopy and at soil, working forward through canopy - do iv = 1,currentPatch%nrad(L,ft) - denom = refl_dif(L,ft,iv,ib) * dif_ratio(L,ft,iv,ib) - denom = 1._r8 - denom - Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv) * tran_dif(L,ft,iv,ib) / & - denom *ftweight(L,ft,iv)/ftweight(L,ft,1) - if (iv > 1)then - if (lai_change(L,ft,iv-1) > 0.0_r8)then - !here we are thinking about whether the layer above had an laichange, - !but calculating the flux onto the layer below. - Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv+1)+ Dif_dn(L,ft,iv)* & - lai_change(L,ft,iv-1)/ftweight(L,ft,1) - Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv+1)+ Dif_dn(L,ft,iv-1)* & - (ftweight(L,ft,1)-ftweight(L,ft,iv-1)/ftweight(L,ft,1)) - else - Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv+1) + Dif_dn(L,ft,iv) * & - (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) - endif - else - Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv+1) + Dif_dn(L,ft,iv) * & - (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) - endif - end do - - weighted_dif_down(L) = weighted_dif_down(L) + Dif_dn(L,ft,currentPatch%nrad(L,ft)+1) * & - ftweight(L,ft,1) - - !instance where the first layer ftweight is used a proxy for the whole column. FTWA - endif !present - end do !ft - if (L == currentPatch%NCL_p.and.currentPatch%NCL_p > 1)then !is the the (incomplete) understorey? - !Add on the radiation going through the canopy gaps. - weighted_dif_down(L) = weighted_dif_down(L) + weighted_dif_down(L-1)*(1.0-sum(ftweight(L,:,1))) - !instance where the first layer ftweight is used a proxy for the whole column. FTWA - endif - end do !L - - do L = currentPatch%NCL_p,1 ,-1 !work up from the bottom. - weighted_dif_up(L) = 0._r8 - do ft = 1, numpft - if (currentPatch%canopy_mask(L,ft) == 1)then - !Bounce diffuse radiation off soil surface. - iv = currentPatch%nrad(L,ft) + 1 - if (L==currentPatch%NCL_p)then !is this the bottom layer ? - Dif_up(L,ft,iv) = currentPatch%gnd_alb_dif(ib) * Dif_dn(L,ft,iv) - else - Dif_up(L,ft,iv) = weighted_dif_up(L+1) - end if - ! Upward diffuse flux within the canopy and above the canopy, working upward through canopy - - do iv = currentPatch%nrad(L,ft), 1, -1 - if (lai_change(L,ft,iv) > 0.0_r8)then - Dif_up(L,ft,iv) = dif_ratio(L,ft,iv,ib) * Dif_dn(L,ft,iv) * & - ftweight(L,ft,iv) / ftweight(L,ft,1) - Dif_up(L,ft,iv) = Dif_up(L,ft,iv) + Dif_up(L,ft,iv+1) * & - tran_dif(L,ft,iv,ib) * lai_change(L,ft,iv)/ftweight(L,ft,1) - Dif_up(L,ft,iv) = Dif_up(L,ft,iv) + Dif_up(L,ft,iv+1) * & - (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) - !nb is this the right constuction? - ! the radiation that hits the empty space is not reflected. - else - Dif_up(L,ft,iv) = dif_ratio(L,ft,iv,ib) * Dif_dn(L,ft,iv) * ftweight(L,ft,iv) - Dif_up(L,ft,iv) = Dif_up(L,ft,iv) + Dif_up(L,ft,iv+1) * (1.0_r8-ftweight(L,ft,iv)) - endif - end do - - weighted_dif_up(L) = weighted_dif_up(L) + Dif_up(L,ft,1) * ftweight(L,ft,1) - !instance where the first layer ftweight is used a proxy for the whole column. FTWA - endif !present - end do !ft - if (L == currentPatch%NCL_p.and.currentPatch%NCL_p > 1)then !is this the (incomplete) understorey? - !Add on the radiation coming up through the canopy gaps. - !diffuse to diffuse - weighted_dif_up(L) = weighted_dif_up(L) +(1.0_r8-sum(ftweight(L,1:numpft,1))) * & - weighted_dif_down(L-1) * currentPatch%gnd_alb_dif(ib) - !direct to diffuse - weighted_dif_up(L) = weighted_dif_up(L) + forc_dir(radtype) * & - weighted_dir_tr(L-1) * (1.0_r8-sum(ftweight(L,1:numpft,1))) * currentPatch%gnd_alb_dir(ib) - endif - end do !L - - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! 3. Iterative calculation of forward and upward diffuse fluxes, iNCL_puding - ! scattered direct beam - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - - ! Flag to exit iteration loop: 0 = exit and 1 = iterate - irep = 1 - ! Iteration loop - iter = 0 - do while(irep ==1 .and. iter<50) - - iter = iter + 1 - irep = 0 - do L = 1,currentPatch%NCL_p !working from the top down - weighted_dif_down(L) = 0._r8 - do ft =1,numpft - if (currentPatch%canopy_mask(L,ft) == 1)then - ! forward diffuse flux within the canopy and at soil, working forward through canopy - ! with Dif_up -from previous iteration-. Dif_dn(1) is the forward diffuse flux onto the canopy. - ! Note: down = forward flux onto next layer - if (L == 1)then !is this the top layer? - Dif_dn(L,ft,1) = forc_dif(radtype) - else - Dif_dn(L,ft,1) = weighted_dif_down(L-1) - end if - down_rad = 0._r8 - - do iv = 1, currentPatch%nrad(L,ft) - - down_rad = Dif_dn(L,ft,iv) * tran_dif(L,ft,iv,ib) + & - Dif_up(L,ft,iv+1) * refl_dif(L,ft,iv,ib) + & - forc_dir(radtype) * tr_dir_z(L,ft,iv) * (1.00_r8 - & - exp(-k_dir(ft) * (currentPatch%elai_profile(L,ft,iv)+ & - currentPatch%esai_profile(L,ft,iv)))) * taul(ft,ib) - down_rad = down_rad *(ftweight(L,ft,iv)/ftweight(L,ft,1)) - - if (iv > 1)then - if (lai_change(L,ft,iv-1) > 0.0_r8)then - down_rad = down_rad + Dif_dn(L,ft,iv) * lai_change(L,ft,iv-1)/ftweight(L,ft,1) - down_rad = down_rad + Dif_dn(L,ft,iv-1) * (ftweight(L,ft,1)-ftweight(L,ft,iv-1))/ & - ftweight(L,ft,1) - else - down_rad = down_rad + Dif_dn(L,ft,iv) * (ftweight(L,ft,1)-ftweight(L,ft,iv))/ & - ftweight(L,ft,1) - endif - else - down_rad = down_rad + Dif_dn(L,ft,iv) * (ftweight(L,ft,1)-ftweight(L,ft,iv))/ & - ftweight(L,ft,1) - endif - - !this is just Dif down, plus refl up, plus dir intercepted and turned into dif... , - if (abs(down_rad - Dif_dn(L,ft,iv+1)) > tolerance)then - irep = 1 - end if - Dif_dn(L,ft,iv+1) = down_rad - - end do !iv - - weighted_dif_down(L) = weighted_dif_down(L) + Dif_dn(L,ft,currentPatch%nrad(L,ft)+1) * & - ftweight(L,ft,1) - - endif !present - end do!ft - if (L == currentPatch%NCL_p.and.currentPatch%NCL_p > 1)then !is this the (incomplete) understorey? - weighted_dif_down(L) = weighted_dif_down(L) + weighted_dif_down(L-1) * & - (1.0_r8-sum(ftweight(L,1:numpft,1))) - end if - end do ! do L loop - - do L = 1, currentPatch%NCL_p ! working from the top down. - weighted_dif_up(L) = 0._r8 - do ft =1,numpft - if (currentPatch%canopy_mask(L,ft) == 1)then - ! Upward diffuse flux at soil or from lower canopy (forward diffuse and unscattered direct beam) - iv = currentPatch%nrad(L,ft) + 1 - if (L==currentPatch%NCL_p)then !In the bottom canopy layer, reflect off the soil - Dif_up(L,ft,iv) = Dif_dn(L,ft,iv) * currentPatch%gnd_alb_dif(ib) + & - forc_dir(radtype) * tr_dir_z(L,ft,iv) * currentPatch%gnd_alb_dir(ib) - else !In the other canopy layers, reflect off the underlying vegetation. - Dif_up(L,ft,iv) = weighted_dif_up(L+1) - end if - - ! Upward diffuse flux within and above the canopy, working upward through canopy - ! with Dif_dn from previous interation. Note: up = upward flux above current layer - do iv = currentPatch%nrad(L,ft),1,-1 - !this is radiation up, by layer transmittance, by - - !reflection of the lower layer, - up_rad = Dif_dn(L,ft,iv) * refl_dif(L,ft,iv,ib) - up_rad = up_rad + forc_dir(radtype) * tr_dir_z(L,ft,iv) * (1.00_r8 - exp(-k_dir(ft) * & - (currentPatch%elai_profile(L,ft,iv) + currentPatch%esai_profile(L,ft,iv)))) * & - rhol(ft,ib) - up_rad = up_rad + Dif_up(L,ft,iv+1) * tran_dif(L,ft,iv,ib) - up_rad = up_rad * ftweight(L,ft,iv)/ftweight(L,ft,1) - up_rad = up_rad + Dif_up(L,ft,iv+1) *(ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) - ! THE LOWER LAYER FLUX IS HOMOGENIZED, SO WE DON"T CONSIDER THE LAI_CHANGE HERE... - - if (abs(up_rad - Dif_up(L,ft,iv)) > tolerance) then !are we close to the tolerance level? - irep = 1 - end if - Dif_up(L,ft,iv) = up_rad - - end do !iv - weighted_dif_up(L) = weighted_dif_up(L) + Dif_up(L,ft,1) * ftweight(L,ft,1) - end if !present - end do!ft - - if (L == currentPatch%NCL_p.and.currentPatch%NCL_p > 1)then !is this the (incomplete) understorey? - !Add on the radiation coming up through the canopy gaps. - weighted_dif_up(L) = weighted_dif_up(L) +(1.0_r8-sum(ftweight(L,1:numpft,1))) * & - weighted_dif_down(L-1) * currentPatch%gnd_alb_dif(ib) - weighted_dif_up(L) = weighted_dif_up(L) + forc_dir(radtype) * & - weighted_dir_tr(L-1) * (1.0_r8-sum(ftweight(L,1:numpft,1)))*currentPatch%gnd_alb_dir(ib) - end if - end do!L - end do ! do while over iter - - abs_rad(ib) = 0._r8 - tr_soili = 0._r8 - tr_soild = 0._r8 - - do L = 1, currentPatch%NCL_p !working from the top down. - abs_dir_z(:,:) = 0._r8 - abs_dif_z(:,:) = 0._r8 - do ft =1,numpft - if (currentPatch%canopy_mask(L,ft) == 1)then - !==============================================================================! - ! Compute absorbed flux densities - !==============================================================================! - - ! Absorbed direct beam and diffuse do leaf layers - do iv = 1, currentPatch%nrad(L,ft) - Abs_dir_z(ft,iv) = ftweight(L,ft,iv)* forc_dir(radtype) * tr_dir_z(L,ft,iv) * & - (1.00_r8 - exp(-k_dir(ft) * (currentPatch%elai_profile(L,ft,iv)+ & - currentPatch%esai_profile(L,ft,iv)))) * (1.00_r8 - f_not_abs(ft,ib)) - Abs_dif_z(ft,iv) = ftweight(L,ft,iv)* ((Dif_dn(L,ft,iv) + & - Dif_up(L,ft,iv+1)) * (1.00_r8 - tr_dif_z(L,ft,iv)) * & - (1.00_r8 - f_not_abs(ft,ib))) - end do - - ! Absorbed direct beam and diffuse do soil - if (L == currentPatch%NCL_p)then - iv = currentPatch%nrad(L,ft) + 1 - Abs_dif_z(ft,iv) = ftweight(L,ft,1)*Dif_dn(L,ft,iv) * (1.0_r8 - currentPatch%gnd_alb_dif(ib) ) - Abs_dir_z(ft,iv) = ftweight(L,ft,1)*forc_dir(radtype) * & - tr_dir_z(L,ft,iv) * (1.0_r8 - currentPatch%gnd_alb_dir(ib) ) - tr_soild = tr_soild + ftweight(L,ft,1)*forc_dir(radtype) * tr_dir_z(L,ft,iv) - tr_soili = tr_soili + ftweight(L,ft,1)*Dif_dn(L,ft,iv) - end if - - ! Absorbed radiation, shaded and sunlit portions of leaf layers - !here we get one unit of diffuse radiation... how much of - !it is absorbed? - if (ib == ivis) then ! only set the absorbed PAR for the visible light band. - do iv = 1, currentPatch%nrad(L,ft) - if (radtype==idirect) then - if ( debug ) then - write(fates_log(),*) 'EDsurfAlb 730 ',Abs_dif_z(ft,iv),currentPatch%f_sun(L,ft,iv) - write(fates_log(),*) 'EDsurfAlb 731 ', currentPatch%fabd_sha_z(L,ft,iv), & - currentPatch%fabd_sun_z(L,ft,iv) - endif - currentPatch%fabd_sha_z(L,ft,iv) = Abs_dif_z(ft,iv) * & - (1._r8 - currentPatch%f_sun(L,ft,iv)) - currentPatch%fabd_sun_z(L,ft,iv) = Abs_dif_z(ft,iv) * & - currentPatch%f_sun(L,ft,iv) + & - Abs_dir_z(ft,iv) - else - currentPatch%fabi_sha_z(L,ft,iv) = Abs_dif_z(ft,iv) * & - (1._r8 - currentPatch%f_sun(L,ft,iv)) - currentPatch%fabi_sun_z(L,ft,iv) = Abs_dif_z(ft,iv) * & - currentPatch%f_sun(L,ft,iv) - endif - if ( debug ) then - write(fates_log(),*) 'EDsurfAlb 740 ', currentPatch%fabd_sha_z(L,ft,iv), & - currentPatch%fabd_sun_z(L,ft,iv) - endif - end do - endif ! ib - - - !==============================================================================! - ! Sum fluxes - !==============================================================================! - ! Solar radiation absorbed by ground - iv = currentPatch%nrad(L,ft) + 1 - if (L==currentPatch%NCL_p)then - abs_rad(ib) = abs_rad(ib) + (Abs_dir_z(ft,iv) + Abs_dif_z(ft,iv)) - end if - ! Solar radiation absorbed by vegetation and sunlit/shaded leaves - do iv = 1,currentPatch%nrad(L,ft) - if (radtype == idirect)then - currentPatch%fabd(ib) = currentPatch%fabd(ib) + & - Abs_dir_z(ft,iv)+Abs_dif_z(ft,iv) - ! bc_out(s)%fabd_parb_out(ib) = currentPatch%fabd(ib) - else - currentPatch%fabi(ib) = currentPatch%fabi(ib) + Abs_dif_z(ft,iv) - ! bc_out(s)%fabi_parb_out(ib) = currentPatch%fabi(ib) - endif - end do - - ! Albefor - if (L==1)then !top canopy layer. - if (radtype == idirect)then - albd_parb_out(ib) = albd_parb_out(ib) + & - Dif_up(L,ft,1) * ftweight(L,ft,1) - else - albi_parb_out(ib) = albi_parb_out(ib) + & - Dif_up(L,ft,1) * ftweight(L,ft,1) - end if - end if - - ! pass normalized PAR profiles for use in diagnostic averaging for history fields - if (ib == ivis) then ! only diagnose PAR profiles for the visible band - do iv = 1, currentPatch%nrad(L,ft) - currentPatch%nrmlzd_parprof_pft_dir_z(radtype,L,ft,iv) = & - forc_dir(radtype) * tr_dir_z(L,ft,iv) - currentPatch%nrmlzd_parprof_pft_dif_z(radtype,L,ft,iv) = & - Dif_dn(L,ft,iv) + Dif_up(L,ft,iv) - ! - currentPatch%nrmlzd_parprof_dir_z(radtype,L,iv) = & - currentPatch%nrmlzd_parprof_dir_z(radtype,L,iv) + & - (forc_dir(radtype) * tr_dir_z(L,ft,iv)) * & - (ftweight(L,ft,iv) / sum(ftweight(L,1:numpft,iv))) - currentPatch%nrmlzd_parprof_dif_z(radtype,L,iv) = & - currentPatch%nrmlzd_parprof_dif_z(radtype,L,iv) + & - (Dif_dn(L,ft,iv) + Dif_up(L,ft,iv)) * & - (ftweight(L,ft,iv) / sum(ftweight(L,1:numpft,iv))) - end do - end if ! ib = visible - end if ! present - end do !ft - if (radtype == idirect)then - fabd_parb_out(ib) = currentPatch%fabd(ib) - else - fabi_parb_out(ib) = currentPatch%fabi(ib) - endif - - - !radiation absorbed from fluxes through unfilled part of lower canopy. - if (currentPatch%NCL_p > 1.and.L == currentPatch%NCL_p)then - abs_rad(ib) = abs_rad(ib) + weighted_dif_down(L-1) * & - (1.0_r8-sum(ftweight(L,1:numpft,1)))*(1.0_r8-currentPatch%gnd_alb_dif(ib) ) - abs_rad(ib) = abs_rad(ib) + forc_dir(radtype) * weighted_dir_tr(L-1) * & - (1.0_r8-sum(ftweight(L,1:numpft,1)))*(1.0_r8-currentPatch%gnd_alb_dir(ib) ) - tr_soili = tr_soili + weighted_dif_down(L-1) * (1.0_r8-sum(ftweight(L,1:numpft,1))) - tr_soild = tr_soild + forc_dir(radtype) * weighted_dir_tr(L-1) * (1.0_r8-sum(ftweight(L,1:numpft,1))) - endif - - if (radtype == idirect)then - currentPatch%tr_soil_dir(ib) = tr_soild - currentPatch%tr_soil_dir_dif(ib) = tr_soili - currentPatch%sabs_dir(ib) = abs_rad(ib) - ftdd_parb_out(ib) = tr_soild - ftid_parb_out(ib) = tr_soili - else - currentPatch%tr_soil_dif(ib) = tr_soili - currentPatch%sabs_dif(ib) = abs_rad(ib) - ftii_parb_out(ib) = tr_soili - end if - - end do!l - - - !==============================================================================! - ! Conservation check - !==============================================================================! - ! Total radiation balance: absorbed = incoming - outgoing - - if (radtype == idirect)then - error = abs(currentPatch%sabs_dir(ib) - (currentPatch%tr_soil_dir(ib) * & - (1.0_r8-currentPatch%gnd_alb_dir(ib) ) + & - currentPatch%tr_soil_dir_dif(ib) * (1.0_r8-currentPatch%gnd_alb_dif(ib) ))) - if ( abs(error) > 0.0001)then - write(fates_log(),*)'dir ground absorption error',error,currentPatch%sabs_dir(ib), & - currentPatch%tr_soil_dir(ib)* & - (1.0_r8-currentPatch%gnd_alb_dir(ib) ),currentPatch%NCL_p,ib,sum(ftweight(1,1:numpft,1)) - write(fates_log(),*) 'albedos',currentPatch%sabs_dir(ib) ,currentPatch%tr_soil_dir(ib), & - (1.0_r8-currentPatch%gnd_alb_dir(ib) ) - - do ft =1,3 - iv = currentPatch%nrad(1,ft) + 1 - write(fates_log(),*) 'abs soil fluxes', Abs_dir_z(ft,iv),Abs_dif_z(ft,iv) - end do - - end if - else - if ( abs(currentPatch%sabs_dif(ib)-(currentPatch%tr_soil_dif(ib) * & - (1.0_r8-currentPatch%gnd_alb_dif(ib) ))) > 0.0001_r8)then - write(fates_log(),*)'dif ground absorption error',currentPatch%sabs_dif(ib) , & - (currentPatch%tr_soil_dif(ib)* & - (1.0_r8-currentPatch%gnd_alb_dif(ib) )),currentPatch%NCL_p,ib,sum(ftweight(1,1:numpft,1)) - endif - endif - - if (radtype == idirect)then - error = (forc_dir(radtype) + forc_dif(radtype)) - & - (fabd_parb_out(ib) + albd_parb_out(ib) + currentPatch%sabs_dir(ib)) - else - error = (forc_dir(radtype) + forc_dif(radtype)) - & - (fabi_parb_out(ib) + albi_parb_out(ib) + currentPatch%sabs_dif(ib)) - endif - lai_reduction(:) = 0.0_r8 - do L = 1, currentPatch%NCL_p - do ft =1,numpft - if (currentPatch%canopy_mask(L,ft) == 1)then - do iv = 1, currentPatch%nrad(L,ft) - if (lai_change(L,ft,iv) > 0.0_r8)then - lai_reduction(L) = max(lai_reduction(L),lai_change(L,ft,iv)) - endif - enddo - endif - enddo - enddo - - if (radtype == idirect)then - !here we are adding a within-ED radiation scheme tolerance, and then adding the diffrence onto the albedo - !it is important that the lower boundary for this is ~1000 times smaller than the tolerance in surface albedo. - if (abs(error) > 1.e-9_r8 .and. abs(error) < 0.15_r8)then - albd_parb_out(ib) = albd_parb_out(ib) + error - !this terms adds the error back on to the albedo. While this is partly inexcusable, it is - ! in the medium term a solution that - ! prevents the model from crashing with small and occasional energy balances issues. - ! These are extremely difficult to debug, many have been solved already, leading - ! to the complexity of this code, but where the system generates occasional errors, we - ! will deal with them for now. - end if - if (abs(error) > 0.15_r8)then - write(fates_log(),*) 'Large Dir Radn consvn error',error ,ib - write(fates_log(),*) 'diags', albd_parb_out(ib), ftdd_parb_out(ib), & - ftid_parb_out(ib), fabd_parb_out(ib) - write(fates_log(),*) 'lai_change',lai_change(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) - write(fates_log(),*) 'elai',currentpatch%elai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) - write(fates_log(),*) 'esai',currentpatch%esai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) - write(fates_log(),*) 'ftweight',ftweight(1,1:numpft,1:diag_nlevleaf) - write(fates_log(),*) 'cp',currentPatch%area, currentPatch%patchno - write(fates_log(),*) 'ground albedo diffuse (ib)', currentPatch%gnd_alb_dir(ib) - - albd_parb_out(ib) = albd_parb_out(ib) + error - end if - else - - if (abs(error) > 1.e-9_r8 .and. abs(error) < 0.15_r8)then - albi_parb_out(ib) = albi_parb_out(ib) + error - end if - - if (abs(error) > 0.15_r8)then - write(fates_log(),*) '>5% Dif Radn consvn error',error ,ib - write(fates_log(),*) 'diags', albi_parb_out(ib), ftii_parb_out(ib), & - fabi_parb_out(ib) - write(fates_log(),*) 'lai_change',lai_change(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) - write(fates_log(),*) 'elai',currentpatch%elai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) - write(fates_log(),*) 'esai',currentpatch%esai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) - write(fates_log(),*) 'ftweight',ftweight(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) - write(fates_log(),*) 'cp',currentPatch%area, currentPatch%patchno - write(fates_log(),*) 'ground albedo diffuse (ib)', currentPatch%gnd_alb_dir(ib) - write(fates_log(),*) 'rhol',rhol(1:numpft,:) - write(fates_log(),*) 'ftw',sum(ftweight(1,1:numpft,1)),ftweight(1,1:numpft,1) - write(fates_log(),*) 'present',currentPatch%canopy_mask(1,1:numpft) - write(fates_log(),*) 'CAP',currentPatch%canopy_area_profile(1,1:numpft,1) - - albi_parb_out(ib) = albi_parb_out(ib) + error - end if - - if (radtype == idirect)then - error = (forc_dir(radtype) + forc_dif(radtype)) - & - (fabd_parb_out(ib) + albd_parb_out(ib) + currentPatch%sabs_dir(ib)) - else - error = (forc_dir(radtype) + forc_dif(radtype)) - & - (fabi_parb_out(ib) + albi_parb_out(ib) + currentPatch%sabs_dif(ib)) - endif - - if (abs(error) > 0.00000001_r8)then - write(fates_log(),*) 'there is still error after correction',error ,ib - end if - - end if - - end do !hlm_numSWb - - enddo ! rad-type - - - end associate - return - end subroutine PatchNormanRadiation - - ! ====================================================================================== - - subroutine ED_SunShadeFracs(nsites, sites,bc_in,bc_out) - - implicit none - - ! Arguments - integer,intent(in) :: nsites - type(ed_site_type),intent(inout),target :: sites(nsites) - type(bc_in_type),intent(in) :: bc_in(nsites) - type(bc_out_type),intent(inout) :: bc_out(nsites) - - - ! locals - type (ed_patch_type),pointer :: cpatch ! c"urrent" patch - real(r8) :: sunlai - real(r8) :: shalai - real(r8) :: elai - integer :: CL - integer :: FT - integer :: iv - integer :: s - integer :: ifp - - - do s = 1,nsites + weighted_dir_tr(:) = 0._r8 + weighted_dif_down(:) = 0._r8 + weighted_dif_up(:) = 0._r8 + + tr_dir_z(:,:,:) = 0._r8 + tr_dif_z(:,:,:) = 0._r8 + lai_change(:,:,:) = 0._r8 + Dif_up(:,:,:) = 0._r8 + Dif_dn(:,:,:) = 0._r8 + refl_dif(:,:,:,:) = 0.0_r8 + tran_dif(:,:,:,:) = 0.0_r8 + dif_ratio(:,:,:,:) = 0.0_r8 + + + ! Initialize the ouput arrays + ! --------------------------------------------------------------------------------- + albd_parb_out(1:hlm_numSWb) = 0.0_r8 + albi_parb_out(1:hlm_numSWb) = 0.0_r8 + fabd_parb_out(1:hlm_numSWb) = 0.0_r8 + fabi_parb_out(1:hlm_numSWb) = 0.0_r8 + ftdd_parb_out(1:hlm_numSWb) = 1.0_r8 + ftid_parb_out(1:hlm_numSWb) = 1.0_r8 + ftii_parb_out(1:hlm_numSWb) = 1.0_r8 + + ! Is this pft/canopy layer combination present in this patch? + + do L = 1,nclmax + do ft = 1,numpft + currentPatch%canopy_mask(L,ft) = 0 + do iv = 1, currentPatch%nrad(L,ft) + if (currentPatch%canopy_area_profile(L,ft,iv) > 0._r8)then + currentPatch%canopy_mask(L,ft) = 1 + !I think 'present' is only used here... + endif + end do !iv + end do !ft + end do !L + + + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! Direct beam extinction coefficient, k_dir. PFT specific. + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + cosz = max(0.001_r8, currentPatch%solar_zenith_angle ) !copied from previous radiation code... + do ft = 1,numpft + sb = (90._r8 - (acos(cosz)*180._r8/pi_const)) * (pi_const / 180._r8) + chil = xl(ft) !min(max(xl(ft), -0.4_r8), 0.6_r8 ) + if ( abs(chil) <= 0.01_r8) then + chil = 0.01_r8 + end if + phi1b(ft) = 0.5_r8 - 0.633_r8*chil - 0.330_r8*chil*chil + phi2b(ft) = 0.877_r8 * (1._r8 - 2._r8*phi1b(ft)) !0 = horiz leaves, 1 - vert leaves. + gdir = phi1b(ft) + phi2b(ft) * sin(sb) + !how much direct light penetrates a singleunit of lai? + k_dir(ft) = clumping_index(ft) * gdir / sin(sb) + end do !FT + + + + + !do this once for one unit of diffuse, and once for one unit of direct radiation + do radtype = 1, n_rad_stream_types + + ! Extract information that needs to be provided by ED into local array. + ! RGK: NOT SURE WHY WE NEED FTWEIGHT ... + ! ------------------------------------------------------------------------------ + + ftweight(:,:,:) = 0._r8 + do L = 1,currentPatch%NCL_p + do ft = 1,numpft + do iv = 1, currentPatch%nrad(L,ft) + !this is already corrected for area in CLAP + ftweight(L,ft,iv) = currentPatch%canopy_area_profile(L,ft,iv) + end do !iv + end do !ft1 + end do !L + if (sum(ftweight(1,:,1))<0.999_r8)then + write(fates_log(),*) 'canopy not full',ftweight(1,:,1) + endif + if (sum(ftweight(1,:,1))>1.0001_r8)then + write(fates_log(),*) 'canopy too full',ftweight(1,:,1) + endif + + do L = 1,currentPatch%NCL_p !start at the top canopy layer (1 is the top layer.) + + weighted_dir_tr(L) = 0.0_r8 + weighted_fsun(L) = 0._r8 + weighted_dif_ratio(L,1:hlm_numSWb) = 0._r8 + + !Each canopy layer (canopy, understorey) has multiple 'parallel' pft's + + do ft =1,numpft + + if (currentPatch%canopy_mask(L,ft) == 1)then !only do calculation if there are the appropriate leaves. + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! Diffuse transmittance, tr_dif, do each layer with thickness elai_z. + ! Estimated do nine sky angles in increments of 10 degrees + ! PFT specific... + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + tr_dif_z(L,ft,:) = 0._r8 + do iv = 1,currentPatch%nrad(L,ft) + do j = 1,9 + angle = (5._r8 + real(j - 1,r8) * 10._r8) * pi_const / 180._r8 + gdir = phi1b(ft) + phi2b(ft) * sin(angle) + tr_dif_z(L,ft,iv) = tr_dif_z(L,ft,iv) + exp(-clumping_index(ft) * & + gdir / sin(angle) * & + (currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv))) * & + sin(angle)*cos(angle) + end do + + tr_dif_z(L,ft,iv) = tr_dif_z(L,ft,iv) * 2._r8 * (10._r8 * pi_const / 180._r8) + + end do + + + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! Direct beam transmittance, tr_dir_z, uses cumulative LAI above layer J to give + ! unscattered direct beam onto layer J. do each PFT section. + ! This is just an decay curve based on k_dir. (leaf & sun angle) + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + if (L==1)then + tr_dir_z(L,ft,1) = 1._r8 + else + tr_dir_z(L,ft,1) = weighted_dir_tr(L-1) + endif + laisum = 0.00_r8 + !total direct beam getting to the bottom of the top canopy. + do iv = 1,currentPatch%nrad(L,ft) + laisum = laisum + currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv) + lai_change(L,ft,iv) = 0.0_r8 + if (( ftweight(L,ft,iv+1) > 0.0_r8 ) .and. ( ftweight(L,ft,iv+1) < ftweight(L,ft,iv) ))then + !where there is a partly empty leaf layer, some fluxes go straight through. + lai_change(L,ft,iv) = ftweight(L,ft,iv)-ftweight(L,ft,iv+1) + endif + if (ftweight(L,ft,iv+1) - ftweight(L,ft,iv) > 1.e-10_r8)then + write(fates_log(),*) 'lower layer has more coverage. This is wrong' , & + ftweight(L,ft,iv),ftweight(L,ft,iv+1),ftweight(L,ft,iv+1)-ftweight(L,ft,iv) + endif + + !n.b. in theory lai_change could be calculated daily in the ED code. + !This is light coming striaght through the canopy. + if (L==1)then + tr_dir_z(L,ft,iv+1) = exp(-k_dir(ft) * laisum)* & + (ftweight(L,ft,iv)/ftweight(L,ft,1)) + else + tr_dir_z(L,ft,iv+1) = weighted_dir_tr(L-1)*exp(-k_dir(ft) * laisum)* & + (ftweight(L,ft,iv)/ftweight(L,ft,1)) + endif + + if (iv == 1)then + !this is the top layer. + tr_dir_z(L,ft,iv+1) = tr_dir_z(L,ft,iv+1) + tr_dir_z(L,ft,iv) * & + ((ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1)) + else + !the lai_change(iv) affects the light incident on layer iv+2 not iv+1 + ! light coming from the layer above (iv-1) goes through iv and onto iv+1. + if (lai_change(L,ft,iv-1) > 0.0_r8)then + tr_dir_z(L,ft,iv+1) = tr_dir_z(L,ft,iv+1) + tr_dir_z(L,ft,iv)* & + lai_change(L,ft,iv-1) / ftweight(L,ft,1) + tr_dir_z(L,ft,iv+1) = tr_dir_z(L,ft,iv+1) + tr_dir_z(L,ft,iv-1)* & + (ftweight(L,ft,1)-ftweight(L,ft,iv-1))/ftweight(L,ft,1) + else + !account fot the light that comes striaght down from unfilled layers above. + tr_dir_z(L,ft,iv+1) = tr_dir_z(L,ft,iv+1) + tr_dir_z(L,ft,iv) * & + ((ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1)) + endif + endif - ifp = 0 - cpatch => sites(s)%oldest_patch - - do while (associated(cpatch)) - if(cpatch%nocomp_pft_label.ne.0)then !only for veg patches - ifp=ifp+1 - - 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) + + !add up all the weighted contributions from the different PFT columns. + weighted_dir_tr(L) = weighted_dir_tr(L) + tr_dir_z(L,ft,currentPatch%nrad(L,ft)+1)*ftweight(L,ft,1) + + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! Sunlit and shaded fraction of leaf layer + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + + !laisum = 0._r8 + do iv = 1,currentPatch%nrad(L,ft) + ! Cumulative leaf area. Original code uses cumulative lai do layer. + ! Now use cumulative lai at center of layer. + ! Same as tr_dir_z calcualtions, but in the middle of the layer? FIX(RF,032414)-WHY? + if (iv == 1) then + laisum = 0.5_r8 * (currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv)) + else + laisum = laisum + currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv) + end if + + + if (L == 1)then !top canopy layer + currentPatch%f_sun(L,ft,iv) = exp(-k_dir(ft) * laisum)* & + (ftweight(L,ft,iv)/ftweight(L,ft,1)) + else + currentPatch%f_sun(L,ft,iv) = weighted_fsun(L-1)* exp(-k_dir(ft) * laisum)* & + (ftweight(L,ft,iv)/ftweight(L,ft,1)) + endif + + if ( iv > 1 ) then ! becasue we are looking at this layer (not the next) + ! we only ever add fluxes if iv>1 + if (lai_change(L,ft,iv-1) > 0.0_r8)then + currentPatch%f_sun(L,ft,iv) = currentPatch%f_sun(L,ft,iv) + & + currentPatch%f_sun(L,ft,iv) * & + lai_change(L,ft,iv-1)/ftweight(L,ft,1) + currentPatch%f_sun(L,ft,iv) = currentPatch%f_sun(L,ft,iv) + & + currentPatch%f_sun(L,ft,iv-1) * & + (ftweight(L,ft,1)-ftweight(L,ft,iv-1))/ftweight(L,ft,1) + else + currentPatch%f_sun(L,ft,iv) = currentPatch%f_sun(L,ft,iv) + & + currentPatch%f_sun(L,ft,iv-1) * & + (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) + endif + endif + + end do !iv + + weighted_fsun(L) = weighted_fsun(L) + currentPatch%f_sun(L,ft,currentPatch%nrad(L,ft))* & + ftweight(L,ft,1) + + ! instance where the first layer ftweight is used a proxy for the whole column. FTWA + ! this is possibly a source of slight error. If we use the ftweight at the top of the PFT column, + ! then we willl underestimate fsun, but if we use ftweight at the bottom of the column, we will + ! underestimate it. Really, we should be tracking the release of direct light from the column as it tapers + ! towards the ground. Is that necessary to get energy closure? It would be quite hard... + endif !present. + end do!pft loop + end do !L + + + do L = currentPatch%NCL_p,1, -1 !start at the bottom and work up. + do ft = 1,numpft + if (currentPatch%canopy_mask(L,ft) == 1)then + + !==============================================================================! + ! Iterative solution do scattering + !==============================================================================! + + do ib = 1,hlm_numSWb !vis, nir + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! Leaf scattering coefficient and terms do diffuse radiation reflected + ! and transmitted by a layer + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + f_not_abs(ft,ib) = rhol(ft,ib) + taul(ft,ib) !leaf level fraction NOT absorbed. + !tr_dif_z is a term that uses the LAI in each layer, whereas rhol and taul do not, + !because they are properties of leaf surfaces and not of the leaf matrix. + do iv = 1,currentPatch%nrad(L,ft) + !How much diffuse light is intercepted and then reflected? + refl_dif(L,ft,iv,ib) = (1._r8 - tr_dif_z(L,ft,iv)) * rhol(ft,ib) + !How much diffuse light in this layer is transmitted? + tran_dif(L,ft,iv,ib) = (1._r8 - tr_dif_z(L,ft,iv)) * & + taul(ft,ib) + tr_dif_z(L,ft,iv) + end do + + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! Ratio of upward to forward diffuse fluxes, dif_ratio + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! Soil diffuse reflectance (ratio of down to up radiation). + iv = currentPatch%nrad(L,ft) + 1 + if (L == currentPatch%NCL_p)then !nearest the soil + dif_ratio(L,ft,iv,ib) = currentPatch%gnd_alb_dif(ib) !bc_in(s)%albgr_dif_rb(ib) + else + dif_ratio(L,ft,iv,ib) = weighted_dif_ratio(L+1,ib) + end if + ! Canopy layers, working upwardfrom soil with dif_ratio(iv+1) known + ! FIX(RF,032414) ray tracing eqution - need to find derivation of this... + ! for each unit going down, there are x units going up. + do iv = currentPatch%nrad(L,ft),1, -1 + dif_ratio(L,ft,iv,ib) = dif_ratio(L,ft,iv+1,ib) * & + tran_dif(L,ft,iv,ib)*tran_dif(L,ft,iv,ib) / & + (1._r8 - dif_ratio(L,ft,iv+1,ib) * refl_dif(L,ft,iv,ib)) & + + refl_dif(L,ft,iv,ib) + dif_ratio(L,ft,iv,ib) = dif_ratio(L,ft,iv,ib) * & + ftweight(L,ft,iv)/ftweight(L,ft,1) + dif_ratio(L,ft,iv,ib) = dif_ratio(L,ft,iv,ib) + dif_ratio(L,ft,iv+1,ib) * & + (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) + end do + weighted_dif_ratio(L,ib) = weighted_dif_ratio(L,ib) + & + dif_ratio(L,ft,1,ib) * ftweight(L,ft,1) + !instance where the first layer ftweight is used a proxy for the whole column. FTWA + end do!hlm_numSWb + endif ! currentPatch%canopy_mask + end do!ft + end do!L + + + do ib = 1,hlm_numSWb + Dif_dn(:,:,:) = 0.00_r8 + Dif_up(:,:,:) = 0.00_r8 + do L = 1, currentPatch%NCL_p !work down from the top of the canopy. + weighted_dif_down(L) = 0._r8 + do ft = 1, numpft + if (currentPatch%canopy_mask(L,ft) == 1)then + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! First estimates do downward and upward diffuse flux + ! + ! Dif_dn = forward diffuse flux onto layer J + ! Dif_up = Upward diffuse flux above layer J + ! + ! Solved here without direct beam radiation and using dif_ratio = Dif_up / Dif_dn + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! downward diffuse flux onto the top surface of the canopy + + if (L == 1)then + Dif_dn(L,ft,1) = forc_dif(radtype) + else + Dif_dn(L,ft,1) = weighted_dif_down(L-1) + end if + ! forward diffuse flux within the canopy and at soil, working forward through canopy + do iv = 1,currentPatch%nrad(L,ft) + denom = refl_dif(L,ft,iv,ib) * dif_ratio(L,ft,iv,ib) + denom = 1._r8 - denom + Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv) * tran_dif(L,ft,iv,ib) / & + denom *ftweight(L,ft,iv)/ftweight(L,ft,1) + if (iv > 1)then + if (lai_change(L,ft,iv-1) > 0.0_r8)then + !here we are thinking about whether the layer above had an laichange, + !but calculating the flux onto the layer below. + Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv+1)+ Dif_dn(L,ft,iv)* & + lai_change(L,ft,iv-1)/ftweight(L,ft,1) + Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv+1)+ Dif_dn(L,ft,iv-1)* & + (ftweight(L,ft,1)-ftweight(L,ft,iv-1)/ftweight(L,ft,1)) + else + Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv+1) + Dif_dn(L,ft,iv) * & + (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) + endif + else + Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv+1) + Dif_dn(L,ft,iv) * & + (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) + endif + end do + + weighted_dif_down(L) = weighted_dif_down(L) + Dif_dn(L,ft,currentPatch%nrad(L,ft)+1) * & + ftweight(L,ft,1) + + !instance where the first layer ftweight is used a proxy for the whole column. FTWA + endif !present + end do !ft + if (L == currentPatch%NCL_p.and.currentPatch%NCL_p > 1)then !is the the (incomplete) understorey? + !Add on the radiation going through the canopy gaps. + weighted_dif_down(L) = weighted_dif_down(L) + weighted_dif_down(L-1)*(1.0-sum(ftweight(L,:,1))) + !instance where the first layer ftweight is used a proxy for the whole column. FTWA + endif + end do !L + + do L = currentPatch%NCL_p,1 ,-1 !work up from the bottom. + weighted_dif_up(L) = 0._r8 + do ft = 1, numpft + if (currentPatch%canopy_mask(L,ft) == 1)then + !Bounce diffuse radiation off soil surface. + iv = currentPatch%nrad(L,ft) + 1 + if (L==currentPatch%NCL_p)then !is this the bottom layer ? + Dif_up(L,ft,iv) = currentPatch%gnd_alb_dif(ib) * Dif_dn(L,ft,iv) + else + Dif_up(L,ft,iv) = weighted_dif_up(L+1) + end if + ! Upward diffuse flux within the canopy and above the canopy, working upward through canopy + + do iv = currentPatch%nrad(L,ft), 1, -1 + if (lai_change(L,ft,iv) > 0.0_r8)then + Dif_up(L,ft,iv) = dif_ratio(L,ft,iv,ib) * Dif_dn(L,ft,iv) * & + ftweight(L,ft,iv) / ftweight(L,ft,1) + Dif_up(L,ft,iv) = Dif_up(L,ft,iv) + Dif_up(L,ft,iv+1) * & + tran_dif(L,ft,iv,ib) * lai_change(L,ft,iv)/ftweight(L,ft,1) + Dif_up(L,ft,iv) = Dif_up(L,ft,iv) + Dif_up(L,ft,iv+1) * & + (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) + !nb is this the right constuction? + ! the radiation that hits the empty space is not reflected. + else + Dif_up(L,ft,iv) = dif_ratio(L,ft,iv,ib) * Dif_dn(L,ft,iv) * ftweight(L,ft,iv) + Dif_up(L,ft,iv) = Dif_up(L,ft,iv) + Dif_up(L,ft,iv+1) * (1.0_r8-ftweight(L,ft,iv)) + endif + end do + + weighted_dif_up(L) = weighted_dif_up(L) + Dif_up(L,ft,1) * ftweight(L,ft,1) + !instance where the first layer ftweight is used a proxy for the whole column. FTWA + endif !present + end do !ft + if (L == currentPatch%NCL_p.and.currentPatch%NCL_p > 1)then !is this the (incomplete) understorey? + !Add on the radiation coming up through the canopy gaps. + !diffuse to diffuse + weighted_dif_up(L) = weighted_dif_up(L) +(1.0_r8-sum(ftweight(L,1:numpft,1))) * & + weighted_dif_down(L-1) * currentPatch%gnd_alb_dif(ib) + !direct to diffuse + weighted_dif_up(L) = weighted_dif_up(L) + forc_dir(radtype) * & + weighted_dir_tr(L-1) * (1.0_r8-sum(ftweight(L,1:numpft,1))) * currentPatch%gnd_alb_dir(ib) + endif + end do !L + + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! 3. Iterative calculation of forward and upward diffuse fluxes, iNCL_puding + ! scattered direct beam + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + + ! Flag to exit iteration loop: 0 = exit and 1 = iterate + irep = 1 + ! Iteration loop + iter = 0 + do while(irep ==1 .and. iter<50) + + iter = iter + 1 + irep = 0 + do L = 1,currentPatch%NCL_p !working from the top down + weighted_dif_down(L) = 0._r8 + do ft =1,numpft + if (currentPatch%canopy_mask(L,ft) == 1)then + ! forward diffuse flux within the canopy and at soil, working forward through canopy + ! with Dif_up -from previous iteration-. Dif_dn(1) is the forward diffuse flux onto the canopy. + ! Note: down = forward flux onto next layer + if (L == 1)then !is this the top layer? + Dif_dn(L,ft,1) = forc_dif(radtype) + else + Dif_dn(L,ft,1) = weighted_dif_down(L-1) + end if + down_rad = 0._r8 + + do iv = 1, currentPatch%nrad(L,ft) + + down_rad = Dif_dn(L,ft,iv) * tran_dif(L,ft,iv,ib) + & + Dif_up(L,ft,iv+1) * refl_dif(L,ft,iv,ib) + & + forc_dir(radtype) * tr_dir_z(L,ft,iv) * (1.00_r8 - & + exp(-k_dir(ft) * (currentPatch%elai_profile(L,ft,iv)+ & + currentPatch%esai_profile(L,ft,iv)))) * taul(ft,ib) + down_rad = down_rad *(ftweight(L,ft,iv)/ftweight(L,ft,1)) + + if (iv > 1)then + if (lai_change(L,ft,iv-1) > 0.0_r8)then + down_rad = down_rad + Dif_dn(L,ft,iv) * lai_change(L,ft,iv-1)/ftweight(L,ft,1) + down_rad = down_rad + Dif_dn(L,ft,iv-1) * (ftweight(L,ft,1)-ftweight(L,ft,iv-1))/ & + ftweight(L,ft,1) + else + down_rad = down_rad + Dif_dn(L,ft,iv) * (ftweight(L,ft,1)-ftweight(L,ft,iv))/ & + ftweight(L,ft,1) + endif + else + down_rad = down_rad + Dif_dn(L,ft,iv) * (ftweight(L,ft,1)-ftweight(L,ft,iv))/ & + ftweight(L,ft,1) + endif + + !this is just Dif down, plus refl up, plus dir intercepted and turned into dif... , + if (abs(down_rad - Dif_dn(L,ft,iv+1)) > tolerance)then + irep = 1 + end if + Dif_dn(L,ft,iv+1) = down_rad + + end do !iv + + weighted_dif_down(L) = weighted_dif_down(L) + Dif_dn(L,ft,currentPatch%nrad(L,ft)+1) * & + ftweight(L,ft,1) + + endif !present + end do!ft + if (L == currentPatch%NCL_p.and.currentPatch%NCL_p > 1)then !is this the (incomplete) understorey? + weighted_dif_down(L) = weighted_dif_down(L) + weighted_dif_down(L-1) * & + (1.0_r8-sum(ftweight(L,1:numpft,1))) + end if + end do ! do L loop + + do L = 1, currentPatch%NCL_p ! working from the top down. + weighted_dif_up(L) = 0._r8 + do ft =1,numpft + if (currentPatch%canopy_mask(L,ft) == 1)then + ! Upward diffuse flux at soil or from lower canopy (forward diffuse and unscattered direct beam) + iv = currentPatch%nrad(L,ft) + 1 + if (L==currentPatch%NCL_p)then !In the bottom canopy layer, reflect off the soil + Dif_up(L,ft,iv) = Dif_dn(L,ft,iv) * currentPatch%gnd_alb_dif(ib) + & + forc_dir(radtype) * tr_dir_z(L,ft,iv) * currentPatch%gnd_alb_dir(ib) + else !In the other canopy layers, reflect off the underlying vegetation. + Dif_up(L,ft,iv) = weighted_dif_up(L+1) + end if + + ! Upward diffuse flux within and above the canopy, working upward through canopy + ! with Dif_dn from previous interation. Note: up = upward flux above current layer + do iv = currentPatch%nrad(L,ft),1,-1 + !this is radiation up, by layer transmittance, by + + !reflection of the lower layer, + up_rad = Dif_dn(L,ft,iv) * refl_dif(L,ft,iv,ib) + up_rad = up_rad + forc_dir(radtype) * tr_dir_z(L,ft,iv) * (1.00_r8 - exp(-k_dir(ft) * & + (currentPatch%elai_profile(L,ft,iv) + currentPatch%esai_profile(L,ft,iv)))) * & + rhol(ft,ib) + up_rad = up_rad + Dif_up(L,ft,iv+1) * tran_dif(L,ft,iv,ib) + up_rad = up_rad * ftweight(L,ft,iv)/ftweight(L,ft,1) + up_rad = up_rad + Dif_up(L,ft,iv+1) *(ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) + ! THE LOWER LAYER FLUX IS HOMOGENIZED, SO WE DON"T CONSIDER THE LAI_CHANGE HERE... + + if (abs(up_rad - Dif_up(L,ft,iv)) > tolerance) then !are we close to the tolerance level? + irep = 1 + end if + Dif_up(L,ft,iv) = up_rad + + end do !iv + weighted_dif_up(L) = weighted_dif_up(L) + Dif_up(L,ft,1) * ftweight(L,ft,1) + end if !present + end do!ft + + if (L == currentPatch%NCL_p.and.currentPatch%NCL_p > 1)then !is this the (incomplete) understorey? + !Add on the radiation coming up through the canopy gaps. + weighted_dif_up(L) = weighted_dif_up(L) +(1.0_r8-sum(ftweight(L,1:numpft,1))) * & + weighted_dif_down(L-1) * currentPatch%gnd_alb_dif(ib) + weighted_dif_up(L) = weighted_dif_up(L) + forc_dir(radtype) * & + weighted_dir_tr(L-1) * (1.0_r8-sum(ftweight(L,1:numpft,1)))*currentPatch%gnd_alb_dir(ib) + end if + end do!L + end do ! do while over iter + + abs_rad(ib) = 0._r8 + tr_soili = 0._r8 + tr_soild = 0._r8 + + do L = 1, currentPatch%NCL_p !working from the top down. + abs_dir_z(:,:) = 0._r8 + abs_dif_z(:,:) = 0._r8 + do ft =1,numpft + if (currentPatch%canopy_mask(L,ft) == 1)then + !==============================================================================! + ! Compute absorbed flux densities + !==============================================================================! + + ! Absorbed direct beam and diffuse do leaf layers + do iv = 1, currentPatch%nrad(L,ft) + Abs_dir_z(ft,iv) = ftweight(L,ft,iv)* forc_dir(radtype) * tr_dir_z(L,ft,iv) * & + (1.00_r8 - exp(-k_dir(ft) * (currentPatch%elai_profile(L,ft,iv)+ & + currentPatch%esai_profile(L,ft,iv)))) * (1.00_r8 - f_not_abs(ft,ib)) + Abs_dif_z(ft,iv) = ftweight(L,ft,iv)* ((Dif_dn(L,ft,iv) + & + Dif_up(L,ft,iv+1)) * (1.00_r8 - tr_dif_z(L,ft,iv)) * & + (1.00_r8 - f_not_abs(ft,ib))) + end do + + ! Absorbed direct beam and diffuse do soil + if (L == currentPatch%NCL_p)then + iv = currentPatch%nrad(L,ft) + 1 + Abs_dif_z(ft,iv) = ftweight(L,ft,1)*Dif_dn(L,ft,iv) * (1.0_r8 - currentPatch%gnd_alb_dif(ib) ) + Abs_dir_z(ft,iv) = ftweight(L,ft,1)*forc_dir(radtype) * & + tr_dir_z(L,ft,iv) * (1.0_r8 - currentPatch%gnd_alb_dir(ib) ) + tr_soild = tr_soild + ftweight(L,ft,1)*forc_dir(radtype) * tr_dir_z(L,ft,iv) + tr_soili = tr_soili + ftweight(L,ft,1)*Dif_dn(L,ft,iv) + end if + + ! Absorbed radiation, shaded and sunlit portions of leaf layers + !here we get one unit of diffuse radiation... how much of + !it is absorbed? + if (ib == ivis) then ! only set the absorbed PAR for the visible light band. + do iv = 1, currentPatch%nrad(L,ft) + if (radtype==idirect) then + if ( debug ) then + write(fates_log(),*) 'EDsurfAlb 730 ',Abs_dif_z(ft,iv),currentPatch%f_sun(L,ft,iv) + write(fates_log(),*) 'EDsurfAlb 731 ', currentPatch%fabd_sha_z(L,ft,iv), & + currentPatch%fabd_sun_z(L,ft,iv) + endif + currentPatch%fabd_sha_z(L,ft,iv) = Abs_dif_z(ft,iv) * & + (1._r8 - currentPatch%f_sun(L,ft,iv)) + currentPatch%fabd_sun_z(L,ft,iv) = Abs_dif_z(ft,iv) * & + currentPatch%f_sun(L,ft,iv) + & + Abs_dir_z(ft,iv) + else + currentPatch%fabi_sha_z(L,ft,iv) = Abs_dif_z(ft,iv) * & + (1._r8 - currentPatch%f_sun(L,ft,iv)) + currentPatch%fabi_sun_z(L,ft,iv) = Abs_dif_z(ft,iv) * & + currentPatch%f_sun(L,ft,iv) + endif + if ( debug ) then + write(fates_log(),*) 'EDsurfAlb 740 ', currentPatch%fabd_sha_z(L,ft,iv), & + currentPatch%fabd_sun_z(L,ft,iv) + endif + end do + endif ! ib + + + !==============================================================================! + ! Sum fluxes + !==============================================================================! + ! Solar radiation absorbed by ground + iv = currentPatch%nrad(L,ft) + 1 + if (L==currentPatch%NCL_p)then + abs_rad(ib) = abs_rad(ib) + (Abs_dir_z(ft,iv) + Abs_dif_z(ft,iv)) + end if + ! Solar radiation absorbed by vegetation and sunlit/shaded leaves + do iv = 1,currentPatch%nrad(L,ft) + if (radtype == idirect)then + currentPatch%fabd(ib) = currentPatch%fabd(ib) + & + Abs_dir_z(ft,iv)+Abs_dif_z(ft,iv) + ! bc_out(s)%fabd_parb_out(ib) = currentPatch%fabd(ib) + else + currentPatch%fabi(ib) = currentPatch%fabi(ib) + Abs_dif_z(ft,iv) + ! bc_out(s)%fabi_parb_out(ib) = currentPatch%fabi(ib) + endif + end do + + ! Albefor + if (L==1)then !top canopy layer. + if (radtype == idirect)then + albd_parb_out(ib) = albd_parb_out(ib) + & + Dif_up(L,ft,1) * ftweight(L,ft,1) + else + albi_parb_out(ib) = albi_parb_out(ib) + & + Dif_up(L,ft,1) * ftweight(L,ft,1) + end if + end if + + ! pass normalized PAR profiles for use in diagnostic averaging for history fields + if (ib == ivis) then ! only diagnose PAR profiles for the visible band + do iv = 1, currentPatch%nrad(L,ft) + currentPatch%nrmlzd_parprof_pft_dir_z(radtype,L,ft,iv) = & + forc_dir(radtype) * tr_dir_z(L,ft,iv) + currentPatch%nrmlzd_parprof_pft_dif_z(radtype,L,ft,iv) = & + Dif_dn(L,ft,iv) + Dif_up(L,ft,iv) + ! + currentPatch%nrmlzd_parprof_dir_z(radtype,L,iv) = & + currentPatch%nrmlzd_parprof_dir_z(radtype,L,iv) + & + (forc_dir(radtype) * tr_dir_z(L,ft,iv)) * & + (ftweight(L,ft,iv) / sum(ftweight(L,1:numpft,iv))) + currentPatch%nrmlzd_parprof_dif_z(radtype,L,iv) = & + currentPatch%nrmlzd_parprof_dif_z(radtype,L,iv) + & + (Dif_dn(L,ft,iv) + Dif_up(L,ft,iv)) * & + (ftweight(L,ft,iv) / sum(ftweight(L,1:numpft,iv))) + end do + end if ! ib = visible + end if ! present + end do !ft + if (radtype == idirect)then + fabd_parb_out(ib) = currentPatch%fabd(ib) + else + fabi_parb_out(ib) = currentPatch%fabi(ib) + endif + + + !radiation absorbed from fluxes through unfilled part of lower canopy. + if (currentPatch%NCL_p > 1.and.L == currentPatch%NCL_p)then + abs_rad(ib) = abs_rad(ib) + weighted_dif_down(L-1) * & + (1.0_r8-sum(ftweight(L,1:numpft,1)))*(1.0_r8-currentPatch%gnd_alb_dif(ib) ) + abs_rad(ib) = abs_rad(ib) + forc_dir(radtype) * weighted_dir_tr(L-1) * & + (1.0_r8-sum(ftweight(L,1:numpft,1)))*(1.0_r8-currentPatch%gnd_alb_dir(ib) ) + tr_soili = tr_soili + weighted_dif_down(L-1) * (1.0_r8-sum(ftweight(L,1:numpft,1))) + tr_soild = tr_soild + forc_dir(radtype) * weighted_dir_tr(L-1) * (1.0_r8-sum(ftweight(L,1:numpft,1))) + endif + + if (radtype == idirect)then + currentPatch%tr_soil_dir(ib) = tr_soild + currentPatch%tr_soil_dir_dif(ib) = tr_soili + currentPatch%sabs_dir(ib) = abs_rad(ib) + ftdd_parb_out(ib) = tr_soild + ftid_parb_out(ib) = tr_soili + else + currentPatch%tr_soil_dif(ib) = tr_soili + currentPatch%sabs_dif(ib) = abs_rad(ib) + ftii_parb_out(ib) = tr_soili + end if + + end do!l + + + !==============================================================================! + ! Conservation check + !==============================================================================! + ! Total radiation balance: absorbed = incoming - outgoing + + if (radtype == idirect)then + error = abs(currentPatch%sabs_dir(ib) - (currentPatch%tr_soil_dir(ib) * & + (1.0_r8-currentPatch%gnd_alb_dir(ib) ) + & + currentPatch%tr_soil_dir_dif(ib) * (1.0_r8-currentPatch%gnd_alb_dif(ib) ))) + if ( abs(error) > 0.0001)then + write(fates_log(),*)'dir ground absorption error',error,currentPatch%sabs_dir(ib), & + currentPatch%tr_soil_dir(ib)* & + (1.0_r8-currentPatch%gnd_alb_dir(ib) ),currentPatch%NCL_p,ib,sum(ftweight(1,1:numpft,1)) + write(fates_log(),*) 'albedos',currentPatch%sabs_dir(ib) ,currentPatch%tr_soil_dir(ib), & + (1.0_r8-currentPatch%gnd_alb_dir(ib) ) + + do ft =1,3 + iv = currentPatch%nrad(1,ft) + 1 + write(fates_log(),*) 'abs soil fluxes', Abs_dir_z(ft,iv),Abs_dif_z(ft,iv) + end do + + end if else - bc_out(s)%fsun_pa(ifp) = 0._r8 + if ( abs(currentPatch%sabs_dif(ib)-(currentPatch%tr_soil_dif(ib) * & + (1.0_r8-currentPatch%gnd_alb_dif(ib) ))) > 0.0001_r8)then + write(fates_log(),*)'dif ground absorption error',currentPatch%sabs_dif(ib) , & + (currentPatch%tr_soil_dif(ib)* & + (1.0_r8-currentPatch%gnd_alb_dif(ib) )),currentPatch%NCL_p,ib,sum(ftweight(1,1:numpft,1)) + endif endif - - if(bc_out(s)%fsun_pa(ifp) > 1._r8)then - write(fates_log(),*) 'too much leaf area in profile', bc_out(s)%fsun_pa(ifp), & - sunlai,shalai + + if (radtype == idirect)then + error = (forc_dir(radtype) + forc_dif(radtype)) - & + (fabd_parb_out(ib) + albd_parb_out(ib) + currentPatch%sabs_dir(ib)) + else + error = (forc_dir(radtype) + forc_dif(radtype)) - & + (fabi_parb_out(ib) + albi_parb_out(ib) + currentPatch%sabs_dif(ib)) endif + lai_reduction(:) = 0.0_r8 + do L = 1, currentPatch%NCL_p + do ft =1,numpft + if (currentPatch%canopy_mask(L,ft) == 1)then + do iv = 1, currentPatch%nrad(L,ft) + if (lai_change(L,ft,iv) > 0.0_r8)then + lai_reduction(L) = max(lai_reduction(L),lai_change(L,ft,iv)) + endif + enddo + endif + enddo + enddo + + if (radtype == idirect)then + !here we are adding a within-ED radiation scheme tolerance, and then adding the diffrence onto the albedo + !it is important that the lower boundary for this is ~1000 times smaller than the tolerance in surface albedo. + if (abs(error) > 1.e-9_r8 .and. abs(error) < 0.15_r8)then + albd_parb_out(ib) = albd_parb_out(ib) + error + !this terms adds the error back on to the albedo. While this is partly inexcusable, it is + ! in the medium term a solution that + ! prevents the model from crashing with small and occasional energy balances issues. + ! These are extremely difficult to debug, many have been solved already, leading + ! to the complexity of this code, but where the system generates occasional errors, we + ! will deal with them for now. + end if + if (abs(error) > 0.15_r8)then + write(fates_log(),*) 'Large Dir Radn consvn error',error ,ib + write(fates_log(),*) 'diags', albd_parb_out(ib), ftdd_parb_out(ib), & + ftid_parb_out(ib), fabd_parb_out(ib) + write(fates_log(),*) 'lai_change',lai_change(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) + write(fates_log(),*) 'elai',currentpatch%elai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) + write(fates_log(),*) 'esai',currentpatch%esai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) + write(fates_log(),*) 'ftweight',ftweight(1,1:numpft,1:diag_nlevleaf) + write(fates_log(),*) 'cp',currentPatch%area, currentPatch%patchno + write(fates_log(),*) 'ground albedo diffuse (ib)', currentPatch%gnd_alb_dir(ib) + + albd_parb_out(ib) = albd_parb_out(ib) + error + end if + else + + if (abs(error) > 1.e-9_r8 .and. abs(error) < 0.15_r8)then + albi_parb_out(ib) = albi_parb_out(ib) + error + end if + + if (abs(error) > 0.15_r8)then + write(fates_log(),*) '>5% Dif Radn consvn error',error ,ib + write(fates_log(),*) 'diags', albi_parb_out(ib), ftii_parb_out(ib), & + fabi_parb_out(ib) + write(fates_log(),*) 'lai_change',lai_change(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) + write(fates_log(),*) 'elai',currentpatch%elai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) + write(fates_log(),*) 'esai',currentpatch%esai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) + write(fates_log(),*) 'ftweight',ftweight(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) + write(fates_log(),*) 'cp',currentPatch%area, currentPatch%patchno + write(fates_log(),*) 'ground albedo diffuse (ib)', currentPatch%gnd_alb_dir(ib) + write(fates_log(),*) 'rhol',rhol(1:numpft,:) + write(fates_log(),*) 'ftw',sum(ftweight(1,1:numpft,1)),ftweight(1,1:numpft,1) + write(fates_log(),*) 'present',currentPatch%canopy_mask(1,1:numpft) + write(fates_log(),*) 'CAP',currentPatch%canopy_area_profile(1,1:numpft,1) + + albi_parb_out(ib) = albi_parb_out(ib) + error + end if + + if (radtype == idirect)then + error = (forc_dir(radtype) + forc_dif(radtype)) - & + (fabd_parb_out(ib) + albd_parb_out(ib) + currentPatch%sabs_dir(ib)) + else + error = (forc_dir(radtype) + forc_dif(radtype)) - & + (fabi_parb_out(ib) + albi_parb_out(ib) + currentPatch%sabs_dif(ib)) + endif + + if (abs(error) > 0.00000001_r8)then + write(fates_log(),*) 'there is still error after correction',error ,ib + end if + + end if + + end do !hlm_numSWb + + enddo ! rad-type + + + end associate + return +end subroutine PatchNormanRadiation + +! ====================================================================================== + +subroutine ED_SunShadeFracs(nsites, sites,bc_in,bc_out) + + implicit none + + ! Arguments + integer,intent(in) :: nsites + type(ed_site_type),intent(inout),target :: sites(nsites) + type(bc_in_type),intent(in) :: bc_in(nsites) + type(bc_out_type),intent(inout) :: bc_out(nsites) + + + ! locals + type (ed_patch_type),pointer :: cpatch ! c"urrent" patch + real(r8) :: sunlai + real(r8) :: shalai + real(r8) :: elai + integer :: CL + integer :: FT + integer :: iv + integer :: s + integer :: ifp + + + do s = 1,nsites + + ifp = 0 + cpatch => sites(s)%oldest_patch + + do while (associated(cpatch)) + if(cpatch%nocomp_pft_label.ne.0)then !only for veg patches + ! do not do albedo calculations for bare ground patch in SP mode + ! and (more impotantly) do not iterate ifp or it will mess up the indexing wherein + ! ifp=1 is the first vegetated patch. + ifp=ifp+1 + + if( debug ) write(fates_log(),*) 'edsurfRad_5600',ifp,s,cpatch%NCL_p,numpft + + ! zero out various datas + cpatch%ed_parsun_z(:,:,:) = 0._r8 + cpatch%ed_parsha_z(:,:,:) = 0._r8 + cpatch%ed_laisun_z(:,:,:) = 0._r8 + cpatch%ed_laisha_z(:,:,:) = 0._r8 + + bc_out(s)%fsun_pa(ifp) = 0._r8 + + sunlai = 0._r8 + shalai = 0._r8 + + cpatch%parprof_pft_dir_z(:,:,:) = 0._r8 + cpatch%parprof_pft_dif_z(:,:,:) = 0._r8 + cpatch%parprof_dir_z(:,:) = 0._r8 + cpatch%parprof_dif_z(:,:) = 0._r8 + + ! Loop over patches to calculate laisun_z and laisha_z for each layer. + ! Derive canopy laisun, laisha, and fsun from layer sums. + ! If sun/shade big leaf code, nrad=1 and fsun_z(p,1) and tlai_z(p,1) from + ! SurfaceAlbedo is canopy integrated so that layer value equals canopy value. + + ! cpatch%f_sun is calculated in the surface_albedo routine... + + do CL = 1, cpatch%NCL_p + do FT = 1,numpft + + if( debug ) write(fates_log(),*) 'edsurfRad_5601',CL,FT,cpatch%nrad(CL,ft) + + do iv = 1, cpatch%nrad(CL,ft) !NORMAL CASE. + + ! FIX(SPM,040114) - existing comment + ! ** Should this be elai or tlai? Surely we only do radiation for elai? + + cpatch%ed_laisun_z(CL,ft,iv) = cpatch%elai_profile(CL,ft,iv) * & + cpatch%f_sun(CL,ft,iv) + + if ( debug ) write(fates_log(),*) 'edsurfRad 570 ',cpatch%elai_profile(CL,ft,iv) + if ( debug ) write(fates_log(),*) 'edsurfRad 571 ',cpatch%f_sun(CL,ft,iv) + + cpatch%ed_laisha_z(CL,ft,iv) = cpatch%elai_profile(CL,ft,iv) * & + (1._r8 - cpatch%f_sun(CL,ft,iv)) + + end do + + !needed for the VOC emissions, etc. + sunlai = sunlai + sum(cpatch%ed_laisun_z(CL,ft,1:cpatch%nrad(CL,ft))) + shalai = shalai + sum(cpatch%ed_laisha_z(CL,ft,1:cpatch%nrad(CL,ft))) + + end do + end do + + if(sunlai+shalai > 0._r8)then + bc_out(s)%fsun_pa(ifp) = sunlai / (sunlai+shalai) + else + bc_out(s)%fsun_pa(ifp) = 0._r8 + endif + + if(bc_out(s)%fsun_pa(ifp) > 1._r8)then + write(fates_log(),*) 'too much leaf area in profile', bc_out(s)%fsun_pa(ifp), & + sunlai,shalai + endif + + elai = calc_areaindex(cpatch,'elai') + + bc_out(s)%laisun_pa(ifp) = elai*bc_out(s)%fsun_pa(ifp) + bc_out(s)%laisha_pa(ifp) = elai*(1.0_r8-bc_out(s)%fsun_pa(ifp)) + + ! Absorbed PAR profile through canopy + ! If sun/shade big leaf code, nrad=1 and fluxes from SurfaceAlbedo + ! are canopy integrated so that layer values equal big leaf values. + + if ( debug ) write(fates_log(),*) 'edsurfRad 645 ',cpatch%NCL_p,numpft + + do CL = 1, cpatch%NCL_p + do FT = 1,numpft + + if ( debug ) write(fates_log(),*) 'edsurfRad 649 ',cpatch%nrad(CL,ft) + + do iv = 1, cpatch%nrad(CL,ft) + + if ( debug ) then + write(fates_log(),*) 'edsurfRad 653 ', cpatch%ed_parsun_z(CL,ft,iv) + write(fates_log(),*) 'edsurfRad 654 ', bc_in(s)%solad_parb(ifp,ipar) + write(fates_log(),*) 'edsurfRad 655 ', bc_in(s)%solai_parb(ifp,ipar) + write(fates_log(),*) 'edsurfRad 656 ', cpatch%fabd_sun_z(CL,ft,iv) + write(fates_log(),*) 'edsurfRad 657 ', cpatch%fabi_sun_z(CL,ft,iv) + endif + + cpatch%ed_parsun_z(CL,ft,iv) = & + bc_in(s)%solad_parb(ifp,ipar)*cpatch%fabd_sun_z(CL,ft,iv) + & + bc_in(s)%solai_parb(ifp,ipar)*cpatch%fabi_sun_z(CL,ft,iv) + + if ( debug )write(fates_log(),*) 'edsurfRad 663 ', cpatch%ed_parsun_z(CL,ft,iv) + + cpatch%ed_parsha_z(CL,ft,iv) = & + bc_in(s)%solad_parb(ifp,ipar)*cpatch%fabd_sha_z(CL,ft,iv) + & + bc_in(s)%solai_parb(ifp,ipar)*cpatch%fabi_sha_z(CL,ft,iv) + + if ( debug ) write(fates_log(),*) 'edsurfRad 669 ', cpatch%ed_parsha_z(CL,ft,iv) + + end do !iv + end do !FT + end do !CL + + ! 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 - elai = calc_areaindex(cpatch,'elai') - - bc_out(s)%laisun_pa(ifp) = elai*bc_out(s)%fsun_pa(ifp) - bc_out(s)%laisha_pa(ifp) = elai*(1.0_r8-bc_out(s)%fsun_pa(ifp)) - - ! Absorbed PAR profile through canopy - ! If sun/shade big leaf code, nrad=1 and fluxes from SurfaceAlbedo - ! are canopy integrated so that layer values equal big leaf values. - - if ( debug ) write(fates_log(),*) 'edsurfRad 645 ',cpatch%NCL_p,numpft - - do CL = 1, cpatch%NCL_p - do FT = 1,numpft - - if ( debug ) write(fates_log(),*) 'edsurfRad 649 ',cpatch%nrad(CL,ft) - - do iv = 1, cpatch%nrad(CL,ft) - - if ( debug ) then - write(fates_log(),*) 'edsurfRad 653 ', cpatch%ed_parsun_z(CL,ft,iv) - write(fates_log(),*) 'edsurfRad 654 ', bc_in(s)%solad_parb(ifp,ipar) - write(fates_log(),*) 'edsurfRad 655 ', bc_in(s)%solai_parb(ifp,ipar) - write(fates_log(),*) 'edsurfRad 656 ', cpatch%fabd_sun_z(CL,ft,iv) - write(fates_log(),*) 'edsurfRad 657 ', cpatch%fabi_sun_z(CL,ft,iv) - endif - - cpatch%ed_parsun_z(CL,ft,iv) = & - bc_in(s)%solad_parb(ifp,ipar)*cpatch%fabd_sun_z(CL,ft,iv) + & - bc_in(s)%solai_parb(ifp,ipar)*cpatch%fabi_sun_z(CL,ft,iv) - - if ( debug )write(fates_log(),*) 'edsurfRad 663 ', cpatch%ed_parsun_z(CL,ft,iv) - - cpatch%ed_parsha_z(CL,ft,iv) = & - bc_in(s)%solad_parb(ifp,ipar)*cpatch%fabd_sha_z(CL,ft,iv) + & - bc_in(s)%solai_parb(ifp,ipar)*cpatch%fabi_sha_z(CL,ft,iv) - - if ( debug ) write(fates_log(),*) 'edsurfRad 669 ', cpatch%ed_parsha_z(CL,ft,iv) - - end do !iv - end do !FT - end do !CL - - ! output the actual PAR profiles through the canopy for diagnostic purposes - - do CL = 1, cpatch%NCL_p - do FT = 1,numpft - do iv = 1, cpatch%nrad(CL,ft) - cpatch%parprof_pft_dir_z(CL,FT,iv) = (bc_in(s)%solad_parb(ifp,ipar) * & - cpatch%nrmlzd_parprof_pft_dir_z(idirect,CL,FT,iv)) + & - (bc_in(s)%solai_parb(ifp,ipar) * & - cpatch%nrmlzd_parprof_pft_dir_z(idiffuse,CL,FT,iv)) - cpatch%parprof_pft_dif_z(CL,FT,iv) = (bc_in(s)%solad_parb(ifp,ipar) * & - cpatch%nrmlzd_parprof_pft_dif_z(idirect,CL,FT,iv)) + & - (bc_in(s)%solai_parb(ifp,ipar) * & - cpatch%nrmlzd_parprof_pft_dif_z(idiffuse,CL,FT,iv)) - end do ! iv - end do ! FT - end do ! CL - - do CL = 1, cpatch%NCL_p - do iv = 1, maxval(cpatch%nrad(CL,:)) - cpatch%parprof_dir_z(CL,iv) = (bc_in(s)%solad_parb(ifp,ipar) * & - cpatch%nrmlzd_parprof_dir_z(idirect,CL,iv)) + & - (bc_in(s)%solai_parb(ifp,ipar) * & - cpatch%nrmlzd_parprof_dir_z(idiffuse,CL,iv)) - cpatch%parprof_dif_z(CL,iv) = (bc_in(s)%solad_parb(ifp,ipar) * & - cpatch%nrmlzd_parprof_dif_z(idirect,CL,iv)) + & - (bc_in(s)%solai_parb(ifp,ipar) * & - cpatch%nrmlzd_parprof_dif_z(idiffuse,CL,iv)) - end do ! iv - end do ! CL - endif ! not bareground patch - cpatch => cpatch%younger - enddo - - - enddo - return - end subroutine ED_SunShadeFracs @@ -1240,6 +1246,6 @@ end subroutine ED_SunShadeFracs ! end do ! return ! end subroutine ED_CheckSolarBalance - + end module EDSurfaceRadiationMod From 543c4d70fa04100c6f3b26d96cc736f6b6b2c17d Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 25 Nov 2020 08:45:08 -0700 Subject: [PATCH 151/209] indenting EDAccumulateFluxesMod.F90 --- biogeophys/EDAccumulateFluxesMod.F90 | 96 ++++++++++++++-------------- 1 file changed, 48 insertions(+), 48 deletions(-) diff --git a/biogeophys/EDAccumulateFluxesMod.F90 b/biogeophys/EDAccumulateFluxesMod.F90 index f9bf10e44f..a0fe4dd7df 100644 --- a/biogeophys/EDAccumulateFluxesMod.F90 +++ b/biogeophys/EDAccumulateFluxesMod.F90 @@ -23,8 +23,8 @@ module EDAccumulateFluxesMod logical :: debug = .false. ! for debugging this module character(len=*), parameter, private :: sourcefile = & - __FILE__ - + __FILE__ + contains !------------------------------------------------------------------------------ @@ -36,9 +36,9 @@ subroutine AccumulateFluxes_ED(nsites, sites, bc_in, bc_out, dt_time) ! see above ! ! !USES: - + use EDTypesMod , only : ed_patch_type, ed_cohort_type, & - ed_site_type, AREA + ed_site_type, AREA use FatesInterfaceTypesMod , only : bc_in_type,bc_out_type ! @@ -59,59 +59,59 @@ subroutine AccumulateFluxes_ED(nsites, sites, bc_in, bc_out, dt_time) !---------------------------------------------------------------------- do s = 1, nsites - + ifp = 0 cpatch => sites(s)%oldest_patch do while (associated(cpatch)) - if(cpatch%nocomp_pft_label.ne.0)then - ifp = ifp+1 - - if( bc_in(s)%filter_photo_pa(ifp) == 3 ) then - ccohort => cpatch%shortest - do while(associated(ccohort)) - - ! Accumulate fluxes from hourly to daily values. - ! _tstep fluxes are KgC/indiv/timestep _acc are KgC/indiv/day - - if ( debug ) then - - write(fates_log(),*) 'EDAccumFlux 64 ',ccohort%npp_tstep - write(fates_log(),*) 'EDAccumFlux 66 ',ccohort%gpp_tstep - write(fates_log(),*) 'EDAccumFlux 67 ',ccohort%resp_tstep - - endif - - ccohort%npp_acc = ccohort%npp_acc + ccohort%npp_tstep - ccohort%gpp_acc = ccohort%gpp_acc + ccohort%gpp_tstep - ccohort%resp_acc = ccohort%resp_acc + ccohort%resp_tstep - - ! weighted mean of D13C by gpp - if((ccohort%gpp_acc + ccohort%gpp_tstep) .eq. 0.0_r8) then - ccohort%c13disc_acc = 0.0_r8 - else - ccohort%c13disc_acc = ((ccohort%c13disc_acc * ccohort%gpp_acc) + & - (ccohort%c13disc_clm * ccohort%gpp_tstep)) / & - (ccohort%gpp_acc + ccohort%gpp_tstep) - endif - - do iv=1,ccohort%nv - if(ccohort%year_net_uptake(iv) == 999._r8)then ! note that there were leaves in this layer this year. - ccohort%year_net_uptake(iv) = 0._r8 - end if - ccohort%year_net_uptake(iv) = ccohort%year_net_uptake(iv) + ccohort%ts_net_uptake(iv) - enddo - - ccohort => ccohort%taller - enddo ! while(associated(ccohort)) - end if + if(cpatch%nocomp_pft_label.ne.0)then + ifp = ifp+1 + + if( bc_in(s)%filter_photo_pa(ifp) == 3 ) then + ccohort => cpatch%shortest + do while(associated(ccohort)) + + ! Accumulate fluxes from hourly to daily values. + ! _tstep fluxes are KgC/indiv/timestep _acc are KgC/indiv/day + + if ( debug ) then + + write(fates_log(),*) 'EDAccumFlux 64 ',ccohort%npp_tstep + write(fates_log(),*) 'EDAccumFlux 66 ',ccohort%gpp_tstep + write(fates_log(),*) 'EDAccumFlux 67 ',ccohort%resp_tstep + + endif + + ccohort%npp_acc = ccohort%npp_acc + ccohort%npp_tstep + ccohort%gpp_acc = ccohort%gpp_acc + ccohort%gpp_tstep + ccohort%resp_acc = ccohort%resp_acc + ccohort%resp_tstep + + ! weighted mean of D13C by gpp + if((ccohort%gpp_acc + ccohort%gpp_tstep) .eq. 0.0_r8) then + ccohort%c13disc_acc = 0.0_r8 + else + ccohort%c13disc_acc = ((ccohort%c13disc_acc * ccohort%gpp_acc) + & + (ccohort%c13disc_clm * ccohort%gpp_tstep)) / & + (ccohort%gpp_acc + ccohort%gpp_tstep) + endif + + do iv=1,ccohort%nv + if(ccohort%year_net_uptake(iv) == 999._r8)then ! note that there were leaves in this layer this year. + ccohort%year_net_uptake(iv) = 0._r8 + end if + ccohort%year_net_uptake(iv) = ccohort%year_net_uptake(iv) + ccohort%ts_net_uptake(iv) + enddo + + ccohort => ccohort%taller + enddo ! while(associated(ccohort)) + end if end if ! not bare ground cpatch => cpatch%younger end do ! while(associated(cpatch)) end do return - - end subroutine AccumulateFluxes_ED + + end subroutine AccumulateFluxes_ED end module EDAccumulateFluxesMod From 73e8799e52f53e899f61a57e78842d89ef6fd2e7 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 25 Nov 2020 08:53:39 -0700 Subject: [PATCH 152/209] indenting EDBtranMod.F90 --- biogeophys/EDBtranMod.F90 | 428 +++++++++++++++++++------------------- 1 file changed, 214 insertions(+), 214 deletions(-) diff --git a/biogeophys/EDBtranMod.F90 b/biogeophys/EDBtranMod.F90 index 5bdcd966bb..17b279d6b3 100644 --- a/biogeophys/EDBtranMod.F90 +++ b/biogeophys/EDBtranMod.F90 @@ -1,44 +1,44 @@ module EDBtranMod - - !------------------------------------------------------------------------------------- - ! Description: - ! - ! ------------------------------------------------------------------------------------ - - use EDPftvarcon , only : EDPftvarcon_inst - use FatesConstantsMod , only : tfrz => t_water_freeze_k_1atm - use FatesConstantsMod , only : itrue,ifalse,nearzero - use EDTypesMod , only : ed_site_type, & - ed_patch_type, & - ed_cohort_type, & - maxpft - use shr_kind_mod , only : r8 => shr_kind_r8 - use FatesInterfaceTypesMod , only : bc_in_type, & - bc_out_type, & - numpft - use FatesInterfaceTypesMod , only : hlm_use_planthydro - use FatesGlobals , only : fates_log - use FatesAllometryMod , only : set_root_fraction - - ! - implicit none - private - - public :: btran_ed - public :: get_active_suction_layers - public :: check_layer_water - + + !------------------------------------------------------------------------------------- + ! Description: + ! + ! ------------------------------------------------------------------------------------ + + use EDPftvarcon , only : EDPftvarcon_inst + use FatesConstantsMod , only : tfrz => t_water_freeze_k_1atm + use FatesConstantsMod , only : itrue,ifalse,nearzero + use EDTypesMod , only : ed_site_type, & + ed_patch_type, & + ed_cohort_type, & + maxpft + use shr_kind_mod , only : r8 => shr_kind_r8 + use FatesInterfaceTypesMod , only : bc_in_type, & + bc_out_type, & + numpft + use FatesInterfaceTypesMod , only : hlm_use_planthydro + use FatesGlobals , only : fates_log + use FatesAllometryMod , only : set_root_fraction + + ! + implicit none + private + + public :: btran_ed + public :: get_active_suction_layers + public :: check_layer_water + contains - + ! ==================================================================================== logical function check_layer_water(h2o_liq_vol, tempk) - + implicit none ! Arguments real(r8),intent(in) :: h2o_liq_vol real(r8),intent(in) :: tempk - + check_layer_water = .false. if ( h2o_liq_vol .gt. 0._r8 ) then @@ -50,206 +50,206 @@ logical function check_layer_water(h2o_liq_vol, tempk) end function check_layer_water ! ===================================================================================== - + subroutine get_active_suction_layers(nsites, sites, bc_in, bc_out) - + ! Arguments - + integer,intent(in) :: nsites type(ed_site_type),intent(inout),target :: sites(nsites) type(bc_in_type),intent(in) :: bc_in(nsites) type(bc_out_type),intent(inout) :: bc_out(nsites) - + ! !LOCAL VARIABLES: integer :: s ! site integer :: j ! soil layer !------------------------------------------------------------------------------ - - do s = 1,nsites - if (bc_in(s)%filter_btran) then - do j = 1,bc_in(s)%nlevsoil - bc_out(s)%active_suction_sl(j) = check_layer_water( bc_in(s)%h2o_liqvol_sl(j),bc_in(s)%tempk_sl(j) ) - end do - else - bc_out(s)%active_suction_sl(:) = .false. - end if - end do + + do s = 1,nsites + if (bc_in(s)%filter_btran) then + do j = 1,bc_in(s)%nlevsoil + bc_out(s)%active_suction_sl(j) = check_layer_water( bc_in(s)%h2o_liqvol_sl(j),bc_in(s)%tempk_sl(j) ) + end do + else + bc_out(s)%active_suction_sl(:) = .false. + end if + end do end subroutine get_active_suction_layers - + ! ===================================================================================== subroutine btran_ed( nsites, sites, bc_in, bc_out) use FatesPlantHydraulicsMod, only : BTranForHLMDiagnosticsFromCohortHydr - - ! --------------------------------------------------------------------------------- - ! Calculate the transpiration wetness function (BTRAN) and the root uptake - ! distribution (ROOTR). - ! Boundary conditions in: bc_in(s)%eff_porosity_sl(j) unfrozen porosity - ! bc_in(s)%watsat_sl(j) porosity - ! bc_in(s)%active_uptake_sl(j) frozen/not frozen - ! bc_in(s)%smp_sl(j) suction - ! Boundary conditions out: bc_out(s)%rootr_pasl root uptake distribution - ! bc_out(s)%btran_pa wetness factor - ! --------------------------------------------------------------------------------- - - ! Arguments - - integer,intent(in) :: nsites - type(ed_site_type),intent(inout),target :: sites(nsites) - type(bc_in_type),intent(in) :: bc_in(nsites) - type(bc_out_type),intent(inout) :: bc_out(nsites) - - ! - ! !LOCAL VARIABLES: - type(ed_patch_type),pointer :: cpatch ! Current Patch Pointer - type(ed_cohort_type),pointer :: ccohort ! Current cohort pointer - integer :: s ! site - integer :: j ! soil layer - integer :: ifp ! patch vector index for the site - integer :: ft ! plant functional type index - real(r8) :: smp_node ! matrix potential - real(r8) :: rresis ! suction limitation to transpiration independent - ! of root density - real(r8) :: pftgs(maxpft) ! pft weighted stomatal conductance m/s - real(r8) :: temprootr - real(r8) :: sum_pftgs ! sum of weighted conductances (for normalization) - real(r8), allocatable :: root_resis(:,:) ! Root resistance in each pft x layer - !------------------------------------------------------------------------------ - - associate( & - smpsc => EDPftvarcon_inst%smpsc , & ! INTERF-TODO: THESE SHOULD BE FATES PARAMETERS - smpso => EDPftvarcon_inst%smpso & ! INTERF-TODO: THESE SHOULD BE FATES PARAMETERS - ) - - do s = 1,nsites - - allocate(root_resis(numpft,bc_in(s)%nlevsoil)) - - bc_out(s)%rootr_pasl(:,:) = 0._r8 - - ifp = 0 - cpatch => sites(s)%oldest_patch - do while (associated(cpatch)) - if(cpatch%nocomp_pft_label.ne.0)then ! only for veg patches - ifp=ifp+1 - - ! THIS SHOULD REALLY BE A COHORT LOOP ONCE WE HAVE rootfr_ft FOR COHORTS (RGK) - - do ft = 1,numpft - - call set_root_fraction(sites(s)%rootfrac_scr, ft, sites(s)%zi_soil ) - - cpatch%btran_ft(ft) = 0.0_r8 - do j = 1,bc_in(s)%nlevsoil - - ! Calculations are only relevant where liquid water exists - ! see clm_fates%wrap_btran for calculation with CLM/ALM - - if ( check_layer_water(bc_in(s)%h2o_liqvol_sl(j),bc_in(s)%tempk_sl(j)) ) then - - smp_node = max(smpsc(ft), bc_in(s)%smp_sl(j)) - - rresis = min( (bc_in(s)%eff_porosity_sl(j)/bc_in(s)%watsat_sl(j))* & - (smp_node - smpsc(ft)) / (smpso(ft) - smpsc(ft)), 1._r8) - - root_resis(ft,j) = sites(s)%rootfrac_scr(j)*rresis - - ! root water uptake is not linearly proportional to root density, - ! to allow proper deep root funciton. Replace with equations from SPA/Newman. FIX(RF,032414) - - cpatch%btran_ft(ft) = cpatch%btran_ft(ft) + root_resis(ft,j) - - else - root_resis(ft,j) = 0._r8 - end if - - end do !j - - ! Normalize root resistances to get layer contribution to ET - do j = 1,bc_in(s)%nlevsoil - if (cpatch%btran_ft(ft) > nearzero) then - root_resis(ft,j) = root_resis(ft,j)/cpatch%btran_ft(ft) - else - root_resis(ft,j) = 0._r8 - end if - end do - - end do !PFT - - ! PFT-averaged point level root fraction for extraction purposese. - ! The cohort's conductance g_sb_laweighted, contains a weighting factor - ! based on the cohort's leaf area. units: [m/s] * [m2] - - pftgs(1:maxpft) = 0._r8 - ccohort => cpatch%tallest - do while(associated(ccohort)) - pftgs(ccohort%pft) = pftgs(ccohort%pft) + ccohort%g_sb_laweight - ccohort => ccohort%shorter - enddo - - ! Process the boundary output, this is necessary for calculating the soil-moisture - ! sink term across the different layers in driver/host. Photosynthesis will - ! pass the host a total transpiration for the patch. This needs rootr to be - ! distributed over the soil layers. - sum_pftgs = sum(pftgs(1:numpft)) - - do j = 1, bc_in(s)%nlevsoil - bc_out(s)%rootr_pasl(ifp,j) = 0._r8 - do ft = 1,numpft - if( sum_pftgs > 0._r8)then !prevent problem with the first timestep - might fail - !bit-retart test as a result? FIX(RF,032414) - bc_out(s)%rootr_pasl(ifp,j) = bc_out(s)%rootr_pasl(ifp,j) + & - root_resis(ft,j) * pftgs(ft)/sum_pftgs - else - bc_out(s)%rootr_pasl(ifp,j) = bc_out(s)%rootr_pasl(ifp,j) + & - root_resis(ft,j) * 1._r8/real(numpft,r8) - end if - enddo - enddo - - ! Calculate the BTRAN that is passed back to the HLM - ! used only for diagnostics. If plant hydraulics is turned off - ! we are using the patchxpft level btran calculation - - if(hlm_use_planthydro.eq.ifalse) then - !weight patch level output BTRAN for the - bc_out(s)%btran_pa(ifp) = 0.0_r8 - do ft = 1,numpft - if( sum_pftgs > 0._r8)then !prevent problem with the first timestep - might fail - !bit-retart test as a result? FIX(RF,032414) - bc_out(s)%btran_pa(ifp) = bc_out(s)%btran_pa(ifp) + cpatch%btran_ft(ft) * pftgs(ft)/sum_pftgs - else - bc_out(s)%btran_pa(ifp) = bc_out(s)%btran_pa(ifp) + cpatch%btran_ft(ft) * 1./numpft - end if - enddo - end if - - temprootr = sum(bc_out(s)%rootr_pasl(ifp,1:bc_in(s)%nlevsoil)) - - if(abs(1.0_r8-temprootr) > 1.0e-10_r8 .and. temprootr > 1.0e-10_r8)then - write(fates_log(),*) 'error with rootr in canopy fluxes',temprootr,sum_pftgs - do j = 1,bc_in(s)%nlevsoil - bc_out(s)%rootr_pasl(ifp,j) = bc_out(s)%rootr_pasl(ifp,j)/temprootr - enddo - end if - endif ! not bare ground - cpatch => cpatch%younger - end do - - deallocate(root_resis) - - end do - - if(hlm_use_planthydro.eq.itrue) then - call BTranForHLMDiagnosticsFromCohortHydr(nsites,sites,bc_out) - end if - - end associate - - end subroutine btran_ed + + ! --------------------------------------------------------------------------------- + ! Calculate the transpiration wetness function (BTRAN) and the root uptake + ! distribution (ROOTR). + ! Boundary conditions in: bc_in(s)%eff_porosity_sl(j) unfrozen porosity + ! bc_in(s)%watsat_sl(j) porosity + ! bc_in(s)%active_uptake_sl(j) frozen/not frozen + ! bc_in(s)%smp_sl(j) suction + ! Boundary conditions out: bc_out(s)%rootr_pasl root uptake distribution + ! bc_out(s)%btran_pa wetness factor + ! --------------------------------------------------------------------------------- + + ! Arguments + + integer,intent(in) :: nsites + type(ed_site_type),intent(inout),target :: sites(nsites) + type(bc_in_type),intent(in) :: bc_in(nsites) + type(bc_out_type),intent(inout) :: bc_out(nsites) + + ! + ! !LOCAL VARIABLES: + type(ed_patch_type),pointer :: cpatch ! Current Patch Pointer + type(ed_cohort_type),pointer :: ccohort ! Current cohort pointer + integer :: s ! site + integer :: j ! soil layer + integer :: ifp ! patch vector index for the site + integer :: ft ! plant functional type index + real(r8) :: smp_node ! matrix potential + real(r8) :: rresis ! suction limitation to transpiration independent + ! of root density + real(r8) :: pftgs(maxpft) ! pft weighted stomatal conductance m/s + real(r8) :: temprootr + real(r8) :: sum_pftgs ! sum of weighted conductances (for normalization) + real(r8), allocatable :: root_resis(:,:) ! Root resistance in each pft x layer + !------------------------------------------------------------------------------ + + associate( & + smpsc => EDPftvarcon_inst%smpsc , & ! INTERF-TODO: THESE SHOULD BE FATES PARAMETERS + smpso => EDPftvarcon_inst%smpso & ! INTERF-TODO: THESE SHOULD BE FATES PARAMETERS + ) + + do s = 1,nsites + + allocate(root_resis(numpft,bc_in(s)%nlevsoil)) + + bc_out(s)%rootr_pasl(:,:) = 0._r8 + + ifp = 0 + cpatch => sites(s)%oldest_patch + do while (associated(cpatch)) + if(cpatch%nocomp_pft_label.ne.0)then ! only for veg patches + ifp=ifp+1 + + ! THIS SHOULD REALLY BE A COHORT LOOP ONCE WE HAVE rootfr_ft FOR COHORTS (RGK) + + do ft = 1,numpft + + call set_root_fraction(sites(s)%rootfrac_scr, ft, sites(s)%zi_soil ) + + cpatch%btran_ft(ft) = 0.0_r8 + do j = 1,bc_in(s)%nlevsoil + + ! Calculations are only relevant where liquid water exists + ! see clm_fates%wrap_btran for calculation with CLM/ALM + + if ( check_layer_water(bc_in(s)%h2o_liqvol_sl(j),bc_in(s)%tempk_sl(j)) ) then + + smp_node = max(smpsc(ft), bc_in(s)%smp_sl(j)) + + rresis = min( (bc_in(s)%eff_porosity_sl(j)/bc_in(s)%watsat_sl(j))* & + (smp_node - smpsc(ft)) / (smpso(ft) - smpsc(ft)), 1._r8) + + root_resis(ft,j) = sites(s)%rootfrac_scr(j)*rresis + + ! root water uptake is not linearly proportional to root density, + ! to allow proper deep root funciton. Replace with equations from SPA/Newman. FIX(RF,032414) + + cpatch%btran_ft(ft) = cpatch%btran_ft(ft) + root_resis(ft,j) + + else + root_resis(ft,j) = 0._r8 + end if + + end do !j + + ! Normalize root resistances to get layer contribution to ET + do j = 1,bc_in(s)%nlevsoil + if (cpatch%btran_ft(ft) > nearzero) then + root_resis(ft,j) = root_resis(ft,j)/cpatch%btran_ft(ft) + else + root_resis(ft,j) = 0._r8 + end if + end do + + end do !PFT + + ! PFT-averaged point level root fraction for extraction purposese. + ! The cohort's conductance g_sb_laweighted, contains a weighting factor + ! based on the cohort's leaf area. units: [m/s] * [m2] + + pftgs(1:maxpft) = 0._r8 + ccohort => cpatch%tallest + do while(associated(ccohort)) + pftgs(ccohort%pft) = pftgs(ccohort%pft) + ccohort%g_sb_laweight + ccohort => ccohort%shorter + enddo + + ! Process the boundary output, this is necessary for calculating the soil-moisture + ! sink term across the different layers in driver/host. Photosynthesis will + ! pass the host a total transpiration for the patch. This needs rootr to be + ! distributed over the soil layers. + sum_pftgs = sum(pftgs(1:numpft)) + + do j = 1, bc_in(s)%nlevsoil + bc_out(s)%rootr_pasl(ifp,j) = 0._r8 + do ft = 1,numpft + if( sum_pftgs > 0._r8)then !prevent problem with the first timestep - might fail + !bit-retart test as a result? FIX(RF,032414) + bc_out(s)%rootr_pasl(ifp,j) = bc_out(s)%rootr_pasl(ifp,j) + & + root_resis(ft,j) * pftgs(ft)/sum_pftgs + else + bc_out(s)%rootr_pasl(ifp,j) = bc_out(s)%rootr_pasl(ifp,j) + & + root_resis(ft,j) * 1._r8/real(numpft,r8) + end if + enddo + enddo + + ! Calculate the BTRAN that is passed back to the HLM + ! used only for diagnostics. If plant hydraulics is turned off + ! we are using the patchxpft level btran calculation + + if(hlm_use_planthydro.eq.ifalse) then + !weight patch level output BTRAN for the + bc_out(s)%btran_pa(ifp) = 0.0_r8 + do ft = 1,numpft + if( sum_pftgs > 0._r8)then !prevent problem with the first timestep - might fail + !bit-retart test as a result? FIX(RF,032414) + bc_out(s)%btran_pa(ifp) = bc_out(s)%btran_pa(ifp) + cpatch%btran_ft(ft) * pftgs(ft)/sum_pftgs + else + bc_out(s)%btran_pa(ifp) = bc_out(s)%btran_pa(ifp) + cpatch%btran_ft(ft) * 1./numpft + end if + enddo + end if + + temprootr = sum(bc_out(s)%rootr_pasl(ifp,1:bc_in(s)%nlevsoil)) + + if(abs(1.0_r8-temprootr) > 1.0e-10_r8 .and. temprootr > 1.0e-10_r8)then + write(fates_log(),*) 'error with rootr in canopy fluxes',temprootr,sum_pftgs + do j = 1,bc_in(s)%nlevsoil + bc_out(s)%rootr_pasl(ifp,j) = bc_out(s)%rootr_pasl(ifp,j)/temprootr + enddo + end if + endif ! not bare ground + cpatch => cpatch%younger + end do + + deallocate(root_resis) + + end do + + if(hlm_use_planthydro.eq.itrue) then + call BTranForHLMDiagnosticsFromCohortHydr(nsites,sites,bc_out) + end if + + end associate + +end subroutine btran_ed end module EDBtranMod From b24f4688388e548971030e1fe2f123a7b983ca7f Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 25 Nov 2020 08:55:53 -0700 Subject: [PATCH 153/209] indenting EDPhysiologyMod.F90 --- biogeochem/EDPhysiologyMod.F90 | 1980 ++++++++++++++++---------------- 1 file changed, 990 insertions(+), 990 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 6437566e34..b624167af9 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -105,7 +105,7 @@ module EDPhysiologyMod use PRTLossFluxesMod, only : PRTDeciduousTurnover use PRTLossFluxesMod, only : PRTReproRelease - + public :: trim_canopy public :: phenology @@ -113,21 +113,21 @@ module EDPhysiologyMod public :: assign_cohort_SP_properties public :: recruitment public :: ZeroLitterFluxes - + public :: ZeroAllocationRates public :: PreDisturbanceLitterFluxes public :: PreDisturbanceIntegrateLitter public :: SeedIn - + logical, parameter :: debug = .false. ! local debug flag character(len=*), parameter, private :: sourcefile = & - __FILE__ + __FILE__ integer, parameter :: dleafon_drycheck = 100 ! Drought deciduous leaves max days on check parameter - + ! ============================================================================ contains @@ -153,7 +153,7 @@ subroutine ZeroLitterFluxes( currentSite ) end do currentPatch => currentPatch%older end do - + return end subroutine ZeroLitterFluxes @@ -169,13 +169,13 @@ subroutine ZeroAllocationRates( currentSite ) currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) - + currentCohort => currentPatch%tallest do while (associated(currentCohort)) ! This sets turnover and growth rates to zero call currentCohort%prt%ZeroRates() - + currentCohort => currentCohort%shorter enddo currentPatch => currentPatch%older @@ -204,7 +204,7 @@ subroutine PreDisturbanceLitterFluxes( currentSite, currentPatch, bc_in ) ! patch areas that are changing. ! ! ----------------------------------------------------------------------------------- - + ! !ARGUMENTS type(ed_site_type), intent(inout) :: currentSite @@ -215,10 +215,10 @@ subroutine PreDisturbanceLitterFluxes( currentSite, currentPatch, bc_in ) ! !LOCAL VARIABLES: type(site_massbal_type), pointer :: site_mass type(litter_type), pointer :: litt ! Points to the litter object for - ! the different element types + ! the different element types integer :: el ! Litter element loop index integer :: nlev_eff_decomp ! Number of active layers over which - ! fragmentation fluxes are transfered + ! fragmentation fluxes are transfered !------------------------------------------------------------------------------------ ! Calculate the fragmentation rates @@ -226,21 +226,21 @@ subroutine PreDisturbanceLitterFluxes( currentSite, currentPatch, bc_in ) do el = 1, num_elements - + litt => currentPatch%litter(el) ! Calculate loss rate of viable seeds to litter call SeedDecay(litt) - + ! Send those decaying seeds in the previous call ! to the litter input flux call SeedDecayToFines(litt) - + ! Calculate seed germination rate, the status flags prevent ! germination from occuring when the site is in a drought ! (for drought deciduous) or too cold (for cold deciduous) call SeedGermination(litt, currentSite%cstatus, currentSite%dstatus) - + ! Send fluxes from newly created litter into the litter pools ! This litter flux is from non-disturbance inducing mortality, as well ! as litter fluxes from live trees @@ -255,15 +255,15 @@ subroutine PreDisturbanceLitterFluxes( currentSite, currentPatch, bc_in ) site_mass => currentSite%mass_balance(el) - + ! Fragmentation flux to soil decomposition model [kg/site/day] site_mass%frag_out = site_mass%frag_out + currentPatch%area * & ( sum(litt%ag_cwd_frag) + sum(litt%bg_cwd_frag) + & sum(litt%leaf_fines_frag) + sum(litt%root_fines_frag)) - + end do - - + + return end subroutine PreDisturbanceLitterFluxes @@ -304,28 +304,28 @@ subroutine PreDisturbanceIntegrateLitter(currentPatch) integer :: dcmpy ! decomposability index do el = 1, num_elements - + litt => currentPatch%litter(el) - + ! Update the bank of viable seeds ! ----------------------------------------------------------------------------------- - + do pft = 1,numpft litt%seed(pft) = litt%seed(pft) + & - litt%seed_in_local(pft) + & - litt%seed_in_extern(pft) - & - litt%seed_decay(pft) - & - litt%seed_germ_in(pft) + litt%seed_in_local(pft) + & + litt%seed_in_extern(pft) - & + litt%seed_decay(pft) - & + litt%seed_germ_in(pft) ! Note that the recruitment scheme will use seed_germ ! for its construction costs. litt%seed_germ(pft) = litt%seed_germ(pft) + & - litt%seed_germ_in(pft) - & - litt%seed_germ_decay(pft) + litt%seed_germ_in(pft) - & + litt%seed_germ_decay(pft) enddo - + ! Update the Coarse Woody Debris pools (above and below) ! ----------------------------------------------------------------------------------- nlevsoil = size(litt%bg_cwd,dim=2) @@ -337,30 +337,30 @@ subroutine PreDisturbanceIntegrateLitter(currentPatch) - litt%bg_cwd_frag(c,ilyr) enddo end do - + ! Update the fine litter pools from leaves and fine-roots ! ----------------------------------------------------------------------------------- - + do dcmpy = 1,ndcmpy - litt%leaf_fines(dcmpy) = litt%leaf_fines(dcmpy) & - + litt%leaf_fines_in(dcmpy) & - - litt%leaf_fines_frag(dcmpy) - do ilyr=1,nlevsoil - litt%root_fines(dcmpy,ilyr) = litt%root_fines(dcmpy,ilyr) & - + litt%root_fines_in(dcmpy,ilyr) & - - litt%root_fines_frag(dcmpy,ilyr) - enddo + litt%leaf_fines(dcmpy) = litt%leaf_fines(dcmpy) & + + litt%leaf_fines_in(dcmpy) & + - litt%leaf_fines_frag(dcmpy) + do ilyr=1,nlevsoil + litt%root_fines(dcmpy,ilyr) = litt%root_fines(dcmpy,ilyr) & + + litt%root_fines_in(dcmpy,ilyr) & + - litt%root_fines_frag(dcmpy,ilyr) + enddo end do - + end do ! litter element loop - + return end subroutine PreDisturbanceIntegrateLitter - + ! ============================================================================ subroutine trim_canopy( currentSite ) @@ -395,7 +395,7 @@ subroutine trim_canopy( currentSite ) real(r8) :: leaf_inc ! LAI-only portion of the vegetation increment of dinc_ed real(r8) :: lai_canopy_above ! the LAI in the canopy layers above the layer of interest real(r8) :: lai_layers_above ! the LAI in the leaf layers, within the current canopy, - ! above the leaf layer of interest + ! above the leaf layer of interest real(r8) :: lai_current ! the LAI in the current leaf layer real(r8) :: cumulative_lai ! whole canopy cumulative LAI, top down, to the leaf layer of interest real(r8) :: cumulative_lai_cohort ! cumulative LAI within the current cohort only @@ -414,7 +414,7 @@ subroutine trim_canopy( currentSite ) ! m is the slope of the linear fit integer :: nll = 3 ! Number of leaf layers to fit a regression to for calculating the optimum lai character(1) :: trans = 'N' ! Input matrix is not transposed - + integer, parameter :: m = 2, n = 2 ! Number of rows and columns, respectively, in matrix A integer, parameter :: nrhs = 1 ! Number of columns in matrix B and X integer, parameter :: workmax = 100 ! Maximum iterations to minimize work @@ -422,7 +422,7 @@ subroutine trim_canopy( currentSite ) integer :: lda = m, ldb = n ! Leading dimension of A and B, respectively integer :: lwork ! Dimension of work array integer :: info ! Procedure diagnostic ouput - + real(r8) :: nnu_clai_a(m,n) ! LHS of linear least squares fit, A matrix real(r8) :: nnu_clai_b(m,nrhs) ! RHS of linear least squares fit, B matrix real(r8) :: work(workmax) ! work array @@ -438,28 +438,28 @@ subroutine trim_canopy( currentSite ) currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) - + ! Add debug diagnstic output to determine which patch if (debug) then write(fates_log(),*) 'Current patch:', ipatch write(fates_log(),*) 'Current patch cohorts:', currentPatch%countcohorts endif - + icohort = 1 - + currentCohort => currentPatch%tallest do while (associated(currentCohort)) - ! Save off the incoming trim and laimemory - initial_trim = currentCohort%canopy_trim - initial_laimem = currentCohort%laimemory + ! Save off the incoming trim and laimemory + initial_trim = currentCohort%canopy_trim + initial_laimem = currentCohort%laimemory ! Add debug diagnstic output to determine which cohort if (debug) then - write(fates_log(),*) 'Current cohort:', icohort - write(fates_log(),*) 'Starting canopy trim:', initial_trim - write(fates_log(),*) 'Starting laimemory:', currentCohort%laimemory - endif + write(fates_log(),*) 'Current cohort:', icohort + write(fates_log(),*) 'Starting canopy trim:', initial_trim + write(fates_log(),*) 'Starting laimemory:', currentCohort%laimemory + endif trimmed = .false. ipft = currentCohort%pft @@ -468,20 +468,20 @@ subroutine trim_canopy( currentSite ) leaf_c = currentCohort%prt%GetState(leaf_organ, all_carbon_elements) currentCohort%treelai = tree_lai(leaf_c, currentCohort%pft, currentCohort%c_area, & - currentCohort%n, currentCohort%canopy_layer, & - currentPatch%canopy_layer_tlai,currentCohort%vcmax25top ) + currentCohort%n, currentCohort%canopy_layer, & + currentPatch%canopy_layer_tlai,currentCohort%vcmax25top ) currentCohort%treesai = tree_sai(currentCohort%pft, currentCohort%dbh, currentCohort%canopy_trim, & - currentCohort%c_area, currentCohort%n, currentCohort%canopy_layer, & - currentPatch%canopy_layer_tlai, currentCohort%treelai, & - currentCohort%vcmax25top,0 ) + currentCohort%c_area, currentCohort%n, currentCohort%canopy_layer, & + currentPatch%canopy_layer_tlai, currentCohort%treelai, & + currentCohort%vcmax25top,0 ) currentCohort%nv = ceiling((currentCohort%treelai+currentCohort%treesai)/dinc_ed) if (currentCohort%nv > nlevleaf)then write(fates_log(),*) 'nv > nlevleaf',currentCohort%nv, & - currentCohort%treelai,currentCohort%treesai, & - currentCohort%c_area,currentCohort%n,leaf_c + currentCohort%treelai,currentCohort%treesai, & + currentCohort%c_area,currentCohort%n,leaf_c call endrun(msg=errMsg(sourcefile, __LINE__)) endif @@ -495,22 +495,22 @@ subroutine trim_canopy( currentSite ) ! Identify current canopy layer (cl) cl = currentCohort%canopy_layer - + ! PFT-level maximum SLA value, even if under a thick canopy (same units as slatop) sla_max = prt_params%slamax(ipft) ! Initialize nnu_clai_a nnu_clai_a(:,:) = 0._r8 nnu_clai_b(:,:) = 0._r8 - + !Leaf cost vs netuptake for each leaf layer. do z = 1, currentCohort%nv ! Calculate the cumulative total vegetation area index (no snow occlusion, stems and leaves) leaf_inc = dinc_ed * & - currentCohort%treelai/(currentCohort%treelai+currentCohort%treesai) - + currentCohort%treelai/(currentCohort%treelai+currentCohort%treesai) + ! Now calculate the cumulative top-down lai of the current layer's midpoint within the current cohort lai_layers_above = leaf_inc * (z-1) lai_current = min(leaf_inc, currentCohort%treelai - lai_layers_above) @@ -522,7 +522,7 @@ subroutine trim_canopy( currentSite ) ! There was activity this year in this leaf layer. This should only occur for bottom most leaf layer if (currentCohort%year_net_uptake(z) /= 999._r8)then - + ! Calculate sla_levleaf following the sla profile with overlying leaf area ! Scale for leaf nitrogen profile kn = decay_coeff_kn(ipft,currentCohort%vcmax25top) @@ -534,7 +534,7 @@ subroutine trim_canopy( currentSite ) if(sla_levleaf > sla_max)then sla_levleaf = sla_max end if - + !Leaf Cost kgC/m2/year-1 !decidous costs. if (prt_params%season_decid(ipft) == itrue .or. & @@ -552,14 +552,14 @@ subroutine trim_canopy( currentSite ) endif currentCohort%leaf_cost = currentCohort%leaf_cost * & - (prt_params%grperc(ipft) + 1._r8) + (prt_params%grperc(ipft) + 1._r8) else !evergreen costs ! Leaf cost at leaf level z accounting for sla profile currentCohort%leaf_cost = 1.0_r8/(sla_levleaf* & sum(prt_params%leaf_long(ipft,:))*1000.0_r8) !convert from sla in m2g-1 to m2kg-1 - - + + if ( int(prt_params%allom_fmode(ipft)) .eq. 1 ) then ! if using trimmed leaf for fine root biomass allometry, add the cost of the root increment ! to the leaf increment; otherwise do not. @@ -568,7 +568,7 @@ subroutine trim_canopy( currentSite ) bfr_per_bleaf / prt_params%root_long(ipft) endif currentCohort%leaf_cost = currentCohort%leaf_cost * & - (prt_params%grperc(ipft) + 1._r8) + (prt_params%grperc(ipft) + 1._r8) endif ! Construct the arrays for a least square fit of the net_net_uptake versus the cumulative lai @@ -576,18 +576,18 @@ subroutine trim_canopy( currentSite ) ! leaf layers. if (currentCohort%nv > nll .and. currentCohort%nv - z < nll) then - ! Build the A matrix for the LHS of the linear system. A = [n sum(x); sum(x) sum(x^2)] - ! where n = nll and x = yearly_net_uptake-leafcost - nnu_clai_a(1,1) = nnu_clai_a(1,1) + 1 ! Increment for each layer used - nnu_clai_a(1,2) = nnu_clai_a(1,2) + currentCohort%year_net_uptake(z) - currentCohort%leaf_cost - nnu_clai_a(2,1) = nnu_clai_a(1,2) - nnu_clai_a(2,2) = nnu_clai_a(2,2) + (currentCohort%year_net_uptake(z) - currentCohort%leaf_cost)**2 - - ! Build the B matrix for the RHS of the linear system. B = [sum(y); sum(x*y)] - ! where x = yearly_net_uptake-leafcost and y = cumulative_lai_cohort - nnu_clai_b(1,1) = nnu_clai_b(1,1) + cumulative_lai_cohort - nnu_clai_b(2,1) = nnu_clai_b(2,1) + (cumulative_lai_cohort * & - (currentCohort%year_net_uptake(z) - currentCohort%leaf_cost)) + ! Build the A matrix for the LHS of the linear system. A = [n sum(x); sum(x) sum(x^2)] + ! where n = nll and x = yearly_net_uptake-leafcost + nnu_clai_a(1,1) = nnu_clai_a(1,1) + 1 ! Increment for each layer used + nnu_clai_a(1,2) = nnu_clai_a(1,2) + currentCohort%year_net_uptake(z) - currentCohort%leaf_cost + nnu_clai_a(2,1) = nnu_clai_a(1,2) + nnu_clai_a(2,2) = nnu_clai_a(2,2) + (currentCohort%year_net_uptake(z) - currentCohort%leaf_cost)**2 + + ! Build the B matrix for the RHS of the linear system. B = [sum(y); sum(x*y)] + ! where x = yearly_net_uptake-leafcost and y = cumulative_lai_cohort + nnu_clai_b(1,1) = nnu_clai_b(1,1) + cumulative_lai_cohort + nnu_clai_b(2,1) = nnu_clai_b(2,1) + (cumulative_lai_cohort * & + (currentCohort%year_net_uptake(z) - currentCohort%leaf_cost)) end if ! Check leaf cost against the yearly net uptake for that cohort leaf layer @@ -595,18 +595,18 @@ subroutine trim_canopy( currentSite ) ! Make sure the cohort trim fraction is great than the pft trim limit if (currentCohort%canopy_trim > EDPftvarcon_inst%trim_limit(ipft)) then - ! if ( debug ) then - ! write(fates_log(),*) 'trimming leaves', & - ! currentCohort%canopy_trim,currentCohort%leaf_cost - ! endif + ! if ( debug ) then + ! write(fates_log(),*) 'trimming leaves', & + ! currentCohort%canopy_trim,currentCohort%leaf_cost + ! endif ! keep trimming until none of the canopy is in negative carbon balance. if (currentCohort%hite > EDPftvarcon_inst%hgt_min(ipft)) then currentCohort%canopy_trim = currentCohort%canopy_trim - & - EDPftvarcon_inst%trim_inc(ipft) + EDPftvarcon_inst%trim_inc(ipft) if (prt_params%evergreen(ipft) /= 1)then currentCohort%laimemory = currentCohort%laimemory * & - (1.0_r8 - EDPftvarcon_inst%trim_inc(ipft)) + (1.0_r8 - EDPftvarcon_inst%trim_inc(ipft)) endif trimmed = .true. @@ -620,55 +620,55 @@ subroutine trim_canopy( currentSite ) ! Compute the optimal cumulative lai based on the cohort net-net uptake profile if at least 2 leaf layers if (nnu_clai_a(1,1) > 1) then - ! Compute the optimum size of the work array - lwork = -1 ! Ask sgels to compute optimal number of entries for work - call dgels(trans, m, n, nrhs, nnu_clai_a, lda, nnu_clai_b, ldb, work, lwork, info) - lwork = int(work(1)) ! Pick the optimum. TBD, can work(1) come back with greater than work size? - - ! if (debug) then - ! write(fates_log(),*) 'LLSF lwork output (info, lwork):', info, lwork - ! endif - - ! Compute the minimum of 2-norm of of the least squares fit to solve for X - ! Note that dgels returns the solution by overwriting the nnu_clai_b array. - ! The result has the form: X = [b; m] - ! where b = y-intercept (i.e. the cohort lai that has zero yearly net-net uptake) - ! and m is the slope of the linear fit - call dgels(trans, m, n, nrhs, nnu_clai_a, lda, nnu_clai_b, ldb, work, lwork, info) - - if (info < 0) then - write(fates_log(),*) 'LLSF optimium LAI calculation returned illegal value' - call endrun(msg=errMsg(sourcefile, __LINE__)) - endif - - if (debug) then - write(fates_log(),*) 'LLSF optimium LAI (intercept,slope):', nnu_clai_b - write(fates_log(),*) 'LLSF optimium LAI:', nnu_clai_b(1,1) - write(fates_log(),*) 'LLSF optimium LAI info:', info - write(fates_log(),*) 'LAI fraction (optimum_lai/cumulative_lai):', nnu_clai_b(1,1) / cumulative_lai_cohort - endif - - ! Calculate the optimum trim based on the initial canopy trim value - if (cumulative_lai_cohort > 0._r8) then ! Sometime cumulative_lai comes in at 0.0? - - ! - optimum_trim = (nnu_clai_b(1,1) / cumulative_lai_cohort) * initial_trim - optimum_laimem = (nnu_clai_b(1,1) / cumulative_lai_cohort) * initial_laimem - - ! Determine if the optimum trim value makes sense. The smallest cohorts tend to have unrealistic fits. - if (optimum_trim > 0. .and. optimum_trim < 1.) then - currentCohort%canopy_trim = optimum_trim - - ! If the cohort pft is not evergreen we reduce the laimemory as well - if (prt_params%evergreen(ipft) /= 1) then - currentCohort%laimemory = optimum_laimem - endif + ! Compute the optimum size of the work array + lwork = -1 ! Ask sgels to compute optimal number of entries for work + call dgels(trans, m, n, nrhs, nnu_clai_a, lda, nnu_clai_b, ldb, work, lwork, info) + lwork = int(work(1)) ! Pick the optimum. TBD, can work(1) come back with greater than work size? + + ! if (debug) then + ! write(fates_log(),*) 'LLSF lwork output (info, lwork):', info, lwork + ! endif + + ! Compute the minimum of 2-norm of of the least squares fit to solve for X + ! Note that dgels returns the solution by overwriting the nnu_clai_b array. + ! The result has the form: X = [b; m] + ! where b = y-intercept (i.e. the cohort lai that has zero yearly net-net uptake) + ! and m is the slope of the linear fit + call dgels(trans, m, n, nrhs, nnu_clai_a, lda, nnu_clai_b, ldb, work, lwork, info) + + if (info < 0) then + write(fates_log(),*) 'LLSF optimium LAI calculation returned illegal value' + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + + if (debug) then + write(fates_log(),*) 'LLSF optimium LAI (intercept,slope):', nnu_clai_b + write(fates_log(),*) 'LLSF optimium LAI:', nnu_clai_b(1,1) + write(fates_log(),*) 'LLSF optimium LAI info:', info + write(fates_log(),*) 'LAI fraction (optimum_lai/cumulative_lai):', nnu_clai_b(1,1) / cumulative_lai_cohort + endif + + ! Calculate the optimum trim based on the initial canopy trim value + if (cumulative_lai_cohort > 0._r8) then ! Sometime cumulative_lai comes in at 0.0? + + ! + optimum_trim = (nnu_clai_b(1,1) / cumulative_lai_cohort) * initial_trim + optimum_laimem = (nnu_clai_b(1,1) / cumulative_lai_cohort) * initial_laimem + + ! Determine if the optimum trim value makes sense. The smallest cohorts tend to have unrealistic fits. + if (optimum_trim > 0. .and. optimum_trim < 1.) then + currentCohort%canopy_trim = optimum_trim + + ! If the cohort pft is not evergreen we reduce the laimemory as well + if (prt_params%evergreen(ipft) /= 1) then + currentCohort%laimemory = optimum_laimem + endif - trimmed = .true. + trimmed = .true. - endif - endif - endif + endif + endif + endif ! Reset activity for the cohort for the start of the next year currentCohort%year_net_uptake(:) = 999.0_r8 @@ -676,12 +676,12 @@ subroutine trim_canopy( currentSite ) ! Add to trim fraction if cohort not trimmed at all if ( (.not.trimmed) .and.currentCohort%canopy_trim < 1.0_r8)then currentCohort%canopy_trim = currentCohort%canopy_trim + EDPftvarcon_inst%trim_inc(ipft) - endif + endif if ( debug ) then write(fates_log(),*) 'trimming:',currentCohort%canopy_trim endif - + ! currentCohort%canopy_trim = 1.0_r8 !FIX(RF,032414) this turns off ctrim for now. currentCohort => currentCohort%shorter icohort = icohort + 1 @@ -703,7 +703,7 @@ subroutine phenology( currentSite, bc_in ) use EDParamsMod, only : ED_val_phen_drought_threshold, ED_val_phen_doff_time use EDParamsMod, only : ED_val_phen_a, ED_val_phen_b, ED_val_phen_c, ED_val_phen_chiltemp use EDParamsMod, only : ED_val_phen_mindayson, ED_val_phen_ncolddayslim, ED_val_phen_coldtemp - + ! ! !ARGUMENTS: @@ -730,7 +730,7 @@ subroutine phenology( currentSite, bc_in ) real(r8) :: struct_c ! structure carbon [kg] real(r8) :: gdd_threshold ! GDD accumulation function, integer :: ilayer_swater ! Layer index for soil water - ! which also depends on chilling days. + ! which also depends on chilling days. integer :: ncdstart ! beginning of counting period for chilling degree days. integer :: gddstart ! beginning of counting period for growing degree days. real(r8) :: temp_in_C ! daily averaged temperature in celcius @@ -738,16 +738,16 @@ subroutine phenology( currentSite, bc_in ) integer, parameter :: canopy_leaf_lifespan = 365 ! Maximum lifespan of drought decid leaves integer, parameter :: min_daysoff_dforcedflush = 30 ! THis is the number of days that must had elapsed - ! since leaves had dropped, in order to forcably - ! flush leaves again. This does not impact flushing - ! due to real moisture constraints, and will prevent - ! drought deciduous in perennially wet environments - ! that have been forced to drop their leaves, from - ! flushing them back immediately. + ! since leaves had dropped, in order to forcably + ! flush leaves again. This does not impact flushing + ! due to real moisture constraints, and will prevent + ! drought deciduous in perennially wet environments + ! that have been forced to drop their leaves, from + ! flushing them back immediately. real(r8),parameter :: dphen_soil_depth = 0.1 ! Use liquid soil water that is - ! closest to this depth [m] - + ! closest to this depth [m] + ! This is the integer model day. The first day of the simulation is 1, and it ! continues monotonically, indefinitely model_day_int = nint(hlm_model_day) @@ -769,8 +769,8 @@ subroutine phenology( currentSite, bc_in ) cpatch => cpatch%younger end do temp_in_C = temp_in_C * area_inv - tfrz - - + + !-----------------Cold Phenology--------------------! !Zero growing degree and chilling day counters @@ -781,7 +781,7 @@ subroutine phenology( currentSite, bc_in ) ncdstart = 120 !Southern Hemisphere beginning May gddstart = 181 !Northern Hemisphere begining July endif - + ! Count the number of chilling days over a seasonal window. ! For comparing against GDD, we start calculating chilling ! in the late autumn. @@ -823,25 +823,25 @@ subroutine phenology( currentSite, bc_in ) if (temp_in_C .gt. 0._r8 .and. currentSite%cstatus == phen_cstat_iscold) then currentSite%grow_deg_days = currentSite%grow_deg_days + temp_in_C endif - + !this logic is to prevent GDD accumulating after the leaves have fallen and before the ! beginnning of the accumulation period, to prevend erroneous autumn leaf flushing. if(model_day_int>365)then !only do this after the first year to prevent odd behaviour - if(currentSite%lat .gt. 0.0_r8)then !Northern Hemisphere - ! In the north, don't accumulate when we are past the leaf fall date. - ! Accumulation starts on day 1 of year in NH. - ! The 180 is to prevent going into an 'always off' state after initialization - if( model_day_int .gt. currentSite%cleafoffdate.and.hlm_day_of_year.gt.180)then ! - currentSite%grow_deg_days = 0._r8 - endif - else !Southern Hemisphere - ! In the South, don't accumulate after the leaf off date, and before the start of - ! the accumulation phase (day 181). - if(model_day_int .gt. currentSite%cleafoffdate.and.hlm_day_of_year.lt.gddstart) then! - currentSite%grow_deg_days = 0._r8 - endif - endif + if(currentSite%lat .gt. 0.0_r8)then !Northern Hemisphere + ! In the north, don't accumulate when we are past the leaf fall date. + ! Accumulation starts on day 1 of year in NH. + ! The 180 is to prevent going into an 'always off' state after initialization + if( model_day_int .gt. currentSite%cleafoffdate.and.hlm_day_of_year.gt.180)then ! + currentSite%grow_deg_days = 0._r8 + endif + else !Southern Hemisphere + ! In the South, don't accumulate after the leaf off date, and before the start of + ! the accumulation phase (day 181). + if(model_day_int .gt. currentSite%cleafoffdate.and.hlm_day_of_year.lt.gddstart) then! + currentSite%grow_deg_days = 0._r8 + endif + endif endif !year1 ! Calculate the number of days since the leaves last came on @@ -871,7 +871,7 @@ subroutine phenology( currentSite, bc_in ) ! preventing them from competing if ( (currentSite%cstatus == phen_cstat_iscold .or. & - currentSite%cstatus == phen_cstat_nevercold) .and. & + currentSite%cstatus == phen_cstat_nevercold) .and. & (currentSite%grow_deg_days > gdd_threshold) .and. & (dayssincecleafoff > ED_val_phen_mindayson) .and. & (currentSite%nchilldays >= 1)) then @@ -892,23 +892,23 @@ subroutine phenology( currentSite, bc_in ) !3) The leaves should not be off already !4) The day of simulation should be larger than the counting period. - + if ( (currentSite%cstatus == phen_cstat_notcold) .and. & (model_day_int > num_vegtemp_mem) .and. & (ncolddays > ED_val_phen_ncolddayslim) .and. & (dayssincecleafon > ED_val_phen_mindayson) )then - + currentSite%grow_deg_days = 0._r8 ! The equations for Botta et al - ! are for calculations of - ! first flush, but if we dont - ! clear this value, it will cause - ! leaves to flush later in the year + ! are for calculations of + ! first flush, but if we dont + ! clear this value, it will cause + ! leaves to flush later in the year currentSite%cstatus = phen_cstat_iscold ! alter status of site to 'leaves off' currentSite%cleafoffdate = model_day_int ! record leaf off date if ( debug ) write(fates_log(),*) 'leaves off' endif - + ! LEAF OFF: COLD LIFESPAN THRESHOLD ! NOTE: Some areas of the planet will never generate a cold day ! and thus %nchilldays will never go from zero to 1. The following logic @@ -916,15 +916,15 @@ subroutine phenology( currentSite, bc_in ) ! plants from re-emerging in areas without at least some cold days if( (currentSite%cstatus == phen_cstat_notcold) .and. & - (dayssincecleafoff > 400)) then ! remove leaves after a whole year - ! when there is no 'off' period. + (dayssincecleafoff > 400)) then ! remove leaves after a whole year + ! when there is no 'off' period. currentSite%grow_deg_days = 0._r8 currentSite%cstatus = phen_cstat_nevercold ! alter status of site to imply that this - ! site is never really cold enough - ! for cold deciduous + ! site is never really cold enough + ! for cold deciduous currentSite%cleafoffdate = model_day_int ! record leaf off date - + if ( debug ) write(fates_log(),*) 'leaves off' endif @@ -979,7 +979,7 @@ subroutine phenology( currentSite, bc_in ) else dayssincedleafoff = model_day_int - currentSite%dleafoffdate endif - + ! the leaves are on. How long have they been on? if (model_day_int < currentSite%dleafondate) then dayssincedleafon = model_day_int - (currentSite%dleafondate-365) @@ -990,7 +990,7 @@ subroutine phenology( currentSite, bc_in ) ! LEAF ON: DROUGHT DECIDUOUS WETNESS ! Here, we used a window of oppurtunity to determine if we are ! close to the time when then leaves came on last year - + ! Has it been ... ! a) a year, plus or minus 1 month since we last had leaf-on? ! b) Has there also been at least a nominaly short amount of "leaf-off" @@ -998,15 +998,15 @@ subroutine phenology( currentSite, bc_in ) ! Note that cold-starts begin in the "leaf-on" ! status if ( (currentSite%dstatus == phen_dstat_timeoff .or. & - currentSite%dstatus == phen_dstat_moistoff) .and. & - (model_day_int > numWaterMem) .and. & - (dayssincedleafon >= 365-30 .and. dayssincedleafon <= 365+30 ) .and. & - (dayssincedleafoff > ED_val_phen_doff_time) ) then + currentSite%dstatus == phen_dstat_moistoff) .and. & + (model_day_int > numWaterMem) .and. & + (dayssincedleafon >= 365-30 .and. dayssincedleafon <= 365+30 ) .and. & + (dayssincedleafoff > ED_val_phen_doff_time) ) then ! If leaves are off, and have been off for at least a few days ! and the time is consistent with the correct ! time window... test if the moisture conditions allow for leaf-on - + if ( mean_10day_liqvol >= ED_val_phen_drought_threshold ) then currentSite%dstatus = phen_dstat_moiston ! set status to leaf-on currentSite%dleafondate = model_day_int ! save the model day we start flushing @@ -1047,17 +1047,17 @@ subroutine phenology( currentSite, bc_in ) ! i.e. Are the leaves rouhgly at the end of their lives? if ( (currentSite%dstatus == phen_dstat_moiston .or. & - currentSite%dstatus == phen_dstat_timeon ) .and. & + currentSite%dstatus == phen_dstat_timeon ) .and. & (dayssincedleafon > canopy_leaf_lifespan) )then - currentSite%dstatus = phen_dstat_timeoff !alter status of site to 'leaves off' - currentSite%dleafoffdate = model_day_int !record leaf on date + currentSite%dstatus = phen_dstat_timeoff !alter status of site to 'leaves off' + currentSite%dleafoffdate = model_day_int !record leaf on date endif ! LEAF OFF: DROUGHT DECIDUOUS DRYNESS - if the soil gets too dry, ! and the leaves have already been on a while... if ( (currentSite%dstatus == phen_dstat_moiston .or. & - currentSite%dstatus == phen_dstat_timeon ) .and. & + currentSite%dstatus == phen_dstat_timeon ) .and. & (model_day_int > numWaterMem) .and. & (mean_10day_liqvol <= ED_val_phen_drought_threshold) .and. & (dayssincedleafon > dleafon_drycheck ) ) then @@ -1113,9 +1113,9 @@ subroutine phenology_leafonoff(currentSite) leaf_c = currentCohort%prt%GetState(leaf_organ, all_carbon_elements) sapw_c = currentCohort%prt%GetState(sapw_organ, all_carbon_elements) struct_c = currentCohort%prt%GetState(struct_organ, all_carbon_elements) - + stem_drop_fraction = EDPftvarcon_inst%phen_stem_drop_fraction(ipft) - + ! COLD LEAF ON ! The site level flags signify that it is no-longer too cold ! for leaves. Time to signal flushing @@ -1124,215 +1124,215 @@ subroutine phenology_leafonoff(currentSite) if ( currentSite%cstatus == phen_cstat_notcold )then ! we have just moved to leaves being on . if (currentCohort%status_coh == leaves_off)then ! Are the leaves currently off? currentCohort%status_coh = leaves_on ! Leaves are on, so change status to - ! stop flow of carbon out of bstore. - + ! stop flow of carbon out of bstore. + if(store_c>nearzero) then - ! flush either the amount required from the laimemory, or -most- of the storage pool - ! RF: added a criterion to stop the entire store pool emptying and triggering termination mortality - ! n.b. this might not be necessary if we adopted a more gradual approach to leaf flushing... - store_c_transfer_frac = min((EDPftvarcon_inst%phenflush_fraction(ipft)* & - currentCohort%laimemory)/store_c,(1.0_r8-carbon_store_buffer)) - - if(prt_params%woody(ipft).ne.itrue)then - totalmemory=currentCohort%laimemory+currentCohort%sapwmemory+currentCohort%structmemory - store_c_transfer_frac = min((EDPftvarcon_inst%phenflush_fraction(ipft)* & - totalmemory)/store_c, (1.0_r8-carbon_store_buffer)) - endif - + ! flush either the amount required from the laimemory, or -most- of the storage pool + ! RF: added a criterion to stop the entire store pool emptying and triggering termination mortality + ! n.b. this might not be necessary if we adopted a more gradual approach to leaf flushing... + store_c_transfer_frac = min((EDPftvarcon_inst%phenflush_fraction(ipft)* & + currentCohort%laimemory)/store_c,(1.0_r8-carbon_store_buffer)) + + if(prt_params%woody(ipft).ne.itrue)then + totalmemory=currentCohort%laimemory+currentCohort%sapwmemory+currentCohort%structmemory + store_c_transfer_frac = min((EDPftvarcon_inst%phenflush_fraction(ipft)* & + totalmemory)/store_c, (1.0_r8-carbon_store_buffer)) + endif + else store_c_transfer_frac = 0.0_r8 end if ! This call will request that storage carbon will be transferred to ! leaf tissues. It is specified as a fraction of the available storage - if(prt_params%woody(ipft) == itrue) then + if(prt_params%woody(ipft) == itrue) then - call PRTPhenologyFlush(currentCohort%prt, ipft, leaf_organ, store_c_transfer_frac) - currentCohort%laimemory = 0.0_r8 + call PRTPhenologyFlush(currentCohort%prt, ipft, leaf_organ, store_c_transfer_frac) + currentCohort%laimemory = 0.0_r8 - else - - ! Check that the stem drop fraction is set to non-zero amount otherwise flush all carbon store to leaves - if (stem_drop_fraction .gt. 0.0_r8) then + else + + ! Check that the stem drop fraction is set to non-zero amount otherwise flush all carbon store to leaves + if (stem_drop_fraction .gt. 0.0_r8) then + + call PRTPhenologyFlush(currentCohort%prt, ipft, leaf_organ, & + store_c_transfer_frac*currentCohort%laimemory/totalmemory) + + call PRTPhenologyFlush(currentCohort%prt, ipft, sapw_organ, & + store_c_transfer_frac*currentCohort%sapwmemory/totalmemory) - call PRTPhenologyFlush(currentCohort%prt, ipft, leaf_organ, & - store_c_transfer_frac*currentCohort%laimemory/totalmemory) + call PRTPhenologyFlush(currentCohort%prt, ipft, struct_organ, & + store_c_transfer_frac*currentCohort%structmemory/totalmemory) - call PRTPhenologyFlush(currentCohort%prt, ipft, sapw_organ, & - store_c_transfer_frac*currentCohort%sapwmemory/totalmemory) + else - call PRTPhenologyFlush(currentCohort%prt, ipft, struct_organ, & - store_c_transfer_frac*currentCohort%structmemory/totalmemory) + call PRTPhenologyFlush(currentCohort%prt, ipft, leaf_organ, & + store_c_transfer_frac) - else + end if - call PRTPhenologyFlush(currentCohort%prt, ipft, leaf_organ, & - store_c_transfer_frac) + currentCohort%laimemory = 0.0_r8 + currentCohort%structmemory = 0.0_r8 + currentCohort%sapwmemory = 0.0_r8 - end if - - currentCohort%laimemory = 0.0_r8 - currentCohort%structmemory = 0.0_r8 - currentCohort%sapwmemory = 0.0_r8 - - endif + endif endif !pft phenology endif ! growing season !COLD LEAF OFF if (currentSite%cstatus == phen_cstat_nevercold .or. & - currentSite%cstatus == phen_cstat_iscold) then ! past leaf drop day? Leaves still on tree? + currentSite%cstatus == phen_cstat_iscold) then ! past leaf drop day? Leaves still on tree? if (currentCohort%status_coh == leaves_on) then ! leaves have not dropped - ! leaf off occur on individuals bigger than specific size for grass - if (currentCohort%dbh > EDPftvarcon_inst%phen_cold_size_threshold(ipft) & - .or. prt_params%woody(ipft)==itrue) then - - ! This sets the cohort to the "leaves off" flag - currentCohort%status_coh = leaves_off + ! leaf off occur on individuals bigger than specific size for grass + if (currentCohort%dbh > EDPftvarcon_inst%phen_cold_size_threshold(ipft) & + .or. prt_params%woody(ipft)==itrue) then - ! Remember what the lai was (leaf mass actually) was for next year - ! the same amount back on in the spring... + ! This sets the cohort to the "leaves off" flag + currentCohort%status_coh = leaves_off - currentCohort%laimemory = leaf_c + ! Remember what the lai was (leaf mass actually) was for next year + ! the same amount back on in the spring... - ! Drop Leaves (this routine will update the leaf state variables, - ! for carbon and any other element that are prognostic. It will - ! also track the turnover masses that will be sent to litter later on) + currentCohort%laimemory = leaf_c - call PRTDeciduousTurnover(currentCohort%prt,ipft, & - leaf_organ, leaf_drop_fraction) - - if(prt_params%woody(ipft).ne.itrue)then - - currentCohort%sapwmemory = sapw_c * stem_drop_fraction - - currentCohort%structmemory = struct_c * stem_drop_fraction - - call PRTDeciduousTurnover(currentCohort%prt,ipft, & + ! Drop Leaves (this routine will update the leaf state variables, + ! for carbon and any other element that are prognostic. It will + ! also track the turnover masses that will be sent to litter later on) + + call PRTDeciduousTurnover(currentCohort%prt,ipft, & + leaf_organ, leaf_drop_fraction) + + if(prt_params%woody(ipft).ne.itrue)then + + currentCohort%sapwmemory = sapw_c * stem_drop_fraction + + currentCohort%structmemory = struct_c * stem_drop_fraction + + call PRTDeciduousTurnover(currentCohort%prt,ipft, & sapw_organ, stem_drop_fraction) - call PRTDeciduousTurnover(currentCohort%prt,ipft, & + call PRTDeciduousTurnover(currentCohort%prt,ipft, & struct_organ, stem_drop_fraction) - endif ! woody plant check - endif ! individual dbh size check - endif !leaf status - endif !currentSite status - endif !season_decid + endif ! woody plant check + endif ! individual dbh size check + endif !leaf status + endif !currentSite status + endif !season_decid ! DROUGHT LEAF ON ! Site level flag indicates it is no longer in drought condition ! deciduous plants can flush if (prt_params%stress_decid(ipft) == itrue )then - - if (currentSite%dstatus == phen_dstat_moiston .or. & - currentSite%dstatus == phen_dstat_timeon )then - ! we have just moved to leaves being on . - if (currentCohort%status_coh == leaves_off)then + if (currentSite%dstatus == phen_dstat_moiston .or. & + currentSite%dstatus == phen_dstat_timeon )then + + ! we have just moved to leaves being on . + if (currentCohort%status_coh == leaves_off)then !is it the leaf-on day? Are the leaves currently off? - currentCohort%status_coh = leaves_on ! Leaves are on, so change status to - ! stop flow of carbon out of bstore. + currentCohort%status_coh = leaves_on ! Leaves are on, so change status to + ! stop flow of carbon out of bstore. - if(store_c>nearzero) then + if(store_c>nearzero) then + + store_c_transfer_frac = & + min(EDPftvarcon_inst%phenflush_fraction(ipft)*currentCohort%laimemory, store_c)/store_c - store_c_transfer_frac = & - min(EDPftvarcon_inst%phenflush_fraction(ipft)*currentCohort%laimemory, store_c)/store_c + if(prt_params%woody(ipft).ne.itrue)then - if(prt_params%woody(ipft).ne.itrue)then - - totalmemory=currentCohort%laimemory+currentCohort%sapwmemory+currentCohort%structmemory - store_c_transfer_frac = min(EDPftvarcon_inst%phenflush_fraction(ipft)* & - totalmemory, store_c)/store_c + totalmemory=currentCohort%laimemory+currentCohort%sapwmemory+currentCohort%structmemory + store_c_transfer_frac = min(EDPftvarcon_inst%phenflush_fraction(ipft)* & + totalmemory, store_c)/store_c - endif + endif + + else + store_c_transfer_frac = 0.0_r8 + endif - else - store_c_transfer_frac = 0.0_r8 - endif - ! This call will request that storage carbon will be transferred to ! leaf tissues. It is specified as a fraction of the available storage - if(prt_params%woody(ipft) == itrue) then - - call PRTPhenologyFlush(currentCohort%prt, ipft, & - leaf_organ, store_c_transfer_frac) - - currentCohort%laimemory = 0.0_r8 - - else - - ! Check that the stem drop fraction is set to non-zero amount otherwise flush all carbon store to leaves - if (stem_drop_fraction .gt. 0.0_r8) then - - call PRTPhenologyFlush(currentCohort%prt, ipft, leaf_organ, & - store_c_transfer_frac*currentCohort%laimemory/totalmemory) - - call PRTPhenologyFlush(currentCohort%prt, ipft, sapw_organ, & - store_c_transfer_frac*currentCohort%sapwmemory/totalmemory) - - call PRTPhenologyFlush(currentCohort%prt, ipft, struct_organ, & - store_c_transfer_frac*currentCohort%structmemory/totalmemory) - - else - - call PRTPhenologyFlush(currentCohort%prt, ipft, leaf_organ, & - store_c_transfer_frac) - - end if - - currentCohort%laimemory = 0.0_r8 - currentCohort%structmemory = 0.0_r8 - currentCohort%sapwmemory = 0.0_r8 - - endif ! woody plant check - endif !currentCohort status again? - endif !currentSite status - - !DROUGHT LEAF OFF - if (currentSite%dstatus == phen_dstat_moistoff .or. & - currentSite%dstatus == phen_dstat_timeoff) then - - if (currentCohort%status_coh == leaves_on) then ! leaves have not dropped - - ! This sets the cohort to the "leaves off" flag - currentCohort%status_coh = leaves_off - - ! Remember what the lai (leaf mass actually) was for next year - currentCohort%laimemory = leaf_c - - call PRTDeciduousTurnover(currentCohort%prt,ipft, & + if(prt_params%woody(ipft) == itrue) then + + call PRTPhenologyFlush(currentCohort%prt, ipft, & + leaf_organ, store_c_transfer_frac) + + currentCohort%laimemory = 0.0_r8 + + else + + ! Check that the stem drop fraction is set to non-zero amount otherwise flush all carbon store to leaves + if (stem_drop_fraction .gt. 0.0_r8) then + + call PRTPhenologyFlush(currentCohort%prt, ipft, leaf_organ, & + store_c_transfer_frac*currentCohort%laimemory/totalmemory) + + call PRTPhenologyFlush(currentCohort%prt, ipft, sapw_organ, & + store_c_transfer_frac*currentCohort%sapwmemory/totalmemory) + + call PRTPhenologyFlush(currentCohort%prt, ipft, struct_organ, & + store_c_transfer_frac*currentCohort%structmemory/totalmemory) + + else + + call PRTPhenologyFlush(currentCohort%prt, ipft, leaf_organ, & + store_c_transfer_frac) + + end if + + currentCohort%laimemory = 0.0_r8 + currentCohort%structmemory = 0.0_r8 + currentCohort%sapwmemory = 0.0_r8 + + endif ! woody plant check + endif !currentCohort status again? + endif !currentSite status + + !DROUGHT LEAF OFF + if (currentSite%dstatus == phen_dstat_moistoff .or. & + currentSite%dstatus == phen_dstat_timeoff) then + + if (currentCohort%status_coh == leaves_on) then ! leaves have not dropped + + ! This sets the cohort to the "leaves off" flag + currentCohort%status_coh = leaves_off + + ! Remember what the lai (leaf mass actually) was for next year + currentCohort%laimemory = leaf_c + + call PRTDeciduousTurnover(currentCohort%prt,ipft, & leaf_organ, leaf_drop_fraction) - - if(prt_params%woody(ipft).ne.itrue)then - - currentCohort%sapwmemory = sapw_c * stem_drop_fraction - currentCohort%structmemory = struct_c * stem_drop_fraction - call PRTDeciduousTurnover(currentCohort%prt,ipft, & - sapw_organ, stem_drop_fraction) + if(prt_params%woody(ipft).ne.itrue)then - call PRTDeciduousTurnover(currentCohort%prt,ipft, & - struct_organ, stem_drop_fraction) - endif + currentCohort%sapwmemory = sapw_c * stem_drop_fraction + currentCohort%structmemory = struct_c * stem_drop_fraction - endif - endif !status - endif !drought dec. + call PRTDeciduousTurnover(currentCohort%prt,ipft, & + sapw_organ, stem_drop_fraction) - if(debug) call currentCohort%prt%CheckMassConservation(ipft,1) + call PRTDeciduousTurnover(currentCohort%prt,ipft, & + struct_organ, stem_drop_fraction) + endif + + endif + endif !status + endif !drought dec. - currentCohort => currentCohort%shorter - enddo !currentCohort + if(debug) call currentCohort%prt%CheckMassConservation(ipft,1) - currentPatch => currentPatch%younger + currentCohort => currentCohort%shorter + enddo !currentCohort - enddo !currentPatch + currentPatch => currentPatch%younger + + enddo !currentPatch end subroutine phenology_leafonoff @@ -1340,11 +1340,11 @@ end subroutine phenology_leafonoff subroutine satellite_phenology(currentSite, bc_in) - ! ----------------------------------------------------------------------------------- - ! Takes the daily inputs of leaf area index, stem area index and canopy height and - ! translates them into a FATES structure with one patch and one cohort per PFT - ! The leaf area of the cohort is modified each day to match that asserted by the HLM - ! ----------------------------------------------------------------------------------- + ! ----------------------------------------------------------------------------------- + ! Takes the daily inputs of leaf area index, stem area index and canopy height and + ! translates them into a FATES structure with one patch and one cohort per PFT + ! The leaf area of the cohort is modified each day to match that asserted by the HLM + ! ----------------------------------------------------------------------------------- ! !USES: ! @@ -1366,110 +1366,110 @@ subroutine satellite_phenology(currentSite, bc_in) integer :: s ! site index - ! To Do in this routine. - ! Get access to HLM input varialbes. - ! Weight them by PFT - ! Loop around patches, and for each single cohort in each patch - ! call assign_cohort_SP_properties to determine cohort height, dbh, 'n', area, leafc from drivers. - - currentSite%sp_tlai(:) = 0._r8 - currentSite%sp_tsai(:) = 0._r8 - currentSite%sp_htop(:) = 0._r8 - - ! WEIGHTING OF FATES PFTs on to HLM_PFTs - ! 1. Add up the area associated with each FATES PFT - ! where pft_areafrac is the area of land in each HLM PFT and (from surface dataset) - ! hlm_pft_map is the area of that land in each FATES PFT (from param file) - - ! 2. weight each fates PFT target for lai, sai and htop by the area of the - ! contrbuting HLM PFTs. - - currentPatch => currentSite%oldest_patch - do while (associated(currentPatch)) - - fates_pft = currentPatch%nocomp_pft_label - if(fates_pft.ne.0)then - - do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) - - if(bc_in%pft_areafrac(hlm_pft) * EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft).gt.0.0_r8)then - !leaf area index - currentSite%sp_tlai(fates_pft) = currentSite%sp_tlai(fates_pft) + & - bc_in%hlm_sp_tlai(hlm_pft) * bc_in%pft_areafrac(hlm_pft) & - * EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft) - !stem area index - currentSite%sp_tsai(fates_pft) = currentSite%sp_tsai(fates_pft) + & - bc_in%hlm_sp_tsai(hlm_pft) * bc_in%pft_areafrac(hlm_pft) & - * EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft) - ! canopy height - currentSite%sp_htop(fates_pft) = currentSite%sp_htop(fates_pft) + & - bc_in%hlm_sp_htop(hlm_pft) * bc_in%pft_areafrac(hlm_pft) & - * EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft) - end if ! there is some area in this patch - end do !hlm_pft - - ! weight for total area in each patch/fates_pft - if(currentPatch%area.gt.0.0_r8)then - currentSite%sp_tlai(fates_pft) = currentSite%sp_tlai(fates_pft) & - /(currentPatch%area/area) - currentSite%sp_tsai(fates_pft) = currentSite%sp_tsai(fates_pft) & - /(currentPatch%area/area) - currentSite%sp_htop(fates_pft) = currentSite%sp_htop(fates_pft) & - /(currentPatch%area/area) - endif - - end if ! not bare patch - currentPatch => currentPatch%younger - end do ! patch loop - - ! ------------------------------------------------------------ - ! now we have the target lai, sai and htop for each PFT/patch - ! find properties of the cohort that go along with that - ! 1. Find canopy area from HTOP (height) - ! 2. Find 'n' associated with canopy area, given a closed canopy - ! 3. Find 'bleaf' associated with TLAI and canopy area. - ! These things happen in the catchily titled "assign_cohort_SP_properties" routine. - ! ------------------------------------------------------------ - - currentPatch => currentSite%oldest_patch - do while (associated(currentPatch)) - - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - - ! FIRST SOME CHECKS. - fates_pft =currentCohort%pft - if(fates_pft.ne.currentPatch%nocomp_pft_label)then ! does this cohort belong in this PFT patch? - write(fates_log(),*) 'wrong PFT label in cohort in SP mode',fates_pft,currentPatch%nocomp_pft_label - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - if(fates_pft.eq.0)then - write(fates_log(),*) 'PFT0 in SP mode' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - ! Call routine to invert SP drivers into cohort properites. - call assign_cohort_SP_properties(currentCohort, currentSite%sp_htop(fates_pft), currentSite%sp_tlai(fates_pft) , currentSite%sp_tsai(fates_pft),currentPatch%area,ifalse,leaf_c) - - currentCohort => currentCohort%shorter - end do !cohort loop - currentPatch => currentPatch%younger - end do ! patch loop + ! To Do in this routine. + ! Get access to HLM input varialbes. + ! Weight them by PFT + ! Loop around patches, and for each single cohort in each patch + ! call assign_cohort_SP_properties to determine cohort height, dbh, 'n', area, leafc from drivers. + + currentSite%sp_tlai(:) = 0._r8 + currentSite%sp_tsai(:) = 0._r8 + currentSite%sp_htop(:) = 0._r8 + + ! WEIGHTING OF FATES PFTs on to HLM_PFTs + ! 1. Add up the area associated with each FATES PFT + ! where pft_areafrac is the area of land in each HLM PFT and (from surface dataset) + ! hlm_pft_map is the area of that land in each FATES PFT (from param file) + + ! 2. weight each fates PFT target for lai, sai and htop by the area of the + ! contrbuting HLM PFTs. + + currentPatch => currentSite%oldest_patch + do while (associated(currentPatch)) + + fates_pft = currentPatch%nocomp_pft_label + if(fates_pft.ne.0)then + + do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) + + if(bc_in%pft_areafrac(hlm_pft) * EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft).gt.0.0_r8)then + !leaf area index + currentSite%sp_tlai(fates_pft) = currentSite%sp_tlai(fates_pft) + & + bc_in%hlm_sp_tlai(hlm_pft) * bc_in%pft_areafrac(hlm_pft) & + * EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft) + !stem area index + currentSite%sp_tsai(fates_pft) = currentSite%sp_tsai(fates_pft) + & + bc_in%hlm_sp_tsai(hlm_pft) * bc_in%pft_areafrac(hlm_pft) & + * EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft) + ! canopy height + currentSite%sp_htop(fates_pft) = currentSite%sp_htop(fates_pft) + & + bc_in%hlm_sp_htop(hlm_pft) * bc_in%pft_areafrac(hlm_pft) & + * EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft) + end if ! there is some area in this patch + end do !hlm_pft + + ! weight for total area in each patch/fates_pft + if(currentPatch%area.gt.0.0_r8)then + currentSite%sp_tlai(fates_pft) = currentSite%sp_tlai(fates_pft) & + /(currentPatch%area/area) + currentSite%sp_tsai(fates_pft) = currentSite%sp_tsai(fates_pft) & + /(currentPatch%area/area) + currentSite%sp_htop(fates_pft) = currentSite%sp_htop(fates_pft) & + /(currentPatch%area/area) + endif + + end if ! not bare patch + currentPatch => currentPatch%younger + end do ! patch loop + + ! ------------------------------------------------------------ + ! now we have the target lai, sai and htop for each PFT/patch + ! find properties of the cohort that go along with that + ! 1. Find canopy area from HTOP (height) + ! 2. Find 'n' associated with canopy area, given a closed canopy + ! 3. Find 'bleaf' associated with TLAI and canopy area. + ! These things happen in the catchily titled "assign_cohort_SP_properties" routine. + ! ------------------------------------------------------------ + + currentPatch => currentSite%oldest_patch + do while (associated(currentPatch)) + + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + + ! FIRST SOME CHECKS. + fates_pft =currentCohort%pft + if(fates_pft.ne.currentPatch%nocomp_pft_label)then ! does this cohort belong in this PFT patch? + write(fates_log(),*) 'wrong PFT label in cohort in SP mode',fates_pft,currentPatch%nocomp_pft_label + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if(fates_pft.eq.0)then + write(fates_log(),*) 'PFT0 in SP mode' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + ! Call routine to invert SP drivers into cohort properites. + call assign_cohort_SP_properties(currentCohort, currentSite%sp_htop(fates_pft), currentSite%sp_tlai(fates_pft) , currentSite%sp_tsai(fates_pft),currentPatch%area,ifalse,leaf_c) + + currentCohort => currentCohort%shorter + end do !cohort loop + currentPatch => currentPatch%younger + end do ! patch loop end subroutine satellite_phenology -! ===================================================================================== + ! ===================================================================================== subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,leaf_c) - ! -----------------------------------------------------------------------------------! - ! Takes the daily inputs of leaf area index, stem area index and canopy height and - ! translates them into a FATES structure with one patch and one cohort per PFT - ! The leaf area of the cohort is modified each day to match that asserted by the HLM - ! -----------------------------------------------------------------------------------! - use EDTypesMod , only : nclmax - + ! -----------------------------------------------------------------------------------! + ! Takes the daily inputs of leaf area index, stem area index and canopy height and + ! translates them into a FATES structure with one patch and one cohort per PFT + ! The leaf area of the cohort is modified each day to match that asserted by the HLM + ! -----------------------------------------------------------------------------------! + use EDTypesMod , only : nclmax + type(ed_cohort_type), intent(inout), target :: currentCohort real(r8), intent(in) :: tlai ! target leaf area index from SP inputs @@ -1487,13 +1487,13 @@ subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,l real(r8) :: fracerr real(r8) :: oldcarea - ! Do some checks - if(associated(currentCohort%shorter))then - write(fates_log(),*) 'SP mode has >1 cohort' - write(fates_log(),*) "SP mode >1 cohort: PFT",currentCohort%pft, currentCohort%shorter%pft - write(fates_log(),*) "SP mode >1 cohort: CL",currentCohort%canopy_layer, currentCohort%shorter%canopy_layer - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if + ! Do some checks + if(associated(currentCohort%shorter))then + write(fates_log(),*) 'SP mode has >1 cohort' + write(fates_log(),*) "SP mode >1 cohort: PFT",currentCohort%pft, currentCohort%shorter%pft + write(fates_log(),*) "SP mode >1 cohort: CL",currentCohort%canopy_layer, currentCohort%shorter%canopy_layer + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if !------------------------------------------ ! Calculate dbh from input height, and c_area from dbh @@ -1503,10 +1503,10 @@ subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,l fates_pft = currentCohort%pft call h2d_allom(currentCohort%hite,fates_pft,currentCohort%dbh) - dummy_n = 1.0_r8 ! make n=1 to get area of one tree. - spread = 1.0_r8 ! fix this to 0 to remove dynamics of canopy closure, assuming a closed canopy. - ! n.b. the value of this will only affect 'n', which isn't/shouldn't be a diagnostic in - ! SP mode. + dummy_n = 1.0_r8 ! make n=1 to get area of one tree. + spread = 1.0_r8 ! fix this to 0 to remove dynamics of canopy closure, assuming a closed canopy. + ! n.b. the value of this will only affect 'n', which isn't/shouldn't be a diagnostic in + ! SP mode. call carea_allom(currentCohort%dbh,dummy_n,spread,currentCohort%pft,currentCohort%c_area) !------------------------------------------ @@ -1523,46 +1523,46 @@ subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,l currentCohort%treelai = tlai canopylai(:) = 0._r8 leaf_c = leafc_from_treelai( currentCohort%treelai, currentCohort%pft, currentCohort%c_area,& - currentCohort%n, currentCohort%canopy_layer, currentCohort%vcmax25top) + currentCohort%n, currentCohort%canopy_layer, currentCohort%vcmax25top) !check that the inverse calculation of leafc from treelai is the same as the ! standard calculation of treelai from leafc. Maybe can delete eventually? check_treelai = tree_lai(leaf_c, currentCohort%pft, currentCohort%c_area, & - currentCohort%n, currentCohort%canopy_layer, & - canopylai,currentCohort%vcmax25top ) - - if( abs(currentCohort%treelai-check_treelai).gt.1.0e-12)then !this is not as precise as nearzero - write(fates_log(),*) 'error in validate treelai',currentCohort%treelai,check_treelai,currentCohort%treelai-check_treelai - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - ! the carea_allom routine sometimes generates precision-tolerance level errors in the canopy area - ! these mean that the canopy area does not exactly add up to the patch area, which causes chaos in - ! the radiation routines. Correct both the area and the 'n' to remove error, and don't use + currentCohort%n, currentCohort%canopy_layer, & + canopylai,currentCohort%vcmax25top ) + + if( abs(currentCohort%treelai-check_treelai).gt.1.0e-12)then !this is not as precise as nearzero + write(fates_log(),*) 'error in validate treelai',currentCohort%treelai,check_treelai,currentCohort%treelai-check_treelai + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + ! the carea_allom routine sometimes generates precision-tolerance level errors in the canopy area + ! these mean that the canopy area does not exactly add up to the patch area, which causes chaos in + ! the radiation routines. Correct both the area and the 'n' to remove error, and don't use !! carea_allom in SP mode after this point. - if(abs(currentCohort%c_area-parea).gt.nearzero)then ! there is an error + if(abs(currentCohort%c_area-parea).gt.nearzero)then ! there is an error if(abs(currentCohort%c_area-parea).lt.10.e-9)then !correct this if it's a very small error - oldcarea = currentCohort%c_area - !generate new cohort area - currentCohort%c_area = currentCohort%c_area - (currentCohort%c_area- parea) - currentCohort%n = currentCohort%n * (currentCohort%c_area/oldcarea) - if(abs(currentCohort%c_area-parea).gt.nearzero)then - write(fates_log(),*) 'SPassign, c_area still broken',currentCohort%c_area-parea,currentCohort%c_area-oldcarea - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if + oldcarea = currentCohort%c_area + !generate new cohort area + currentCohort%c_area = currentCohort%c_area - (currentCohort%c_area- parea) + currentCohort%n = currentCohort%n * (currentCohort%c_area/oldcarea) + if(abs(currentCohort%c_area-parea).gt.nearzero)then + write(fates_log(),*) 'SPassign, c_area still broken',currentCohort%c_area-parea,currentCohort%c_area-oldcarea + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if else - write(fates_log(),*) 'SPassign, big error in c_area',currentCohort%c_area-parea,currentCohort%pft + write(fates_log(),*) 'SPassign, big error in c_area',currentCohort%c_area-parea,currentCohort%pft end if ! still broken - end if !small error + end if !small error - if(init.eq.ifalse)then + if(init.eq.ifalse)then call SetState(currentCohort%prt,leaf_organ,1,leaf_c,1) - endif - - ! assert sai - currentCohort%treesai = tsai + endif + + ! assert sai + currentCohort%treesai = tsai end subroutine assign_cohort_SP_properties @@ -1608,7 +1608,7 @@ subroutine SeedIn( currentSite, bc_in ) !------------------------------------------------------------------------------------ do el = 1, num_elements - + site_seed_rain(:) = 0._r8 element_id = element_list(el) @@ -1618,12 +1618,12 @@ subroutine SeedIn( currentSite, bc_in ) ! Loop over all patches and sum up the seed input for each PFT currentPatch => currentSite%oldest_patch do while (associated(currentPatch)) - + currentCohort => currentPatch%tallest do while (associated(currentCohort)) - + pft = currentCohort%pft - + ! a certain fraction of bstore might go to clonal reproduction when plants die ! (since this is only applied to the dying portion of the cohort ! we do not actually pair down the storage via PARTEH, instead @@ -1631,8 +1631,8 @@ subroutine SeedIn( currentSite, bc_in ) ! to the litter in CWDInput) ! units = [kg/ha/day] = [kg] * [fraction] * [plants/ha/year] * [year/day] store_m_to_repro = -currentCohort%prt%GetState(store_organ,element_id) * & - EDPftvarcon_inst%allom_frbstor_repro(pft)*currentCohort%dndt*years_per_day - + EDPftvarcon_inst%allom_frbstor_repro(pft)*currentCohort%dndt*years_per_day + ! Transfer all reproductive tissues into seed production ! The following call to PRTReproRelease, will return the mass ! of seeds [kg] released by the plant, per the mass_fraction @@ -1640,18 +1640,18 @@ subroutine SeedIn( currentSite, bc_in ) ! from the parteh state-variable. call PRTReproRelease(currentCohort%prt,repro_organ,element_id, & - 1.0_r8, seed_prod) - + 1.0_r8, seed_prod) + if(element_id==carbon12_element)then - currentcohort%seed_prod = seed_prod + currentcohort%seed_prod = seed_prod end if site_seed_rain(pft) = site_seed_rain(pft) + & - (seed_prod * currentCohort%n + store_m_to_repro) - + (seed_prod * currentCohort%n + store_m_to_repro) + currentCohort => currentCohort%shorter enddo !cohort loop - + currentPatch => currentPatch%younger enddo @@ -1661,8 +1661,8 @@ subroutine SeedIn( currentSite, bc_in ) if ( homogenize_seed_pfts ) then site_seed_rain(1:numpft) = sum(site_seed_rain(:))/real(numpft,r8) end if - - + + ! Loop over all patches again and disperse the mixed seeds into the input flux ! arrays @@ -1674,43 +1674,43 @@ subroutine SeedIn( currentSite, bc_in ) do pft = 1,numpft if(currentSite%use_this_pft(pft).eq.itrue)then - ! Seed input from local sources (within site) - litt%seed_in_local(pft) = litt%seed_in_local(pft) + site_seed_rain(pft)/area - - ! If there is forced external seed rain, we calculate the input mass flux - ! from the different elements, usung the seed optimal stoichiometry - ! for non-carbon - select case(element_id) - case(carbon12_element) - seed_stoich = 1._r8 - case(nitrogen_element) - seed_stoich = prt_params%nitr_stoich_p2(pft,repro_organ) - case(phosphorus_element) - seed_stoich = prt_params%phos_stoich_p2(pft,repro_organ) - case default - write(fates_log(), *) 'undefined element specified' - write(fates_log(), *) 'while defining forced external seed mass flux' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end select - - ! Seed input from external sources (user param seed rain, or dispersal model) - seed_in_external = seed_stoich*EDPftvarcon_inst%seed_suppl(pft)*years_per_day - litt%seed_in_extern(pft) = litt%seed_in_extern(pft) + seed_in_external - - ! Seeds entering externally [kg/site/day] - site_mass%seed_in = site_mass%seed_in + seed_in_external*currentPatch%area - end if !use this pft + ! Seed input from local sources (within site) + litt%seed_in_local(pft) = litt%seed_in_local(pft) + site_seed_rain(pft)/area + + ! If there is forced external seed rain, we calculate the input mass flux + ! from the different elements, usung the seed optimal stoichiometry + ! for non-carbon + select case(element_id) + case(carbon12_element) + seed_stoich = 1._r8 + case(nitrogen_element) + seed_stoich = prt_params%nitr_stoich_p2(pft,repro_organ) + case(phosphorus_element) + seed_stoich = prt_params%phos_stoich_p2(pft,repro_organ) + case default + write(fates_log(), *) 'undefined element specified' + write(fates_log(), *) 'while defining forced external seed mass flux' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end select + + ! Seed input from external sources (user param seed rain, or dispersal model) + seed_in_external = seed_stoich*EDPftvarcon_inst%seed_suppl(pft)*years_per_day + litt%seed_in_extern(pft) = litt%seed_in_extern(pft) + seed_in_external + + ! Seeds entering externally [kg/site/day] + site_mass%seed_in = site_mass%seed_in + seed_in_external*currentPatch%area + end if !use this pft enddo - - + + currentPatch => currentPatch%younger enddo - + end do return end subroutine SeedIn - + ! ============================================================================ subroutine SeedDecay( litt ) @@ -1733,10 +1733,10 @@ subroutine SeedDecay( litt ) do pft = 1,numpft litt%seed_decay(pft) = litt%seed(pft) * & - EDPftvarcon_inst%seed_decay_rate(pft)*years_per_day + EDPftvarcon_inst%seed_decay_rate(pft)*years_per_day litt%seed_germ_decay(pft) = litt%seed_germ(pft) * & - EDPftvarcon_inst%seed_decay_rate(pft)*years_per_day + EDPftvarcon_inst%seed_decay_rate(pft)*years_per_day enddo @@ -1750,7 +1750,7 @@ subroutine SeedGermination( litt, cold_stat, drought_stat ) ! Flux from seed pool into sapling pool ! ! !USES: - + ! ! !ARGUMENTS type(litter_type) :: litt @@ -1760,9 +1760,9 @@ subroutine SeedGermination( litt, cold_stat, drought_stat ) ! !LOCAL VARIABLES: integer :: pft - + real(r8), parameter :: max_germination = 1.0_r8 ! Cap on germination rates. - ! KgC/m2/yr Lishcke et al. 2009 + ! KgC/m2/yr Lishcke et al. 2009 ! Turning of this cap? because the cap will impose changes on proportionality ! of nutrients. (RGK 02-2019) @@ -1778,17 +1778,17 @@ subroutine SeedGermination( litt, cold_stat, drought_stat ) do pft = 1,numpft litt%seed_germ_in(pft) = min(litt%seed(pft) * EDPftvarcon_inst%germination_rate(pft), & - max_germination)*years_per_day - + max_germination)*years_per_day + !set the germination only under the growing season...c.xu if ((prt_params%season_decid(pft) == itrue ) .and. & - (any(cold_stat == [phen_cstat_nevercold,phen_cstat_iscold]))) then - litt%seed_germ_in(pft) = 0.0_r8 + (any(cold_stat == [phen_cstat_nevercold,phen_cstat_iscold]))) then + litt%seed_germ_in(pft) = 0.0_r8 endif if ((prt_params%stress_decid(pft) == itrue ) .and. & - (any(drought_stat == [phen_dstat_timeoff,phen_dstat_moistoff]))) then - litt%seed_germ_in(pft) = 0.0_r8 + (any(drought_stat == [phen_dstat_timeoff,phen_dstat_moistoff]))) then + litt%seed_germ_in(pft) = 0.0_r8 end if @@ -1846,9 +1846,9 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) real(r8) :: m_repro ! reproductive mass (element agnostic) [kg] real(r8) :: mass_avail ! The mass of each nutrient/carbon available in the seed_germination pool [kg] real(r8) :: mass_demand ! Total mass demanded by the plant to achieve the stoichiometric targets - ! of all the organs in the recruits. Used for both [kg per plant] and [kg per cohort] + ! of all the organs in the recruits. Used for both [kg per plant] and [kg per cohort] real(r8) :: stem_drop_fraction - + !---------------------------------------------------------------------- allocate(temp_cohort) ! create temporary cohort @@ -1856,247 +1856,247 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) do ft = 1,numpft - if(currentSite%use_this_pft(ft).eq.itrue)then - temp_cohort%canopy_trim = 0.8_r8 !starting with the canopy not fully expanded - temp_cohort%pft = ft - temp_cohort%hite = EDPftvarcon_inst%hgt_min(ft) - temp_cohort%coage = 0.0_r8 - stem_drop_fraction = EDPftvarcon_inst%phen_stem_drop_fraction(ft) - - call h2d_allom(temp_cohort%hite,ft,temp_cohort%dbh) - - ! Initialize live pools - call bleaf(temp_cohort%dbh,ft,temp_cohort%canopy_trim,c_leaf) - call bfineroot(temp_cohort%dbh,ft,temp_cohort%canopy_trim,c_fnrt) - call bsap_allom(temp_cohort%dbh,ft,temp_cohort%canopy_trim,a_sapw, c_sapw) - call bagw_allom(temp_cohort%dbh,ft,c_agw) - call bbgw_allom(temp_cohort%dbh,ft,c_bgw) - call bdead_allom(c_agw,c_bgw,c_sapw,ft,c_struct) - call bstore_allom(temp_cohort%dbh,ft,temp_cohort%canopy_trim,c_store) - - ! Default assumption is that leaves are on - cohortstatus = leaves_on - temp_cohort%laimemory = 0.0_r8 - temp_cohort%sapwmemory = 0.0_r8 - temp_cohort%structmemory = 0.0_r8 - - - ! But if the plant is seasonally (cold) deciduous, and the site status is flagged - ! as "cold", then set the cohort's status to leaves_off, and remember the leaf biomass - if ((prt_params%season_decid(ft) == itrue) .and. & - (any(currentSite%cstatus == [phen_cstat_nevercold,phen_cstat_iscold]))) then - temp_cohort%laimemory = c_leaf - c_leaf = 0.0_r8 - - ! If plant is not woody then set sapwood and structural biomass as well - if (prt_params%woody(ft).ne.itrue) then - temp_cohort%sapwmemory = c_sapw * stem_drop_fraction - temp_cohort%structmemory = c_struct * stem_drop_fraction - c_sapw = (1.0_r8 - stem_drop_fraction) * c_sapw - c_struct = (1.0_r8 - stem_drop_fraction) * c_struct - endif - cohortstatus = leaves_off - endif - - ! Or.. if the plant is drought deciduous, and the site status is flagged as - ! "in a drought", then likewise, set the cohort's status to leaves_off, and remember leaf - ! biomass - if ((prt_params%stress_decid(ft) == itrue) .and. & - (any(currentSite%dstatus == [phen_dstat_timeoff,phen_dstat_moistoff]))) then - temp_cohort%laimemory = c_leaf - c_leaf = 0.0_r8 - - ! If plant is not woody then set sapwood and structural biomass as well - if(prt_params%woody(ft).ne.itrue)then - temp_cohort%sapwmemory = c_sapw * stem_drop_fraction - temp_cohort%structmemory = c_struct * stem_drop_fraction - c_sapw = (1.0_r8 - stem_drop_fraction) * c_sapw - c_struct = (1.0_r8 - stem_drop_fraction) * c_struct - endif - cohortstatus = leaves_off - endif - - - ! Cycle through available carbon and nutrients, find the limiting element - ! to dictate the total number of plants that can be generated - - if ( (hlm_use_ed_prescribed_phys .eq. ifalse) .or. & - (EDPftvarcon_inst%prescribed_recruitment(ft) .lt. 0._r8) ) then - - temp_cohort%n = 1.e10_r8 - - do el = 1,num_elements - - element_id = element_list(el) - select case(element_id) - case(carbon12_element) - - mass_demand = (c_struct+c_leaf+c_fnrt+c_sapw+c_store) - - case(nitrogen_element) - - mass_demand = c_struct*prt_params%nitr_stoich_p1(ft,struct_organ) + & - c_leaf*prt_params%nitr_stoich_p1(ft,leaf_organ) + & - c_fnrt*prt_params%nitr_stoich_p1(ft,fnrt_organ) + & - c_sapw*prt_params%nitr_stoich_p1(ft,sapw_organ) + & - c_store*prt_params%nitr_stoich_p1(ft,store_organ) - - case(phosphorus_element) - - mass_demand = c_struct*prt_params%phos_stoich_p1(ft,struct_organ) + & - c_leaf*prt_params%phos_stoich_p1(ft,leaf_organ) + & - c_fnrt*prt_params%phos_stoich_p1(ft,fnrt_organ) + & - c_sapw*prt_params%phos_stoich_p1(ft,sapw_organ) + & - c_store*prt_params%phos_stoich_p1(ft,store_organ) - - case default + if(currentSite%use_this_pft(ft).eq.itrue)then + temp_cohort%canopy_trim = 0.8_r8 !starting with the canopy not fully expanded + temp_cohort%pft = ft + temp_cohort%hite = EDPftvarcon_inst%hgt_min(ft) + temp_cohort%coage = 0.0_r8 + stem_drop_fraction = EDPftvarcon_inst%phen_stem_drop_fraction(ft) + + call h2d_allom(temp_cohort%hite,ft,temp_cohort%dbh) + + ! Initialize live pools + call bleaf(temp_cohort%dbh,ft,temp_cohort%canopy_trim,c_leaf) + call bfineroot(temp_cohort%dbh,ft,temp_cohort%canopy_trim,c_fnrt) + call bsap_allom(temp_cohort%dbh,ft,temp_cohort%canopy_trim,a_sapw, c_sapw) + call bagw_allom(temp_cohort%dbh,ft,c_agw) + call bbgw_allom(temp_cohort%dbh,ft,c_bgw) + call bdead_allom(c_agw,c_bgw,c_sapw,ft,c_struct) + call bstore_allom(temp_cohort%dbh,ft,temp_cohort%canopy_trim,c_store) + + ! Default assumption is that leaves are on + cohortstatus = leaves_on + temp_cohort%laimemory = 0.0_r8 + temp_cohort%sapwmemory = 0.0_r8 + temp_cohort%structmemory = 0.0_r8 + + + ! But if the plant is seasonally (cold) deciduous, and the site status is flagged + ! as "cold", then set the cohort's status to leaves_off, and remember the leaf biomass + if ((prt_params%season_decid(ft) == itrue) .and. & + (any(currentSite%cstatus == [phen_cstat_nevercold,phen_cstat_iscold]))) then + temp_cohort%laimemory = c_leaf + c_leaf = 0.0_r8 + + ! If plant is not woody then set sapwood and structural biomass as well + if (prt_params%woody(ft).ne.itrue) then + temp_cohort%sapwmemory = c_sapw * stem_drop_fraction + temp_cohort%structmemory = c_struct * stem_drop_fraction + c_sapw = (1.0_r8 - stem_drop_fraction) * c_sapw + c_struct = (1.0_r8 - stem_drop_fraction) * c_struct + endif + cohortstatus = leaves_off + endif + + ! Or.. if the plant is drought deciduous, and the site status is flagged as + ! "in a drought", then likewise, set the cohort's status to leaves_off, and remember leaf + ! biomass + if ((prt_params%stress_decid(ft) == itrue) .and. & + (any(currentSite%dstatus == [phen_dstat_timeoff,phen_dstat_moistoff]))) then + temp_cohort%laimemory = c_leaf + c_leaf = 0.0_r8 + + ! If plant is not woody then set sapwood and structural biomass as well + if(prt_params%woody(ft).ne.itrue)then + temp_cohort%sapwmemory = c_sapw * stem_drop_fraction + temp_cohort%structmemory = c_struct * stem_drop_fraction + c_sapw = (1.0_r8 - stem_drop_fraction) * c_sapw + c_struct = (1.0_r8 - stem_drop_fraction) * c_struct + endif + cohortstatus = leaves_off + endif + + + ! Cycle through available carbon and nutrients, find the limiting element + ! to dictate the total number of plants that can be generated + + if ( (hlm_use_ed_prescribed_phys .eq. ifalse) .or. & + (EDPftvarcon_inst%prescribed_recruitment(ft) .lt. 0._r8) ) then + + temp_cohort%n = 1.e10_r8 + + do el = 1,num_elements + + element_id = element_list(el) + select case(element_id) + case(carbon12_element) + + mass_demand = (c_struct+c_leaf+c_fnrt+c_sapw+c_store) + + case(nitrogen_element) + + mass_demand = c_struct*prt_params%nitr_stoich_p1(ft,struct_organ) + & + c_leaf*prt_params%nitr_stoich_p1(ft,leaf_organ) + & + c_fnrt*prt_params%nitr_stoich_p1(ft,fnrt_organ) + & + c_sapw*prt_params%nitr_stoich_p1(ft,sapw_organ) + & + c_store*prt_params%nitr_stoich_p1(ft,store_organ) + + case(phosphorus_element) + + mass_demand = c_struct*prt_params%phos_stoich_p1(ft,struct_organ) + & + c_leaf*prt_params%phos_stoich_p1(ft,leaf_organ) + & + c_fnrt*prt_params%phos_stoich_p1(ft,fnrt_organ) + & + c_sapw*prt_params%phos_stoich_p1(ft,sapw_organ) + & + c_store*prt_params%phos_stoich_p1(ft,store_organ) + + case default write(fates_log(),*) 'Undefined element type in recruitment' call endrun(msg=errMsg(sourcefile, __LINE__)) - end select - - mass_avail = currentPatch%area * currentPatch%litter(el)%seed_germ(ft) + end select - ! ------------------------------------------------------------------------ - ! Update number density if this is the limiting mass - ! ------------------------------------------------------------------------ + mass_avail = currentPatch%area * currentPatch%litter(el)%seed_germ(ft) - temp_cohort%n = min(temp_cohort%n, mass_avail/mass_demand) + ! ------------------------------------------------------------------------ + ! Update number density if this is the limiting mass + ! ------------------------------------------------------------------------ - end do + temp_cohort%n = min(temp_cohort%n, mass_avail/mass_demand) + end do - else - ! prescribed recruitment rates. number per sq. meter per year - temp_cohort%n = currentPatch%area * & - EDPftvarcon_inst%prescribed_recruitment(ft) * & - hlm_freq_day - endif - ! Only bother allocating a new cohort if there is a reasonable amount of it - if (temp_cohort%n > min_n_safemath )then - - ! ----------------------------------------------------------------------------- - ! PART II. - ! Initialize the PARTEH object, and determine the initial masses of all - ! organs and elements. - ! ----------------------------------------------------------------------------- - prt => null() - call InitPRTObject(prt) - - do el = 1,num_elements - - element_id = element_list(el) - - ! If this is carbon12, then the initialization is straight forward - ! otherwise, we use stoichiometric ratios - select case(element_id) - case(carbon12_element) - - m_struct = c_struct - m_leaf = c_leaf - m_fnrt = c_fnrt - m_sapw = c_sapw - m_store = c_store - m_repro = 0._r8 - - case(nitrogen_element) - - m_struct = c_struct*prt_params%nitr_stoich_p1(ft,struct_organ) - m_leaf = c_leaf*prt_params%nitr_stoich_p1(ft,leaf_organ) - m_fnrt = c_fnrt*prt_params%nitr_stoich_p1(ft,fnrt_organ) - m_sapw = c_sapw*prt_params%nitr_stoich_p1(ft,sapw_organ) - m_store = c_store*prt_params%nitr_stoich_p1(ft,store_organ) - m_repro = 0._r8 - - case(phosphorus_element) - - m_struct = c_struct*prt_params%phos_stoich_p1(ft,struct_organ) - m_leaf = c_leaf*prt_params%phos_stoich_p1(ft,leaf_organ) - m_fnrt = c_fnrt*prt_params%phos_stoich_p1(ft,fnrt_organ) - m_sapw = c_sapw*prt_params%phos_stoich_p1(ft,sapw_organ) - m_store = c_store*prt_params%phos_stoich_p1(ft,store_organ) - m_repro = 0._r8 - - end select - - select case(hlm_parteh_mode) - case (prt_carbon_allom_hyp,prt_cnp_flex_allom_hyp ) - - ! Put all of the leaf mass into the first bin - call SetState(prt,leaf_organ, element_id,m_leaf,1) - do iage = 2,nleafage - call SetState(prt,leaf_organ, element_id,0._r8,iage) - end do - - call SetState(prt,fnrt_organ, element_id, m_fnrt) - call SetState(prt,sapw_organ, element_id, m_sapw) - call SetState(prt,store_organ, element_id, m_store) - call SetState(prt,struct_organ, element_id, m_struct) - call SetState(prt,repro_organ, element_id, m_repro) - - case default - write(fates_log(),*) 'Unspecified PARTEH module during create_cohort' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end select - - site_mass => currentSite%mass_balance(el) - - ! Remove mass from the germination pool. However, if we are use prescribed physiology, - ! AND the forced recruitment model, then we are not realling using the prognostic - ! seed_germination model, so we have to short circuit things. We send all of the - ! seed germination mass to an outflux pool, and use an arbitrary generic input flux - ! to balance out the new recruits. - - if ( (hlm_use_ed_prescribed_phys .eq. itrue ) .and. & - (EDPftvarcon_inst%prescribed_recruitment(ft) .ge. 0._r8 )) then - - site_mass%flux_generic_in = site_mass%flux_generic_in + & + else + ! prescribed recruitment rates. number per sq. meter per year + temp_cohort%n = currentPatch%area * & + EDPftvarcon_inst%prescribed_recruitment(ft) * & + hlm_freq_day + endif + + ! Only bother allocating a new cohort if there is a reasonable amount of it + if (temp_cohort%n > min_n_safemath )then + + ! ----------------------------------------------------------------------------- + ! PART II. + ! Initialize the PARTEH object, and determine the initial masses of all + ! organs and elements. + ! ----------------------------------------------------------------------------- + prt => null() + call InitPRTObject(prt) + + do el = 1,num_elements + + element_id = element_list(el) + + ! If this is carbon12, then the initialization is straight forward + ! otherwise, we use stoichiometric ratios + select case(element_id) + case(carbon12_element) + + m_struct = c_struct + m_leaf = c_leaf + m_fnrt = c_fnrt + m_sapw = c_sapw + m_store = c_store + m_repro = 0._r8 + + case(nitrogen_element) + + m_struct = c_struct*prt_params%nitr_stoich_p1(ft,struct_organ) + m_leaf = c_leaf*prt_params%nitr_stoich_p1(ft,leaf_organ) + m_fnrt = c_fnrt*prt_params%nitr_stoich_p1(ft,fnrt_organ) + m_sapw = c_sapw*prt_params%nitr_stoich_p1(ft,sapw_organ) + m_store = c_store*prt_params%nitr_stoich_p1(ft,store_organ) + m_repro = 0._r8 + + case(phosphorus_element) + + m_struct = c_struct*prt_params%phos_stoich_p1(ft,struct_organ) + m_leaf = c_leaf*prt_params%phos_stoich_p1(ft,leaf_organ) + m_fnrt = c_fnrt*prt_params%phos_stoich_p1(ft,fnrt_organ) + m_sapw = c_sapw*prt_params%phos_stoich_p1(ft,sapw_organ) + m_store = c_store*prt_params%phos_stoich_p1(ft,store_organ) + m_repro = 0._r8 + + end select + + select case(hlm_parteh_mode) + case (prt_carbon_allom_hyp,prt_cnp_flex_allom_hyp ) + + ! Put all of the leaf mass into the first bin + call SetState(prt,leaf_organ, element_id,m_leaf,1) + do iage = 2,nleafage + call SetState(prt,leaf_organ, element_id,0._r8,iage) + end do + + call SetState(prt,fnrt_organ, element_id, m_fnrt) + call SetState(prt,sapw_organ, element_id, m_sapw) + call SetState(prt,store_organ, element_id, m_store) + call SetState(prt,struct_organ, element_id, m_struct) + call SetState(prt,repro_organ, element_id, m_repro) + + case default + write(fates_log(),*) 'Unspecified PARTEH module during create_cohort' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end select + + site_mass => currentSite%mass_balance(el) + + ! Remove mass from the germination pool. However, if we are use prescribed physiology, + ! AND the forced recruitment model, then we are not realling using the prognostic + ! seed_germination model, so we have to short circuit things. We send all of the + ! seed germination mass to an outflux pool, and use an arbitrary generic input flux + ! to balance out the new recruits. + + if ( (hlm_use_ed_prescribed_phys .eq. itrue ) .and. & + (EDPftvarcon_inst%prescribed_recruitment(ft) .ge. 0._r8 )) then + + site_mass%flux_generic_in = site_mass%flux_generic_in + & temp_cohort%n*(m_struct + m_leaf + m_fnrt + m_sapw + m_store + m_repro) - - site_mass%flux_generic_out = site_mass%flux_generic_out + & + + site_mass%flux_generic_out = site_mass%flux_generic_out + & currentPatch%area * currentPatch%litter(el)%seed_germ(ft) - - currentPatch%litter(el)%seed_germ(ft) = 0._r8 - - else + currentPatch%litter(el)%seed_germ(ft) = 0._r8 + - currentPatch%litter(el)%seed_germ(ft) = currentPatch%litter(el)%seed_germ(ft) - & + else + + currentPatch%litter(el)%seed_germ(ft) = currentPatch%litter(el)%seed_germ(ft) - & temp_cohort%n / currentPatch%area * & (m_struct + m_leaf + m_fnrt + m_sapw + m_store + m_repro) - - end if - - - - end do - - ! This call cycles through the initial conditions, and makes sure that they - ! are all initialized. - ! ----------------------------------------------------------------------------------- - - call prt%CheckInitialConditions() - ! This initializes the cohort - call create_cohort(currentSite,currentPatch, temp_cohort%pft, temp_cohort%n, & - temp_cohort%hite, temp_cohort%coage, temp_cohort%dbh, prt, & - temp_cohort%laimemory, temp_cohort%sapwmemory, temp_cohort%structmemory, & - cohortstatus, recruitstatus, & - temp_cohort%canopy_trim,temp_cohort%c_area, & - currentPatch%NCL_p, currentSite%spread, bc_in) - - ! Note that if hydraulics is on, the number of cohorts may had - ! changed due to hydraulic constraints. - ! This constaint is applied during "create_cohort" subroutine. - - ! keep track of how many individuals were recruited for passing to history - currentSite%recruitment_rate(ft) = currentSite%recruitment_rate(ft) + temp_cohort%n - - endif - endif !use_this_pft - enddo !pft loop - - deallocate(temp_cohort) ! delete temporary cohort + end if + + + + end do + + ! This call cycles through the initial conditions, and makes sure that they + ! are all initialized. + ! ----------------------------------------------------------------------------------- + + call prt%CheckInitialConditions() + ! This initializes the cohort + call create_cohort(currentSite,currentPatch, temp_cohort%pft, temp_cohort%n, & + temp_cohort%hite, temp_cohort%coage, temp_cohort%dbh, prt, & + temp_cohort%laimemory, temp_cohort%sapwmemory, temp_cohort%structmemory, & + cohortstatus, recruitstatus, & + temp_cohort%canopy_trim,temp_cohort%c_area, & + currentPatch%NCL_p, currentSite%spread, bc_in) + + ! Note that if hydraulics is on, the number of cohorts may had + ! changed due to hydraulic constraints. + ! This constaint is applied during "create_cohort" subroutine. + + ! keep track of how many individuals were recruited for passing to history + currentSite%recruitment_rate(ft) = currentSite%recruitment_rate(ft) + temp_cohort%n + + + endif + endif !use_this_pft + enddo !pft loop + + deallocate(temp_cohort) ! delete temporary cohort end subroutine recruitment @@ -2132,9 +2132,9 @@ subroutine CWDInput( currentSite, currentPatch, litt) real(r8) :: dead_n_dlogging ! direct logging understory dead-tree density real(r8) :: dead_n_ilogging ! indirect understory dead-tree density (logging) real(r8) :: dead_n_natural ! understory dead density not associated - ! with direct logging + ! with direct logging real(r8) :: leaf_m ! mass of the element of interest in the - ! leaf [kg] + ! leaf [kg] real(r8) :: fnrt_m ! fine-root [kg] real(r8) :: sapw_m ! sapwood [kg] real(r8) :: struct_m ! structural [kg] @@ -2149,9 +2149,9 @@ subroutine CWDInput( currentSite, currentPatch, litt) real(r8) :: dcmpy_frac ! Fraction of mass sent to decomposability pool real(r8) :: plant_dens ! Number of plants per m2 real(r8) :: bg_cwd_tot ! Total below-ground coarse woody debris - ! input flux + ! input flux real(r8) :: root_fines_tot ! Total below-ground fine root coarse - ! woody debris + ! woody debris integer :: element_id ! element id consistent with parteh/PRTGenericMod.F90 real(r8) :: trunk_wood ! carbon flux into trunk products kgC/day/site @@ -2168,263 +2168,263 @@ subroutine CWDInput( currentSite, currentPatch, litt) numlevsoil = currentSite%nlevsoil element_id = litt%element_id - + ! Object tracking flux diagnostics for each element flux_diags => currentSite%flux_diags(element_pos(element_id)) - + ! Object tracking site level mass balance for each element site_mass => currentSite%mass_balance(element_pos(element_id)) currentCohort => currentPatch%shortest do while(associated(currentCohort)) - pft = currentCohort%pft - - call set_root_fraction(currentSite%rootfrac_scr, pft, currentSite%zi_soil) - - leaf_m_turnover = currentCohort%prt%GetTurnover(leaf_organ,element_id) - store_m_turnover = currentCohort%prt%GetTurnover(store_organ,element_id) - fnrt_m_turnover = currentCohort%prt%GetTurnover(fnrt_organ,element_id) - sapw_m_turnover = currentCohort%prt%GetTurnover(sapw_organ,element_id) - struct_m_turnover = currentCohort%prt%GetTurnover(struct_organ,element_id) - repro_m_turnover = currentCohort%prt%GetTurnover(repro_organ,element_id) - - leaf_m = currentCohort%prt%GetState(leaf_organ,element_id) - store_m = currentCohort%prt%GetState(store_organ,element_id) - fnrt_m = currentCohort%prt%GetState(fnrt_organ,element_id) - sapw_m = currentCohort%prt%GetState(sapw_organ,element_id) - struct_m = currentCohort%prt%GetState(struct_organ,element_id) - repro_m = currentCohort%prt%GetState(repro_organ,element_id) - - plant_dens = currentCohort%n/currentPatch%area - - ! --------------------------------------------------------------------------------- - ! PART 1 Litter fluxes from non-mortal tissue turnovers Kg/m2/day - ! Important note: Turnover has already been removed from the cohorts. - ! So, in the next part of this algorithm, when we send the biomass - ! from dying trees to the litter pools, we don't have to worry - ! about double counting. - ! --------------------------------------------------------------------------------- - - flux_diags%leaf_litter_input(pft) = & + pft = currentCohort%pft + + call set_root_fraction(currentSite%rootfrac_scr, pft, currentSite%zi_soil) + + leaf_m_turnover = currentCohort%prt%GetTurnover(leaf_organ,element_id) + store_m_turnover = currentCohort%prt%GetTurnover(store_organ,element_id) + fnrt_m_turnover = currentCohort%prt%GetTurnover(fnrt_organ,element_id) + sapw_m_turnover = currentCohort%prt%GetTurnover(sapw_organ,element_id) + struct_m_turnover = currentCohort%prt%GetTurnover(struct_organ,element_id) + repro_m_turnover = currentCohort%prt%GetTurnover(repro_organ,element_id) + + leaf_m = currentCohort%prt%GetState(leaf_organ,element_id) + store_m = currentCohort%prt%GetState(store_organ,element_id) + fnrt_m = currentCohort%prt%GetState(fnrt_organ,element_id) + sapw_m = currentCohort%prt%GetState(sapw_organ,element_id) + struct_m = currentCohort%prt%GetState(struct_organ,element_id) + repro_m = currentCohort%prt%GetState(repro_organ,element_id) + + plant_dens = currentCohort%n/currentPatch%area + + ! --------------------------------------------------------------------------------- + ! PART 1 Litter fluxes from non-mortal tissue turnovers Kg/m2/day + ! Important note: Turnover has already been removed from the cohorts. + ! So, in the next part of this algorithm, when we send the biomass + ! from dying trees to the litter pools, we don't have to worry + ! about double counting. + ! --------------------------------------------------------------------------------- + + flux_diags%leaf_litter_input(pft) = & flux_diags%leaf_litter_input(pft) + & leaf_m_turnover * currentCohort%n - - root_fines_tot = (fnrt_m_turnover + store_m_turnover ) * & + + root_fines_tot = (fnrt_m_turnover + store_m_turnover ) * & plant_dens - do dcmpy=1,ndcmpy + do dcmpy=1,ndcmpy dcmpy_frac = GetDecompyFrac(pft,leaf_organ,dcmpy) litt%leaf_fines_in(dcmpy) = litt%leaf_fines_in(dcmpy) + & - (leaf_m_turnover+repro_m_turnover) * plant_dens * dcmpy_frac + (leaf_m_turnover+repro_m_turnover) * plant_dens * dcmpy_frac dcmpy_frac = GetDecompyFrac(pft,fnrt_organ,dcmpy) do ilyr = 1, numlevsoil - litt%root_fines_in(dcmpy,ilyr) = litt%root_fines_in(dcmpy,ilyr) + & - currentSite%rootfrac_scr(ilyr) * root_fines_tot * dcmpy_frac + litt%root_fines_in(dcmpy,ilyr) = litt%root_fines_in(dcmpy,ilyr) + & + currentSite%rootfrac_scr(ilyr) * root_fines_tot * dcmpy_frac end do - end do - - flux_diags%root_litter_input(pft) = & + end do + + flux_diags%root_litter_input(pft) = & flux_diags%root_litter_input(pft) + & (fnrt_m_turnover + store_m_turnover ) * currentCohort%n - - - ! Assumption: turnover from deadwood and sapwood are lumped together in CWD pool - - do c = 1,ncwd - litt%ag_cwd_in(c) = litt%ag_cwd_in(c) + & - (sapw_m_turnover + struct_m_turnover) * & - SF_val_CWD_frac(c) * plant_dens * & - prt_params%allom_agb_frac(pft) - - flux_diags%cwd_ag_input(c) = flux_diags%cwd_ag_input(c) + & + + + ! Assumption: turnover from deadwood and sapwood are lumped together in CWD pool + + do c = 1,ncwd + litt%ag_cwd_in(c) = litt%ag_cwd_in(c) + & + (sapw_m_turnover + struct_m_turnover) * & + SF_val_CWD_frac(c) * plant_dens * & + prt_params%allom_agb_frac(pft) + + flux_diags%cwd_ag_input(c) = flux_diags%cwd_ag_input(c) + & (struct_m_turnover + sapw_m_turnover) * SF_val_CWD_frac(c) * & prt_params%allom_agb_frac(pft) * currentCohort%n - bg_cwd_tot = (sapw_m_turnover + struct_m_turnover) * & - SF_val_CWD_frac(c) * plant_dens * & - (1.0_r8-prt_params%allom_agb_frac(pft)) + bg_cwd_tot = (sapw_m_turnover + struct_m_turnover) * & + SF_val_CWD_frac(c) * plant_dens * & + (1.0_r8-prt_params%allom_agb_frac(pft)) - do ilyr = 1, numlevsoil - litt%bg_cwd_in(c,ilyr) = litt%bg_cwd_in(c,ilyr) + & + do ilyr = 1, numlevsoil + litt%bg_cwd_in(c,ilyr) = litt%bg_cwd_in(c,ilyr) + & bg_cwd_tot * currentSite%rootfrac_scr(ilyr) - end do - - flux_diags%cwd_bg_input(c) = flux_diags%cwd_bg_input(c) + & + end do + + flux_diags%cwd_bg_input(c) = flux_diags%cwd_bg_input(c) + & bg_cwd_tot*currentPatch%area - - enddo + + enddo - ! --------------------------------------------------------------------------------- - ! PART 2 Litter fluxes from non-disturbance inducing mortality. Kg/m2/day - ! --------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------- + ! PART 2 Litter fluxes from non-disturbance inducing mortality. Kg/m2/day + ! --------------------------------------------------------------------------------- - ! Total number of dead (n/m2/day) - dead_n = -1.0_r8 * currentCohort%dndt/currentPatch%area*years_per_day + ! Total number of dead (n/m2/day) + dead_n = -1.0_r8 * currentCohort%dndt/currentPatch%area*years_per_day - if(currentCohort%canopy_layer > 1)then + if(currentCohort%canopy_layer > 1)then - ! Total number of dead understory from direct logging - ! (it is possible that large harvestable trees are in the understory) - dead_n_dlogging = currentCohort%lmort_direct * & - currentCohort%n/currentPatch%area + ! Total number of dead understory from direct logging + ! (it is possible that large harvestable trees are in the understory) + dead_n_dlogging = currentCohort%lmort_direct * & + currentCohort%n/currentPatch%area - ! Total number of dead understory from indirect logging - dead_n_ilogging = (currentCohort%lmort_collateral + currentCohort%lmort_infra) * & - currentCohort%n/currentPatch%area + ! Total number of dead understory from indirect logging + dead_n_ilogging = (currentCohort%lmort_collateral + currentCohort%lmort_infra) * & + currentCohort%n/currentPatch%area - else + else - ! All mortality from logging in the canopy is - ! is disturbance generating + ! All mortality from logging in the canopy is + ! is disturbance generating - dead_n_dlogging = 0._r8 - dead_n_ilogging = 0._r8 + dead_n_dlogging = 0._r8 + dead_n_ilogging = 0._r8 - end if + end if - dead_n_natural = dead_n - dead_n_dlogging - dead_n_ilogging + dead_n_natural = dead_n - dead_n_dlogging - dead_n_ilogging - flux_diags%leaf_litter_input(pft) = & + flux_diags%leaf_litter_input(pft) = & flux_diags%leaf_litter_input(pft) + & leaf_m * dead_n*currentPatch%area - ! %n has not been updated due to mortality yet, thus - ! the litter flux has already been counted since it captured - ! the losses of live trees and those flagged for death - - root_fines_tot = dead_n * (fnrt_m + & - store_m*(1._r8-EDPftvarcon_inst%allom_frbstor_repro(pft)) ) + ! %n has not been updated due to mortality yet, thus + ! the litter flux has already been counted since it captured + ! the losses of live trees and those flagged for death - do dcmpy=1,ndcmpy + root_fines_tot = dead_n * (fnrt_m + & + store_m*(1._r8-EDPftvarcon_inst%allom_frbstor_repro(pft)) ) + + do dcmpy=1,ndcmpy dcmpy_frac = GetDecompyFrac(pft,leaf_organ,dcmpy) litt%leaf_fines_in(dcmpy) = litt%leaf_fines_in(dcmpy) + & - (leaf_m+repro_m) * dead_n * dcmpy_frac + (leaf_m+repro_m) * dead_n * dcmpy_frac dcmpy_frac = GetDecompyFrac(pft,fnrt_organ,dcmpy) do ilyr = 1, numlevsoil - litt%root_fines_in(dcmpy,ilyr) = litt%root_fines_in(dcmpy,ilyr) + & - root_fines_tot * currentSite%rootfrac_scr(ilyr) * dcmpy_frac + litt%root_fines_in(dcmpy,ilyr) = litt%root_fines_in(dcmpy,ilyr) + & + root_fines_tot * currentSite%rootfrac_scr(ilyr) * dcmpy_frac end do - end do + end do - flux_diags%root_litter_input(pft) = & + flux_diags%root_litter_input(pft) = & flux_diags%root_litter_input(pft) + & root_fines_tot*currentPatch%area - ! Track CWD inputs from dead plants - - do c = 1,ncwd - - ! Below-ground - - bg_cwd_tot = (struct_m + sapw_m) * & - SF_val_CWD_frac(c) * dead_n * & - (1.0_r8-prt_params%allom_agb_frac(pft)) - - do ilyr = 1, numlevsoil - litt%bg_cwd_in(c,ilyr) = litt%bg_cwd_in(c,ilyr) + & + ! Track CWD inputs from dead plants + + do c = 1,ncwd + + ! Below-ground + + bg_cwd_tot = (struct_m + sapw_m) * & + SF_val_CWD_frac(c) * dead_n * & + (1.0_r8-prt_params%allom_agb_frac(pft)) + + do ilyr = 1, numlevsoil + litt%bg_cwd_in(c,ilyr) = litt%bg_cwd_in(c,ilyr) + & currentSite%rootfrac_scr(ilyr) * bg_cwd_tot - end do + end do - flux_diags%cwd_bg_input(c) = flux_diags%cwd_bg_input(c) + & + flux_diags%cwd_bg_input(c) = flux_diags%cwd_bg_input(c) + & bg_cwd_tot * currentPatch%area - ! Send AGB component of boles from logging activities into the litter. - ! This includes fluxes from indirect modes of death, as well as the - ! non-exported boles due to direct harvesting. + ! Send AGB component of boles from logging activities into the litter. + ! This includes fluxes from indirect modes of death, as well as the + ! non-exported boles due to direct harvesting. + + if (c==ncwd) then - if (c==ncwd) then - - trunk_wood = (struct_m + sapw_m) * & - SF_val_CWD_frac(c) * dead_n_dlogging * & - prt_params%allom_agb_frac(pft) - - site_mass%wood_product = site_mass%wood_product + & - trunk_wood * currentPatch%area * logging_export_frac + trunk_wood = (struct_m + sapw_m) * & + SF_val_CWD_frac(c) * dead_n_dlogging * & + prt_params%allom_agb_frac(pft) - ! Add AG wood to litter from the non-exported fraction of wood - ! from direct anthro sources + site_mass%wood_product = site_mass%wood_product + & + trunk_wood * currentPatch%area * logging_export_frac - litt%ag_cwd_in(c) = litt%ag_cwd_in(c) + & - trunk_wood * (1._r8-logging_export_frac) + ! Add AG wood to litter from the non-exported fraction of wood + ! from direct anthro sources - flux_diags%cwd_ag_input(c) = flux_diags%cwd_ag_input(c) + & - trunk_wood * (1._r8-logging_export_frac) * currentPatch%area + litt%ag_cwd_in(c) = litt%ag_cwd_in(c) + & + trunk_wood * (1._r8-logging_export_frac) - ! Add AG wood to litter from indirect anthro sources + flux_diags%cwd_ag_input(c) = flux_diags%cwd_ag_input(c) + & + trunk_wood * (1._r8-logging_export_frac) * currentPatch%area - litt%ag_cwd_in(c) = litt%ag_cwd_in(c) + (struct_m + sapw_m) * & - SF_val_CWD_frac(c) * (dead_n_natural+dead_n_ilogging) * & - prt_params%allom_agb_frac(pft) + ! Add AG wood to litter from indirect anthro sources - flux_diags%cwd_ag_input(c) = flux_diags%cwd_ag_input(c) + & + litt%ag_cwd_in(c) = litt%ag_cwd_in(c) + (struct_m + sapw_m) * & + SF_val_CWD_frac(c) * (dead_n_natural+dead_n_ilogging) * & + prt_params%allom_agb_frac(pft) + + flux_diags%cwd_ag_input(c) = flux_diags%cwd_ag_input(c) + & SF_val_CWD_frac(c) * (dead_n_natural+dead_n_ilogging) * & currentPatch%area * prt_params%allom_agb_frac(pft) - else + else - litt%ag_cwd_in(c) = litt%ag_cwd_in(c) + (struct_m + sapw_m) * & - SF_val_CWD_frac(c) * dead_n * & - prt_params%allom_agb_frac(pft) + litt%ag_cwd_in(c) = litt%ag_cwd_in(c) + (struct_m + sapw_m) * & + SF_val_CWD_frac(c) * dead_n * & + prt_params%allom_agb_frac(pft) - flux_diags%cwd_ag_input(c) = flux_diags%cwd_ag_input(c) + & + flux_diags%cwd_ag_input(c) = flux_diags%cwd_ag_input(c) + & SF_val_CWD_frac(c) * dead_n * (struct_m + sapw_m) * & currentPatch%area * prt_params%allom_agb_frac(pft) - - end if - - end do + end if + + end do + + + ! Update diagnostics that track resource management - ! Update diagnostics that track resource management + if( element_id .eq. carbon12_element ) then - if( element_id .eq. carbon12_element ) then - - currentSite%resources_management%delta_litter_stock = & - currentSite%resources_management%delta_litter_stock + & - (leaf_m + fnrt_m + store_m ) * & - (dead_n_ilogging+dead_n_dlogging) * currentPatch%area + currentSite%resources_management%delta_litter_stock = & + currentSite%resources_management%delta_litter_stock + & + (leaf_m + fnrt_m + store_m ) * & + (dead_n_ilogging+dead_n_dlogging) * currentPatch%area - currentSite%resources_management%delta_biomass_stock = & - currentSite%resources_management%delta_biomass_stock + & - (leaf_m + fnrt_m + store_m ) * & - (dead_n_ilogging+dead_n_dlogging) *currentPatch%area + currentSite%resources_management%delta_biomass_stock = & + currentSite%resources_management%delta_biomass_stock + & + (leaf_m + fnrt_m + store_m ) * & + (dead_n_ilogging+dead_n_dlogging) *currentPatch%area - currentSite%resources_management%trunk_product_site = & + currentSite%resources_management%trunk_product_site = & currentSite%resources_management%trunk_product_site + & trunk_wood * logging_export_frac * currentPatch%area - do c = 1,ncwd - currentSite%resources_management%delta_litter_stock = & + do c = 1,ncwd + currentSite%resources_management%delta_litter_stock = & currentSite%resources_management%delta_litter_stock + & (struct_m + sapw_m) * & SF_val_CWD_frac(c) * (dead_n_natural+dead_n_ilogging) * & currentPatch%area - - currentSite%resources_management%delta_biomass_stock = & + + currentSite%resources_management%delta_biomass_stock = & currentSite%resources_management%delta_biomass_stock + & (struct_m + sapw_m) * & SF_val_CWD_frac(c) * dead_n * currentPatch%area - end do - - ! Update diagnostics that track resource management - currentSite%resources_management%delta_individual = & + end do + + ! Update diagnostics that track resource management + currentSite%resources_management%delta_individual = & currentSite%resources_management%delta_individual + & (dead_n_dlogging+dead_n_ilogging) * hlm_freq_day * currentPatch%area - end if - - - currentCohort => currentCohort%taller - enddo ! end loop over cohorts - - - return + end if + + + currentCohort => currentCohort%taller + enddo ! end loop over cohorts + + + return end subroutine CWDInput ! ===================================================================================== @@ -2441,22 +2441,22 @@ subroutine SeedDecayToFines(litt) do pft = 1,numpft - litt%leaf_fines_in(ilabile) = litt%leaf_fines_in(ilabile) + & - (litt%seed_decay(pft) + litt%seed_germ_decay(pft)) * EDPftvarcon_inst%lf_flab(pft) - - litt%leaf_fines_in(icellulose) = litt%leaf_fines_in(icellulose) + & - (litt%seed_decay(pft) + litt%seed_germ_decay(pft)) * EDPftvarcon_inst%lf_fcel(pft) - - litt%leaf_fines_in(ilignin) = litt%leaf_fines_in(ilignin) + & - (litt%seed_decay(pft) + litt%seed_germ_decay(pft)) * EDPftvarcon_inst%lf_flig(pft) + litt%leaf_fines_in(ilabile) = litt%leaf_fines_in(ilabile) + & + (litt%seed_decay(pft) + litt%seed_germ_decay(pft)) * EDPftvarcon_inst%lf_flab(pft) + + litt%leaf_fines_in(icellulose) = litt%leaf_fines_in(icellulose) + & + (litt%seed_decay(pft) + litt%seed_germ_decay(pft)) * EDPftvarcon_inst%lf_fcel(pft) + + litt%leaf_fines_in(ilignin) = litt%leaf_fines_in(ilignin) + & + (litt%seed_decay(pft) + litt%seed_germ_decay(pft)) * EDPftvarcon_inst%lf_flig(pft) enddo - - + + return end subroutine SeedDecayToFines - - + + @@ -2493,36 +2493,36 @@ subroutine fragmentation_scaler( currentPatch, bc_in) catanf(t1) = 11.75_r8 +(29.7_r8 / pi) * atan( pi * 0.031_r8 * ( t1 - 15.4_r8 )) catanf_30 = catanf(30._r8) - + ifp = currentPatch%patchno if(currentPatch%nocomp_pft_label.gt.0)then - if ( .not. use_century_tfunc ) then - !calculate rate constant scalar for soil temperature,assuming that the base rate constants - !are assigned for non-moisture limiting conditions at 25C. - if (bc_in%t_veg24_pa(ifp) >= tfrz) then - t_scalar = q10_mr**((bc_in%t_veg24_pa(ifp)-(tfrz+25._r8))/10._r8) - ! Q10**((t_soisno(c,j)-(tfrz+25._r8))/10._r8) - else - t_scalar = (q10_mr**(-25._r8/10._r8))*(q10_froz**((bc_in%t_veg24_pa(ifp)-tfrz)/10._r8)) - !Q10**(-25._r8/10._r8))*(froz_q10**((t_soisno(c,j)-tfrz)/10._r8) - endif - else - ! original century uses an arctangent function to calculate the - ! temperature dependence of decomposition - t_scalar = max(catanf(bc_in%t_veg24_pa(ifp)-tfrz)/catanf_30,0.01_r8) - endif - - !Moisture Limitations - !BTRAN APPROACH - is quite simple, but max's out decomp at all unstressed - !soil moisture values, which is not realistic. - !litter decomp is proportional to water limitation on average... - w_scalar = sum(currentPatch%btran_ft(1:numpft))/real(numpft,r8) - - currentPatch%fragmentation_scaler = min(1.0_r8,max(0.0_r8,t_scalar * w_scalar)) + if ( .not. use_century_tfunc ) then + !calculate rate constant scalar for soil temperature,assuming that the base rate constants + !are assigned for non-moisture limiting conditions at 25C. + if (bc_in%t_veg24_pa(ifp) >= tfrz) then + t_scalar = q10_mr**((bc_in%t_veg24_pa(ifp)-(tfrz+25._r8))/10._r8) + ! Q10**((t_soisno(c,j)-(tfrz+25._r8))/10._r8) + else + t_scalar = (q10_mr**(-25._r8/10._r8))*(q10_froz**((bc_in%t_veg24_pa(ifp)-tfrz)/10._r8)) + !Q10**(-25._r8/10._r8))*(froz_q10**((t_soisno(c,j)-tfrz)/10._r8) + endif + else + ! original century uses an arctangent function to calculate the + ! temperature dependence of decomposition + t_scalar = max(catanf(bc_in%t_veg24_pa(ifp)-tfrz)/catanf_30,0.01_r8) + endif + + !Moisture Limitations + !BTRAN APPROACH - is quite simple, but max's out decomp at all unstressed + !soil moisture values, which is not realistic. + !litter decomp is proportional to water limitation on average... + w_scalar = sum(currentPatch%btran_ft(1:numpft))/real(numpft,r8) + + currentPatch%fragmentation_scaler = min(1.0_r8,max(0.0_r8,t_scalar * w_scalar)) endif ! not bare ground end subroutine fragmentation_scaler - + ! ============================================================================ subroutine CWDOut( litt, fragmentation_scaler, nlev_eff_decomp ) @@ -2537,14 +2537,14 @@ subroutine CWDOut( litt, fragmentation_scaler, nlev_eff_decomp ) ! ! !ARGUMENTS type(litter_type),intent(inout),target :: litt - + real(r8),intent(in) :: fragmentation_scaler ! This is not necessarily every soil layer, this is the number ! of effective layers that are active and can be sent ! to the soil decomposition model integer,intent(in) :: nlev_eff_decomp - + ! ! !LOCAL VARIABLES: integer :: c @@ -2556,12 +2556,12 @@ subroutine CWDOut( litt, fragmentation_scaler, nlev_eff_decomp ) do c = 1,ncwd litt%ag_cwd_frag(c) = litt%ag_cwd(c) * SF_val_max_decomp(c) * & - years_per_day * fragmentation_scaler - + years_per_day * fragmentation_scaler + do ilyr = 1,nlev_eff_decomp - - litt%bg_cwd_frag(c,ilyr) = litt%bg_cwd(c,ilyr) * SF_val_max_decomp(c) * & - years_per_day * fragmentation_scaler + + litt%bg_cwd_frag(c,ilyr) = litt%bg_cwd(c,ilyr) * SF_val_max_decomp(c) * & + years_per_day * fragmentation_scaler enddo end do @@ -2574,11 +2574,11 @@ subroutine CWDOut( litt, fragmentation_scaler, nlev_eff_decomp ) do dcmpy = 1,ndcmpy litt%leaf_fines_frag(dcmpy) = litt%leaf_fines(dcmpy) * & - years_per_day * SF_val_max_decomp(dl_sf) * fragmentation_scaler - + years_per_day * SF_val_max_decomp(dl_sf) * fragmentation_scaler + do ilyr = 1,nlev_eff_decomp - litt%root_fines_frag(dcmpy,ilyr) = litt%root_fines(dcmpy,ilyr) * & - years_per_day * SF_val_max_decomp(dl_sf) * fragmentation_scaler + litt%root_fines_frag(dcmpy,ilyr) = litt%root_fines(dcmpy,ilyr) * & + years_per_day * SF_val_max_decomp(dl_sf) * fragmentation_scaler end do enddo From 74f33d5b8453e819ef038013aa4b836ee949cdba Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 25 Nov 2020 09:07:08 -0700 Subject: [PATCH 154/209] biogeophys/FatesPlantHydraulicsMod.F90 --- biogeophys/FatesPlantHydraulicsMod.F90 | 8235 ++++++++++++------------ 1 file changed, 4117 insertions(+), 4118 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 7dda7cc928..ee7c4454f4 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -47,7 +47,7 @@ module FatesPlantHydraulicsMod use EDParamsMod , only : hydr_kmax_rsurf2 use EDParamsMod , only : hydr_psi0 use EDParamsMod , only : hydr_psicap - + use EDTypesMod , only : ed_site_type use EDTypesMod , only : ed_patch_type use EDTypesMod , only : ed_cohort_type @@ -89,7 +89,7 @@ module FatesPlantHydraulicsMod use FatesHydraulicsMemMod, only: recruit_water_avail_layer use FatesHydraulicsMemMod, only: rwccap, rwcft use FatesHydraulicsMemMod, only: ignore_layer1 - + use PRTGenericMod, only : all_carbon_elements use PRTGenericMod, only : leaf_organ, fnrt_organ, sapw_organ use PRTGenericMod, only : store_organ, repro_organ, struct_organ @@ -131,9 +131,9 @@ module FatesPlantHydraulicsMod ! (i.e., non-instantaneous) be considered ! within plant hydraulics? ! logical, public :: do_kbound_upstream = .true. ! should the hydraulic conductance at the - ! boundary between nodes be taken to be a - ! function of the upstream loss of - ! conductivity (flc)? + ! boundary between nodes be taken to be a + ! function of the upstream loss of + ! conductivity (flc)? ! DO NOT TURN THIS ON. LEAVING THIS ONLY IF THE HLMS START HAVING ! TROUBLE RESPONDING TO SUPERSATURATION @@ -142,7 +142,7 @@ module FatesPlantHydraulicsMod ! past saturation, should we attempt to help ! fix the situation by assigning some ! of the water to a runoff term? - + logical, public :: do_growthrecruiteffects = .true. ! should size- or root length-dependent ! hydraulic properties and states be @@ -154,7 +154,7 @@ module FatesPlantHydraulicsMod logical, parameter :: do_upstream_k = .true. - + logical :: do_parallel_stem = .true. ! If this mode is active, we treat the conduit through ! the plant (in 1D solves) as closed from root layer ! to the stomata. The effect of this, is that @@ -164,23 +164,22 @@ module FatesPlantHydraulicsMod ! proceeds over the entire time-step. - ! These switches are for developers who which to understand if there simulations ! are ever entering regimes where water contents go negative (yes physically impossible) ! or water pressures exceed that at saturation (maybe, maybe not likely) ! These situations are possible/likely due to the nature of the constant flux boundary condition ! of transpiration, due to the loosely-coupled nature of the hydro-land-energy-photosynthesis ! system - + logical, parameter :: trap_neg_wc = .false. logical, parameter :: trap_supersat_psi = .false. - + real(r8), parameter :: thsat_buff = 0.001_r8 ! Ensure that this amount of buffer - ! is left between soil moisture and saturation [m3/m3] - ! (if we are going to help purge super-saturation) - + ! is left between soil moisture and saturation [m3/m3] + ! (if we are going to help purge super-saturation) + logical,parameter :: debug = .false. ! flag to report warning in hydro @@ -191,21 +190,21 @@ module FatesPlantHydraulicsMod integer, public, parameter :: van_genuchten_type = 1 integer, public, parameter :: campbell_type = 2 integer, public, parameter :: tfs_type = 3 - + integer, parameter :: plant_wrf_type = tfs_type integer, parameter :: plant_wkf_type = tfs_type integer, parameter :: soil_wrf_type = campbell_type integer, parameter :: soil_wkf_type = campbell_type - - + + ! Define the global object that holds the water retention functions ! for plants of each different porous media type, and plant functional type - + class(wrf_arr_type),pointer :: wrf_plant(:,:) - + ! Define the global object that holds the water conductance functions ! for plants of each different porous media type, and plant functional type - + class(wkf_arr_type), pointer :: wkf_plant(:,:) ! Testing parameters for Van Genuchten soil WRTs @@ -328,7 +327,7 @@ subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) do s = 1,nsites csite_hydr=>sites(s)%si_hydr - + cpatch => sites(s)%oldest_patch do while(associated(cpatch)) @@ -369,7 +368,7 @@ subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) ! -------------------------------------------------------------------------------- ! Initialize the Water Retention Functions ! ----------------------------------------------------------------------------------- - + select case(soil_wrf_type) case(van_genuchten_type) do j=1,sites(s)%si_hydr%nlevrhiz @@ -385,17 +384,17 @@ subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) sites(s)%si_hydr%wrf_soil(j)%p => wrf_cch call wrf_cch%set_wrf_param([bc_in(s)%watsat_sisl(j_bc), & (-1.0_r8)*bc_in(s)%sucsat_sisl(j_bc)*denh2o*grav_earth*mpa_per_pa*m_per_mm , & - bc_in(s)%bsw_sisl(j_bc)]) + bc_in(s)%bsw_sisl(j_bc)]) end do case(tfs_type) write(fates_log(),*) 'TFS water retention curves not available for soil' call endrun(msg=errMsg(sourcefile, __LINE__)) end select - + ! ----------------------------------------------------------------------------------- ! Initialize the Water Conductance (K) Functions ! ----------------------------------------------------------------------------------- - + select case(soil_wkf_type) case(van_genuchten_type) do j=1,sites(s)%si_hydr%nlevrhiz @@ -417,7 +416,7 @@ subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) write(fates_log(),*) 'TFS conductance not used in soil' call endrun(msg=errMsg(sourcefile, __LINE__)) end select - + @@ -465,8 +464,8 @@ subroutine InitPlantHydStates(site, cohort) real(r8) :: h_aroot_mean ! minimum total potential of absorbing roots real(r8), parameter :: psi_aroot_init = -0.2_r8 ! Initialize aroots with -0.2 MPa real(r8), parameter :: dh_dz = 0.02_r8 ! amount to decrease downstream - ! compartment total potentials [MPa/meter] - + ! compartment total potentials [MPa/meter] + ! In init mode = 1, set absorbing roots to -0.2 MPa ! = 2, use soil as starting point, match total potentials ! and then reduce plant compartment total potential by 1KPa @@ -475,7 +474,7 @@ subroutine InitPlantHydStates(site, cohort) integer, parameter :: init_mode = 2 class(wrf_arr_type),pointer :: wrfa,wrft class(wkf_arr_type),pointer :: wkfa,wkft - + site_hydr => site%si_hydr cohort_hydr => cohort%co_hydr ft = cohort%pft @@ -487,32 +486,32 @@ subroutine InitPlantHydStates(site, cohort) ! Set abosrbing root if(init_mode == 2) then - -! h_aroot_mean = 0._r8 + + ! h_aroot_mean = 0._r8 do j=1, site_hydr%nlevrhiz - + ! Match the potential of the absorbing root to the inner rhizosphere shell cohort_hydr%psi_aroot(j) = site_hydr%wrf_soil(j)%p%psi_from_th(site_hydr%h2osoi_liqvol_shell(j,1)) ! Calculate the mean total potential (include height) of absorbing roots -! h_aroot_mean = h_aroot_mean + cohort_hydr%psi_aroot(j) + mpa_per_pa*denh2o*grav_earth*(-site_hydr%zi_rhiz(j)) - + ! h_aroot_mean = h_aroot_mean + cohort_hydr%psi_aroot(j) + mpa_per_pa*denh2o*grav_earth*(-site_hydr%zi_rhiz(j)) + cohort_hydr%th_aroot(j) = wrfa%p%th_from_psi(cohort_hydr%psi_aroot(j)) cohort_hydr%ftc_aroot(j) = wkfa%p%ftc_from_psi(cohort_hydr%psi_aroot(j)) end do - + else - + do j=1, site_hydr%nlevrhiz cohort_hydr%psi_aroot(j) = psi_aroot_init ! Calculate the mean total potential (include height) of absorbing roots -! h_aroot_mean = h_aroot_mean + cohort_hydr%psi_aroot(j) + mpa_per_pa*denh2o*grav_earth*(-site_hydr%zi_rhiz(j)) + ! h_aroot_mean = h_aroot_mean + cohort_hydr%psi_aroot(j) + mpa_per_pa*denh2o*grav_earth*(-site_hydr%zi_rhiz(j)) cohort_hydr%th_aroot(j) = wrfa%p%th_from_psi(cohort_hydr%psi_aroot(j)) cohort_hydr%ftc_aroot(j) = wkfa%p%ftc_from_psi(cohort_hydr%psi_aroot(j)) end do end if - + !h_aroot_mean = h_aroot_mean/real(site_hydr%nlevrhiz,r8) h_aroot_mean = minval(cohort_hydr%psi_aroot(:) + mpa_per_pa*denh2o*grav_earth*(-site_hydr%zi_rhiz(:))) @@ -543,7 +542,7 @@ subroutine InitPlantHydStates(site, cohort) cohort_hydr%th_ag(n_hypool_ag) = wrf_plant(stem_p_media,ft)%p%th_from_psi(cohort_hydr%psi_ag(n_hypool_ag)) cohort_hydr%ftc_ag(n_hypool_ag) = wkf_plant(stem_p_media,ft)%p%ftc_from_psi(cohort_hydr%psi_ag(n_hypool_ag)) - + do k=n_hypool_ag-1, 1, -1 dz = cohort_hydr%z_node_ag(k) - cohort_hydr%z_node_ag(k+1) cohort_hydr%psi_ag(k) = cohort_hydr%psi_ag(k+1) - & @@ -567,11 +566,11 @@ subroutine InitPlantHydStates(site, cohort) !flc_gs_from_psi(cohort_hydr%psi_ag(1),cohort%pft) - + ! We do allow for positive pressures. ! But starting off with positive pressures is something we try to avoid if ( (cohort_hydr%psi_troot>0.0_r8) .or. & - any(cohort_hydr%psi_ag(:)>0._r8) .or. & + any(cohort_hydr%psi_ag(:)>0._r8) .or. & any(cohort_hydr%psi_aroot(:)>0._r8) ) then write(fates_log(),*) 'Initialized plant compartments with positive pressure?' write(fates_log(),*) 'psi troot: ',cohort_hydr%psi_troot @@ -580,14 +579,14 @@ subroutine InitPlantHydStates(site, cohort) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - + end subroutine InitPlantHydStates - + ! ===================================================================================== subroutine UpdatePlantPsiFTCFromTheta(ccohort,csite_hydr) - + ! This subroutine updates the potential and the fractional ! of total conductivity based on the relative water ! content @@ -602,15 +601,15 @@ subroutine UpdatePlantPsiFTCFromTheta(ccohort,csite_hydr) type(ed_cohort_hydr_type), pointer :: ccohort_hydr - + ccohort_hydr => ccohort%co_hydr ft = ccohort%pft - + ! Update Psi and FTC in above-ground compartments ! ----------------------------------------------------------------------------------- do k = 1,n_hypool_leaf - ccohort_hydr%psi_ag(k) = wrf_plant(leaf_p_media,ft)%p%psi_from_th(ccohort_hydr%th_ag(k)) - ccohort_hydr%ftc_ag(k) = wkf_plant(leaf_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_ag(k)) + ccohort_hydr%psi_ag(k) = wrf_plant(leaf_p_media,ft)%p%psi_from_th(ccohort_hydr%th_ag(k)) + ccohort_hydr%ftc_ag(k) = wkf_plant(leaf_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_ag(k)) end do do k = n_hypool_leaf+1, n_hypool_ag @@ -704,7 +703,7 @@ subroutine UpdatePlantHydrNodes(ccohort_hydr,ft,plant_height,csite_hydr) 0.001_r8, 0.001_r8, 0.5_r8, z_cumul_rf) z_cumul_rf = min(z_cumul_rf, abs(csite_hydr%zi_rhiz(nlevrhiz))) ccohort_hydr%z_node_troot = -z_cumul_rf - + return end subroutine UpdatePlantHydrNodes @@ -791,7 +790,7 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) ! Arguments type(ed_cohort_type),intent(inout) :: ccohort type(ed_site_hydr_type),intent(in) :: site_hydr - + type(ed_cohort_hydr_type),pointer :: ccohort_hydr ! Plant hydraulics structure integer :: j,k integer :: ft ! Plant functional type index @@ -825,10 +824,10 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) real(r8), parameter :: t2aroot_vol_donate_frac = 0.65_r8 real(r8), parameter :: min_leaf_frac = 0.1_r8 ! Fraction of maximum leaf carbon that - ! we set as our lower cap on leaf volume + ! we set as our lower cap on leaf volume real(r8), parameter :: min_trim = 0.1_r8 ! The lower cap on trimming function used - ! to estimate maximum leaf carbon - + ! to estimate maximum leaf carbon + ccohort_hydr => ccohort%co_hydr ft = ccohort%pft nlevrhiz = site_hydr%nlevrhiz @@ -846,12 +845,12 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) ! NOTE: SLATOP currently does not use any vertical scaling functions ! but that may not be so forever. ie sla = slatop (RGK-082017) ! m2/gC * cm2/m2 -> cm2/gC - + sla = prt_params%slatop(ft) * cm2_per_m2 - + ! empirical regression data from leaves at Caxiuana (~ 8 spp) denleaf = -2.3231_r8*sla/prt_params%c2b(ft) + 781.899_r8 - + ! Leaf volumes ! Note: Leaf volumes of zero is problematic for two reasons. Zero volumes create ! numerical difficulties, and they could also create problems when a leaf is trying @@ -865,7 +864,7 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) ! We also place a lower bound on how low the leaf volume is allowed to go, which is 10% ! of the plant's carrying capacity. - + ! [kgC] * [kg/kgC] / [kg/m3] -> [m3] ! Get the target, or rather, maximum leaf carrying capacity of plant @@ -877,7 +876,7 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) ccohort_hydr%v_ag(1:n_hypool_leaf) = max(leaf_c,min_leaf_frac*leaf_c_target) * & prt_params%c2b(ft) / denleaf/ real(n_hypool_leaf,r8) end if - + ! Step sapwood volume ! ----------------------------------------------------------------------------------- @@ -907,18 +906,18 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) ! coarse (transporting) root biomass woody_bg_c = (1.0_r8-prt_params%allom_agb_frac(ft)) * (sapw_c + struct_c) - + v_troot = woody_bg_c * prt_params%c2b(ft) / & - (prt_params%wood_density(ft)*kg_per_g*cm3_per_m3) - - + (prt_params%wood_density(ft)*kg_per_g*cm3_per_m3) + + ! Estimate absorbing root total length (all layers) ! SRL is in m/g ! [m] = [kgC]*1000[g/kg]*[kg/kgC]*[m/g] ! ------------------------------------------------------------------------------ l_aroot_tot = fnrt_c*g_per_kg*prt_params%c2b(ft)*EDPftvarcon_inst%hydr_srl(ft) - - + + ! Estimate absorbing root volume (all layers) ! ------------------------------------------------------------------------------ v_aroot_tot = pi_const * (EDPftvarcon_inst%hydr_rs2(ft)**2._r8) * l_aroot_tot @@ -927,26 +926,26 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) ! to the layer-by-layer absorbing root (which is now a hybrid compartment) ! ------------------------------------------------------------------------------ ccohort_hydr%v_troot = (1._r8-t2aroot_vol_donate_frac) * v_troot - + ! Partition the total absorbing root lengths and volumes into the active soil layers ! We have a condition, where we may ignore the first layer ! ------------------------------------------------------------------------------ - + norm = 1._r8 - & - zeng2001_crootfr(roota, rootb,site_hydr%zi_rhiz(1)-site_hydr%dz_rhiz(1), site_hydr%zi_rhiz(nlevrhiz)) - + zeng2001_crootfr(roota, rootb,site_hydr%zi_rhiz(1)-site_hydr%dz_rhiz(1), site_hydr%zi_rhiz(nlevrhiz)) + do j=1,nlevrhiz - - rootfr = norm*(zeng2001_crootfr(roota, rootb, site_hydr%zi_rhiz(j),site_hydr%zi_rhiz(nlevrhiz)) - & - zeng2001_crootfr(roota, rootb, site_hydr%zi_rhiz(j)-site_hydr%dz_rhiz(j),site_hydr%zi_rhiz(nlevrhiz))) - - ccohort_hydr%l_aroot_layer(j) = rootfr*l_aroot_tot - - ! This is a hybrid absorbing root and transporting root volume - ccohort_hydr%v_aroot_layer(j) = rootfr*(v_aroot_tot + t2aroot_vol_donate_frac*v_troot) + + rootfr = norm*(zeng2001_crootfr(roota, rootb, site_hydr%zi_rhiz(j),site_hydr%zi_rhiz(nlevrhiz)) - & + zeng2001_crootfr(roota, rootb, site_hydr%zi_rhiz(j)-site_hydr%dz_rhiz(j),site_hydr%zi_rhiz(nlevrhiz))) + + ccohort_hydr%l_aroot_layer(j) = rootfr*l_aroot_tot + + ! This is a hybrid absorbing root and transporting root volume + ccohort_hydr%v_aroot_layer(j) = rootfr*(v_aroot_tot + t2aroot_vol_donate_frac*v_troot) end do - + return end subroutine UpdatePlantHydrLenVol @@ -978,15 +977,15 @@ subroutine UpdateSizeDepPlantHydStates(currentSite,ccohort) ccohort_hydr => ccohort%co_hydr FT = cCohort%pft - + associate(pm_node => currentSite%si_hydr%pm_node) - - ! MAYBE ADD A NAN CATCH? If UpdateSizeDepPlantHydProps() was not called twice prior to the first - ! time this routine is called for a new cohort, then v_ag_init(k) will be a nan. - ! It should be ok, but may be vulnerable if code is changed (RGK 02-2017) - ! UPDATE WATER CONTENTS (assume water for growth comes from within tissue itself - ! -- apply water mass conservation) + ! MAYBE ADD A NAN CATCH? If UpdateSizeDepPlantHydProps() was not called twice prior to the first + ! time this routine is called for a new cohort, then v_ag_init(k) will be a nan. + ! It should be ok, but may be vulnerable if code is changed (RGK 02-2017) + + ! UPDATE WATER CONTENTS (assume water for growth comes from within tissue itself + ! -- apply water mass conservation) do k=1,n_hypool_leaf if( ccohort_hydr%v_ag(k) > nearzero ) then @@ -1032,4369 +1031,4369 @@ subroutine UpdateSizeDepPlantHydStates(currentSite,ccohort) ! UPDATES OF WATER POTENTIALS ARE DONE PRIOR TO RICHARDS' SOLUTION WITHIN FATESPLANTHYDRAULICSMOD.F90 - end associate + end associate - end subroutine UpdateSizeDepPlantHydStates - - ! ===================================================================================== +end subroutine UpdateSizeDepPlantHydStates - function constrain_water_contents(th_uncorr, delta, ft, pm_type) result(th_corr) +! ===================================================================================== - ! !ARGUMENTS: - real(r8) , intent(in) :: th_uncorr ! uncorrected water content (m3 m-3) - real(r8) , intent(in) :: delta - integer , intent(in) :: ft - integer , intent(in) :: pm_type - ! - ! !Local: - real(r8) :: thr ! residual water content (m3 m-3) - real(r8) :: ths ! saturated water content (m3 m-3) - ! - ! !RESULT - real(r8) :: th_corr ! corrected water content - ! - !------------------------------------------------------------------------ - ths = EDPftvarcon_inst%hydr_thetas_node(ft,pm_type) - thr = EDPftvarcon_inst%hydr_resid_node(ft,pm_type) - th_corr = max((thr+delta),min((ths-delta),th_uncorr)) +function constrain_water_contents(th_uncorr, delta, ft, pm_type) result(th_corr) - return + ! !ARGUMENTS: + real(r8) , intent(in) :: th_uncorr ! uncorrected water content (m3 m-3) + real(r8) , intent(in) :: delta + integer , intent(in) :: ft + integer , intent(in) :: pm_type + ! + ! !Local: + real(r8) :: thr ! residual water content (m3 m-3) + real(r8) :: ths ! saturated water content (m3 m-3) + ! + ! !RESULT + real(r8) :: th_corr ! corrected water content + ! + !------------------------------------------------------------------------ + ths = EDPftvarcon_inst%hydr_thetas_node(ft,pm_type) + thr = EDPftvarcon_inst%hydr_resid_node(ft,pm_type) + th_corr = max((thr+delta),min((ths-delta),th_uncorr)) + + return + +end function constrain_water_contents + +! ===================================================================================== + +subroutine CopyCohortHydraulics(newCohort, oldCohort) + + ! Arguments + type(ed_cohort_type), intent(inout), target :: newCohort + type(ed_cohort_type), intent(inout), target :: oldCohort + + ! Locals + type(ed_cohort_hydr_type), pointer :: ncohort_hydr + type(ed_cohort_hydr_type), pointer :: ocohort_hydr + + + ncohort_hydr => newCohort%co_hydr + ocohort_hydr => oldCohort%co_hydr + + ! Node heights + ncohort_hydr%z_node_ag = ocohort_hydr%z_node_ag + ncohort_hydr%z_upper_ag = ocohort_hydr%z_upper_ag + ncohort_hydr%z_lower_ag = ocohort_hydr%z_lower_ag + ncohort_hydr%z_node_troot = ocohort_hydr%z_node_troot + + ! Compartment kmax's + ncohort_hydr%kmax_petiole_to_leaf = ocohort_hydr%kmax_petiole_to_leaf + ncohort_hydr%kmax_stem_lower = ocohort_hydr%kmax_stem_lower + ncohort_hydr%kmax_stem_upper = ocohort_hydr%kmax_stem_upper + ncohort_hydr%kmax_troot_upper = ocohort_hydr%kmax_troot_upper + ncohort_hydr%kmax_troot_lower = ocohort_hydr%kmax_troot_lower + ncohort_hydr%kmax_aroot_upper = ocohort_hydr%kmax_aroot_upper + ncohort_hydr%kmax_aroot_lower = ocohort_hydr%kmax_aroot_lower + ncohort_hydr%kmax_aroot_radial_in = ocohort_hydr%kmax_aroot_radial_in + ncohort_hydr%kmax_aroot_radial_out = ocohort_hydr%kmax_aroot_radial_out + + ! Compartment volumes + ncohort_hydr%v_ag_init = ocohort_hydr%v_ag_init + ncohort_hydr%v_ag = ocohort_hydr%v_ag + ncohort_hydr%v_troot_init = ocohort_hydr%v_troot_init + ncohort_hydr%v_troot = ocohort_hydr%v_troot + ncohort_hydr%v_aroot_layer_init = ocohort_hydr%v_aroot_layer_init + ncohort_hydr%v_aroot_layer = ocohort_hydr%v_aroot_layer + ncohort_hydr%l_aroot_layer = ocohort_hydr%l_aroot_layer + + ! State Variables + ncohort_hydr%th_ag = ocohort_hydr%th_ag + ncohort_hydr%th_troot = ocohort_hydr%th_troot + ncohort_hydr%th_aroot = ocohort_hydr%th_aroot + ncohort_hydr%psi_ag = ocohort_hydr%psi_ag + ncohort_hydr%psi_troot = ocohort_hydr%psi_troot + ncohort_hydr%psi_aroot = ocohort_hydr%psi_aroot + ncohort_hydr%ftc_ag = ocohort_hydr%ftc_ag + ncohort_hydr%ftc_troot = ocohort_hydr%ftc_troot + ncohort_hydr%ftc_aroot = ocohort_hydr%ftc_aroot + + ! Other + ncohort_hydr%btran = ocohort_hydr%btran + ncohort_hydr%supsub_flag = ocohort_hydr%supsub_flag + ncohort_hydr%iterh1 = ocohort_hydr%iterh1 + ncohort_hydr%iterh2 = ocohort_hydr%iterh2 + ncohort_hydr%iterlayer = ocohort_hydr%iterlayer + ncohort_hydr%errh2o = ocohort_hydr%errh2o + ncohort_hydr%errh2o_growturn_ag = ocohort_hydr%errh2o_growturn_ag + ncohort_hydr%errh2o_pheno_ag = ocohort_hydr%errh2o_pheno_ag + ncohort_hydr%errh2o_growturn_troot = ocohort_hydr%errh2o_growturn_troot + ncohort_hydr%errh2o_pheno_troot = ocohort_hydr%errh2o_pheno_troot + ncohort_hydr%errh2o_growturn_aroot = ocohort_hydr%errh2o_growturn_aroot + ncohort_hydr%errh2o_pheno_aroot = ocohort_hydr%errh2o_pheno_aroot + + ! BC PLANT HYDRAULICS - flux terms + ncohort_hydr%qtop = ocohort_hydr%qtop + + ncohort_hydr%is_newly_recruited = ocohort_hydr%is_newly_recruited + +end subroutine CopyCohortHydraulics + +! ===================================================================================== +subroutine FuseCohortHydraulics(currentSite,currentCohort, nextCohort, bc_in, newn) + + + type(ed_cohort_type), intent(inout), target :: currentCohort ! current cohort + type(ed_cohort_type), intent(inout), target :: nextCohort ! next (donor) cohort + type(ed_site_type), intent(inout), target :: currentSite ! current site + + type(bc_in_type), intent(in) :: bc_in + real(r8), intent(in) :: newn + + ! !LOCAL VARIABLES: + type(ed_site_hydr_type), pointer :: site_hydr + type(ed_cohort_hydr_type), pointer :: ccohort_hydr ! current cohort hydraulics derived type + type(ed_cohort_hydr_type), pointer :: ncohort_hydr ! donor (next) cohort hydraulics d type + integer :: j,k ! indices + integer :: ft + + site_hydr => currentSite%si_hydr + + ccohort_hydr => currentCohort%co_hydr + ncohort_hydr => nextCohort%co_hydr + + ccohort_hydr%th_ag(:) = (currentCohort%n*ccohort_hydr%th_ag(:) + & + nextCohort%n*ncohort_hydr%th_ag(:))/newn + ccohort_hydr%th_troot = (currentCohort%n*ccohort_hydr%th_troot + & + nextCohort%n*ncohort_hydr%th_troot)/newn + ccohort_hydr%th_aroot(:) = (currentCohort%n*ccohort_hydr%th_aroot(:) + & + nextCohort%n*ncohort_hydr%th_aroot(:))/newn + ccohort_hydr%supsub_flag = 0 + + ! Only save the iteration counters for the worse of the two cohorts + if(ncohort_hydr%iterh1 > ccohort_hydr%iterh1)then + ccohort_hydr%iterh1 = ncohort_hydr%iterh1 + ccohort_hydr%iterh2 = ncohort_hydr%iterh2 + ccohort_hydr%iterlayer = ncohort_hydr%iterlayer + end if + + ft = currentCohort%pft + do k=1,n_hypool_leaf + ccohort_hydr%psi_ag(k) = wrf_plant(leaf_p_media,ft)%p%psi_from_th(ccohort_hydr%th_ag(k)) + ccohort_hydr%ftc_ag(k) = wkf_plant(leaf_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_ag(k)) + end do + + do k = n_hypool_leaf+1,n_hypool_ag + ccohort_hydr%psi_ag(k) = wrf_plant(stem_p_media,ft)%p%psi_from_th(ccohort_hydr%th_ag(k)) + ccohort_hydr%ftc_ag(k) = wkf_plant(stem_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_ag(k)) + end do + + ccohort_hydr%psi_troot = wrf_plant(troot_p_media,ft)%p%psi_from_th(ccohort_hydr%th_troot) + ccohort_hydr%ftc_troot = wkf_plant(troot_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_troot) + + do j=1,site_hydr%nlevrhiz + ccohort_hydr%psi_aroot(j) = wrf_plant(aroot_p_media,ft)%p%psi_from_th(ccohort_hydr%th_aroot(j)) + ccohort_hydr%ftc_aroot(j) = wkf_plant(aroot_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_aroot(j)) + end do + + + ccohort_hydr%btran = wkf_plant(stomata_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_ag(1)) + + ccohort_hydr%qtop = (currentCohort%n*ccohort_hydr%qtop + & + nextCohort%n*ncohort_hydr%qtop)/newn + + ccohort_hydr%errh2o = (currentCohort%n*ccohort_hydr%errh2o + & + nextCohort%n*ncohort_hydr%errh2o)/newn + ccohort_hydr%errh2o_growturn_ag(:) = (currentCohort%n*ccohort_hydr%errh2o_growturn_ag(:) + & + nextCohort%n*ncohort_hydr%errh2o_growturn_ag(:))/newn + ccohort_hydr%errh2o_pheno_ag(:) = (currentCohort%n*ccohort_hydr%errh2o_pheno_ag(:) + & + nextCohort%n*ncohort_hydr%errh2o_pheno_ag(:))/newn + ccohort_hydr%errh2o_growturn_troot = (currentCohort%n*ccohort_hydr%errh2o_growturn_troot + & + nextCohort%n*ncohort_hydr%errh2o_growturn_troot)/newn + ccohort_hydr%errh2o_pheno_troot = (currentCohort%n*ccohort_hydr%errh2o_pheno_troot + & + nextCohort%n*ncohort_hydr%errh2o_pheno_troot)/newn + ccohort_hydr%errh2o_growturn_aroot = (currentCohort%n*ccohort_hydr%errh2o_growturn_aroot + & + nextCohort%n*ncohort_hydr%errh2o_growturn_aroot)/newn + ccohort_hydr%errh2o_pheno_aroot = (currentCohort%n*ccohort_hydr%errh2o_pheno_aroot + & + nextCohort%n*ncohort_hydr%errh2o_pheno_aroot)/newn - end function constrain_water_contents + ccohort_hydr%is_newly_recruited = .false. - ! ===================================================================================== +end subroutine FuseCohortHydraulics - subroutine CopyCohortHydraulics(newCohort, oldCohort) +! ===================================================================================== +! Initialization Routines +! ===================================================================================== - ! Arguments - type(ed_cohort_type), intent(inout), target :: newCohort - type(ed_cohort_type), intent(inout), target :: oldCohort +subroutine InitHydrCohort(currentSite,currentCohort) - ! Locals - type(ed_cohort_hydr_type), pointer :: ncohort_hydr - type(ed_cohort_hydr_type), pointer :: ocohort_hydr - - - ncohort_hydr => newCohort%co_hydr - ocohort_hydr => oldCohort%co_hydr - - ! Node heights - ncohort_hydr%z_node_ag = ocohort_hydr%z_node_ag - ncohort_hydr%z_upper_ag = ocohort_hydr%z_upper_ag - ncohort_hydr%z_lower_ag = ocohort_hydr%z_lower_ag - ncohort_hydr%z_node_troot = ocohort_hydr%z_node_troot - - ! Compartment kmax's - ncohort_hydr%kmax_petiole_to_leaf = ocohort_hydr%kmax_petiole_to_leaf - ncohort_hydr%kmax_stem_lower = ocohort_hydr%kmax_stem_lower - ncohort_hydr%kmax_stem_upper = ocohort_hydr%kmax_stem_upper - ncohort_hydr%kmax_troot_upper = ocohort_hydr%kmax_troot_upper - ncohort_hydr%kmax_troot_lower = ocohort_hydr%kmax_troot_lower - ncohort_hydr%kmax_aroot_upper = ocohort_hydr%kmax_aroot_upper - ncohort_hydr%kmax_aroot_lower = ocohort_hydr%kmax_aroot_lower - ncohort_hydr%kmax_aroot_radial_in = ocohort_hydr%kmax_aroot_radial_in - ncohort_hydr%kmax_aroot_radial_out = ocohort_hydr%kmax_aroot_radial_out - - ! Compartment volumes - ncohort_hydr%v_ag_init = ocohort_hydr%v_ag_init - ncohort_hydr%v_ag = ocohort_hydr%v_ag - ncohort_hydr%v_troot_init = ocohort_hydr%v_troot_init - ncohort_hydr%v_troot = ocohort_hydr%v_troot - ncohort_hydr%v_aroot_layer_init = ocohort_hydr%v_aroot_layer_init - ncohort_hydr%v_aroot_layer = ocohort_hydr%v_aroot_layer - ncohort_hydr%l_aroot_layer = ocohort_hydr%l_aroot_layer - - ! State Variables - ncohort_hydr%th_ag = ocohort_hydr%th_ag - ncohort_hydr%th_troot = ocohort_hydr%th_troot - ncohort_hydr%th_aroot = ocohort_hydr%th_aroot - ncohort_hydr%psi_ag = ocohort_hydr%psi_ag - ncohort_hydr%psi_troot = ocohort_hydr%psi_troot - ncohort_hydr%psi_aroot = ocohort_hydr%psi_aroot - ncohort_hydr%ftc_ag = ocohort_hydr%ftc_ag - ncohort_hydr%ftc_troot = ocohort_hydr%ftc_troot - ncohort_hydr%ftc_aroot = ocohort_hydr%ftc_aroot - - ! Other - ncohort_hydr%btran = ocohort_hydr%btran - ncohort_hydr%supsub_flag = ocohort_hydr%supsub_flag - ncohort_hydr%iterh1 = ocohort_hydr%iterh1 - ncohort_hydr%iterh2 = ocohort_hydr%iterh2 - ncohort_hydr%iterlayer = ocohort_hydr%iterlayer - ncohort_hydr%errh2o = ocohort_hydr%errh2o - ncohort_hydr%errh2o_growturn_ag = ocohort_hydr%errh2o_growturn_ag - ncohort_hydr%errh2o_pheno_ag = ocohort_hydr%errh2o_pheno_ag - ncohort_hydr%errh2o_growturn_troot = ocohort_hydr%errh2o_growturn_troot - ncohort_hydr%errh2o_pheno_troot = ocohort_hydr%errh2o_pheno_troot - ncohort_hydr%errh2o_growturn_aroot = ocohort_hydr%errh2o_growturn_aroot - ncohort_hydr%errh2o_pheno_aroot = ocohort_hydr%errh2o_pheno_aroot - - ! BC PLANT HYDRAULICS - flux terms - ncohort_hydr%qtop = ocohort_hydr%qtop - - ncohort_hydr%is_newly_recruited = ocohort_hydr%is_newly_recruited - - end subroutine CopyCohortHydraulics + ! Arguments + type(ed_site_type), target :: currentSite + type(ed_cohort_type), target :: currentCohort + type(ed_cohort_hydr_type), pointer :: ccohort_hydr - ! ===================================================================================== - subroutine FuseCohortHydraulics(currentSite,currentCohort, nextCohort, bc_in, newn) + if ( hlm_use_planthydro.eq.ifalse ) return + allocate(ccohort_hydr) + currentCohort%co_hydr => ccohort_hydr + call ccohort_hydr%AllocateHydrCohortArrays(currentSite%si_hydr%nlevrhiz) + ccohort_hydr%is_newly_recruited = .false. - type(ed_cohort_type), intent(inout), target :: currentCohort ! current cohort - type(ed_cohort_type), intent(inout), target :: nextCohort ! next (donor) cohort - type(ed_site_type), intent(inout), target :: currentSite ! current site +end subroutine InitHydrCohort - type(bc_in_type), intent(in) :: bc_in - real(r8), intent(in) :: newn +! ===================================================================================== +subroutine DeallocateHydrCohort(currentCohort) - ! !LOCAL VARIABLES: - type(ed_site_hydr_type), pointer :: site_hydr - type(ed_cohort_hydr_type), pointer :: ccohort_hydr ! current cohort hydraulics derived type - type(ed_cohort_hydr_type), pointer :: ncohort_hydr ! donor (next) cohort hydraulics d type - integer :: j,k ! indices - integer :: ft - - site_hydr => currentSite%si_hydr - - ccohort_hydr => currentCohort%co_hydr - ncohort_hydr => nextCohort%co_hydr - - ccohort_hydr%th_ag(:) = (currentCohort%n*ccohort_hydr%th_ag(:) + & - nextCohort%n*ncohort_hydr%th_ag(:))/newn - ccohort_hydr%th_troot = (currentCohort%n*ccohort_hydr%th_troot + & - nextCohort%n*ncohort_hydr%th_troot)/newn - ccohort_hydr%th_aroot(:) = (currentCohort%n*ccohort_hydr%th_aroot(:) + & - nextCohort%n*ncohort_hydr%th_aroot(:))/newn - ccohort_hydr%supsub_flag = 0 - - ! Only save the iteration counters for the worse of the two cohorts - if(ncohort_hydr%iterh1 > ccohort_hydr%iterh1)then - ccohort_hydr%iterh1 = ncohort_hydr%iterh1 - ccohort_hydr%iterh2 = ncohort_hydr%iterh2 - ccohort_hydr%iterlayer = ncohort_hydr%iterlayer - end if + ! Arguments + type(ed_cohort_type), target :: currentCohort + type(ed_cohort_hydr_type), pointer :: ccohort_hydr - ft = currentCohort%pft - do k=1,n_hypool_leaf - ccohort_hydr%psi_ag(k) = wrf_plant(leaf_p_media,ft)%p%psi_from_th(ccohort_hydr%th_ag(k)) - ccohort_hydr%ftc_ag(k) = wkf_plant(leaf_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_ag(k)) - end do + if ( hlm_use_planthydro.eq.ifalse ) return - do k = n_hypool_leaf+1,n_hypool_ag - ccohort_hydr%psi_ag(k) = wrf_plant(stem_p_media,ft)%p%psi_from_th(ccohort_hydr%th_ag(k)) - ccohort_hydr%ftc_ag(k) = wkf_plant(stem_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_ag(k)) - end do + ccohort_hydr => currentCohort%co_hydr + call ccohort_hydr%DeAllocateHydrCohortArrays() + deallocate(ccohort_hydr) - ccohort_hydr%psi_troot = wrf_plant(troot_p_media,ft)%p%psi_from_th(ccohort_hydr%th_troot) - ccohort_hydr%ftc_troot = wkf_plant(troot_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_troot) + return +end subroutine DeallocateHydrCohort - do j=1,site_hydr%nlevrhiz - ccohort_hydr%psi_aroot(j) = wrf_plant(aroot_p_media,ft)%p%psi_from_th(ccohort_hydr%th_aroot(j)) - ccohort_hydr%ftc_aroot(j) = wkf_plant(aroot_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_aroot(j)) - end do +! ===================================================================================== +subroutine InitHydrSites(sites,bc_in) - ccohort_hydr%btran = wkf_plant(stomata_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_ag(1)) + ! Arguments + type(ed_site_type),intent(inout),target :: sites(:) + type(bc_in_type),intent(in) :: bc_in(:) - ccohort_hydr%qtop = (currentCohort%n*ccohort_hydr%qtop + & - nextCohort%n*ncohort_hydr%qtop)/newn + ! Locals + integer :: nsites + integer :: s + integer :: j + integer :: jj + type(ed_site_hydr_type),pointer :: csite_hydr - ccohort_hydr%errh2o = (currentCohort%n*ccohort_hydr%errh2o + & - nextCohort%n*ncohort_hydr%errh2o)/newn - ccohort_hydr%errh2o_growturn_ag(:) = (currentCohort%n*ccohort_hydr%errh2o_growturn_ag(:) + & - nextCohort%n*ncohort_hydr%errh2o_growturn_ag(:))/newn - ccohort_hydr%errh2o_pheno_ag(:) = (currentCohort%n*ccohort_hydr%errh2o_pheno_ag(:) + & - nextCohort%n*ncohort_hydr%errh2o_pheno_ag(:))/newn - ccohort_hydr%errh2o_growturn_troot = (currentCohort%n*ccohort_hydr%errh2o_growturn_troot + & - nextCohort%n*ncohort_hydr%errh2o_growturn_troot)/newn - ccohort_hydr%errh2o_pheno_troot = (currentCohort%n*ccohort_hydr%errh2o_pheno_troot + & - nextCohort%n*ncohort_hydr%errh2o_pheno_troot)/newn - ccohort_hydr%errh2o_growturn_aroot = (currentCohort%n*ccohort_hydr%errh2o_growturn_aroot + & - nextCohort%n*ncohort_hydr%errh2o_growturn_aroot)/newn - ccohort_hydr%errh2o_pheno_aroot = (currentCohort%n*ccohort_hydr%errh2o_pheno_aroot + & - nextCohort%n*ncohort_hydr%errh2o_pheno_aroot)/newn - ccohort_hydr%is_newly_recruited = .false. - end subroutine FuseCohortHydraulics + if ( hlm_use_planthydro.eq.ifalse ) return - ! ===================================================================================== - ! Initialization Routines - ! ===================================================================================== + ! Initialize any derived hydraulics parameters - subroutine InitHydrCohort(currentSite,currentCohort) + nsites = ubound(sites,1) + do s=1,nsites + allocate(csite_hydr) + sites(s)%si_hydr => csite_hydr + if ( bc_in(s)%nlevsoil > nlevsoi_hyd_max ) then + write(fates_log(),*) 'The host land model has defined soil with' + write(fates_log(),*) bc_in(s)%nlevsoil,' layers, for one of its columns.' + write(fates_log(),*) 'Fates-hydro temporary array spaces with size' + write(fates_log(),*) 'nlevsoi_hyd_max = ',nlevsoi_hyd_max,' must be larger' + write(fates_log(),*) 'see main/FatesHydraulicsMemMod.F90' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if - ! Arguments - type(ed_site_type), target :: currentSite - type(ed_cohort_type), target :: currentCohort - type(ed_cohort_hydr_type), pointer :: ccohort_hydr + ! Calculate the number of rhizosphere + ! layers used + if(ignore_layer1) then + csite_hydr%i_rhiz_t = 2 + csite_hydr%i_rhiz_b = bc_in(s)%nlevsoil + else + csite_hydr%i_rhiz_t = 1 + csite_hydr%i_rhiz_b = bc_in(s)%nlevsoil + end if - if ( hlm_use_planthydro.eq.ifalse ) return - allocate(ccohort_hydr) - currentCohort%co_hydr => ccohort_hydr - call ccohort_hydr%AllocateHydrCohortArrays(currentSite%si_hydr%nlevrhiz) + csite_hydr%nlevrhiz = csite_hydr%i_rhiz_b-csite_hydr%i_rhiz_t+1 + call sites(s)%si_hydr%InitHydrSite(numpft,nlevsclass) - ccohort_hydr%is_newly_recruited = .false. + jj=1 + do j=csite_hydr%i_rhiz_t,csite_hydr%i_rhiz_b + csite_hydr%zi_rhiz(jj) = bc_in(s)%zi_sisl(j) + csite_hydr%dz_rhiz(jj) = bc_in(s)%dz_sisl(j) + jj=jj+1 + end do - end subroutine InitHydrCohort + end do - ! ===================================================================================== - subroutine DeallocateHydrCohort(currentCohort) +end subroutine InitHydrSites - ! Arguments - type(ed_cohort_type), target :: currentCohort - type(ed_cohort_hydr_type), pointer :: ccohort_hydr +! =================================================================================== +subroutine HydrSiteColdStart(sites, bc_in )! , bc_out) - if ( hlm_use_planthydro.eq.ifalse ) return - ccohort_hydr => currentCohort%co_hydr - call ccohort_hydr%DeAllocateHydrCohortArrays() - deallocate(ccohort_hydr) + ! Arguments + type(ed_site_type),intent(inout),target :: sites(:) + type(bc_in_type),intent(in) :: bc_in(:) - return - end subroutine DeallocateHydrCohort + ! Local + type(ed_site_hydr_type), pointer :: site_hydr + real(r8) :: smp ! matric potential temp + real(r8) :: h2osoi_liqvol ! liquid water content (m3/m3) + integer :: s + integer :: j,j_bc + integer :: nsites + integer :: nlevrhiz + class(wrf_type_vg), pointer :: wrf_vg + class(wkf_type_vg), pointer :: wkf_vg + class(wrf_type_cch), pointer :: wrf_cch + class(wkf_type_cch), pointer :: wkf_cch - ! ===================================================================================== - subroutine InitHydrSites(sites,bc_in) + nsites = ubound(sites,1) - ! Arguments - type(ed_site_type),intent(inout),target :: sites(:) - type(bc_in_type),intent(in) :: bc_in(:) + do s = 1,nsites - ! Locals - integer :: nsites - integer :: s - integer :: j - integer :: jj - type(ed_site_hydr_type),pointer :: csite_hydr + site_hydr => sites(s)%si_hydr + nlevrhiz = site_hydr%nlevrhiz + do j = 1,nlevrhiz + j_bc=j+site_hydr%i_rhiz_t-1 + h2osoi_liqvol = min(bc_in(s)%eff_porosity_sl(j_bc), & + bc_in(s)%h2o_liq_sisl(j_bc)/(site_hydr%dz_rhiz(j)*denh2o)) + site_hydr%h2osoi_liqvol_shell(j,1:nshell) = h2osoi_liqvol + site_hydr%h2osoi_liq_prev(j) = bc_in(s)%h2o_liq_sisl(j_bc) + end do - if ( hlm_use_planthydro.eq.ifalse ) return - ! Initialize any derived hydraulics parameters + site_hydr%l_aroot_layer(1:site_hydr%nlevrhiz) = 0.0_r8 - nsites = ubound(sites,1) - do s=1,nsites - allocate(csite_hydr) - sites(s)%si_hydr => csite_hydr - if ( bc_in(s)%nlevsoil > nlevsoi_hyd_max ) then - write(fates_log(),*) 'The host land model has defined soil with' - write(fates_log(),*) bc_in(s)%nlevsoil,' layers, for one of its columns.' - write(fates_log(),*) 'Fates-hydro temporary array spaces with size' - write(fates_log(),*) 'nlevsoi_hyd_max = ',nlevsoi_hyd_max,' must be larger' - write(fates_log(),*) 'see main/FatesHydraulicsMemMod.F90' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - ! Calculate the number of rhizosphere - ! layers used - if(ignore_layer1) then - csite_hydr%i_rhiz_t = 2 - csite_hydr%i_rhiz_b = bc_in(s)%nlevsoil - else - csite_hydr%i_rhiz_t = 1 - csite_hydr%i_rhiz_b = bc_in(s)%nlevsoil - end if - - csite_hydr%nlevrhiz = csite_hydr%i_rhiz_b-csite_hydr%i_rhiz_t+1 - call sites(s)%si_hydr%InitHydrSite(numpft,nlevsclass) - - jj=1 - do j=csite_hydr%i_rhiz_t,csite_hydr%i_rhiz_b - csite_hydr%zi_rhiz(jj) = bc_in(s)%zi_sisl(j) - csite_hydr%dz_rhiz(jj) = bc_in(s)%dz_sisl(j) - jj=jj+1 - end do - - end do + ! -------------------------------------------------------------------------------- + ! Initialize water transfer functions + ! which include both water retention functions (WRFs) + ! as well as the water conductance (K) functions (WKFs) + ! But, this is only for soil! + ! -------------------------------------------------------------------------------- + ! Initialize the Water Retention Functions + ! ----------------------------------------------------------------------------------- - end subroutine InitHydrSites + select case(soil_wrf_type) + case(van_genuchten_type) + do j=1,sites(s)%si_hydr%nlevrhiz + j_bc=j+site_hydr%i_rhiz_t-1 + allocate(wrf_vg) + site_hydr%wrf_soil(j)%p => wrf_vg + call wrf_vg%set_wrf_param([alpha_vg, psd_vg, th_sat_vg, th_res_vg]) + end do + case(campbell_type) + do j=1,site_hydr%nlevrhiz + j_bc=j+site_hydr%i_rhiz_t-1 + allocate(wrf_cch) + site_hydr%wrf_soil(j)%p => wrf_cch + call wrf_cch%set_wrf_param([bc_in(s)%watsat_sisl(j_bc), & + (-1.0_r8)*bc_in(s)%sucsat_sisl(j_bc)*denh2o*grav_earth*mpa_per_pa*m_per_mm , & + bc_in(s)%bsw_sisl(j_bc)]) + end do + case(tfs_type) + write(fates_log(),*) 'TFS water retention curves not available for soil' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end select + + ! ----------------------------------------------------------------------------------- + ! Initialize the Water Conductance (K) Functions + ! ----------------------------------------------------------------------------------- + + select case(soil_wkf_type) + case(van_genuchten_type) + do j=1,sites(s)%si_hydr%nlevrhiz + allocate(wkf_vg) + site_hydr%wkf_soil(j)%p => wkf_vg + call wkf_vg%set_wkf_param([alpha_vg, psd_vg, th_sat_vg, th_res_vg, tort_vg]) + end do + case(campbell_type) + do j=1,sites(s)%si_hydr%nlevrhiz + j_bc=j+site_hydr%i_rhiz_t-1 + allocate(wkf_cch) + site_hydr%wkf_soil(j)%p => wkf_cch + call wkf_cch%set_wkf_param([bc_in(s)%watsat_sisl(j_bc), & + (-1.0_r8)*bc_in(s)%sucsat_sisl(j_bc)*denh2o*grav_earth*mpa_per_pa*m_per_mm , & + bc_in(s)%bsw_sisl(j_bc)]) + end do + case(tfs_type) + write(fates_log(),*) 'TFS conductance not used in soil' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end select - ! =================================================================================== - subroutine HydrSiteColdStart(sites, bc_in )! , bc_out) + end do + ! + !! call UpdateH2OVeg(nsites,sites,bc_out) - ! Arguments - type(ed_site_type),intent(inout),target :: sites(:) - type(bc_in_type),intent(in) :: bc_in(:) + ! -------------------------------------------------------------------------------- + ! All other ed_Hydr_site_type variables are initialized elsewhere: + ! + ! init_patch() -> UpdateSizeDepRhizHydProps -> shellgeom() + ! this%v_shell + ! this%r_node_shell + ! this%r_out_shell + ! + ! init_patch() -> UpdateSizeDepRhizHydProps() + ! this%l_aroot_layer_init + ! this%l_aroot_1D + ! this%kmax_upper_shell + ! this%kmax_lower_shell + ! + ! hydraulics_bc() + ! this%supsub_flag + ! this%errh2o_hyd = ! hydraulics_bc + ! this%dwat_veg = ! hydraulics_bc + ! + ! ed_update_site() -> update_h2oveg() + ! this%h2oveg + ! -------------------------------------------------------------------------------- - ! Local - type(ed_site_hydr_type), pointer :: site_hydr - real(r8) :: smp ! matric potential temp - real(r8) :: h2osoi_liqvol ! liquid water content (m3/m3) - integer :: s - integer :: j,j_bc - integer :: nsites - integer :: nlevrhiz - class(wrf_type_vg), pointer :: wrf_vg - class(wkf_type_vg), pointer :: wkf_vg - class(wrf_type_cch), pointer :: wrf_cch - class(wkf_type_cch), pointer :: wkf_cch + return +end subroutine HydrSiteColdStart +! ===================================================================================== - nsites = ubound(sites,1) +subroutine UpdateH2OVeg(nsites,sites,bc_out) - do s = 1,nsites + ! ---------------------------------------------------------------------------------- + ! This subroutine is called following dynamics. After growth has been updated + ! there needs to be a re-assesment of the how much liquid water is bound in the + ! plants. This value is necessary for water balancing in the HLM. + ! ---------------------------------------------------------------------------------- - site_hydr => sites(s)%si_hydr - nlevrhiz = site_hydr%nlevrhiz - - do j = 1,nlevrhiz - j_bc=j+site_hydr%i_rhiz_t-1 - h2osoi_liqvol = min(bc_in(s)%eff_porosity_sl(j_bc), & - bc_in(s)%h2o_liq_sisl(j_bc)/(site_hydr%dz_rhiz(j)*denh2o)) - - site_hydr%h2osoi_liqvol_shell(j,1:nshell) = h2osoi_liqvol - site_hydr%h2osoi_liq_prev(j) = bc_in(s)%h2o_liq_sisl(j_bc) - end do - + ! Arguments + integer, intent(in) :: nsites + type(ed_site_type), intent(inout), target :: sites(nsites) + type(bc_out_type), intent(inout) :: bc_out(nsites) + + ! Locals + type(ed_cohort_type), pointer :: currentCohort + type(ed_patch_type), pointer :: currentPatch + type(ed_cohort_hydr_type), pointer :: ccohort_hydr + type(ed_site_hydr_type), pointer :: csite_hydr + integer :: s + real(r8) :: balive_patch + integer :: nstep !number of time steps + + !for debug only + nstep = get_nstep() + + do s = 1,nsites + bc_out(s)%plant_stored_h2o_si = 0.0_r8 + end do + + if( hlm_use_planthydro.eq.ifalse ) return + + do s = 1,nsites + + csite_hydr => sites(s)%si_hydr + csite_hydr%h2oveg = 0.0_r8 + currentPatch => sites(s)%oldest_patch + do while(associated(currentPatch)) + currentCohort=>currentPatch%tallest + do while(associated(currentCohort)) + ccohort_hydr => currentCohort%co_hydr + !only account for the water for not newly recruit for mass balance + if(.not.ccohort_hydr%is_newly_recruited) then + csite_hydr%h2oveg = csite_hydr%h2oveg + & + (sum(ccohort_hydr%th_ag(:)*ccohort_hydr%v_ag(:)) + & + ccohort_hydr%th_troot*ccohort_hydr%v_troot + & + sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:)))* & + denh2o*currentCohort%n + endif + + currentCohort => currentCohort%shorter + enddo !cohort + currentPatch => currentPatch%younger + enddo !end patch loop + + csite_hydr%h2oveg = csite_hydr%h2oveg*AREA_INV + + ! Note that h2oveg_dead is incremented wherever we have litter fluxes + ! and it will be reduced via an evaporation term + ! growturn_err is a term to accomodate error in growth or turnover. need to be improved for future(CX) + bc_out(s)%plant_stored_h2o_si = csite_hydr%h2oveg + csite_hydr%h2oveg_dead - & + csite_hydr%h2oveg_growturn_err - & + csite_hydr%h2oveg_pheno_err-& + csite_hydr%h2oveg_hydro_err + + end do + + + return +end subroutine UpdateH2OVeg + +!===================================================================================== +subroutine RecruitWUptake(nsites,sites,bc_in,dtime,recruitflag) - site_hydr%l_aroot_layer(1:site_hydr%nlevrhiz) = 0.0_r8 + ! ---------------------------------------------------------------------------------- + ! This subroutine is called to calculate the water requirement for newly recruited cohorts + ! The water update is allocated proportionally to the root biomass, which could be updated + ! to accomodate the soil moisture and rooting depth for small seedlings (Chonggang XU). + ! After the root water uptake, is_newly_recruited flag is set to false. + ! Note, this routine is not accounting for the normal water uptake of new plants + ! going forward, this routine accounts for the water that needs to be accounted for + ! as the plants pop into existance. + ! ---------------------------------------------------------------------------------- + ! Arguments + integer, intent(in) :: nsites + type(ed_site_type), intent(inout), target :: sites(nsites) + type(bc_in_type), intent(in) :: bc_in(nsites) + real(r8), intent(in) :: dtime !time (seconds) + logical, intent(out) :: recruitflag !flag to check if there is newly recruited cohorts + + ! Locals + type(ed_cohort_type), pointer :: currentCohort + type(ed_patch_type), pointer :: currentPatch + type(ed_cohort_hydr_type), pointer :: ccohort_hydr + type(ed_site_hydr_type), pointer :: csite_hydr + integer :: s, j, ft + integer :: nstep !number of time steps + real(r8) :: rootfr !fraction of root in different soil layer + real(r8) :: recruitw !water for newly recruited cohorts (kg water/m2/s) + real(r8) :: recruitw_total ! total water for newly recruited cohorts (kg water/m2/s) + real(r8) :: err !mass error of water for newly recruited cohorts (kg water/m2/s) + real(r8) :: sumrw_uptake !sum of water take for newly recruited cohorts (kg water/m2/s) + real(r8) :: sum_l_aroot !sum of absorbing root lenghts + recruitflag = .false. + do s = 1,nsites + csite_hydr => sites(s)%si_hydr + csite_hydr%recruit_w_uptake = 0.0_r8 + currentPatch => sites(s)%oldest_patch + recruitw_total = 0.0_r8 + do while(associated(currentPatch)) + currentCohort=>currentPatch%tallest + do while(associated(currentCohort)) + ccohort_hydr => currentCohort%co_hydr + ft = currentCohort%pft + !----------------------------------------------------------- + ! recruitment water uptake + if(ccohort_hydr%is_newly_recruited) then + recruitflag = .true. + recruitw = (sum(ccohort_hydr%th_ag(:)*ccohort_hydr%v_ag(:)) + & + ccohort_hydr%th_troot*ccohort_hydr%v_troot + & + sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:)))* & + denh2o*currentCohort%n*AREA_INV/dtime + recruitw_total = recruitw_total + recruitw + sum_l_aroot = sum(ccohort_hydr%l_aroot_layer(:)) + do j=1,csite_hydr%nlevrhiz + rootfr = ccohort_hydr%l_aroot_layer(j)/sum_l_aroot + csite_hydr%recruit_w_uptake(j) = csite_hydr%recruit_w_uptake(j) + & + recruitw*rootfr + end do + ccohort_hydr%is_newly_recruited = .false. + endif + currentCohort=>currentCohort%shorter + end do !cohort loop + currentPatch => currentPatch%younger + end do !patch + !balance check + sumrw_uptake = sum(csite_hydr%recruit_w_uptake) + err = recruitw_total - sumrw_uptake + if(abs(err)>1.0e-10_r8)then + do j=1,csite_hydr%nlevrhiz + csite_hydr%recruit_w_uptake(j) = csite_hydr%recruit_w_uptake(j) + & + err*csite_hydr%recruit_w_uptake(j)/sumrw_uptake + enddo + write(fates_log(),*) 'math check on recruit water failed.' + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + end do ! site loop + + !write(fates_log(),*) 'Calculating recruit water' + !write(fates_log(),*) csite_hydr%recruit_w_uptake + + +end subroutine RecruitWUptake + +!===================================================================================== +subroutine ConstrainRecruitNumber(csite,ccohort, bc_in) + + ! --------------------------------------------------------------------------- + ! This subroutine constrains the number of plants so that there is enought water + ! for newly recruited individuals from the soil + ! --------------------------------------------------------------------------- + + ! Arguments + type(ed_site_type), intent(inout), target :: csite + type(ed_cohort_type) , intent(inout), target :: ccohort + type(bc_in_type) , intent(in) :: bc_in + + ! Locals + type(ed_cohort_hydr_type), pointer :: ccohort_hydr + type(ed_site_hydr_type), pointer :: csite_hydr + real(r8) :: tmp1 + real(r8) :: watres_local !minum water content [m3/m3] + real(r8) :: total_water !total water in rhizosphere at a specific layer (m^3 ha-1) + real(r8) :: total_water_min !total minimum water in rhizosphere at a specific layer (m^3) + real(r8) :: rootfr !fraction of root in different soil layer + real(r8) :: recruitw !water for newly recruited cohorts (kg water/m2/individual) + real(r8) :: n, nmin !number of individuals in cohorts + real(r8) :: sum_l_aroot + integer :: s, j, ft + + csite_hydr => csite%si_hydr + ccohort_hydr =>ccohort%co_hydr + recruitw = (sum(ccohort_hydr%th_ag(:)*ccohort_hydr%v_ag(:)) + & + ccohort_hydr%th_troot*ccohort_hydr%v_troot + & + sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:)))* & + denh2o + sum_l_aroot = sum(ccohort_hydr%l_aroot_layer(:)) + do j=1,csite_hydr%nlevrhiz + cohort_recruit_water_layer(j) = recruitw*ccohort_hydr%l_aroot_layer(j)/sum_l_aroot + end do + + do j=1,csite_hydr%nlevrhiz + watres_local = csite_hydr%wrf_soil(j)%p%th_from_psi(bc_in%smpmin_si*denh2o*grav_earth*m_per_mm*mpa_per_pa) + + total_water = sum(csite_hydr%v_shell(j,:)*csite_hydr%h2osoi_liqvol_shell(j,:)) + total_water_min = sum(csite_hydr%v_shell(j,:)*watres_local) + + !assumes that only 50% is available for recruit water.... + recruit_water_avail_layer(j)=0.5_r8*max(0.0_r8,total_water-total_water_min) + + end do + + nmin = 1.0e+36 + do j=1,csite_hydr%nlevrhiz + if(cohort_recruit_water_layer(j)>0.0_r8) then + n = recruit_water_avail_layer(j)/cohort_recruit_water_layer(j) + nmin = min(n, nmin) + endif + end do + ccohort%n = min (ccohort%n, nmin) + +end subroutine ConstrainRecruitNumber + + +! ===================================================================================== + +subroutine SavePreviousRhizVolumes(currentSite) + + ! !ARGUMENTS: + type(ed_site_type) , intent(inout), target :: currentSite + type(ed_site_hydr_type), pointer :: csite_hydr + + csite_hydr => currentSite%si_hydr + csite_hydr%l_aroot_layer_init(:) = csite_hydr%l_aroot_layer(:) + csite_hydr%r_node_shell_init(:,:) = csite_hydr%r_node_shell(:,:) + csite_hydr%v_shell_init(:,:) = csite_hydr%v_shell(:,:) + + return +end subroutine SavePreviousRhizVolumes + +! ====================================================================================== + +subroutine UpdateSizeDepRhizVolLenCon(currentSite, bc_in) - ! -------------------------------------------------------------------------------- - ! Initialize water transfer functions - ! which include both water retention functions (WRFs) - ! as well as the water conductance (K) functions (WKFs) - ! But, this is only for soil! - ! -------------------------------------------------------------------------------- - ! Initialize the Water Retention Functions - ! ----------------------------------------------------------------------------------- + ! + ! !DESCRIPTION: Updates size of 'representative' rhizosphere -- node radii, volumes. + ! As fine root biomass (and thus absorbing root length) increases, this characteristic + ! rhizosphere shrinks even though the total volume of soil tapped by fine roots remains + ! the same. + ! + ! !USES: - select case(soil_wrf_type) - case(van_genuchten_type) - do j=1,sites(s)%si_hydr%nlevrhiz - j_bc=j+site_hydr%i_rhiz_t-1 - allocate(wrf_vg) - site_hydr%wrf_soil(j)%p => wrf_vg - call wrf_vg%set_wrf_param([alpha_vg, psd_vg, th_sat_vg, th_res_vg]) - end do - case(campbell_type) - do j=1,site_hydr%nlevrhiz - j_bc=j+site_hydr%i_rhiz_t-1 - allocate(wrf_cch) - site_hydr%wrf_soil(j)%p => wrf_cch - call wrf_cch%set_wrf_param([bc_in(s)%watsat_sisl(j_bc), & - (-1.0_r8)*bc_in(s)%sucsat_sisl(j_bc)*denh2o*grav_earth*mpa_per_pa*m_per_mm , & - bc_in(s)%bsw_sisl(j_bc)]) - end do - case(tfs_type) - write(fates_log(),*) 'TFS water retention curves not available for soil' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end select - ! ----------------------------------------------------------------------------------- - ! Initialize the Water Conductance (K) Functions - ! ----------------------------------------------------------------------------------- - - select case(soil_wkf_type) - case(van_genuchten_type) - do j=1,sites(s)%si_hydr%nlevrhiz - allocate(wkf_vg) - site_hydr%wkf_soil(j)%p => wkf_vg - call wkf_vg%set_wkf_param([alpha_vg, psd_vg, th_sat_vg, th_res_vg, tort_vg]) - end do - case(campbell_type) - do j=1,sites(s)%si_hydr%nlevrhiz - j_bc=j+site_hydr%i_rhiz_t-1 - allocate(wkf_cch) - site_hydr%wkf_soil(j)%p => wkf_cch - call wkf_cch%set_wkf_param([bc_in(s)%watsat_sisl(j_bc), & - (-1.0_r8)*bc_in(s)%sucsat_sisl(j_bc)*denh2o*grav_earth*mpa_per_pa*m_per_mm , & - bc_in(s)%bsw_sisl(j_bc)]) - end do - case(tfs_type) - write(fates_log(),*) 'TFS conductance not used in soil' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end select + ! !ARGUMENTS: + type(ed_site_type) , intent(inout), target :: currentSite + type(bc_in_type) , intent(in) :: bc_in - end do + ! + ! !LOCAL VARIABLES: + type(ed_site_hydr_type), pointer :: csite_hydr + type(ed_patch_type) , pointer :: cPatch + type(ed_cohort_type) , pointer :: cCohort + type(ed_cohort_hydr_type), pointer :: ccohort_hydr + real(r8) :: hksat_s ! hksat converted to units of 10^6sec + ! which is equiv to [kg m-1 s-1 MPa-1] + integer :: j,k ! gridcell, soil layer, rhizosphere shell indices + integer :: j_bc ! soil layer index of boundary condition + real(r8) :: large_kmax_bound = 1.e4_r8 ! for replacing kmax_bound_shell wherever the + ! innermost shell radius is less than the assumed + ! absorbing root radius rs1 + ! 1.e-5_r8 from Rudinger et al 1994 + integer :: nlevrhiz + integer, parameter :: k_inner = 1 ! innermost rhizosphere shell + !----------------------------------------------------------------------- + + csite_hydr => currentSite%si_hydr + nlevrhiz = csite_hydr%nlevrhiz + + ! update cohort-level root length density and accumulate it across cohorts and patches to the column level + csite_hydr%l_aroot_layer(:) = 0._r8 + cPatch => currentSite%youngest_patch + do while(associated(cPatch)) + cCohort => cPatch%tallest + do while(associated(cCohort)) + ccohort_hydr => cCohort%co_hydr + csite_hydr%l_aroot_layer(:) = csite_hydr%l_aroot_layer(:) + ccohort_hydr%l_aroot_layer(:)*cCohort%n + cCohort => cCohort%shorter + enddo !cohort + cPatch => cPatch%older + enddo !patch + + ! update outer radii of column-level rhizosphere shells (same across patches and cohorts) + do j = 1,nlevrhiz + ! proceed only if l_aroot_coh has changed + ! if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then + call shellGeom( csite_hydr%l_aroot_layer(j), csite_hydr%rs1(j), AREA, csite_hydr%dz_rhiz(j), & + csite_hydr%r_out_shell(j,:), csite_hydr%r_node_shell(j,:),csite_hydr%v_shell(j,:)) + ! end if !has l_aroot_layer changed? + enddo + + + do j = 1,nlevrhiz + j_bc = j+csite_hydr%i_rhiz_t-1 + + ! bc_in%hksat_sisl(j): hydraulic conductivity at saturation (mm H2O /s) + ! + ! converted from [mm H2O s-1] -> [kg s-1 MPa-1 m-1] + ! + ! Conversion of Pascals: 1 Pa = 1 kg m-1 s-2 + ! + ! [mm s-1] * 1e-3 [m mm-1] + ! * 1 [kg m-1 s-2 Pa-1] + ! * 9.8-1 [s2 m-1] + ! * 1e6 [Pa MPa-1] + ! = [kg s-1 m-1 MPa-1] + + hksat_s = bc_in%hksat_sisl(j_bc) * m_per_mm * 1._r8/grav_earth * pa_per_mpa + + ! proceed only if the total absorbing root length (site-level) has changed in this layer + if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then + + ! Set the max conductance on the inner shell first. If the node radius + ! on the shell is smaller than the root radius, just set the max conductance + ! to something extremely high. + + if( csite_hydr%r_node_shell(j,k_inner) <= csite_hydr%rs1(j) ) then + csite_hydr%kmax_upper_shell(j,k_inner) = large_kmax_bound + else + csite_hydr%kmax_upper_shell(j,k_inner) = 2._r8*pi_const*csite_hydr%l_aroot_layer(j) / & + log(csite_hydr%r_node_shell(j,k_inner)/csite_hydr%rs1(j))*hksat_s + end if - ! - !! call UpdateH2OVeg(nsites,sites,bc_out) + csite_hydr%kmax_lower_shell(j,k_inner) = 2._r8*pi_const*csite_hydr%l_aroot_layer(j) / & + log(csite_hydr%r_out_shell(j,k_inner)/csite_hydr%r_node_shell(j,k_inner) )*hksat_s - ! -------------------------------------------------------------------------------- - ! All other ed_Hydr_site_type variables are initialized elsewhere: - ! - ! init_patch() -> UpdateSizeDepRhizHydProps -> shellgeom() - ! this%v_shell - ! this%r_node_shell - ! this%r_out_shell - ! - ! init_patch() -> UpdateSizeDepRhizHydProps() - ! this%l_aroot_layer_init - ! this%l_aroot_1D - ! this%kmax_upper_shell - ! this%kmax_lower_shell - ! - ! hydraulics_bc() - ! this%supsub_flag - ! this%errh2o_hyd = ! hydraulics_bc - ! this%dwat_veg = ! hydraulics_bc - ! - ! ed_update_site() -> update_h2oveg() - ! this%h2oveg - ! -------------------------------------------------------------------------------- + do k = 2,nshell + csite_hydr%kmax_upper_shell(j,k) = 2._r8*pi_const*csite_hydr%l_aroot_layer(j) / & + log(csite_hydr%r_node_shell(j,k)/csite_hydr%r_out_shell(j,k-1))*hksat_s - return - end subroutine HydrSiteColdStart + csite_hydr%kmax_lower_shell(j,k) = 2._r8*pi_const*csite_hydr%l_aroot_layer(j) / & + log(csite_hydr%r_out_shell(j,k)/csite_hydr%r_node_shell(j,k ))*hksat_s + enddo ! loop over rhizosphere shells - ! ===================================================================================== - subroutine UpdateH2OVeg(nsites,sites,bc_out) - ! ---------------------------------------------------------------------------------- - ! This subroutine is called following dynamics. After growth has been updated - ! there needs to be a re-assesment of the how much liquid water is bound in the - ! plants. This value is necessary for water balancing in the HLM. - ! ---------------------------------------------------------------------------------- - ! Arguments - integer, intent(in) :: nsites - type(ed_site_type), intent(inout), target :: sites(nsites) - type(bc_out_type), intent(inout) :: bc_out(nsites) + end if !has l_aroot_layer changed? + enddo ! loop over soil layers - ! Locals - type(ed_cohort_type), pointer :: currentCohort - type(ed_patch_type), pointer :: currentPatch - type(ed_cohort_hydr_type), pointer :: ccohort_hydr - type(ed_site_hydr_type), pointer :: csite_hydr - integer :: s - real(r8) :: balive_patch - integer :: nstep !number of time steps + return +end subroutine UpdateSizeDepRhizVolLenCon - !for debug only - nstep = get_nstep() - do s = 1,nsites - bc_out(s)%plant_stored_h2o_si = 0.0_r8 - end do +! ===================================================================================== - if( hlm_use_planthydro.eq.ifalse ) return - do s = 1,nsites +subroutine UpdateSizeDepRhizHydProps(currentSite, bc_in ) + ! + ! !DESCRIPTION: Updates size of 'representative' rhizosphere -- node radii, volumes. + ! As fine root biomass (and thus absorbing root length) increases, this characteristic + ! rhizosphere shrinks even though the total volume of soil tapped by fine roots remains + ! the same. + ! + ! !USES: - csite_hydr => sites(s)%si_hydr - csite_hydr%h2oveg = 0.0_r8 - currentPatch => sites(s)%oldest_patch - do while(associated(currentPatch)) - currentCohort=>currentPatch%tallest - do while(associated(currentCohort)) - ccohort_hydr => currentCohort%co_hydr - !only account for the water for not newly recruit for mass balance - if(.not.ccohort_hydr%is_newly_recruited) then - csite_hydr%h2oveg = csite_hydr%h2oveg + & - (sum(ccohort_hydr%th_ag(:)*ccohort_hydr%v_ag(:)) + & - ccohort_hydr%th_troot*ccohort_hydr%v_troot + & - sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:)))* & - denh2o*currentCohort%n - endif - - currentCohort => currentCohort%shorter - enddo !cohort - currentPatch => currentPatch%younger - enddo !end patch loop - - csite_hydr%h2oveg = csite_hydr%h2oveg*AREA_INV - - ! Note that h2oveg_dead is incremented wherever we have litter fluxes - ! and it will be reduced via an evaporation term - ! growturn_err is a term to accomodate error in growth or turnover. need to be improved for future(CX) - bc_out(s)%plant_stored_h2o_si = csite_hydr%h2oveg + csite_hydr%h2oveg_dead - & - csite_hydr%h2oveg_growturn_err - & - csite_hydr%h2oveg_pheno_err-& - csite_hydr%h2oveg_hydro_err + ! !ARGUMENTS: + type(ed_site_type) , intent(inout), target :: currentSite + type(bc_in_type) , intent(in) :: bc_in - end do + ! Save current volumes, lenghts and nodes to an "initial" + ! used to calculate effects in states later on. - return - end subroutine UpdateH2OVeg + call SavePreviousRhizVolumes(currentSite) - !===================================================================================== - subroutine RecruitWUptake(nsites,sites,bc_in,dtime,recruitflag) + ! Update the properties of the vegetation-soil hydraulic environment + ! these are independent on the water state - ! ---------------------------------------------------------------------------------- - ! This subroutine is called to calculate the water requirement for newly recruited cohorts - ! The water update is allocated proportionally to the root biomass, which could be updated - ! to accomodate the soil moisture and rooting depth for small seedlings (Chonggang XU). - ! After the root water uptake, is_newly_recruited flag is set to false. - ! Note, this routine is not accounting for the normal water uptake of new plants - ! going forward, this routine accounts for the water that needs to be accounted for - ! as the plants pop into existance. - ! ---------------------------------------------------------------------------------- + call UpdateSizeDepRhizVolLenCon(currentSite, bc_in) - ! Arguments - integer, intent(in) :: nsites - type(ed_site_type), intent(inout), target :: sites(nsites) - type(bc_in_type), intent(in) :: bc_in(nsites) - real(r8), intent(in) :: dtime !time (seconds) - logical, intent(out) :: recruitflag !flag to check if there is newly recruited cohorts - ! Locals - type(ed_cohort_type), pointer :: currentCohort - type(ed_patch_type), pointer :: currentPatch - type(ed_cohort_hydr_type), pointer :: ccohort_hydr - type(ed_site_hydr_type), pointer :: csite_hydr - integer :: s, j, ft - integer :: nstep !number of time steps - real(r8) :: rootfr !fraction of root in different soil layer - real(r8) :: recruitw !water for newly recruited cohorts (kg water/m2/s) - real(r8) :: recruitw_total ! total water for newly recruited cohorts (kg water/m2/s) - real(r8) :: err !mass error of water for newly recruited cohorts (kg water/m2/s) - real(r8) :: sumrw_uptake !sum of water take for newly recruited cohorts (kg water/m2/s) - real(r8) :: sum_l_aroot !sum of absorbing root lenghts - recruitflag = .false. - do s = 1,nsites - csite_hydr => sites(s)%si_hydr - csite_hydr%recruit_w_uptake = 0.0_r8 - currentPatch => sites(s)%oldest_patch - recruitw_total = 0.0_r8 - do while(associated(currentPatch)) - currentCohort=>currentPatch%tallest - do while(associated(currentCohort)) - ccohort_hydr => currentCohort%co_hydr - ft = currentCohort%pft - !----------------------------------------------------------- - ! recruitment water uptake - if(ccohort_hydr%is_newly_recruited) then - recruitflag = .true. - recruitw = (sum(ccohort_hydr%th_ag(:)*ccohort_hydr%v_ag(:)) + & - ccohort_hydr%th_troot*ccohort_hydr%v_troot + & - sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:)))* & - denh2o*currentCohort%n*AREA_INV/dtime - recruitw_total = recruitw_total + recruitw - sum_l_aroot = sum(ccohort_hydr%l_aroot_layer(:)) - do j=1,csite_hydr%nlevrhiz - rootfr = ccohort_hydr%l_aroot_layer(j)/sum_l_aroot - csite_hydr%recruit_w_uptake(j) = csite_hydr%recruit_w_uptake(j) + & - recruitw*rootfr - end do - ccohort_hydr%is_newly_recruited = .false. - endif - currentCohort=>currentCohort%shorter - end do !cohort loop - currentPatch => currentPatch%younger - end do !patch - !balance check - sumrw_uptake = sum(csite_hydr%recruit_w_uptake) - err = recruitw_total - sumrw_uptake - if(abs(err)>1.0e-10_r8)then - do j=1,csite_hydr%nlevrhiz - csite_hydr%recruit_w_uptake(j) = csite_hydr%recruit_w_uptake(j) + & - err*csite_hydr%recruit_w_uptake(j)/sumrw_uptake - enddo - write(fates_log(),*) 'math check on recruit water failed.' - call endrun(msg=errMsg(sourcefile, __LINE__)) - endif - end do ! site loop - - !write(fates_log(),*) 'Calculating recruit water' - !write(fates_log(),*) csite_hydr%recruit_w_uptake + return +end subroutine UpdateSizeDepRhizHydProps +! ================================================================================= - end subroutine RecruitWUptake +subroutine UpdateSizeDepRhizHydStates(currentSite, bc_in) + ! + ! !DESCRIPTION: Updates size of 'representative' rhizosphere -- node radii, volumes. + ! As fine root biomass (and thus absorbing root length) increases, this characteristic + ! rhizosphere shrinks even though the total volume of soil tapped by fine roots remains + ! the same. + ! + ! !USES: + ! + ! !ARGUMENTS: + type(ed_site_type), intent(inout), target :: currentSite + type(bc_in_type), intent(in) :: bc_in + ! + ! !LOCAL VARIABLES: + real(r8) :: v_rhiz(nlevsoi_hyd_max) ! updated volume of all rhizosphere compartments [m3] + real(r8) :: r_delta ! change in radius of innermost rhizosphere compartment [m] + real(r8) :: dpsidr ! water potential gradient near root surface [MPa/m] + real(r8) :: w_shell_new ! updated water volume in rhizosphere compartment [m3] + real(r8) :: w_layer_init(nlevsoi_hyd_max) ! initial water mass by layer [kg] + real(r8) :: w_layer_interp(nlevsoi_hyd_max) ! water mass after interpolating to new rhizosphere [kg] + real(r8) :: w_layer_new(nlevsoi_hyd_max) ! water mass by layer after interpolation and fudging [kg] + real(r8) :: h2osoi_liq_col_new(nlevsoi_hyd_max) ! water mass per area after interpolating to new rhizosphere [kg/m2] + real(r8) :: s_shell_init(nlevsoi_hyd_max,nshell) ! initial saturation fraction in rhizosphere compartment [0-1] + real(r8) :: s_shell_interp(nlevsoi_hyd_max,nshell) ! interpolated saturation fraction in rhizosphere compartment [0-1] + real(r8) :: psi_shell_init(nlevsoi_hyd_max,nshell) ! initial water potential in rhizosphere compartment [MPa] + real(r8) :: psi_shell_interp(nlevsoi_hyd_max,nshell) ! interpolated psi_shell to new r_node_shell [MPa] + real(r8) :: delta_s(nlevsoi_hyd_max) ! change in saturation fraction needed to ensure water bal [0-1] + real(r8) :: errh2o(nlevsoi_hyd_max) ! water budget error after updating [kg/m2] + integer :: j,k ! gridcell, column, soil layer, rhizosphere shell indicies + integer :: j_bc ! level index for boundary conditions + integer :: indexc,indexj ! column and layer indices where there is a water balance error + logical :: found ! flag in search loop + type(ed_site_hydr_type), pointer :: csite_hydr + !----------------------------------------------------------------------- + + s_shell_init(:,:) = 0._r8 + psi_shell_init(:,:) = 0._r8 + psi_shell_interp(:,:) = 0._r8 + s_shell_interp(:,:) = 0._r8 + + csite_hydr => currentSite%si_hydr + + if(.false.) then + + do j = 1, csite_hydr%nlevrhiz + ! proceed only if l_aroot_coh has changed + if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then + + do k = 1,nshell + psi_shell_init(j,k) = csite_hydr%wrf_soil(j)%p%psi_from_th(csite_hydr%h2osoi_liqvol_shell(j,k)) + end do - !===================================================================================== - subroutine ConstrainRecruitNumber(csite,ccohort, bc_in) + end if !has l_aroot_coh changed? + enddo - ! --------------------------------------------------------------------------- - ! This subroutine constrains the number of plants so that there is enought water - ! for newly recruited individuals from the soil - ! --------------------------------------------------------------------------- + ! interpolate initial psi values by layer and shell + ! BOC...To-Do: need to constrain psi to be within realistic limits (i.e., < 0) + do j = 1,csite_hydr%nlevrhiz + ! proceed only if l_aroot_coh has changed + if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then + + ! fine root length increased, thus shrinking the rhizosphere size + if(csite_hydr%r_node_shell(j,nshell) < csite_hydr%r_node_shell_init(j,nshell)) then + r_delta = csite_hydr%r_node_shell(j,1) - csite_hydr%r_node_shell_init(j,1) + !dpsidr = (psi_shell_init(j,2) - psi_shell_init(j,1)) / & + ! (csite_hydr%r_node_shell_init(j,2) - csite_hydr%r_node_shell_init(j,1)) + + ! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! HACK for special case of nshell = 1 -- compiler throws error because of index 2 in above line, + ! even though at run-time the code should skip over this section: MUST FIX + ! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + dpsidr = (psi_shell_init(j,1) - psi_shell_init(j,1)) / & + (csite_hydr%r_node_shell_init(j,1) - csite_hydr%r_node_shell_init(j,1)) + psi_shell_interp(j,1) = dpsidr * r_delta + do k = 2,nshell + r_delta = csite_hydr%r_node_shell(j,k) - csite_hydr%r_node_shell_init(j,k) + dpsidr = (psi_shell_init(j,k) - psi_shell_init(j,k-1)) / & + (csite_hydr%r_node_shell_init(j,k) - csite_hydr%r_node_shell_init(j,k-1)) + psi_shell_interp(j,k) = dpsidr * r_delta + enddo + else + ! fine root length decreased, thus increasing the rhizosphere size + do k = 1,(nshell-1) + r_delta = csite_hydr%r_node_shell(j,k) - csite_hydr%r_node_shell_init(j,k) + dpsidr = (psi_shell_init(j,k+1) - psi_shell_init(j,k)) / & + (csite_hydr%r_node_shell_init(j,k+1) - csite_hydr%r_node_shell_init(j,k)) + psi_shell_interp(j,k) = dpsidr * r_delta + enddo + r_delta = csite_hydr%r_node_shell(j,nshell) - csite_hydr%r_node_shell_init(j,nshell) + !dpsidr = (psi_shell_init(j,nshell) - psi_shell_init(j,nshell-1)) / & + ! (csite_hydr%r_node_shell_init(j,nshell) - csite_hydr%r_node_shell_init(j,nshell-1)) + + ! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! HACK for special case of nshell = 1 -- compiler throws error because of index nshell-1 in + ! above line, even though at run-time the code should skip over this section: MUST FIX + ! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + dpsidr = (psi_shell_init(j,nshell) - psi_shell_init(j,nshell)) / & + (csite_hydr%r_node_shell_init(j,nshell) - csite_hydr%r_node_shell_init(j,nshell)) + + psi_shell_interp(j,k) = dpsidr * r_delta + end if + end if !has l_aroot_coh changed? + enddo - ! Arguments - type(ed_site_type), intent(inout), target :: csite - type(ed_cohort_type) , intent(inout), target :: ccohort - type(bc_in_type) , intent(in) :: bc_in + ! 1st guess at new s based on interpolated psi + do j = 1,csite_hydr%nlevrhiz + j_bc = j+csite_hydr%i_rhiz_t-1 - ! Locals - type(ed_cohort_hydr_type), pointer :: ccohort_hydr - type(ed_site_hydr_type), pointer :: csite_hydr - real(r8) :: tmp1 - real(r8) :: watres_local !minum water content [m3/m3] - real(r8) :: total_water !total water in rhizosphere at a specific layer (m^3 ha-1) - real(r8) :: total_water_min !total minimum water in rhizosphere at a specific layer (m^3) - real(r8) :: rootfr !fraction of root in different soil layer - real(r8) :: recruitw !water for newly recruited cohorts (kg water/m2/individual) - real(r8) :: n, nmin !number of individuals in cohorts - real(r8) :: sum_l_aroot - integer :: s, j, ft - - csite_hydr => csite%si_hydr - ccohort_hydr =>ccohort%co_hydr - recruitw = (sum(ccohort_hydr%th_ag(:)*ccohort_hydr%v_ag(:)) + & - ccohort_hydr%th_troot*ccohort_hydr%v_troot + & - sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:)))* & - denh2o - sum_l_aroot = sum(ccohort_hydr%l_aroot_layer(:)) - do j=1,csite_hydr%nlevrhiz - cohort_recruit_water_layer(j) = recruitw*ccohort_hydr%l_aroot_layer(j)/sum_l_aroot - end do + ! proceed only if l_aroot_coh has changed + if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then - do j=1,csite_hydr%nlevrhiz - watres_local = csite_hydr%wrf_soil(j)%p%th_from_psi(bc_in%smpmin_si*denh2o*grav_earth*m_per_mm*mpa_per_pa) + s_shell_interp(j,k) = ( csite_hydr%wrf_soil(j)%p%th_from_psi(psi_shell_interp(j,k)) - bc_in%watres_sisl(j_bc)) / & + (bc_in%watres_sisl(j_bc)+bc_in%watres_sisl(j_bc)) - total_water = sum(csite_hydr%v_shell(j,:)*csite_hydr%h2osoi_liqvol_shell(j,:)) - total_water_min = sum(csite_hydr%v_shell(j,:)*watres_local) + end if !has l_aroot_coh changed? + enddo - !assumes that only 50% is available for recruit water.... - recruit_water_avail_layer(j)=0.5_r8*max(0.0_r8,total_water-total_water_min) + ! accumlate water across shells for each layer (initial and interpolated) + do j = 1,csite_hydr%nlevrhiz + j_bc = j+csite_hydr%i_rhiz_t-1 + ! proceed only if l_aroot_coh has changed + if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then + w_layer_init(j) = 0._r8 + w_layer_interp(j) = 0._r8 + v_rhiz(j) = 0._r8 + do k = 1,nshell + w_layer_init(j) = w_layer_init(j) + denh2o * & + (csite_hydr%v_shell_init(j,k)*csite_hydr%h2osoi_liqvol_shell(j,k) ) + w_layer_interp(j) = w_layer_interp(j) + denh2o * & + (csite_hydr%v_shell(j,k) * & + (s_shell_interp(j,k)*(bc_in%watsat_sisl(j_bc)-bc_in%watres_sisl(j_bc))+bc_in%watres_sisl(j_bc)) ) + v_rhiz(j) = v_rhiz(j) + csite_hydr%v_shell(j,k) + enddo + end if !has l_aroot_coh changed? + enddo - end do + ! estimate delta_s across all shells needed to ensure total water in each layer doesn't change + ! BOC...FIX: need to handle special cases where delta_s causes s_shell to go above or below 1 or 0, respectively. + do j = 1,csite_hydr%nlevrhiz + j_bc = j+csite_hydr%i_rhiz_t-1 + ! proceed only if l_aroot_coh has changed + if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then + delta_s(j) = (( w_layer_init(j) - w_layer_interp(j) )/( v_rhiz(j) * denh2o ) - bc_in%watres_sisl(j_bc)) / & + (bc_in%watsat_sisl(j_bc)-bc_in%watres_sisl(j_bc)) + end if !has l_aroot_coh changed? + enddo - nmin = 1.0e+36 - do j=1,csite_hydr%nlevrhiz - if(cohort_recruit_water_layer(j)>0.0_r8) then - n = recruit_water_avail_layer(j)/cohort_recruit_water_layer(j) - nmin = min(n, nmin) - endif - end do - ccohort%n = min (ccohort%n, nmin) + ! update h2osoi_liqvol_shell and h2osoi_liq_shell + do j = 1,csite_hydr%nlevrhiz + j_bc = j+csite_hydr%i_rhiz_t-1 + ! proceed only if l_aroot_coh has changed + if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then + w_layer_new(j) = 0._r8 + do k = 1,nshell + s_shell_interp(j,k) = s_shell_interp(j,k) + delta_s(j) + csite_hydr%h2osoi_liqvol_shell(j,k) = s_shell_interp(j,k) * & + ( bc_in%watsat_sisl(j_bc)-bc_in%watres_sisl(j_bc) ) + bc_in%watres_sisl(j_bc) + w_shell_new = csite_hydr%h2osoi_liqvol_shell(j,k) * & + csite_hydr%v_shell(j,k) + w_layer_new(j) = w_layer_new(j) + w_shell_new + enddo + h2osoi_liq_col_new(j) = w_layer_new(j)/ v_rhiz(j) + end if !has l_aroot_coh changed? + enddo - end subroutine ConstrainRecruitNumber + ! balance check + do j = 1,csite_hydr%nlevrhiz + j_bc = j+csite_hydr%i_rhiz_t-1 + errh2o(j) = h2osoi_liq_col_new(j) - bc_in%h2o_liq_sisl(j_bc) + if (abs(errh2o(j)) > 1.e-4_r8) then + write(fates_log(),*)'WARNING: water balance error ',& + ' updating rhizosphere shells: ',j,errh2o(j) + write(fates_log(),*)'errh2o= ',errh2o(j), ' [kg/m2]' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + enddo + end if !nshell > 1 + +end subroutine UpdateSizeDepRhizHydStates + +! ==================================================================================== + +subroutine BTranForHLMDiagnosticsFromCohortHydr(nsites,sites,bc_out) + + ! Arguments + integer,intent(in) :: nsites + type(ed_site_type),intent(inout),target :: sites(nsites) + type(bc_out_type),intent(inout) :: bc_out(nsites) + + ! Locals + integer :: s + integer :: ifp + real(r8) :: balive_patch + type(ed_patch_type),pointer :: cpatch + type(ed_cohort_type),pointer :: ccohort + + do s = 1,nsites + + ifp = 0 + cpatch => sites(s)%oldest_patch + do while (associated(cpatch)) + ifp=ifp+1 + + balive_patch = 0._r8 + ccohort=>cpatch%tallest + do while(associated(ccohort)) + balive_patch = balive_patch + & + (cCohort%prt%GetState(fnrt_organ, all_carbon_elements) + & + cCohort%prt%GetState(sapw_organ, all_carbon_elements) + & + cCohort%prt%GetState(leaf_organ, all_carbon_elements))* ccohort%n + ccohort => ccohort%shorter + enddo !cohort + + bc_out(s)%btran_pa(ifp) = 0.0_r8 + ccohort=>cpatch%tallest + do while(associated(ccohort)) + bc_out(s)%btran_pa(ifp) = bc_out(s)%btran_pa(ifp) + & + ccohort%co_hydr%btran * & + (cCohort%prt%GetState(fnrt_organ, all_carbon_elements) + & + cCohort%prt%GetState(sapw_organ, all_carbon_elements) + & + cCohort%prt%GetState(leaf_organ, all_carbon_elements)) * & + ccohort%n / balive_patch + ccohort => ccohort%shorter + enddo !cohort + cpatch => cpatch%younger + enddo !end patch loop + end do + return +end subroutine BTranForHLMDiagnosticsFromCohortHydr + +! ========================================================================== + +subroutine FillDrainRhizShells(nsites, sites, bc_in, bc_out) + ! + ! Created by Brad Christoffersen, Jan 2016 + ! + ! !DESCRIPTION: + ! Parses out mean vertical water fluxes resulting from infiltration, + ! drainage, and vertical water movement (dwat_kgm2) over radially stratified + ! rhizosphere shells. + ! + ! The approach used is heuristic, but based on the principle that water + ! fluxing out of a layer will preferentially come from rhizosphere + ! shells with higher water contents/potentials within that layer, and + ! alternatively, that water fluxing into a layer will preferentially go + ! into shells with lower water contents/potentials. + ! + ! This principle is implemented by filling (draining) the rhizosphere + ! shells in order from the driest (wettest) shell to the wettest (driest). + ! Each shell is filled (drained) up (down) to the next wettest (driest) + ! shell until the change in mean layer water (dwat_kgm2) is accounted for. + ! + ! !USES: + ! + ! !ARGUMENTS: + integer, intent(in) :: nsites + type(ed_site_type), intent(inout), target :: sites(nsites) + type(bc_in_type), intent(in) :: bc_in(nsites) + type(bc_out_type), intent(inout) :: bc_out(nsites) + + ! Locals + type(ed_site_hydr_type), pointer :: csite_hydr ! pointer to site hydraulics object + real(r8) :: dwat_kgm2 ! change in layer water content [kg/m2] + integer :: s,j,k ! site, soil layer, rhizosphere shell indicies + integer :: i,f,ff,kk ! indicies + integer :: j_bc ! layer index for matching boundary condition soil layers + integer :: indexj ! column and layer indices where there is a water balance error + integer :: ordered(nshell) = (/(i,i=1,nshell,1)/) ! array of rhizosphere indices which have been ordered + real(r8) :: area_col ! column area [m2] + real(r8) :: v_cum ! cumulative shell volume from driest/wettest shell to kth shell [m3] + real(r8) :: dwat_kg ! water remaining to be distributed across shells [kg] + real(r8) :: thdiff ! water content difference between ordered adjacent rhiz shells [m3 m-3] + real(r8) :: wdiff ! mass of water represented by thdiff over previous k shells [kg] + real(r8) :: errh2o(nlevsoi_hyd_max) ! water budget error after updating [kg/m2] + real(r8) :: cumShellH2O ! sum of water in all the shells of a specific layer [kg/m2] + real(r8) :: h2osoi_liq_shell(nlevsoi_hyd_max,nshell) ! water in the rhizosphere shells [kg] + integer :: tmp ! temporary + logical :: found ! flag in search loop + !----------------------------------------------------------------------- + + do s = 1,nsites + + + ! First step, identify how the liquid water in each layer has changed + ! since the last time it was updated. This should be due to drainage. + ! The drainage component should be the total change in liquid water content from the last time + ! the hydraulics driver was called, and then adding back in the losses due to root uptake + ! (which was already taken out). + + ! BOC: This was previously in HydrologyDrainage: + + csite_hydr => sites(s)%si_hydr + + do j = 1,csite_hydr%nlevrhiz + j_bc = j+csite_hydr%i_rhiz_t-1 + + cumShellH2O=sum(csite_hydr%h2osoi_liqvol_shell(j,:) *csite_hydr%v_shell(j,:)) * denh2o*AREA_INV + + dwat_kgm2 = bc_in(s)%h2o_liq_sisl(j_bc) - cumShellH2O + + dwat_kg = dwat_kgm2 * AREA + + ! order shells in terms of increasing or decreasing volumetric water content + ! algorithm same as that used in histFileMod.F90 to alphabetize history tape contents + if(nshell > 1) then + do k = nshell-1,1,-1 + do kk = 1,k + if (csite_hydr%h2osoi_liqvol_shell(j,ordered(kk)) > & + csite_hydr%h2osoi_liqvol_shell(j,ordered(kk+1))) then + if (dwat_kg > 0._r8) then !order increasing + tmp = ordered(kk) + ordered(kk) = ordered(kk+1) + ordered(kk+1) = tmp + end if + else + if (dwat_kg < 0._r8) then !order decreasing + tmp = ordered(kk) + ordered(kk) = ordered(kk+1) + ordered(kk+1) = tmp + end if + end if + enddo + enddo + end if - ! ===================================================================================== + ! fill shells with water up to the water content of the next-wettest shell, + ! in order from driest to wettest (dwat_kg > 0) + ! ------ OR ------ + ! drain shells' water down to the water content of the next-driest shell, + ! in order from wettest to driest (dwat_kg < 0) + k = 1 + do while ( (dwat_kg /= 0._r8) .and. (k < nshell) ) + thdiff = csite_hydr%h2osoi_liqvol_shell(j,ordered(k+1)) - & + csite_hydr%h2osoi_liqvol_shell(j,ordered(k)) + v_cum = sum(csite_hydr%v_shell(j,ordered(1:k))) + wdiff = thdiff * v_cum * denh2o ! change in h2o [kg / ha] for shells ordered(1:k) + if(abs(dwat_kg) >= abs(wdiff)) then + csite_hydr%h2osoi_liqvol_shell(j,ordered(1:k)) = csite_hydr%h2osoi_liqvol_shell(j,ordered(k+1)) + dwat_kg = dwat_kg - wdiff + else + csite_hydr%h2osoi_liqvol_shell(j,ordered(1:k)) = & + csite_hydr%h2osoi_liqvol_shell(j,ordered(1:k)) + dwat_kg/denh2o/v_cum + dwat_kg = 0._r8 + end if + k = k + 1 + enddo + + if (dwat_kg /= 0._r8) then + v_cum = sum(csite_hydr%v_shell(j,ordered(1:nshell))) + thdiff = dwat_kg / v_cum / denh2o + do k = nshell, 1, -1 + csite_hydr%h2osoi_liqvol_shell(j,k) = csite_hydr%h2osoi_liqvol_shell(j,k) + thdiff + end do + end if - subroutine SavePreviousRhizVolumes(currentSite) + ! m3/m3 * Total volume m3 * kg/m3 = kg + h2osoi_liq_shell(j,:) = csite_hydr%h2osoi_liqvol_shell(j,:) * & + csite_hydr%v_shell(j,:) * denh2o - ! !ARGUMENTS: - type(ed_site_type) , intent(inout), target :: currentSite - type(ed_site_hydr_type), pointer :: csite_hydr - csite_hydr => currentSite%si_hydr - csite_hydr%l_aroot_layer_init(:) = csite_hydr%l_aroot_layer(:) - csite_hydr%r_node_shell_init(:,:) = csite_hydr%r_node_shell(:,:) - csite_hydr%v_shell_init(:,:) = csite_hydr%v_shell(:,:) + errh2o(j) = sum(h2osoi_liq_shell(j,:))*AREA_INV - bc_in(s)%h2o_liq_sisl(j_bc) - return - end subroutine SavePreviousRhizVolumes + if (abs(errh2o(j)) > 1.e-9_r8) then + write(fates_log(),*)'WARNING: water balance error in FillDrainRhizShells' + write(fates_log(),*)'errh2o= ',errh2o(j), ' [kg/m2]' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end do - ! ====================================================================================== + end do + return +end subroutine FillDrainRhizShells - subroutine UpdateSizeDepRhizVolLenCon(currentSite, bc_in) +! ==================================================================================== - ! - ! !DESCRIPTION: Updates size of 'representative' rhizosphere -- node radii, volumes. - ! As fine root biomass (and thus absorbing root length) increases, this characteristic - ! rhizosphere shrinks even though the total volume of soil tapped by fine roots remains - ! the same. - ! - ! !USES: +subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) + ! ---------------------------------------------------------------------------------- + ! added by Brad Christoffersen Jan 2016 for use in ED hydraulics + ! van Genuchten (1980)-specific functions for the swc (soil water characteristic) + ! and for the kunsat (unsaturated hydraulic conductivity) curves. Test mod 06/20/2016 - ! !ARGUMENTS: - type(ed_site_type) , intent(inout), target :: currentSite - type(bc_in_type) , intent(in) :: bc_in + ! resolved the mass-balance bugs and tested Jan, 2018 by C. XU + ! + ! BOC...for quick implementation avoided JT's abstract interface, + ! but these should be converted to interfaces in the future + ! ---------------------------------------------------------------------------------- - ! - ! !LOCAL VARIABLES: - type(ed_site_hydr_type), pointer :: csite_hydr - type(ed_patch_type) , pointer :: cPatch - type(ed_cohort_type) , pointer :: cCohort - type(ed_cohort_hydr_type), pointer :: ccohort_hydr - real(r8) :: hksat_s ! hksat converted to units of 10^6sec - ! which is equiv to [kg m-1 s-1 MPa-1] - integer :: j,k ! gridcell, soil layer, rhizosphere shell indices - integer :: j_bc ! soil layer index of boundary condition - real(r8) :: large_kmax_bound = 1.e4_r8 ! for replacing kmax_bound_shell wherever the - ! innermost shell radius is less than the assumed - ! absorbing root radius rs1 - ! 1.e-5_r8 from Rudinger et al 1994 - integer :: nlevrhiz - integer, parameter :: k_inner = 1 ! innermost rhizosphere shell - !----------------------------------------------------------------------- + ! + ! !DESCRIPTION: + !s + ! !USES: + use FatesUtilsMod , only : check_var_real + + ! ARGUMENTS: + ! ----------------------------------------------------------------------------------- + integer,intent(in) :: nsites + type(ed_site_type),intent(inout),target :: sites(nsites) + type(bc_in_type),intent(in) :: bc_in(nsites) + type(bc_out_type),intent(inout) :: bc_out(nsites) + real(r8),intent(in) :: dtime - csite_hydr => currentSite%si_hydr - nlevrhiz = csite_hydr%nlevrhiz - - ! update cohort-level root length density and accumulate it across cohorts and patches to the column level - csite_hydr%l_aroot_layer(:) = 0._r8 - cPatch => currentSite%youngest_patch - do while(associated(cPatch)) - cCohort => cPatch%tallest - do while(associated(cCohort)) - ccohort_hydr => cCohort%co_hydr - csite_hydr%l_aroot_layer(:) = csite_hydr%l_aroot_layer(:) + ccohort_hydr%l_aroot_layer(:)*cCohort%n - cCohort => cCohort%shorter - enddo !cohort - cPatch => cPatch%older - enddo !patch - - ! update outer radii of column-level rhizosphere shells (same across patches and cohorts) - do j = 1,nlevrhiz - ! proceed only if l_aroot_coh has changed - ! if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then - call shellGeom( csite_hydr%l_aroot_layer(j), csite_hydr%rs1(j), AREA, csite_hydr%dz_rhiz(j), & - csite_hydr%r_out_shell(j,:), csite_hydr%r_node_shell(j,:),csite_hydr%v_shell(j,:)) -! end if !has l_aroot_layer changed? - enddo + ! + ! !LOCAL VARIABLES: + integer :: iv ! leaf layer + integer :: ifp ! index of FATES patch + integer :: s ! index of FATES site + integer :: i ! shell index + integer :: j,jj ! soil layer + integer :: j_bc ! soil layer index for boundary conditions + integer :: k ! 1D plant-soil continuum array + integer :: ft ! plant functional type index + integer :: sz ! plant's size class index + integer :: t ! previous timesteps (for lwp stability calculation) + integer :: nstep !number of time steps + + !---------------------------------------------------------------------- + + type (ed_patch_type), pointer :: cpatch ! current patch pointer + type (ed_cohort_type), pointer :: ccohort ! current cohort pointer + type(ed_site_hydr_type), pointer :: site_hydr ! site hydraulics pointer + type(ed_cohort_hydr_type), pointer :: ccohort_hydr ! cohort hydraulics pointer + + ! Local arrays + + ! accumulated water content change over all cohorts in a column [m3 m-3] + real(r8) :: dth_layershell_col(nlevsoi_hyd_max,nshell) + + ! array of soil layer indices which have been ordered + integer :: ordered(nlevsoi_hyd_max) = (/(j,j=1,nlevsoi_hyd_max,1)/) + + ! total absorbing root & rhizosphere conductance (over all shells) by soil layer [MPa] + real(r8) :: kbg_layer(nlevsoi_hyd_max) + real(r8) :: rootuptake(nlevsoi_hyd_max) ! mass-flux from 1st rhizosphere to absorbing roots [kg/indiv/layer/step] + + real(r8) :: site_runoff ! If plants are pushing water into saturated soils, we create + ! runoff. This is either banked, or sent to the correct flux pool [kg/m2] + real(r8) :: aroot_frac_plant ! The fraction of the total length of absorbing roots contained in one soil layer + ! that are devoted to a single plant + real(r8) :: wb_err_plant ! Solve error for a single plant [kg] + real(r8) :: wb_check_site ! the water balance error we get from summing fluxes + ! and changes in storage + ! and is just a double check on our error accounting). [kg/m2] + real(r8) :: dwat_plant ! change in water mass in the whole plant [kg] + real(r8) :: qflx_tran_veg_indiv ! individiual transpiration rate [kgh2o indiv-1 s-1] + real(r8) :: gscan_patch ! sum of ccohort%gscan across all cohorts within a patch + real(r8) :: sapflow ! mass-flux for the cohort between transporting root and stem [kg/indiv/step] + real(r8) :: prev_h2oveg ! plant water storage at start of timestep (kg/m2) + real(r8) :: prev_h2osoil ! soil water storage at start of timestep (kg/m2) + logical :: recruitflag ! flag to check if there is newly recruited cohorts + real(r8) :: root_flux ! total water flux into roots [kg/m2] + real(r8) :: transp_flux ! total transpiration flux from plants [kg/m2] + real(r8) :: delta_plant_storage ! change in plant water storage over the step [kg/m2] + real(r8) :: delta_soil_storage ! change in soil water storage over the step [kg/m2] + real(r8) :: sumcheck ! used to debug mass balance in soil horizon diagnostics + integer :: nlevrhiz ! local for number of rhizosphere levels + integer :: sc ! size class index + ! ---------------------------------------------------------------------------------- + ! Important note: We are interested in calculating the total fluxes in and out of the + ! site/column. Usually, when we do things like this, we acknowledge that FATES + ! does not consider the bare ground patch. However, since this routine + ! calculates "column level" fluxes, we have to factor in that patch-level fluxes + ! are only accounting for a portion of the area. + ! ---------------------------------------------------------------------------------- - do j = 1,nlevrhiz - j_bc = j+csite_hydr%i_rhiz_t-1 - - ! bc_in%hksat_sisl(j): hydraulic conductivity at saturation (mm H2O /s) - ! - ! converted from [mm H2O s-1] -> [kg s-1 MPa-1 m-1] - ! - ! Conversion of Pascals: 1 Pa = 1 kg m-1 s-2 - ! - ! [mm s-1] * 1e-3 [m mm-1] - ! * 1 [kg m-1 s-2 Pa-1] - ! * 9.8-1 [s2 m-1] - ! * 1e6 [Pa MPa-1] - ! = [kg s-1 m-1 MPa-1] - - hksat_s = bc_in%hksat_sisl(j_bc) * m_per_mm * 1._r8/grav_earth * pa_per_mpa - - ! proceed only if the total absorbing root length (site-level) has changed in this layer - if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then - - ! Set the max conductance on the inner shell first. If the node radius - ! on the shell is smaller than the root radius, just set the max conductance - ! to something extremely high. - - if( csite_hydr%r_node_shell(j,k_inner) <= csite_hydr%rs1(j) ) then - csite_hydr%kmax_upper_shell(j,k_inner) = large_kmax_bound - else - csite_hydr%kmax_upper_shell(j,k_inner) = 2._r8*pi_const*csite_hydr%l_aroot_layer(j) / & - log(csite_hydr%r_node_shell(j,k_inner)/csite_hydr%rs1(j))*hksat_s + !For newly recruited cohorts, add the water uptake demand to csite_hydr%recruit_w_uptake + call RecruitWUptake(nsites,sites,bc_in,dtime,recruitflag) + + !update water storage in veg after incorporating newly recuited cohorts + if(recruitflag) call UpdateH2OVeg(nsites,sites,bc_out) + + do s = 1, nsites + + site_hydr => sites(s)%si_hydr + + nlevrhiz = site_hydr%nlevrhiz + + ! AVERAGE ROOT WATER UPTAKE (BY RHIZOSPHERE SHELL) ACROSS ALL COHORTS WITHIN A COLUMN + dth_layershell_col(:,:) = 0._r8 + site_hydr%dwat_veg = 0._r8 + site_hydr%errh2o_hyd = 0._r8 + prev_h2oveg = site_hydr%h2oveg + prev_h2osoil = sum(site_hydr%h2osoi_liqvol_shell(:,:) * & + site_hydr%v_shell(:,:)) * denh2o * AREA_INV + + bc_out(s)%qflx_ro_sisl(:) = 0._r8 + + ! Zero out diagnotsics that rely on accumulation + site_hydr%sapflow_scpf(:,:) = 0._r8 + site_hydr%rootuptake_sl(:) = 0._r8 + site_hydr%rootuptake0_scpf(:,:) = 0._r8 + site_hydr%rootuptake10_scpf(:,:) = 0._r8 + site_hydr%rootuptake50_scpf(:,:) = 0._r8 + site_hydr%rootuptake100_scpf(:,:) = 0._r8 + + ! Initialize water mass balancing terms [kg h2o / m2] + ! -------------------------------------------------------------------------------- + transp_flux = 0._r8 + root_flux = 0._r8 + + ! Initialize the delta in soil water and plant water storage + ! with the initial condition. + + !err_soil = delta_soil_storage - root_flux + !err_plot = delta_plant_storage - (root_flux - transp_flux) + + ifp = 0 + cpatch => sites(s)%oldest_patch + do while (associated(cpatch)) + if(cpatch%nocomp_pft_label.ne.0)then + ifp = ifp + 1 + + ! ---------------------------------------------------------------------------- + ! Objective: Partition the transpiration flux + ! specfied by the land model to the cohorts. The weighting + ! factor we use to downscale is the cohort combo term: g_sb_laweight + ! This term is the stomatal conductance multiplied by total leaf + ! area. gscan_patch is the sum over all cohorts, used to normalize. + ! ---------------------------------------------------------------------------- + + gscan_patch = 0.0_r8 + ccohort=>cpatch%tallest + do while(associated(ccohort)) + ccohort_hydr => ccohort%co_hydr + gscan_patch = gscan_patch + ccohort%g_sb_laweight + ccohort => ccohort%shorter + enddo !cohort + + ! The HLM predicted transpiration flux even though no leaves are present? + if(bc_in(s)%qflx_transp_pa(ifp) > 1.e-10_r8 .and. gscan_patchcpatch%tallest + do while(associated(ccohort)) + ccohort_hydr => ccohort%co_hydr + ft = ccohort%pft - ! ===================================================================================== + ! Relative transpiration of this cohort from the whole patch + ! Note that g_sb_laweight / gscan_patch is the weighting that gives cohort contribution per area + ! [mm H2O/plant/s] = [mm H2O/ m2 / s] * [m2 / patch] * [cohort/plant] * [patch/cohort] + if(ccohort%g_sb_laweight>nearzero) then + qflx_tran_veg_indiv = bc_in(s)%qflx_transp_pa(ifp) * cpatch%total_canopy_area * & + (ccohort%g_sb_laweight/gscan_patch)/ccohort%n + else + qflx_tran_veg_indiv = 0._r8 + end if - subroutine UpdateSizeDepRhizHydProps(currentSite, bc_in ) - ! - ! !DESCRIPTION: Updates size of 'representative' rhizosphere -- node radii, volumes. - ! As fine root biomass (and thus absorbing root length) increases, this characteristic - ! rhizosphere shrinks even though the total volume of soil tapped by fine roots remains - ! the same. - ! - ! !USES: + ! Save the transpiration flux for diagnostics (currently its a constant boundary condition) + ccohort_hydr%qtop = qflx_tran_veg_indiv*dtime + + transp_flux = transp_flux + (qflx_tran_veg_indiv*dtime)*ccohort%n*AREA_INV + + ! VERTICAL LAYER CONTRIBUTION TO TOTAL ROOT WATER UPTAKE OR LOSS + ! _____ + ! | | + ! |leaf | + ! |_____| + ! / + ! \ + ! / + ! __\__ + ! | | + ! |stem | + ! |_____| + !------/----------------_____--------------------------------- + ! \ | | | | | | | + ! / _/\/\|aroot| | |shell | shell | shell | layer j-1 + ! \ _/ |_____| | | k-1 | k | k+1 | + !------/------_/--------_____-------------------------------------- + ! \ _/ | | | | | | | + ! __/__ / _/\/\/\/\/|aroot| | | shell | shell | shell | layer j + ! | |_/ |_____| | | k-1 | k | k+1 | + !---|troot|-------------_____---------------------------------------------- + ! |_____|\_ | | | | | | | + ! \/\/\/\/\/|aroot| | | shell | shell | shell | layer j+1 + ! |_____| | | k-1 | k | k+1 | + !--------------------------------------------------------------------------- + + + if(use_2d_hydrosolve) then - ! !ARGUMENTS: - type(ed_site_type) , intent(inout), target :: currentSite - type(bc_in_type) , intent(in) :: bc_in + call MatSolve2D(bc_in(s),site_hydr,ccohort,ccohort_hydr, & + dtime,qflx_tran_veg_indiv, & + sapflow,rootuptake(1:nlevrhiz),wb_err_plant,dwat_plant, & + dth_layershell_col) + + else + + ! --------------------------------------------------------------------------------- + ! Approach: do nlevsoi_hyd sequential solutions to Richards' equation, + ! each of which encompass all plant nodes and soil nodes for a given soil layer j, + ! with the timestep fraction for each layer-specific solution proportional to each + ! layer's contribution to the total root-soil conductance + ! Water potential in plant nodes is updated after each solution + ! As such, the order across soil layers in which the solution is conducted matters. + ! For now, the order proceeds across soil layers in order of decreasing root-soil conductance + ! NET EFFECT: total water removed from plant-soil system remains the same: it + ! sums up to total transpiration (qflx_tran_veg_indiv*dtime) + ! root water uptake in each layer is proportional to each layer's total + ! root length density and soil matric potential + ! root hydraulic redistribution emerges within this sequence when a + ! layers have transporting-to-absorbing root water potential gradients of opposite sign + ! ----------------------------------------------------------------------------------- + + call OrderLayersForSolve1D(site_hydr, ccohort, ccohort_hydr, ordered, kbg_layer) + + call ImTaylorSolve1D(site_hydr,ccohort,ccohort_hydr, & + dtime,qflx_tran_veg_indiv,ordered, kbg_layer, & + sapflow,rootuptake(1:nlevrhiz), & + wb_err_plant,dwat_plant, & + dth_layershell_col) + end if - ! Save current volumes, lenghts and nodes to an "initial" - ! used to calculate effects in states later on. + ! Remember the error for the cohort + ccohort_hydr%errh2o = ccohort_hydr%errh2o + wb_err_plant - call SavePreviousRhizVolumes(currentSite) + ! Update total error in [kg/m2 ground] + site_hydr%errh2o_hyd = site_hydr%errh2o_hyd + wb_err_plant*ccohort%n*AREA_INV - ! Update the properties of the vegetation-soil hydraulic environment - ! these are independent on the water state + ! Accumulate site level diagnostic of plant water change [kg/m2] + ! (this is zerod) + site_hydr%dwat_veg = site_hydr%dwat_veg + dwat_plant*ccohort%n*AREA_INV - call UpdateSizeDepRhizVolLenCon(currentSite, bc_in) + ! Update total site-level stored plant water [kg/m2] + ! (this is not zerod, but incremented) + site_hydr%h2oveg = site_hydr%h2oveg + dwat_plant*ccohort%n*AREA_INV + sc = ccohort%size_class - return - end subroutine UpdateSizeDepRhizHydProps + ! Sapflow diagnostic [kg/ha/s] + site_hydr%sapflow_scpf(sc,ft) = site_hydr%sapflow_scpf(sc,ft) + sapflow*ccohort%n/dtime - ! ================================================================================= + ! Root uptake per rhiz layer [kg/ha/s] + site_hydr%rootuptake_sl(1:nlevrhiz) = site_hydr%rootuptake_sl(1:nlevrhiz) + & + rootuptake(1:nlevrhiz)*ccohort%n/dtime - subroutine UpdateSizeDepRhizHydStates(currentSite, bc_in) - ! - ! !DESCRIPTION: Updates size of 'representative' rhizosphere -- node radii, volumes. - ! As fine root biomass (and thus absorbing root length) increases, this characteristic - ! rhizosphere shrinks even though the total volume of soil tapped by fine roots remains - ! the same. - ! - ! !USES: - ! - ! !ARGUMENTS: - type(ed_site_type), intent(inout), target :: currentSite - type(bc_in_type), intent(in) :: bc_in - ! - ! !LOCAL VARIABLES: - real(r8) :: v_rhiz(nlevsoi_hyd_max) ! updated volume of all rhizosphere compartments [m3] - real(r8) :: r_delta ! change in radius of innermost rhizosphere compartment [m] - real(r8) :: dpsidr ! water potential gradient near root surface [MPa/m] - real(r8) :: w_shell_new ! updated water volume in rhizosphere compartment [m3] - real(r8) :: w_layer_init(nlevsoi_hyd_max) ! initial water mass by layer [kg] - real(r8) :: w_layer_interp(nlevsoi_hyd_max) ! water mass after interpolating to new rhizosphere [kg] - real(r8) :: w_layer_new(nlevsoi_hyd_max) ! water mass by layer after interpolation and fudging [kg] - real(r8) :: h2osoi_liq_col_new(nlevsoi_hyd_max) ! water mass per area after interpolating to new rhizosphere [kg/m2] - real(r8) :: s_shell_init(nlevsoi_hyd_max,nshell) ! initial saturation fraction in rhizosphere compartment [0-1] - real(r8) :: s_shell_interp(nlevsoi_hyd_max,nshell) ! interpolated saturation fraction in rhizosphere compartment [0-1] - real(r8) :: psi_shell_init(nlevsoi_hyd_max,nshell) ! initial water potential in rhizosphere compartment [MPa] - real(r8) :: psi_shell_interp(nlevsoi_hyd_max,nshell) ! interpolated psi_shell to new r_node_shell [MPa] - real(r8) :: delta_s(nlevsoi_hyd_max) ! change in saturation fraction needed to ensure water bal [0-1] - real(r8) :: errh2o(nlevsoi_hyd_max) ! water budget error after updating [kg/m2] - integer :: j,k ! gridcell, column, soil layer, rhizosphere shell indicies - integer :: j_bc ! level index for boundary conditions - integer :: indexc,indexj ! column and layer indices where there is a water balance error - logical :: found ! flag in search loop - type(ed_site_hydr_type), pointer :: csite_hydr - !----------------------------------------------------------------------- + ! Root uptake per pft x size class, over set layer depths [kg/ha/m/s] + ! These are normalized by depth (in case the desired horizon extends + ! beyond the actual rhizosphere) - s_shell_init(:,:) = 0._r8 - psi_shell_init(:,:) = 0._r8 - psi_shell_interp(:,:) = 0._r8 - s_shell_interp(:,:) = 0._r8 - - csite_hydr => currentSite%si_hydr - - if(.false.) then - - do j = 1, csite_hydr%nlevrhiz - ! proceed only if l_aroot_coh has changed - if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then - - do k = 1,nshell - psi_shell_init(j,k) = csite_hydr%wrf_soil(j)%p%psi_from_th(csite_hydr%h2osoi_liqvol_shell(j,k)) - end do - - end if !has l_aroot_coh changed? - enddo - - ! interpolate initial psi values by layer and shell - ! BOC...To-Do: need to constrain psi to be within realistic limits (i.e., < 0) - do j = 1,csite_hydr%nlevrhiz - ! proceed only if l_aroot_coh has changed - if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then - - ! fine root length increased, thus shrinking the rhizosphere size - if(csite_hydr%r_node_shell(j,nshell) < csite_hydr%r_node_shell_init(j,nshell)) then - r_delta = csite_hydr%r_node_shell(j,1) - csite_hydr%r_node_shell_init(j,1) - !dpsidr = (psi_shell_init(j,2) - psi_shell_init(j,1)) / & - ! (csite_hydr%r_node_shell_init(j,2) - csite_hydr%r_node_shell_init(j,1)) - - ! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! HACK for special case of nshell = 1 -- compiler throws error because of index 2 in above line, - ! even though at run-time the code should skip over this section: MUST FIX - ! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - dpsidr = (psi_shell_init(j,1) - psi_shell_init(j,1)) / & - (csite_hydr%r_node_shell_init(j,1) - csite_hydr%r_node_shell_init(j,1)) - psi_shell_interp(j,1) = dpsidr * r_delta - do k = 2,nshell - r_delta = csite_hydr%r_node_shell(j,k) - csite_hydr%r_node_shell_init(j,k) - dpsidr = (psi_shell_init(j,k) - psi_shell_init(j,k-1)) / & - (csite_hydr%r_node_shell_init(j,k) - csite_hydr%r_node_shell_init(j,k-1)) - psi_shell_interp(j,k) = dpsidr * r_delta - enddo - else - ! fine root length decreased, thus increasing the rhizosphere size - do k = 1,(nshell-1) - r_delta = csite_hydr%r_node_shell(j,k) - csite_hydr%r_node_shell_init(j,k) - dpsidr = (psi_shell_init(j,k+1) - psi_shell_init(j,k)) / & - (csite_hydr%r_node_shell_init(j,k+1) - csite_hydr%r_node_shell_init(j,k)) - psi_shell_interp(j,k) = dpsidr * r_delta - enddo - r_delta = csite_hydr%r_node_shell(j,nshell) - csite_hydr%r_node_shell_init(j,nshell) - !dpsidr = (psi_shell_init(j,nshell) - psi_shell_init(j,nshell-1)) / & - ! (csite_hydr%r_node_shell_init(j,nshell) - csite_hydr%r_node_shell_init(j,nshell-1)) - - ! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! HACK for special case of nshell = 1 -- compiler throws error because of index nshell-1 in - ! above line, even though at run-time the code should skip over this section: MUST FIX - ! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - dpsidr = (psi_shell_init(j,nshell) - psi_shell_init(j,nshell)) / & - (csite_hydr%r_node_shell_init(j,nshell) - csite_hydr%r_node_shell_init(j,nshell)) - - psi_shell_interp(j,k) = dpsidr * r_delta - end if - end if !has l_aroot_coh changed? - enddo - - ! 1st guess at new s based on interpolated psi - do j = 1,csite_hydr%nlevrhiz - j_bc = j+csite_hydr%i_rhiz_t-1 - - ! proceed only if l_aroot_coh has changed - if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then - - s_shell_interp(j,k) = ( csite_hydr%wrf_soil(j)%p%th_from_psi(psi_shell_interp(j,k)) - bc_in%watres_sisl(j_bc)) / & - (bc_in%watres_sisl(j_bc)+bc_in%watres_sisl(j_bc)) - - end if !has l_aroot_coh changed? - enddo - - ! accumlate water across shells for each layer (initial and interpolated) - do j = 1,csite_hydr%nlevrhiz - j_bc = j+csite_hydr%i_rhiz_t-1 - ! proceed only if l_aroot_coh has changed - if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then - w_layer_init(j) = 0._r8 - w_layer_interp(j) = 0._r8 - v_rhiz(j) = 0._r8 - do k = 1,nshell - w_layer_init(j) = w_layer_init(j) + denh2o * & - (csite_hydr%v_shell_init(j,k)*csite_hydr%h2osoi_liqvol_shell(j,k) ) - w_layer_interp(j) = w_layer_interp(j) + denh2o * & - (csite_hydr%v_shell(j,k) * & - (s_shell_interp(j,k)*(bc_in%watsat_sisl(j_bc)-bc_in%watres_sisl(j_bc))+bc_in%watres_sisl(j_bc)) ) - v_rhiz(j) = v_rhiz(j) + csite_hydr%v_shell(j,k) - enddo - end if !has l_aroot_coh changed? - enddo - - ! estimate delta_s across all shells needed to ensure total water in each layer doesn't change - ! BOC...FIX: need to handle special cases where delta_s causes s_shell to go above or below 1 or 0, respectively. - do j = 1,csite_hydr%nlevrhiz - j_bc = j+csite_hydr%i_rhiz_t-1 - ! proceed only if l_aroot_coh has changed - if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then - delta_s(j) = (( w_layer_init(j) - w_layer_interp(j) )/( v_rhiz(j) * denh2o ) - bc_in%watres_sisl(j_bc)) / & - (bc_in%watsat_sisl(j_bc)-bc_in%watres_sisl(j_bc)) - end if !has l_aroot_coh changed? - enddo - - ! update h2osoi_liqvol_shell and h2osoi_liq_shell - do j = 1,csite_hydr%nlevrhiz - j_bc = j+csite_hydr%i_rhiz_t-1 - ! proceed only if l_aroot_coh has changed - if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then - w_layer_new(j) = 0._r8 - do k = 1,nshell - s_shell_interp(j,k) = s_shell_interp(j,k) + delta_s(j) - csite_hydr%h2osoi_liqvol_shell(j,k) = s_shell_interp(j,k) * & - ( bc_in%watsat_sisl(j_bc)-bc_in%watres_sisl(j_bc) ) + bc_in%watres_sisl(j_bc) - w_shell_new = csite_hydr%h2osoi_liqvol_shell(j,k) * & - csite_hydr%v_shell(j,k) - w_layer_new(j) = w_layer_new(j) + w_shell_new - enddo - h2osoi_liq_col_new(j) = w_layer_new(j)/ v_rhiz(j) - end if !has l_aroot_coh changed? - enddo - - ! balance check - do j = 1,csite_hydr%nlevrhiz - j_bc = j+csite_hydr%i_rhiz_t-1 - errh2o(j) = h2osoi_liq_col_new(j) - bc_in%h2o_liq_sisl(j_bc) - if (abs(errh2o(j)) > 1.e-4_r8) then - write(fates_log(),*)'WARNING: water balance error ',& - ' updating rhizosphere shells: ',j,errh2o(j) - write(fates_log(),*)'errh2o= ',errh2o(j), ' [kg/m2]' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - enddo - - end if !nshell > 1 - - end subroutine UpdateSizeDepRhizHydStates + site_hydr%rootuptake0_scpf(sc,ft) = site_hydr%rootuptake0_scpf(sc,ft) + & + SumBetweenDepths(site_hydr,0._r8,0.1_r8,rootuptake(1:nlevrhiz))*ccohort%n/dtime - ! ==================================================================================== - - subroutine BTranForHLMDiagnosticsFromCohortHydr(nsites,sites,bc_out) + site_hydr%rootuptake10_scpf(sc,ft) = site_hydr%rootuptake10_scpf(sc,ft) + & + SumBetweenDepths(site_hydr,0.1_r8,0.5_r8,rootuptake(1:nlevrhiz))*ccohort%n/dtime - ! Arguments - integer,intent(in) :: nsites - type(ed_site_type),intent(inout),target :: sites(nsites) - type(bc_out_type),intent(inout) :: bc_out(nsites) + site_hydr%rootuptake50_scpf(sc,ft) = site_hydr%rootuptake50_scpf(sc,ft) + & + SumBetweenDepths(site_hydr,0.5_r8,1.0_r8,rootuptake(1:nlevrhiz))*ccohort%n/dtime - ! Locals - integer :: s - integer :: ifp - real(r8) :: balive_patch - type(ed_patch_type),pointer :: cpatch - type(ed_cohort_type),pointer :: ccohort + site_hydr%rootuptake100_scpf(sc,ft) = site_hydr%rootuptake100_scpf(sc,ft) + & + SumBetweenDepths(site_hydr,1.0_r8,1.e10_r8,rootuptake(1:nlevrhiz))*ccohort%n/dtime - do s = 1,nsites + ! --------------------------------------------------------- + ! Update water potential and frac total conductivity + ! of plant compartments + ! --------------------------------------------------------- - ifp = 0 - cpatch => sites(s)%oldest_patch - do while (associated(cpatch)) - ifp=ifp+1 - - balive_patch = 0._r8 - ccohort=>cpatch%tallest - do while(associated(ccohort)) - balive_patch = balive_patch + & - (cCohort%prt%GetState(fnrt_organ, all_carbon_elements) + & - cCohort%prt%GetState(sapw_organ, all_carbon_elements) + & - cCohort%prt%GetState(leaf_organ, all_carbon_elements))* ccohort%n - ccohort => ccohort%shorter - enddo !cohort - - bc_out(s)%btran_pa(ifp) = 0.0_r8 - ccohort=>cpatch%tallest - do while(associated(ccohort)) - bc_out(s)%btran_pa(ifp) = bc_out(s)%btran_pa(ifp) + & - ccohort%co_hydr%btran * & - (cCohort%prt%GetState(fnrt_organ, all_carbon_elements) + & - cCohort%prt%GetState(sapw_organ, all_carbon_elements) + & - cCohort%prt%GetState(leaf_organ, all_carbon_elements)) * & - ccohort%n / balive_patch - ccohort => ccohort%shorter - enddo !cohort - cpatch => cpatch%younger - enddo !end patch loop - end do - return - end subroutine BTranForHLMDiagnosticsFromCohortHydr + call UpdatePlantPsiFTCFromTheta(ccohort,site_hydr) - ! ========================================================================== + ccohort_hydr%btran = wkf_plant(stomata_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_ag(1)) - subroutine FillDrainRhizShells(nsites, sites, bc_in, bc_out) - ! - ! Created by Brad Christoffersen, Jan 2016 - ! - ! !DESCRIPTION: - ! Parses out mean vertical water fluxes resulting from infiltration, - ! drainage, and vertical water movement (dwat_kgm2) over radially stratified - ! rhizosphere shells. - ! - ! The approach used is heuristic, but based on the principle that water - ! fluxing out of a layer will preferentially come from rhizosphere - ! shells with higher water contents/potentials within that layer, and - ! alternatively, that water fluxing into a layer will preferentially go - ! into shells with lower water contents/potentials. - ! - ! This principle is implemented by filling (draining) the rhizosphere - ! shells in order from the driest (wettest) shell to the wettest (driest). - ! Each shell is filled (drained) up (down) to the next wettest (driest) - ! shell until the change in mean layer water (dwat_kgm2) is accounted for. - ! - ! !USES: - ! - ! !ARGUMENTS: - integer, intent(in) :: nsites - type(ed_site_type), intent(inout), target :: sites(nsites) - type(bc_in_type), intent(in) :: bc_in(nsites) - type(bc_out_type), intent(inout) :: bc_out(nsites) - ! Locals - type(ed_site_hydr_type), pointer :: csite_hydr ! pointer to site hydraulics object - real(r8) :: dwat_kgm2 ! change in layer water content [kg/m2] - integer :: s,j,k ! site, soil layer, rhizosphere shell indicies - integer :: i,f,ff,kk ! indicies - integer :: j_bc ! layer index for matching boundary condition soil layers - integer :: indexj ! column and layer indices where there is a water balance error - integer :: ordered(nshell) = (/(i,i=1,nshell,1)/) ! array of rhizosphere indices which have been ordered - real(r8) :: area_col ! column area [m2] - real(r8) :: v_cum ! cumulative shell volume from driest/wettest shell to kth shell [m3] - real(r8) :: dwat_kg ! water remaining to be distributed across shells [kg] - real(r8) :: thdiff ! water content difference between ordered adjacent rhiz shells [m3 m-3] - real(r8) :: wdiff ! mass of water represented by thdiff over previous k shells [kg] - real(r8) :: errh2o(nlevsoi_hyd_max) ! water budget error after updating [kg/m2] - real(r8) :: cumShellH2O ! sum of water in all the shells of a specific layer [kg/m2] - real(r8) :: h2osoi_liq_shell(nlevsoi_hyd_max,nshell) ! water in the rhizosphere shells [kg] - integer :: tmp ! temporary - logical :: found ! flag in search loop - !----------------------------------------------------------------------- + ccohort => ccohort%shorter + enddo !cohort + endif ! not barground patch + cpatch => cpatch%younger + enddo !patch - do s = 1,nsites + ! -------------------------------------------------------------------------------- + ! The cohort level water fluxes are complete, the remainder of this subroutine + ! is dedicated to doing site level resulting mass balance calculations and checks + ! -------------------------------------------------------------------------------- + ! Calculate the amount of water fluxing through the roots. It is the sum + ! of the change in thr rhizosphere shells. Note that following this calculation + ! we may adjust the change in soil water to avoid super-saturation and sub-residual + ! water contents. But the pre-adjusted value is the actual amount of root flux. + ! [kg/m2] - ! First step, identify how the liquid water in each layer has changed - ! since the last time it was updated. This should be due to drainage. - ! The drainage component should be the total change in liquid water content from the last time - ! the hydraulics driver was called, and then adding back in the losses due to root uptake - ! (which was already taken out). - - ! BOC: This was previously in HydrologyDrainage: - - csite_hydr => sites(s)%si_hydr - - do j = 1,csite_hydr%nlevrhiz - j_bc = j+csite_hydr%i_rhiz_t-1 - - cumShellH2O=sum(csite_hydr%h2osoi_liqvol_shell(j,:) *csite_hydr%v_shell(j,:)) * denh2o*AREA_INV - - dwat_kgm2 = bc_in(s)%h2o_liq_sisl(j_bc) - cumShellH2O - - dwat_kg = dwat_kgm2 * AREA - - ! order shells in terms of increasing or decreasing volumetric water content - ! algorithm same as that used in histFileMod.F90 to alphabetize history tape contents - if(nshell > 1) then - do k = nshell-1,1,-1 - do kk = 1,k - if (csite_hydr%h2osoi_liqvol_shell(j,ordered(kk)) > & - csite_hydr%h2osoi_liqvol_shell(j,ordered(kk+1))) then - if (dwat_kg > 0._r8) then !order increasing - tmp = ordered(kk) - ordered(kk) = ordered(kk+1) - ordered(kk+1) = tmp - end if - else - if (dwat_kg < 0._r8) then !order decreasing - tmp = ordered(kk) - ordered(kk) = ordered(kk+1) - ordered(kk+1) = tmp - end if - end if - enddo - enddo - end if - - ! fill shells with water up to the water content of the next-wettest shell, - ! in order from driest to wettest (dwat_kg > 0) - ! ------ OR ------ - ! drain shells' water down to the water content of the next-driest shell, - ! in order from wettest to driest (dwat_kg < 0) - k = 1 - do while ( (dwat_kg /= 0._r8) .and. (k < nshell) ) - thdiff = csite_hydr%h2osoi_liqvol_shell(j,ordered(k+1)) - & - csite_hydr%h2osoi_liqvol_shell(j,ordered(k)) - v_cum = sum(csite_hydr%v_shell(j,ordered(1:k))) - wdiff = thdiff * v_cum * denh2o ! change in h2o [kg / ha] for shells ordered(1:k) - if(abs(dwat_kg) >= abs(wdiff)) then - csite_hydr%h2osoi_liqvol_shell(j,ordered(1:k)) = csite_hydr%h2osoi_liqvol_shell(j,ordered(k+1)) - dwat_kg = dwat_kg - wdiff - else - csite_hydr%h2osoi_liqvol_shell(j,ordered(1:k)) = & - csite_hydr%h2osoi_liqvol_shell(j,ordered(1:k)) + dwat_kg/denh2o/v_cum - dwat_kg = 0._r8 - end if - k = k + 1 - enddo - - if (dwat_kg /= 0._r8) then - v_cum = sum(csite_hydr%v_shell(j,ordered(1:nshell))) - thdiff = dwat_kg / v_cum / denh2o - do k = nshell, 1, -1 - csite_hydr%h2osoi_liqvol_shell(j,k) = csite_hydr%h2osoi_liqvol_shell(j,k) + thdiff - end do - end if - - ! m3/m3 * Total volume m3 * kg/m3 = kg - h2osoi_liq_shell(j,:) = csite_hydr%h2osoi_liqvol_shell(j,:) * & - csite_hydr%v_shell(j,:) * denh2o - - - errh2o(j) = sum(h2osoi_liq_shell(j,:))*AREA_INV - bc_in(s)%h2o_liq_sisl(j_bc) - - if (abs(errh2o(j)) > 1.e-9_r8) then - write(fates_log(),*)'WARNING: water balance error in FillDrainRhizShells' - write(fates_log(),*)'errh2o= ',errh2o(j), ' [kg/m2]' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end do + root_flux = -sum(dth_layershell_col(1:site_hydr%nlevrhiz,:)*site_hydr%v_shell(:,:))*denh2o*AREA_INV - end do - return - end subroutine FillDrainRhizShells - ! ==================================================================================== + do j=1,site_hydr%nlevrhiz + j_bc = j+site_hydr%i_rhiz_t-1 - subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) + ! Update the site-level state variable + ! rhizosphere shell water content [m3/m3] + site_hydr%h2osoi_liqvol_shell(j,:) = site_hydr%h2osoi_liqvol_shell(j,:) + & + dth_layershell_col(j,:) - ! ---------------------------------------------------------------------------------- - ! added by Brad Christoffersen Jan 2016 for use in ED hydraulics - ! van Genuchten (1980)-specific functions for the swc (soil water characteristic) - ! and for the kunsat (unsaturated hydraulic conductivity) curves. Test mod 06/20/2016 - ! resolved the mass-balance bugs and tested Jan, 2018 by C. XU - ! - ! BOC...for quick implementation avoided JT's abstract interface, - ! but these should be converted to interfaces in the future - ! ---------------------------------------------------------------------------------- + bc_out(s)%qflx_soil2root_sisl(j_bc) = & + -(sum(dth_layershell_col(j,:)*site_hydr%v_shell(j,:))*denh2o*AREA_INV/dtime) + & + site_hydr%recruit_w_uptake(j) - ! - ! !DESCRIPTION: - !s - ! !USES: - use FatesUtilsMod , only : check_var_real - ! ARGUMENTS: - ! ----------------------------------------------------------------------------------- - integer,intent(in) :: nsites - type(ed_site_type),intent(inout),target :: sites(nsites) - type(bc_in_type),intent(in) :: bc_in(nsites) - type(bc_out_type),intent(inout) :: bc_out(nsites) - real(r8),intent(in) :: dtime + ! Save the amount of liquid soil water known to the model after root uptake + ! This calculation also assumes that 1mm of water is 1kg + site_hydr%h2osoi_liq_prev(j) = bc_in(s)%h2o_liq_sisl(j_bc) - & + dtime*bc_out(s)%qflx_soil2root_sisl(j_bc) - ! - ! !LOCAL VARIABLES: - integer :: iv ! leaf layer - integer :: ifp ! index of FATES patch - integer :: s ! index of FATES site - integer :: i ! shell index - integer :: j,jj ! soil layer - integer :: j_bc ! soil layer index for boundary conditions - integer :: k ! 1D plant-soil continuum array - integer :: ft ! plant functional type index - integer :: sz ! plant's size class index - integer :: t ! previous timesteps (for lwp stability calculation) - integer :: nstep !number of time steps - !---------------------------------------------------------------------- - - type (ed_patch_type), pointer :: cpatch ! current patch pointer - type (ed_cohort_type), pointer :: ccohort ! current cohort pointer - type(ed_site_hydr_type), pointer :: site_hydr ! site hydraulics pointer - type(ed_cohort_hydr_type), pointer :: ccohort_hydr ! cohort hydraulics pointer - - ! Local arrays - - ! accumulated water content change over all cohorts in a column [m3 m-3] - real(r8) :: dth_layershell_col(nlevsoi_hyd_max,nshell) - - ! array of soil layer indices which have been ordered - integer :: ordered(nlevsoi_hyd_max) = (/(j,j=1,nlevsoi_hyd_max,1)/) - - ! total absorbing root & rhizosphere conductance (over all shells) by soil layer [MPa] - real(r8) :: kbg_layer(nlevsoi_hyd_max) - real(r8) :: rootuptake(nlevsoi_hyd_max) ! mass-flux from 1st rhizosphere to absorbing roots [kg/indiv/layer/step] - - real(r8) :: site_runoff ! If plants are pushing water into saturated soils, we create - ! runoff. This is either banked, or sent to the correct flux pool [kg/m2] - real(r8) :: aroot_frac_plant ! The fraction of the total length of absorbing roots contained in one soil layer - ! that are devoted to a single plant - real(r8) :: wb_err_plant ! Solve error for a single plant [kg] - real(r8) :: wb_check_site ! the water balance error we get from summing fluxes - ! and changes in storage - ! and is just a double check on our error accounting). [kg/m2] - real(r8) :: dwat_plant ! change in water mass in the whole plant [kg] - real(r8) :: qflx_tran_veg_indiv ! individiual transpiration rate [kgh2o indiv-1 s-1] - real(r8) :: gscan_patch ! sum of ccohort%gscan across all cohorts within a patch - real(r8) :: sapflow ! mass-flux for the cohort between transporting root and stem [kg/indiv/step] - real(r8) :: prev_h2oveg ! plant water storage at start of timestep (kg/m2) - real(r8) :: prev_h2osoil ! soil water storage at start of timestep (kg/m2) - logical :: recruitflag ! flag to check if there is newly recruited cohorts - real(r8) :: root_flux ! total water flux into roots [kg/m2] - real(r8) :: transp_flux ! total transpiration flux from plants [kg/m2] - real(r8) :: delta_plant_storage ! change in plant water storage over the step [kg/m2] - real(r8) :: delta_soil_storage ! change in soil water storage over the step [kg/m2] - real(r8) :: sumcheck ! used to debug mass balance in soil horizon diagnostics - integer :: nlevrhiz ! local for number of rhizosphere levels - integer :: sc ! size class index - - ! ---------------------------------------------------------------------------------- - ! Important note: We are interested in calculating the total fluxes in and out of the - ! site/column. Usually, when we do things like this, we acknowledge that FATES - ! does not consider the bare ground patch. However, since this routine - ! calculates "column level" fluxes, we have to factor in that patch-level fluxes - ! are only accounting for a portion of the area. - ! ---------------------------------------------------------------------------------- + ! We accept that it is possible for gravity to push + ! water into saturated soils, particularly at night when + ! transpiration has stopped. In the real world, the water + ! would be driven out of the layer, although we have no + ! boundary flux on the rhizospheres in these substeps. To accomodate + ! this, if soils are pushed beyond saturation minus a small buffer + ! then we remove that excess, send it to a runoff pool, and + ! fix the node's water content to the saturation minus buffer value - !For newly recruited cohorts, add the water uptake demand to csite_hydr%recruit_w_uptake - call RecruitWUptake(nsites,sites,bc_in,dtime,recruitflag) + site_runoff = 0._r8 + if(purge_supersaturation) then + do i = 1,nshell + if(site_hydr%h2osoi_liqvol_shell(j,i)>(bc_in(s)%watsat_sisl(j_bc)-thsat_buff)) then - !update water storage in veg after incorporating newly recuited cohorts - if(recruitflag) call UpdateH2OVeg(nsites,sites,bc_out) + ! [m3/m3] * [kg/m3] * [m3/site] * [site/m2] => [kg/m2] + site_runoff = site_runoff + & + (site_hydr%h2osoi_liqvol_shell(j,i)-(bc_in(s)%watsat_sisl(j_bc)-thsat_buff)) * & + site_hydr%v_shell(j,i)*AREA_INV*denh2o - do s = 1, nsites + site_hydr%h2osoi_liqvol_shell(j,i) = bc_in(s)%watsat_sisl(j_bc)-thsat_buff - site_hydr => sites(s)%si_hydr + end if + end do - nlevrhiz = site_hydr%nlevrhiz - - ! AVERAGE ROOT WATER UPTAKE (BY RHIZOSPHERE SHELL) ACROSS ALL COHORTS WITHIN A COLUMN - dth_layershell_col(:,:) = 0._r8 - site_hydr%dwat_veg = 0._r8 - site_hydr%errh2o_hyd = 0._r8 - prev_h2oveg = site_hydr%h2oveg - prev_h2osoil = sum(site_hydr%h2osoi_liqvol_shell(:,:) * & - site_hydr%v_shell(:,:)) * denh2o * AREA_INV + bc_out(s)%qflx_ro_sisl(j_bc) = site_runoff/dtime + end if + enddo - bc_out(s)%qflx_ro_sisl(:) = 0._r8 - ! Zero out diagnotsics that rely on accumulation - site_hydr%sapflow_scpf(:,:) = 0._r8 - site_hydr%rootuptake_sl(:) = 0._r8 - site_hydr%rootuptake0_scpf(:,:) = 0._r8 - site_hydr%rootuptake10_scpf(:,:) = 0._r8 - site_hydr%rootuptake50_scpf(:,:) = 0._r8 - site_hydr%rootuptake100_scpf(:,:) = 0._r8 + ! Note that the cohort-level solvers are expected to update + ! site_hydr%h2oveg - ! Initialize water mass balancing terms [kg h2o / m2] - ! -------------------------------------------------------------------------------- - transp_flux = 0._r8 - root_flux = 0._r8 - - ! Initialize the delta in soil water and plant water storage - ! with the initial condition. - - !err_soil = delta_soil_storage - root_flux - !err_plot = delta_plant_storage - (root_flux - transp_flux) - - ifp = 0 - cpatch => sites(s)%oldest_patch - do while (associated(cpatch)) - if(cpatch%nocomp_pft_label.ne.0)then - ifp = ifp + 1 - - ! ---------------------------------------------------------------------------- - ! Objective: Partition the transpiration flux - ! specfied by the land model to the cohorts. The weighting - ! factor we use to downscale is the cohort combo term: g_sb_laweight - ! This term is the stomatal conductance multiplied by total leaf - ! area. gscan_patch is the sum over all cohorts, used to normalize. - ! ---------------------------------------------------------------------------- - - gscan_patch = 0.0_r8 - ccohort=>cpatch%tallest - do while(associated(ccohort)) - ccohort_hydr => ccohort%co_hydr - gscan_patch = gscan_patch + ccohort%g_sb_laweight - ccohort => ccohort%shorter - enddo !cohort - - ! The HLM predicted transpiration flux even though no leaves are present? - if(bc_in(s)%qflx_transp_pa(ifp) > 1.e-10_r8 .and. gscan_patchcpatch%tallest - do while(associated(ccohort)) + ! Calculate site total kg's of runoff + site_runoff = sum(bc_out(s)%qflx_ro_sisl(:))*dtime - ccohort_hydr => ccohort%co_hydr - ft = ccohort%pft - - ! Relative transpiration of this cohort from the whole patch - ! Note that g_sb_laweight / gscan_patch is the weighting that gives cohort contribution per area - ! [mm H2O/plant/s] = [mm H2O/ m2 / s] * [m2 / patch] * [cohort/plant] * [patch/cohort] - - if(ccohort%g_sb_laweight>nearzero) then - qflx_tran_veg_indiv = bc_in(s)%qflx_transp_pa(ifp) * cpatch%total_canopy_area * & - (ccohort%g_sb_laweight/gscan_patch)/ccohort%n - else - qflx_tran_veg_indiv = 0._r8 - end if - - ! Save the transpiration flux for diagnostics (currently its a constant boundary condition) - ccohort_hydr%qtop = qflx_tran_veg_indiv*dtime - - transp_flux = transp_flux + (qflx_tran_veg_indiv*dtime)*ccohort%n*AREA_INV - - ! VERTICAL LAYER CONTRIBUTION TO TOTAL ROOT WATER UPTAKE OR LOSS - ! _____ - ! | | - ! |leaf | - ! |_____| - ! / - ! \ - ! / - ! __\__ - ! | | - ! |stem | - ! |_____| - !------/----------------_____--------------------------------- - ! \ | | | | | | | - ! / _/\/\|aroot| | |shell | shell | shell | layer j-1 - ! \ _/ |_____| | | k-1 | k | k+1 | - !------/------_/--------_____-------------------------------------- - ! \ _/ | | | | | | | - ! __/__ / _/\/\/\/\/|aroot| | | shell | shell | shell | layer j - ! | |_/ |_____| | | k-1 | k | k+1 | - !---|troot|-------------_____---------------------------------------------- - ! |_____|\_ | | | | | | | - ! \/\/\/\/\/|aroot| | | shell | shell | shell | layer j+1 - ! |_____| | | k-1 | k | k+1 | - !--------------------------------------------------------------------------- - - - if(use_2d_hydrosolve) then + delta_plant_storage = site_hydr%h2oveg - prev_h2oveg - call MatSolve2D(bc_in(s),site_hydr,ccohort,ccohort_hydr, & - dtime,qflx_tran_veg_indiv, & - sapflow,rootuptake(1:nlevrhiz),wb_err_plant,dwat_plant, & - dth_layershell_col) - - else - - ! --------------------------------------------------------------------------------- - ! Approach: do nlevsoi_hyd sequential solutions to Richards' equation, - ! each of which encompass all plant nodes and soil nodes for a given soil layer j, - ! with the timestep fraction for each layer-specific solution proportional to each - ! layer's contribution to the total root-soil conductance - ! Water potential in plant nodes is updated after each solution - ! As such, the order across soil layers in which the solution is conducted matters. - ! For now, the order proceeds across soil layers in order of decreasing root-soil conductance - ! NET EFFECT: total water removed from plant-soil system remains the same: it - ! sums up to total transpiration (qflx_tran_veg_indiv*dtime) - ! root water uptake in each layer is proportional to each layer's total - ! root length density and soil matric potential - ! root hydraulic redistribution emerges within this sequence when a - ! layers have transporting-to-absorbing root water potential gradients of opposite sign - ! ----------------------------------------------------------------------------------- - - call OrderLayersForSolve1D(site_hydr, ccohort, ccohort_hydr, ordered, kbg_layer) - - call ImTaylorSolve1D(site_hydr,ccohort,ccohort_hydr, & - dtime,qflx_tran_veg_indiv,ordered, kbg_layer, & - sapflow,rootuptake(1:nlevrhiz), & - wb_err_plant,dwat_plant, & - dth_layershell_col) - - end if - - ! Remember the error for the cohort - ccohort_hydr%errh2o = ccohort_hydr%errh2o + wb_err_plant - - ! Update total error in [kg/m2 ground] - site_hydr%errh2o_hyd = site_hydr%errh2o_hyd + wb_err_plant*ccohort%n*AREA_INV - - ! Accumulate site level diagnostic of plant water change [kg/m2] - ! (this is zerod) - site_hydr%dwat_veg = site_hydr%dwat_veg + dwat_plant*ccohort%n*AREA_INV - - ! Update total site-level stored plant water [kg/m2] - ! (this is not zerod, but incremented) - site_hydr%h2oveg = site_hydr%h2oveg + dwat_plant*ccohort%n*AREA_INV - - sc = ccohort%size_class - - ! Sapflow diagnostic [kg/ha/s] - site_hydr%sapflow_scpf(sc,ft) = site_hydr%sapflow_scpf(sc,ft) + sapflow*ccohort%n/dtime - - ! Root uptake per rhiz layer [kg/ha/s] - site_hydr%rootuptake_sl(1:nlevrhiz) = site_hydr%rootuptake_sl(1:nlevrhiz) + & - rootuptake(1:nlevrhiz)*ccohort%n/dtime - - ! Root uptake per pft x size class, over set layer depths [kg/ha/m/s] - ! These are normalized by depth (in case the desired horizon extends - ! beyond the actual rhizosphere) - - site_hydr%rootuptake0_scpf(sc,ft) = site_hydr%rootuptake0_scpf(sc,ft) + & - SumBetweenDepths(site_hydr,0._r8,0.1_r8,rootuptake(1:nlevrhiz))*ccohort%n/dtime - - site_hydr%rootuptake10_scpf(sc,ft) = site_hydr%rootuptake10_scpf(sc,ft) + & - SumBetweenDepths(site_hydr,0.1_r8,0.5_r8,rootuptake(1:nlevrhiz))*ccohort%n/dtime - - site_hydr%rootuptake50_scpf(sc,ft) = site_hydr%rootuptake50_scpf(sc,ft) + & - SumBetweenDepths(site_hydr,0.5_r8,1.0_r8,rootuptake(1:nlevrhiz))*ccohort%n/dtime - - site_hydr%rootuptake100_scpf(sc,ft) = site_hydr%rootuptake100_scpf(sc,ft) + & - SumBetweenDepths(site_hydr,1.0_r8,1.e10_r8,rootuptake(1:nlevrhiz))*ccohort%n/dtime - - ! --------------------------------------------------------- - ! Update water potential and frac total conductivity - ! of plant compartments - ! --------------------------------------------------------- - - call UpdatePlantPsiFTCFromTheta(ccohort,site_hydr) - - ccohort_hydr%btran = wkf_plant(stomata_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_ag(1)) - - - ccohort => ccohort%shorter - enddo !cohort - endif ! not barground patch - cpatch => cpatch%younger - enddo !patch + delta_soil_storage = sum(site_hydr%h2osoi_liqvol_shell(:,:) * & + site_hydr%v_shell(:,:)) * denh2o * AREA_INV - prev_h2osoil - ! -------------------------------------------------------------------------------- - ! The cohort level water fluxes are complete, the remainder of this subroutine - ! is dedicated to doing site level resulting mass balance calculations and checks - ! -------------------------------------------------------------------------------- + if(abs(delta_plant_storage - (root_flux - transp_flux)) > 1.e-3_r8 ) then + write(fates_log(),*) 'Site plant water balance does not close' + write(fates_log(),*) 'balance error: ',abs(delta_plant_storage - (root_flux - transp_flux)) + write(fates_log(),*) 'delta plant storage: ',delta_plant_storage,' [kg/m2]' + write(fates_log(),*) 'integrated root flux: ',root_flux,' [kg/m2]' + write(fates_log(),*) 'transpiration flux: ',transp_flux,' [kg/m2]' + write(fates_log(),*) 'end storage: ',site_hydr%h2oveg + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if - ! Calculate the amount of water fluxing through the roots. It is the sum - ! of the change in thr rhizosphere shells. Note that following this calculation - ! we may adjust the change in soil water to avoid super-saturation and sub-residual - ! water contents. But the pre-adjusted value is the actual amount of root flux. - ! [kg/m2] - - root_flux = -sum(dth_layershell_col(1:site_hydr%nlevrhiz,:)*site_hydr%v_shell(:,:))*denh2o*AREA_INV - - - do j=1,site_hydr%nlevrhiz - j_bc = j+site_hydr%i_rhiz_t-1 - - ! Update the site-level state variable - ! rhizosphere shell water content [m3/m3] - site_hydr%h2osoi_liqvol_shell(j,:) = site_hydr%h2osoi_liqvol_shell(j,:) + & - dth_layershell_col(j,:) - - - bc_out(s)%qflx_soil2root_sisl(j_bc) = & - -(sum(dth_layershell_col(j,:)*site_hydr%v_shell(j,:))*denh2o*AREA_INV/dtime) + & - site_hydr%recruit_w_uptake(j) - - - ! Save the amount of liquid soil water known to the model after root uptake - ! This calculation also assumes that 1mm of water is 1kg - site_hydr%h2osoi_liq_prev(j) = bc_in(s)%h2o_liq_sisl(j_bc) - & - dtime*bc_out(s)%qflx_soil2root_sisl(j_bc) - - - ! We accept that it is possible for gravity to push - ! water into saturated soils, particularly at night when - ! transpiration has stopped. In the real world, the water - ! would be driven out of the layer, although we have no - ! boundary flux on the rhizospheres in these substeps. To accomodate - ! this, if soils are pushed beyond saturation minus a small buffer - ! then we remove that excess, send it to a runoff pool, and - ! fix the node's water content to the saturation minus buffer value - - site_runoff = 0._r8 - if(purge_supersaturation) then - do i = 1,nshell - if(site_hydr%h2osoi_liqvol_shell(j,i)>(bc_in(s)%watsat_sisl(j_bc)-thsat_buff)) then - - ! [m3/m3] * [kg/m3] * [m3/site] * [site/m2] => [kg/m2] - site_runoff = site_runoff + & - (site_hydr%h2osoi_liqvol_shell(j,i)-(bc_in(s)%watsat_sisl(j_bc)-thsat_buff)) * & - site_hydr%v_shell(j,i)*AREA_INV*denh2o - - site_hydr%h2osoi_liqvol_shell(j,i) = bc_in(s)%watsat_sisl(j_bc)-thsat_buff - - end if - end do - - bc_out(s)%qflx_ro_sisl(j_bc) = site_runoff/dtime - end if - enddo + if(abs(delta_soil_storage + root_flux + site_runoff) > 1.e-3_r8 ) then + write(fates_log(),*) 'Site soil water balance does not close' + write(fates_log(),*) 'delta soil storage: ',delta_soil_storage,' [kg/m2]' + write(fates_log(),*) 'integrated root flux (pos into root): ',root_flux,' [kg/m2]' + write(fates_log(),*) 'site runoff: ',site_runoff,' [kg/m2]' + write(fates_log(),*) 'end storage: ',sum(site_hydr%h2osoi_liqvol_shell(:,:) * & + site_hydr%v_shell(:,:)) * denh2o * AREA_INV, & + ' [kg/m2]' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if - - ! Note that the cohort-level solvers are expected to update - ! site_hydr%h2oveg - - ! Calculate site total kg's of runoff - site_runoff = sum(bc_out(s)%qflx_ro_sisl(:))*dtime - - delta_plant_storage = site_hydr%h2oveg - prev_h2oveg - - delta_soil_storage = sum(site_hydr%h2osoi_liqvol_shell(:,:) * & - site_hydr%v_shell(:,:)) * denh2o * AREA_INV - prev_h2osoil - - if(abs(delta_plant_storage - (root_flux - transp_flux)) > 1.e-3_r8 ) then - write(fates_log(),*) 'Site plant water balance does not close' - write(fates_log(),*) 'balance error: ',abs(delta_plant_storage - (root_flux - transp_flux)) - write(fates_log(),*) 'delta plant storage: ',delta_plant_storage,' [kg/m2]' - write(fates_log(),*) 'integrated root flux: ',root_flux,' [kg/m2]' - write(fates_log(),*) 'transpiration flux: ',transp_flux,' [kg/m2]' - write(fates_log(),*) 'end storage: ',site_hydr%h2oveg - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - if(abs(delta_soil_storage + root_flux + site_runoff) > 1.e-3_r8 ) then - write(fates_log(),*) 'Site soil water balance does not close' - write(fates_log(),*) 'delta soil storage: ',delta_soil_storage,' [kg/m2]' - write(fates_log(),*) 'integrated root flux (pos into root): ',root_flux,' [kg/m2]' - write(fates_log(),*) 'site runoff: ',site_runoff,' [kg/m2]' - write(fates_log(),*) 'end storage: ',sum(site_hydr%h2osoi_liqvol_shell(:,:) * & - site_hydr%v_shell(:,:)) * denh2o * AREA_INV, & - ' [kg/m2]' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if + !----------------------------------------------------------------------- + ! mass balance check and pass the total stored vegetation water to HLM + ! in order for it to fill its balance checks + + + ! Compare the integrated error to the site mass balance + ! error sign is positive towards transpiration overestimation + ! Loss fluxes should = decrease in storage + ! (transp_flux + site_runoff) = -(delta_plant_storage+delta_soil_storage ) + + wb_check_site = delta_plant_storage+delta_soil_storage+site_runoff+transp_flux + + ! if( abs(wb_check_site - site_hydr%errh2o_hyd) > 1.e-5_r8 ) then + ! write(fates_log(),*) 'FATES hydro water ERROR balance does not add up [kg/m2]:',wb_check_site - site_hydr%errh2o_hyd + ! write(fates_log(),*) 'wb_error_site: ',site_hydr%errh2o_hyd + ! write(fates_log(),*) 'wb_check_site: ',wb_check_site + ! write(fates_log(),*) 'delta_plant_storage: ',delta_plant_storage + ! write(fates_log(),*) 'delta_soil_storage: ',delta_soil_storage + ! write(fates_log(),*) 'site_runoff: ',site_runoff + ! write(fates_log(),*) 'transp_flux: ',transp_flux + ! call endrun(msg=errMsg(sourcefile, __LINE__)) + ! end if + + ! Now check on total error + if( abs(wb_check_site) > 1.e-4_r8 ) then + write(fates_log(),*) 'FATES hydro water balance is not so great [kg/m2]' + write(fates_log(),*) 'site_hydr%errh2o_hyd: ',wb_check_site + write(fates_log(),*) 'delta_plant_storage: ',delta_plant_storage + write(fates_log(),*) 'delta_soil_storage: ',delta_soil_storage + write(fates_log(),*) 'site_runoff: ',site_runoff + write(fates_log(),*) 'transp_flux: ',transp_flux + end if - !----------------------------------------------------------------------- - ! mass balance check and pass the total stored vegetation water to HLM - ! in order for it to fill its balance checks - - - ! Compare the integrated error to the site mass balance - ! error sign is positive towards transpiration overestimation - ! Loss fluxes should = decrease in storage - ! (transp_flux + site_runoff) = -(delta_plant_storage+delta_soil_storage ) - - wb_check_site = delta_plant_storage+delta_soil_storage+site_runoff+transp_flux - -! if( abs(wb_check_site - site_hydr%errh2o_hyd) > 1.e-5_r8 ) then -! write(fates_log(),*) 'FATES hydro water ERROR balance does not add up [kg/m2]:',wb_check_site - site_hydr%errh2o_hyd -! write(fates_log(),*) 'wb_error_site: ',site_hydr%errh2o_hyd -! write(fates_log(),*) 'wb_check_site: ',wb_check_site -! write(fates_log(),*) 'delta_plant_storage: ',delta_plant_storage -! write(fates_log(),*) 'delta_soil_storage: ',delta_soil_storage -! write(fates_log(),*) 'site_runoff: ',site_runoff -! write(fates_log(),*) 'transp_flux: ',transp_flux -! call endrun(msg=errMsg(sourcefile, __LINE__)) -! end if - - ! Now check on total error - if( abs(wb_check_site) > 1.e-4_r8 ) then - write(fates_log(),*) 'FATES hydro water balance is not so great [kg/m2]' - write(fates_log(),*) 'site_hydr%errh2o_hyd: ',wb_check_site - write(fates_log(),*) 'delta_plant_storage: ',delta_plant_storage - write(fates_log(),*) 'delta_soil_storage: ',delta_soil_storage - write(fates_log(),*) 'site_runoff: ',site_runoff - write(fates_log(),*) 'transp_flux: ',transp_flux - end if + site_hydr%h2oveg_hydro_err = site_hydr%h2oveg_hydro_err + site_hydr%errh2o_hyd - site_hydr%h2oveg_hydro_err = site_hydr%h2oveg_hydro_err + site_hydr%errh2o_hyd + bc_out(s)%plant_stored_h2o_si = site_hydr%h2oveg + site_hydr%h2oveg_dead - & + site_hydr%h2oveg_growturn_err - & + site_hydr%h2oveg_pheno_err-& + site_hydr%h2oveg_hydro_err - bc_out(s)%plant_stored_h2o_si = site_hydr%h2oveg + site_hydr%h2oveg_dead - & - site_hydr%h2oveg_growturn_err - & - site_hydr%h2oveg_pheno_err-& - site_hydr%h2oveg_hydro_err + enddo !site - enddo !site + return +end subroutine Hydraulics_BC - return - end subroutine Hydraulics_BC +! ===================================================================================== - ! ===================================================================================== +subroutine UpdatePlantKmax(ccohort_hydr,ccohort,csite_hydr) - subroutine UpdatePlantKmax(ccohort_hydr,ccohort,csite_hydr) + ! --------------------------------------------------------------------------------- + ! + ! This routine sets the maximum conductance of all compartments in the plant, from + ! leaves, to stem, to transporting root, to the absorbing roots. + ! These properties are dependent only on the materials (conductivity) and the + ! geometry of the compartments. + ! The units of all K_max values are [kg H2O s-1 MPa-1] + ! + ! There are some different ways to represent overall conductance from node-to-node + ! throughout the hydraulic system. Universally, all can make use of a system + ! where we separate the hydraulic compartments of the nodes into the upper (closer + ! to the sky) and lower (away from the sky) portions of the compartment. It is + ! possible that due to things like xylem taper, the two portions may have different + ! conductivity, and therefore differnet conductances. + ! + ! Assumption 0. This routine calculates maximum conductivity for 1 plant. + ! Assumption 1. The compartment volumes, heights and lengths have all been + ! determined, probably called just before this routine. + ! + ! Steudle, E. Water uptake by roots: effects of water deficit. + ! J Exp Bot 51, 1531-1542, doi:DOI 10.1093/jexbot/51.350.1531 (2000). + ! --------------------------------------------------------------------------------- + + ! Arguments + + type(ed_cohort_hydr_type),intent(inout),target :: ccohort_hydr + type(ed_cohort_type),intent(in),target :: ccohort + type(ed_site_hydr_type),intent(in),target :: csite_hydr + + ! Locals + integer :: k ! Compartment (node) index + integer :: j ! Soil layer index + integer :: k_ag ! Compartment index for above-ground indexed array + integer :: pft ! Plant Functional Type index + real(r8) :: c_sap_dummy ! Dummy variable (unused) with sapwood carbon [kg] + real(r8) :: z_lower ! distance between lower edge and mean petiole height [m] + real(r8) :: z_upper ! distance between upper edge and mean petiole height [m] + real(r8) :: z_node ! distance between compartment center and mph [m] + real(r8) :: kmax_lower ! Max conductance from compartment edge to mph [kg s-1 Mpa-1] + real(r8) :: kmax_node ! Max conductance from compartment edge to mph [kg s-1 Mpa-1] + real(r8) :: kmax_upper ! Max conductance from compartment edge to mph [kg s-1 Mpa-1] + real(r8) :: a_sapwood ! Mean cross section area of sapwood [m2] + real(r8) :: rmin_ag ! Minimum total resistance of all above ground pathways + ! [kg-1 s MPa] + real(r8) :: kmax_bg ! Total maximum conductance of all below-ground pathways + ! from the absorbing roots center nodes to the + ! transporting root center node + real(r8) :: rootfr ! fraction of absorbing root in each soil layer + ! assumes propotion of absorbing root is equal + ! to proportion of total root + real(r8) :: kmax_layer ! max conductance between transporting root node + ! and absorbing root node in each layer [kg s-1 MPa-1] + real(r8) :: surfarea_aroot_layer ! Surface area of absorbing roots in each + ! soil layer [m2] + real(r8) :: sum_l_aroot ! sum of plant's total root length + real(r8),parameter :: min_pet_stem_dz = 0.00001_r8 ! Force at least a small difference + ! in the top of stem and petiole + + + pft = ccohort%pft + + ! Get the cross-section of the plant's sapwood area [m2] + call bsap_allom(ccohort%dbh,pft,ccohort%canopy_trim,a_sapwood,c_sap_dummy) + + ! Leaf Maximum Hydraulic Conductance + ! The starting hypothesis is that there is no resistance inside the + ! leaf, between the petiole and the center of storage. To override + ! this, make provisions by changing the kmax to a not-absurdly high + ! value. It is assumed that the conductance in this default case, + ! is regulated completely by the stem conductance from the stem's + ! center of storage, to the petiole. + + ccohort_hydr%kmax_petiole_to_leaf = 1.e8_r8 + + + ! Stem Maximum Hydraulic Conductance + + do k=1, n_hypool_stem + + ! index for "above-ground" arrays, that contain stem and leaf + ! in one vector + k_ag = k+n_hypool_leaf + + ! Depth from the petiole to the lower, node and upper compartment edges + + z_lower = ccohort_hydr%z_node_ag(n_hypool_leaf) - ccohort_hydr%z_lower_ag(k_ag) + z_node = ccohort_hydr%z_node_ag(n_hypool_leaf) - ccohort_hydr%z_node_ag(k_ag) + z_upper = max( min_pet_stem_dz,ccohort_hydr%z_node_ag(n_hypool_leaf) - & + ccohort_hydr%z_upper_ag(k_ag)) + + + ! Then we calculate the maximum conductance from each the lower, node and upper + ! edges of the compartment to the petiole. The xylem taper factor requires + ! that the kmax it is scaling is from the point of interest to the mean height + ! of the petioles. Then we can back out the conductance over just the path + ! of the upper and lower compartments, but subtracting them as resistors in + ! series. + + ! max conductance from upper edge to mean petiole height + ! If there is no height difference between the upper compartment edge and + ! the petiole, at least give it some nominal amount to void FPE's + kmax_upper = EDPftvarcon_inst%hydr_kmax_node(pft,2) * & + xylemtaper(EDPftvarcon_inst%hydr_p_taper(pft), z_upper) * & + a_sapwood / z_upper + + ! max conductance from node to mean petiole height + kmax_node = EDPftvarcon_inst%hydr_kmax_node(pft,2) * & + xylemtaper(EDPftvarcon_inst%hydr_p_taper(pft), z_node) * & + a_sapwood / z_node + + ! max conductance from lower edge to mean petiole height + kmax_lower = EDPftvarcon_inst%hydr_kmax_node(pft,2) * & + xylemtaper(EDPftvarcon_inst%hydr_p_taper(pft), z_lower) * & + a_sapwood / z_lower + + ! Max conductance over the path of the upper side of the compartment + ccohort_hydr%kmax_stem_upper(k) = (1._r8/kmax_node - 1._r8/kmax_upper)**(-1._r8) + + ! Max conductance over the path on the loewr side of the compartment + ccohort_hydr%kmax_stem_lower(k) = (1._r8/kmax_lower - 1._r8/kmax_node)**(-1._r8) + + if(debug) then + ! The following clauses should never be true: + if( (z_lower < z_node) .or. & + (z_node < z_upper) ) then + write(fates_log(),*) 'Problem calculating stem Kmax' + write(fates_log(),*) z_lower, z_node, z_upper + write(fates_log(),*) kmax_lower*z_lower, kmax_node*z_node, kmax_upper*z_upper + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if - ! --------------------------------------------------------------------------------- - ! - ! This routine sets the maximum conductance of all compartments in the plant, from - ! leaves, to stem, to transporting root, to the absorbing roots. - ! These properties are dependent only on the materials (conductivity) and the - ! geometry of the compartments. - ! The units of all K_max values are [kg H2O s-1 MPa-1] - ! - ! There are some different ways to represent overall conductance from node-to-node - ! throughout the hydraulic system. Universally, all can make use of a system - ! where we separate the hydraulic compartments of the nodes into the upper (closer - ! to the sky) and lower (away from the sky) portions of the compartment. It is - ! possible that due to things like xylem taper, the two portions may have different - ! conductivity, and therefore differnet conductances. - ! - ! Assumption 0. This routine calculates maximum conductivity for 1 plant. - ! Assumption 1. The compartment volumes, heights and lengths have all been - ! determined, probably called just before this routine. - ! - ! Steudle, E. Water uptake by roots: effects of water deficit. - ! J Exp Bot 51, 1531-1542, doi:DOI 10.1093/jexbot/51.350.1531 (2000). - ! --------------------------------------------------------------------------------- + enddo - ! Arguments + ! Maximum conductance of the upper compartment in the transporting root + ! that connects to the lowest stem (btw: z_lower_ag(n_hypool_ag) == 0) - type(ed_cohort_hydr_type),intent(inout),target :: ccohort_hydr - type(ed_cohort_type),intent(in),target :: ccohort - type(ed_site_hydr_type),intent(in),target :: csite_hydr + z_upper = ccohort_hydr%z_lower_ag(n_hypool_leaf) + z_node = ccohort_hydr%z_lower_ag(n_hypool_leaf)-ccohort_hydr%z_node_troot - ! Locals - integer :: k ! Compartment (node) index - integer :: j ! Soil layer index - integer :: k_ag ! Compartment index for above-ground indexed array - integer :: pft ! Plant Functional Type index - real(r8) :: c_sap_dummy ! Dummy variable (unused) with sapwood carbon [kg] - real(r8) :: z_lower ! distance between lower edge and mean petiole height [m] - real(r8) :: z_upper ! distance between upper edge and mean petiole height [m] - real(r8) :: z_node ! distance between compartment center and mph [m] - real(r8) :: kmax_lower ! Max conductance from compartment edge to mph [kg s-1 Mpa-1] - real(r8) :: kmax_node ! Max conductance from compartment edge to mph [kg s-1 Mpa-1] - real(r8) :: kmax_upper ! Max conductance from compartment edge to mph [kg s-1 Mpa-1] - real(r8) :: a_sapwood ! Mean cross section area of sapwood [m2] - real(r8) :: rmin_ag ! Minimum total resistance of all above ground pathways - ! [kg-1 s MPa] - real(r8) :: kmax_bg ! Total maximum conductance of all below-ground pathways - ! from the absorbing roots center nodes to the - ! transporting root center node - real(r8) :: rootfr ! fraction of absorbing root in each soil layer - ! assumes propotion of absorbing root is equal - ! to proportion of total root - real(r8) :: kmax_layer ! max conductance between transporting root node - ! and absorbing root node in each layer [kg s-1 MPa-1] - real(r8) :: surfarea_aroot_layer ! Surface area of absorbing roots in each - ! soil layer [m2] - real(r8) :: sum_l_aroot ! sum of plant's total root length - real(r8),parameter :: min_pet_stem_dz = 0.00001_r8 ! Force at least a small difference - ! in the top of stem and petiole - - - pft = ccohort%pft - - ! Get the cross-section of the plant's sapwood area [m2] - call bsap_allom(ccohort%dbh,pft,ccohort%canopy_trim,a_sapwood,c_sap_dummy) - - ! Leaf Maximum Hydraulic Conductance - ! The starting hypothesis is that there is no resistance inside the - ! leaf, between the petiole and the center of storage. To override - ! this, make provisions by changing the kmax to a not-absurdly high - ! value. It is assumed that the conductance in this default case, - ! is regulated completely by the stem conductance from the stem's - ! center of storage, to the petiole. - - ccohort_hydr%kmax_petiole_to_leaf = 1.e8_r8 - - - ! Stem Maximum Hydraulic Conductance - - do k=1, n_hypool_stem - - ! index for "above-ground" arrays, that contain stem and leaf - ! in one vector - k_ag = k+n_hypool_leaf - - ! Depth from the petiole to the lower, node and upper compartment edges - - z_lower = ccohort_hydr%z_node_ag(n_hypool_leaf) - ccohort_hydr%z_lower_ag(k_ag) - z_node = ccohort_hydr%z_node_ag(n_hypool_leaf) - ccohort_hydr%z_node_ag(k_ag) - z_upper = max( min_pet_stem_dz,ccohort_hydr%z_node_ag(n_hypool_leaf) - & - ccohort_hydr%z_upper_ag(k_ag)) - - - ! Then we calculate the maximum conductance from each the lower, node and upper - ! edges of the compartment to the petiole. The xylem taper factor requires - ! that the kmax it is scaling is from the point of interest to the mean height - ! of the petioles. Then we can back out the conductance over just the path - ! of the upper and lower compartments, but subtracting them as resistors in - ! series. - - ! max conductance from upper edge to mean petiole height - ! If there is no height difference between the upper compartment edge and - ! the petiole, at least give it some nominal amount to void FPE's - kmax_upper = EDPftvarcon_inst%hydr_kmax_node(pft,2) * & - xylemtaper(EDPftvarcon_inst%hydr_p_taper(pft), z_upper) * & - a_sapwood / z_upper - - ! max conductance from node to mean petiole height - kmax_node = EDPftvarcon_inst%hydr_kmax_node(pft,2) * & - xylemtaper(EDPftvarcon_inst%hydr_p_taper(pft), z_node) * & - a_sapwood / z_node - - ! max conductance from lower edge to mean petiole height - kmax_lower = EDPftvarcon_inst%hydr_kmax_node(pft,2) * & - xylemtaper(EDPftvarcon_inst%hydr_p_taper(pft), z_lower) * & - a_sapwood / z_lower - - ! Max conductance over the path of the upper side of the compartment - ccohort_hydr%kmax_stem_upper(k) = (1._r8/kmax_node - 1._r8/kmax_upper)**(-1._r8) - - ! Max conductance over the path on the loewr side of the compartment - ccohort_hydr%kmax_stem_lower(k) = (1._r8/kmax_lower - 1._r8/kmax_node)**(-1._r8) - - if(debug) then - ! The following clauses should never be true: - if( (z_lower < z_node) .or. & - (z_node < z_upper) ) then - write(fates_log(),*) 'Problem calculating stem Kmax' - write(fates_log(),*) z_lower, z_node, z_upper - write(fates_log(),*) kmax_lower*z_lower, kmax_node*z_node, kmax_upper*z_upper - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - enddo + kmax_node = EDPftvarcon_inst%hydr_kmax_node(pft,2) * & + xylemtaper(EDPftvarcon_inst%hydr_p_taper(pft), z_node) * & + a_sapwood / z_node - ! Maximum conductance of the upper compartment in the transporting root - ! that connects to the lowest stem (btw: z_lower_ag(n_hypool_ag) == 0) + kmax_upper = EDPftvarcon_inst%hydr_kmax_node(pft,2) * & + xylemtaper(EDPftvarcon_inst%hydr_p_taper(pft), z_upper) * & + a_sapwood / z_upper - z_upper = ccohort_hydr%z_lower_ag(n_hypool_leaf) - z_node = ccohort_hydr%z_lower_ag(n_hypool_leaf)-ccohort_hydr%z_node_troot + ccohort_hydr%kmax_troot_upper = (1._r8/kmax_node - 1._r8/kmax_upper)**(-1._r8) - kmax_node = EDPftvarcon_inst%hydr_kmax_node(pft,2) * & - xylemtaper(EDPftvarcon_inst%hydr_p_taper(pft), z_node) * & - a_sapwood / z_node + ! The maximum conductance between the center node of the transporting root + ! compartment, and the center node of the absorbing root compartment, is calculated + ! as a residual. Specifically, we look at the total resistance the plant has in + ! the stem so far, by adding those resistances in series. + ! Then we use a parameter to specify what fraction of the resistance + ! should be below-ground between the transporting root node and the absorbing roots. + ! After that total is calculated, we then convert to a conductance, and split the + ! conductance in parallel between root layers, based on the root fraction. + ! Note* The inverse of max conductance (KMax) is minimum resistance: - kmax_upper = EDPftvarcon_inst%hydr_kmax_node(pft,2) * & - xylemtaper(EDPftvarcon_inst%hydr_p_taper(pft), z_upper) * & - a_sapwood / z_upper - ccohort_hydr%kmax_troot_upper = (1._r8/kmax_node - 1._r8/kmax_upper)**(-1._r8) + rmin_ag = 1._r8/ccohort_hydr%kmax_petiole_to_leaf + & + sum(1._r8/ccohort_hydr%kmax_stem_upper(1:n_hypool_stem)) + & + sum(1._r8/ccohort_hydr%kmax_stem_lower(1:n_hypool_stem)) + & + 1._r8/ccohort_hydr%kmax_troot_upper - ! The maximum conductance between the center node of the transporting root - ! compartment, and the center node of the absorbing root compartment, is calculated - ! as a residual. Specifically, we look at the total resistance the plant has in - ! the stem so far, by adding those resistances in series. - ! Then we use a parameter to specify what fraction of the resistance - ! should be below-ground between the transporting root node and the absorbing roots. - ! After that total is calculated, we then convert to a conductance, and split the - ! conductance in parallel between root layers, based on the root fraction. - ! Note* The inverse of max conductance (KMax) is minimum resistance: + ! Calculate the residual resistance below ground, as a resistor + ! in series with the existing above ground + ! Invert to find below-ground kmax + ! (rmin_ag+rmin_bg)*fr = rmin_ag + ! rmin_ag + rmin_bg = rmin_ag/fr + ! rmin_bg = (1/fr-1) * rmin_ag + ! + ! if kmax_bg = 1/rmin_bg : + ! + ! kmax_bg = 1/((1/fr-1) * rmin_ag) + kmax_bg = 1._r8/(rmin_ag*(1._r8/EDPftvarcon_inst%hydr_rfrac_stem(pft) - 1._r8)) - rmin_ag = 1._r8/ccohort_hydr%kmax_petiole_to_leaf + & - sum(1._r8/ccohort_hydr%kmax_stem_upper(1:n_hypool_stem)) + & - sum(1._r8/ccohort_hydr%kmax_stem_lower(1:n_hypool_stem)) + & - 1._r8/ccohort_hydr%kmax_troot_upper - ! Calculate the residual resistance below ground, as a resistor - ! in series with the existing above ground - ! Invert to find below-ground kmax - ! (rmin_ag+rmin_bg)*fr = rmin_ag - ! rmin_ag + rmin_bg = rmin_ag/fr - ! rmin_bg = (1/fr-1) * rmin_ag - ! - ! if kmax_bg = 1/rmin_bg : - ! - ! kmax_bg = 1/((1/fr-1) * rmin_ag) - - kmax_bg = 1._r8/(rmin_ag*(1._r8/EDPftvarcon_inst%hydr_rfrac_stem(pft) - 1._r8)) - - - ! The max conductance of each layer is in parallel, therefore - ! the kmax terms of each layer, should sum to kmax_bg - sum_l_aroot = sum(ccohort_hydr%l_aroot_layer(:)) - do j=1,csite_hydr%nlevrhiz - - kmax_layer = kmax_bg*ccohort_hydr%l_aroot_layer(j)/sum_l_aroot - - ! Two transport pathways, in two compartments exist in each layer. - ! These pathways are connected in serial. - ! For simplicity, we simply split the resistance between the two. - ! Mathematically, this results in simply doubling the conductance - ! and applying to both paths. Here are the two paths: - ! 1) is the path between the transporting root's center node, to - ! the boundary of the transporting root with the boundary of - ! the absorbing root (kmax_troot_lower) - ! 2) is the path between the boundary of the absorbing root and - ! transporting root, with the absorbing root's center node - ! (kmax_aroot_upper) - - ccohort_hydr%kmax_troot_lower(j) = 3.0_r8 * kmax_layer - ccohort_hydr%kmax_aroot_upper(j) = 3.0_r8 * kmax_layer - ccohort_hydr%kmax_aroot_lower(j) = 3.0_r8 * kmax_layer + ! The max conductance of each layer is in parallel, therefore + ! the kmax terms of each layer, should sum to kmax_bg + sum_l_aroot = sum(ccohort_hydr%l_aroot_layer(:)) + do j=1,csite_hydr%nlevrhiz - end do + kmax_layer = kmax_bg*ccohort_hydr%l_aroot_layer(j)/sum_l_aroot - ! Finally, we calculate maximum radial conductance from the root - ! surface to its center node. This transport is not a xylem transport - ! like the calculations prior to this. This transport is through the - ! exodermis, cortex, casparian strip and endodermis. The actual conductance - ! will possibly depend on the potential gradient (whether out-of the root, - ! or in-to the root). So we calculate the kmax's for both cases, - ! and save them for the final conductance calculation. + ! Two transport pathways, in two compartments exist in each layer. + ! These pathways are connected in serial. + ! For simplicity, we simply split the resistance between the two. + ! Mathematically, this results in simply doubling the conductance + ! and applying to both paths. Here are the two paths: + ! 1) is the path between the transporting root's center node, to + ! the boundary of the transporting root with the boundary of + ! the absorbing root (kmax_troot_lower) + ! 2) is the path between the boundary of the absorbing root and + ! transporting root, with the absorbing root's center node + ! (kmax_aroot_upper) - do j=1,csite_hydr%nlevrhiz + ccohort_hydr%kmax_troot_lower(j) = 3.0_r8 * kmax_layer + ccohort_hydr%kmax_aroot_upper(j) = 3.0_r8 * kmax_layer + ccohort_hydr%kmax_aroot_lower(j) = 3.0_r8 * kmax_layer - ! Surface area of the absorbing roots for a single plant in this layer [m2] - surfarea_aroot_layer = 2._r8 * pi_const * & - EDPftvarcon_inst%hydr_rs2(ccohort%pft) * ccohort_hydr%l_aroot_layer(j) + end do - ! Convert from surface conductivity [kg H2O m-2 s-1 MPa-1] to [kg H2O s-1 MPa-1] - ccohort_hydr%kmax_aroot_radial_in(j) = hydr_kmax_rsurf1 * surfarea_aroot_layer + ! Finally, we calculate maximum radial conductance from the root + ! surface to its center node. This transport is not a xylem transport + ! like the calculations prior to this. This transport is through the + ! exodermis, cortex, casparian strip and endodermis. The actual conductance + ! will possibly depend on the potential gradient (whether out-of the root, + ! or in-to the root). So we calculate the kmax's for both cases, + ! and save them for the final conductance calculation. - ccohort_hydr%kmax_aroot_radial_out(j) = hydr_kmax_rsurf2 * surfarea_aroot_layer + do j=1,csite_hydr%nlevrhiz - end do + ! Surface area of the absorbing roots for a single plant in this layer [m2] + surfarea_aroot_layer = 2._r8 * pi_const * & + EDPftvarcon_inst%hydr_rs2(ccohort%pft) * ccohort_hydr%l_aroot_layer(j) - return - end subroutine UpdatePlantKmax + ! Convert from surface conductivity [kg H2O m-2 s-1 MPa-1] to [kg H2O s-1 MPa-1] + ccohort_hydr%kmax_aroot_radial_in(j) = hydr_kmax_rsurf1 * surfarea_aroot_layer - ! =================================================================================== + ccohort_hydr%kmax_aroot_radial_out(j) = hydr_kmax_rsurf2 * surfarea_aroot_layer - subroutine OrderLayersForSolve1D(site_hydr,cohort,cohort_hydr,ordered, kbg_layer) - - ! Arguments (IN) - type(ed_site_hydr_type), intent(in),target :: site_hydr - type(ed_cohort_type), intent(in),target :: cohort - type(ed_cohort_hydr_type),intent(in),target :: cohort_hydr + end do + return +end subroutine UpdatePlantKmax - ! Arguments (INOUT) - integer, intent(inout) :: ordered(:) - real(r8), intent(out) :: kbg_layer(:) - - ! Locals - - real(r8) :: kbg_tot ! total absorbing root & rhizosphere conductance (over all shells and soil layers [MPa] - real(r8) :: psi_inner_shell ! matric potential of the inner shell, used for calculating - ! which kmax to use when forecasting uptake layer ordering [MPa] - real(r8) :: psi_aroot ! matric potential of absorbing root [MPa] - real(r8) :: kmax_aroot ! max conductance of the absorbing root [kg s-1 Mpa-1] - real(r8) :: ftc_aroot ! fraction of total conductivity of abs root - real(r8) :: r_bg ! total estimated resistance in below ground compartments - ! for each soil layer [s Mpa kg-1] (used to predict order in 1d solve) - real(r8) :: aroot_frac_plant ! This is the fraction of absorbing root from one plant - real(r8) :: kmax_lo ! maximum conductance of lower (away from atm) half of path [kg s-1 Mpa-1] - real(r8) :: kmax_up ! maximum conductance of upper (close to atm) half of path [kg s-1 MPa-1] - real(r8) :: psi_shell ! matric potential of a given shell [-] - real(r8) :: ftc_shell ! fraction of total cond. of a given rhiz shell [-] - integer :: tmp ! temporarily holds a soil layer index - integer :: ft ! functional type index of plant - integer :: j,jj,k ! layer and shell indices - - - kbg_tot = 0._r8 - kbg_layer(:) = 0._r8 - - ft = cohort%pft - - do j=1,site_hydr%nlevrhiz - - ! Path is between the absorbing root - ! and the first rhizosphere shell nodes - ! Special case. Maximum conductance depends on the - ! potential gradient (same elevation, no geopotential - ! required. - - psi_inner_shell = site_hydr%wrf_soil(j)%p%psi_from_th(site_hydr%h2osoi_liqvol_shell(j,1)) - - ! Note, since their is no elevation difference between - ! the absorbing root and its layer, no need to calc - ! diff in total, just matric is fine [MPa] - if(cohort_hydr%psi_aroot(j) < psi_inner_shell) then - kmax_aroot = cohort_hydr%kmax_aroot_radial_in(j) - else - kmax_aroot = cohort_hydr%kmax_aroot_radial_out(j) - end if - - ! Get matric potential [Mpa] of the absorbing root - psi_aroot = wrf_plant(aroot_p_media,ft)%p%psi_from_th(cohort_hydr%th_aroot(j)) - - ! Get Fraction of Total Conductivity [-] of the absorbing root - ftc_aroot = wkf_plant(aroot_p_media,ft)%p%ftc_from_psi(cohort_hydr%psi_aroot(j)) - - ! Calculate total effective conductance over path [kg s-1 MPa-1] - ! from absorbing root node to 1st rhizosphere shell - r_bg = 1._r8/(kmax_aroot*ftc_aroot) - - ! Path is across the upper an lower rhizosphere comparment - ! on each side of the nodes. Since there is no flow across the outer - ! node to the edge, we ignore that last half compartment - aroot_frac_plant = cohort_hydr%l_aroot_layer(j)/site_hydr%l_aroot_layer(j) - - do k = 1,nshell - - kmax_up = site_hydr%kmax_upper_shell(j,k)*aroot_frac_plant - kmax_lo = site_hydr%kmax_lower_shell(j,k)*aroot_frac_plant - - psi_shell = site_hydr%wrf_soil(j)%p%psi_from_th(site_hydr%h2osoi_liqvol_shell(j,k)) - - ftc_shell = site_hydr%wkf_soil(j)%p%ftc_from_psi(psi_shell) - - r_bg = r_bg + 1._r8/(kmax_up*ftc_shell) - if(k site_hydr%pm_node) + ! Arguments (IN) + type(ed_site_hydr_type), intent(in),target :: site_hydr + type(ed_cohort_type), intent(in),target :: cohort + type(ed_cohort_hydr_type),intent(in),target :: cohort_hydr + + + ! Arguments (INOUT) + integer, intent(inout) :: ordered(:) + real(r8), intent(out) :: kbg_layer(:) + + ! Locals + + real(r8) :: kbg_tot ! total absorbing root & rhizosphere conductance (over all shells and soil layers [MPa] + real(r8) :: psi_inner_shell ! matric potential of the inner shell, used for calculating + ! which kmax to use when forecasting uptake layer ordering [MPa] + real(r8) :: psi_aroot ! matric potential of absorbing root [MPa] + real(r8) :: kmax_aroot ! max conductance of the absorbing root [kg s-1 Mpa-1] + real(r8) :: ftc_aroot ! fraction of total conductivity of abs root + real(r8) :: r_bg ! total estimated resistance in below ground compartments + ! for each soil layer [s Mpa kg-1] (used to predict order in 1d solve) + real(r8) :: aroot_frac_plant ! This is the fraction of absorbing root from one plant + real(r8) :: kmax_lo ! maximum conductance of lower (away from atm) half of path [kg s-1 Mpa-1] + real(r8) :: kmax_up ! maximum conductance of upper (close to atm) half of path [kg s-1 MPa-1] + real(r8) :: psi_shell ! matric potential of a given shell [-] + real(r8) :: ftc_shell ! fraction of total cond. of a given rhiz shell [-] + integer :: tmp ! temporarily holds a soil layer index + integer :: ft ! functional type index of plant + integer :: j,jj,k ! layer and shell indices + + + kbg_tot = 0._r8 + kbg_layer(:) = 0._r8 + + ft = cohort%pft + + do j=1,site_hydr%nlevrhiz + + ! Path is between the absorbing root + ! and the first rhizosphere shell nodes + ! Special case. Maximum conductance depends on the + ! potential gradient (same elevation, no geopotential + ! required. + + psi_inner_shell = site_hydr%wrf_soil(j)%p%psi_from_th(site_hydr%h2osoi_liqvol_shell(j,1)) + + ! Note, since their is no elevation difference between + ! the absorbing root and its layer, no need to calc + ! diff in total, just matric is fine [MPa] + if(cohort_hydr%psi_aroot(j) < psi_inner_shell) then + kmax_aroot = cohort_hydr%kmax_aroot_radial_in(j) + else + kmax_aroot = cohort_hydr%kmax_aroot_radial_out(j) + end if + + ! Get matric potential [Mpa] of the absorbing root + psi_aroot = wrf_plant(aroot_p_media,ft)%p%psi_from_th(cohort_hydr%th_aroot(j)) + + ! Get Fraction of Total Conductivity [-] of the absorbing root + ftc_aroot = wkf_plant(aroot_p_media,ft)%p%ftc_from_psi(cohort_hydr%psi_aroot(j)) + + ! Calculate total effective conductance over path [kg s-1 MPa-1] + ! from absorbing root node to 1st rhizosphere shell + r_bg = 1._r8/(kmax_aroot*ftc_aroot) + + ! Path is across the upper an lower rhizosphere comparment + ! on each side of the nodes. Since there is no flow across the outer + ! node to the edge, we ignore that last half compartment + aroot_frac_plant = cohort_hydr%l_aroot_layer(j)/site_hydr%l_aroot_layer(j) + + do k = 1,nshell + + kmax_up = site_hydr%kmax_upper_shell(j,k)*aroot_frac_plant + kmax_lo = site_hydr%kmax_lower_shell(j,k)*aroot_frac_plant + + psi_shell = site_hydr%wrf_soil(j)%p%psi_from_th(site_hydr%h2osoi_liqvol_shell(j,k)) + + ftc_shell = site_hydr%wkf_soil(j)%p%ftc_from_psi(psi_shell) + + r_bg = r_bg + 1._r8/(kmax_up*ftc_shell) + if(k site_hydr%pm_node) ! This is the maximum number of iterations needed for this cohort ! (each soil layer has a different number, this saves the max) - cohort_hydr%iterh1 = 0 - cohort_hydr%iterh2 = 0 - - ! Initialize plant water error (integrated flux-storage) - wb_err_plant = 0._r8 - - ! Initialize integrated change in total plant water - dwat_plant = 0._r8 - - ! These are diagnostics that must be calculated. - ! in this routine (uses differentials and actual fluxes) - ! So we need to zero them, as they are incremented - ! over the sub-steps - sapflow = 0._r8 - rootuptake(:) = 0._r8 - - ft = cohort%pft - - ! Total length of roots per plant for this cohort - sum_l_aroot = sum(cohort_hydr%l_aroot_layer(:)) - - ! ----------------------------------------------------------------------------------- - ! As mentioned when calling this routine, we calculate a solution to the flux - ! equations, sequentially, for the plant and each soil layer. - ! Go through soil layers in order of decreasing total root-soil conductance - ! ----------------------------------------------------------------------------------- - - do jj=1,site_hydr%nlevrhiz - - ilayer = ordered(jj) - - if(do_parallel_stem) then - ! If we do "parallel" stem - ! conduits, we integrate - ! each layer over the whole time, but - ! reduce the conductance cross section - ! according to what fraction of root is active - dt_step = dtime + cohort_hydr%iterh1 = 0 + cohort_hydr%iterh2 = 0 + + ! Initialize plant water error (integrated flux-storage) + wb_err_plant = 0._r8 + + ! Initialize integrated change in total plant water + dwat_plant = 0._r8 + + ! These are diagnostics that must be calculated. + ! in this routine (uses differentials and actual fluxes) + ! So we need to zero them, as they are incremented + ! over the sub-steps + sapflow = 0._r8 + rootuptake(:) = 0._r8 + + ft = cohort%pft + + ! Total length of roots per plant for this cohort + sum_l_aroot = sum(cohort_hydr%l_aroot_layer(:)) + + ! ----------------------------------------------------------------------------------- + ! As mentioned when calling this routine, we calculate a solution to the flux + ! equations, sequentially, for the plant and each soil layer. + ! Go through soil layers in order of decreasing total root-soil conductance + ! ----------------------------------------------------------------------------------- + + do jj=1,site_hydr%nlevrhiz + + ilayer = ordered(jj) + + if(do_parallel_stem) then + ! If we do "parallel" stem + ! conduits, we integrate + ! each layer over the whole time, but + ! reduce the conductance cross section + ! according to what fraction of root is active + dt_step = dtime + else + if(weight_serial_dt)then + dt_step = dtime*kbg_layer(ilayer) else - if(weight_serial_dt)then - dt_step = dtime*kbg_layer(ilayer) - else - dt_step = dtime/real(site_hydr%nlevrhiz,r8) - end if + dt_step = dtime/real(site_hydr%nlevrhiz,r8) end if - - ! ------------------------------------------------------------------------------- - ! Part 1. Calculate node quantities: - ! matric potential: psi_node - ! fraction of total conductance: ftc_node - ! total potential (matric + elevatio) h_node - ! deriv. ftc wrt theta: dftc_dtheta_node - ! deriv. psi wrt theta: dpsi_dtheta_node - ! ------------------------------------------------------------------------------- - - - ! This is the fraction of total absorbing root length that a single - ! plant for this cohort takes up, relative to ALL cohorts at the site. Note: - ! cohort_hydr%l_aroot_layer(ilayer) is units [m/plant] - ! site_hydr%l_aroot_layer(ilayer) is units [m/site] - - aroot_frac_plant = cohort_hydr%l_aroot_layer(ilayer)/site_hydr%l_aroot_layer(ilayer) - - wb_err_layer = 0._r8 - - ! If in "spatially parallel" mode, scale down cross section - ! of flux through top by the root fraction of this layer - - if(do_parallel_stem)then - rootfr_scaler = cohort_hydr%l_aroot_layer(ilayer)/sum_l_aroot + end if + + ! ------------------------------------------------------------------------------- + ! Part 1. Calculate node quantities: + ! matric potential: psi_node + ! fraction of total conductance: ftc_node + ! total potential (matric + elevatio) h_node + ! deriv. ftc wrt theta: dftc_dtheta_node + ! deriv. psi wrt theta: dpsi_dtheta_node + ! ------------------------------------------------------------------------------- + + + ! This is the fraction of total absorbing root length that a single + ! plant for this cohort takes up, relative to ALL cohorts at the site. Note: + ! cohort_hydr%l_aroot_layer(ilayer) is units [m/plant] + ! site_hydr%l_aroot_layer(ilayer) is units [m/site] + + aroot_frac_plant = cohort_hydr%l_aroot_layer(ilayer)/site_hydr%l_aroot_layer(ilayer) + + wb_err_layer = 0._r8 + + ! If in "spatially parallel" mode, scale down cross section + ! of flux through top by the root fraction of this layer + + if(do_parallel_stem)then + rootfr_scaler = cohort_hydr%l_aroot_layer(ilayer)/sum_l_aroot + else + rootfr_scaler = 1.0_r8 + end if + + q_top_eff = q_top * rootfr_scaler + + ! For all nodes leaf through rhizosphere + ! Send node heights and compartment volumes to a node-based array + + do i = 1,n_hypool_tot + + if (i<=n_hypool_ag) then + z_node(i) = cohort_hydr%z_node_ag(i) + v_node(i) = cohort_hydr%v_ag(i) + th_node_init(i) = cohort_hydr%th_ag(i) + elseif (i==n_hypool_ag+1) then + z_node(i) = cohort_hydr%z_node_troot + v_node(i) = cohort_hydr%v_troot + th_node_init(i) = cohort_hydr%th_troot + elseif (i==n_hypool_ag+2) then + z_node(i) = -site_hydr%zi_rhiz(ilayer) + v_node(i) = cohort_hydr%v_aroot_layer(ilayer) + th_node_init(i) = cohort_hydr%th_aroot(ilayer) else - rootfr_scaler = 1.0_r8 + ishell = i-(n_hypool_ag+2) + z_node(i) = -site_hydr%zi_rhiz(ilayer) + ! The volume of the Rhizosphere for a single plant + v_node(i) = site_hydr%v_shell(ilayer,ishell)*aroot_frac_plant + th_node_init(i) = site_hydr%h2osoi_liqvol_shell(ilayer,ishell) end if + end do - q_top_eff = q_top * rootfr_scaler - - ! For all nodes leaf through rhizosphere - ! Send node heights and compartment volumes to a node-based array - - do i = 1,n_hypool_tot - - if (i<=n_hypool_ag) then - z_node(i) = cohort_hydr%z_node_ag(i) - v_node(i) = cohort_hydr%v_ag(i) - th_node_init(i) = cohort_hydr%th_ag(i) - elseif (i==n_hypool_ag+1) then - z_node(i) = cohort_hydr%z_node_troot - v_node(i) = cohort_hydr%v_troot - th_node_init(i) = cohort_hydr%th_troot - elseif (i==n_hypool_ag+2) then - z_node(i) = -site_hydr%zi_rhiz(ilayer) - v_node(i) = cohort_hydr%v_aroot_layer(ilayer) - th_node_init(i) = cohort_hydr%th_aroot(ilayer) - else - ishell = i-(n_hypool_ag+2) - z_node(i) = -site_hydr%zi_rhiz(ilayer) - ! The volume of the Rhizosphere for a single plant - v_node(i) = site_hydr%v_shell(ilayer,ishell)*aroot_frac_plant - th_node_init(i) = site_hydr%h2osoi_liqvol_shell(ilayer,ishell) - end if - end do - - ! Outer iteration loop - ! This cuts timestep in half and resolve the solution with smaller substeps - ! This loop is cleared when the model has found a solution - - solution_found = .false. - iter = 0 - do while( .not.solution_found ) - - ! Gracefully quit if too many iterations have been used - if(iter>max_iter)then - call Report1DError(cohort,site_hydr,ilayer,z_node,v_node, & - th_node_init,q_top_eff,dt_step,w_tot_beg,w_tot_end,& - rootfr_scaler,aroot_frac_plant,error_code,error_arr) - - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if + ! Outer iteration loop + ! This cuts timestep in half and resolve the solution with smaller substeps + ! This loop is cleared when the model has found a solution - ! If debugging, then lets re-initialize our diagnostics of - ! time integrated K and flux across the paths - if(debug)then - k_diag = 0._r8 - flux_diag = 0._r8 - end if + solution_found = .false. + iter = 0 + do while( .not.solution_found ) - sapflow_lyr = 0._r8 - rootuptake_lyr = 0._r8 - - ! For each attempt, we want to reset theta with the initial value - th_node(:) = th_node_init(:) - - ! Determine how many substeps, and how long they are + ! Gracefully quit if too many iterations have been used + if(iter>max_iter)then + call Report1DError(cohort,site_hydr,ilayer,z_node,v_node, & + th_node_init,q_top_eff,dt_step,w_tot_beg,w_tot_end,& + rootfr_scaler,aroot_frac_plant,error_code,error_arr) - nsteps = max(imult*iter,1) ! Factor by which we divide through the timestep - ! start with full step (ie dt_fac = 1) - ! Then increase per the "imult" value. - - dt_substep = dt_step/real(nsteps,r8) ! This is the sub-stem length in seconds - - ! Walk through sub-steps - do istep = 1,nsteps + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + ! If debugging, then lets re-initialize our diagnostics of + ! time integrated K and flux across the paths + if(debug)then + k_diag = 0._r8 + flux_diag = 0._r8 + end if - ! Total water mass in the plant at the beginning of this solve [kg h2o] - w_tot_beg = sum(th_node(:)*v_node(:))*denh2o + sapflow_lyr = 0._r8 + rootuptake_lyr = 0._r8 - ! Calculate on-node quantities: potential, and derivatives - do i = 1,n_hypool_plant + ! For each attempt, we want to reset theta with the initial value + th_node(:) = th_node_init(:) - ! Get matric potential [Mpa] - psi_node(i) = wrf_plant(pm_node(i),ft)%p%psi_from_th(th_node(i)) + ! Determine how many substeps, and how long they are - ! Get total potential [Mpa] - h_node(i) = mpa_per_pa*denh2o*grav_earth*z_node(i) + psi_node(i) + nsteps = max(imult*iter,1) ! Factor by which we divide through the timestep + ! start with full step (ie dt_fac = 1) + ! Then increase per the "imult" value. - ! Get Fraction of Total Conductivity [-] - ftc_node(i) = wkf_plant(pm_node(i),ft)%p%ftc_from_psi(psi_node(i)) + dt_substep = dt_step/real(nsteps,r8) ! This is the sub-stem length in seconds - ! deriv psi wrt theta - dpsi_dtheta_node(i) = wrf_plant(pm_node(i),ft)%p%dpsidth_from_th(th_node(i)) + ! Walk through sub-steps + do istep = 1,nsteps - ! deriv ftc wrt psi + ! Total water mass in the plant at the beginning of this solve [kg h2o] + w_tot_beg = sum(th_node(:)*v_node(:))*denh2o - dftc_dpsi = wkf_plant(pm_node(i),ft)%p%dftcdpsi_from_psi(psi_node(i)) + ! Calculate on-node quantities: potential, and derivatives + do i = 1,n_hypool_plant - dftc_dtheta_node(i) = dftc_dpsi * dpsi_dtheta_node(i) + ! Get matric potential [Mpa] + psi_node(i) = wrf_plant(pm_node(i),ft)%p%psi_from_th(th_node(i)) - ! We have two ways to calculate radial absorbing root conductance - ! 1) Assume that water potential does not effect conductance - ! 2) The standard FTC function applies + ! Get total potential [Mpa] + h_node(i) = mpa_per_pa*denh2o*grav_earth*z_node(i) + psi_node(i) - if(i==n_hypool_ag+2)then - if(no_ftc_radialk) then - ftc_node(i) = 1.0_r8 - dftc_dtheta_node(i) = 0.0_r8 - end if - end if + ! Get Fraction of Total Conductivity [-] + ftc_node(i) = wkf_plant(pm_node(i),ft)%p%ftc_from_psi(psi_node(i)) + + ! deriv psi wrt theta + dpsi_dtheta_node(i) = wrf_plant(pm_node(i),ft)%p%dpsidth_from_th(th_node(i)) + + ! deriv ftc wrt psi + + dftc_dpsi = wkf_plant(pm_node(i),ft)%p%dftcdpsi_from_psi(psi_node(i)) + + dftc_dtheta_node(i) = dftc_dpsi * dpsi_dtheta_node(i) + + ! We have two ways to calculate radial absorbing root conductance + ! 1) Assume that water potential does not effect conductance + ! 2) The standard FTC function applies + + if(i==n_hypool_ag+2)then + if(no_ftc_radialk) then + ftc_node(i) = 1.0_r8 + dftc_dtheta_node(i) = 0.0_r8 + end if + end if + + end do + + + ! Same updates as loop above, but for rhizosphere shells + + do i = n_hypool_plant+1,n_hypool_tot + psi_node(i) = site_hydr%wrf_soil(ilayer)%p%psi_from_th(th_node(i)) + h_node(i) = mpa_per_pa*denh2o*grav_earth*z_node(i) + psi_node(i) + ftc_node(i) = site_hydr%wkf_soil(ilayer)%p%ftc_from_psi(psi_node(i)) + dpsi_dtheta_node(i) = site_hydr%wrf_soil(ilayer)%p%dpsidth_from_th(th_node(i)) + dftc_dpsi = site_hydr%wkf_soil(ilayer)%p%dftcdpsi_from_psi(psi_node(i)) + dftc_dtheta_node(i) = dftc_dpsi * dpsi_dtheta_node(i) + end do + + !-------------------------------------------------------------------------------- + ! Part 2. Effective conductances over the path-length and Flux terms + ! over the node-to-node paths + !-------------------------------------------------------------------------------- + + ! Path is between the leaf node and first stem node + ! ------------------------------------------------------------------------------- + + j = 1 + i_up = 2 ! upstream node index + i_dn = 1 ! downstream node index + kmax_dn = rootfr_scaler*cohort_hydr%kmax_petiole_to_leaf + kmax_up = rootfr_scaler*cohort_hydr%kmax_stem_upper(1) + + call GetImTaylorKAB(kmax_up,kmax_dn, & + ftc_node(i_up),ftc_node(i_dn), & + h_node(i_up),h_node(i_dn), & + dftc_dtheta_node(i_up), dftc_dtheta_node(i_dn), & + dpsi_dtheta_node(i_up), dpsi_dtheta_node(i_dn), & + k_eff(j), & + A_term(j), & + B_term(j)) + + + ! Path is between stem nodes + ! ------------------------------------------------------------------------------- + + do j=2,n_hypool_ag-1 + + i_up = j+1 + i_dn = j + + ! "Up" is the "upstream" node, which also uses + ! the "upper" side of its compartment for the calculation. + ! "dn" is the "downstream" node, which uses the lower + ! side of its compartment + ! This compartment is the "lower" node, but uses + ! the "higher" side of its compartment. + + kmax_dn = rootfr_scaler*cohort_hydr%kmax_stem_lower(i_dn-n_hypool_leaf) + kmax_up = rootfr_scaler*cohort_hydr%kmax_stem_upper(i_up-n_hypool_leaf) + + call GetImTaylorKAB(kmax_up,kmax_dn, & + ftc_node(i_up),ftc_node(i_dn), & + h_node(i_up),h_node(i_dn), & + dftc_dtheta_node(i_up), dftc_dtheta_node(i_dn), & + dpsi_dtheta_node(i_up), dpsi_dtheta_node(i_dn), & + k_eff(j), & + A_term(j), & + B_term(j)) + + end do + + + ! Path is between lowest stem and transporting root + + j = n_hypool_ag + i_up = j+1 + i_dn = j + kmax_dn = rootfr_scaler*cohort_hydr%kmax_stem_lower(n_hypool_stem) + kmax_up = rootfr_scaler*cohort_hydr%kmax_troot_upper + + call GetImTaylorKAB(kmax_up,kmax_dn, & + ftc_node(i_up),ftc_node(i_dn), & + h_node(i_up),h_node(i_dn), & + dftc_dtheta_node(i_up), dftc_dtheta_node(i_dn), & + dpsi_dtheta_node(i_up), dpsi_dtheta_node(i_dn), & + k_eff(j), & + A_term(j), & + B_term(j)) + + ! Path is between the transporting root + ! and the absorbing root for this layer + ! NOTE: No need to scale by root fraction + ! even if in parallel mode, already parallel! + + j = n_hypool_ag+1 + i_up = j+1 + i_dn = j + kmax_dn = cohort_hydr%kmax_troot_lower(ilayer) + kmax_up = cohort_hydr%kmax_aroot_upper(ilayer) + + call GetImTaylorKAB(kmax_up,kmax_dn, & + ftc_node(i_up),ftc_node(i_dn), & + h_node(i_up),h_node(i_dn), & + dftc_dtheta_node(i_up), dftc_dtheta_node(i_dn), & + dpsi_dtheta_node(i_up), dpsi_dtheta_node(i_dn), & + k_eff(j), & + A_term(j), & + B_term(j)) + + ! Path is between the absorbing root + ! and the first rhizosphere shell nodes + + j = n_hypool_ag+2 + i_up = j+1 + i_dn = j + + ! Special case. Maximum conductance depends on the + ! potential gradient. + if(h_node(i_up) > h_node(i_dn) ) then + kmax_dn = 1._r8/(1._r8/cohort_hydr%kmax_aroot_lower(ilayer) + & + 1._r8/cohort_hydr%kmax_aroot_radial_in(ilayer)) + else + kmax_dn = 1._r8/(1._r8/cohort_hydr%kmax_aroot_lower(ilayer) + & + 1._r8/cohort_hydr%kmax_aroot_radial_out(ilayer)) + end if + + kmax_up = site_hydr%kmax_upper_shell(ilayer,1)*aroot_frac_plant + + call GetImTaylorKAB(kmax_up,kmax_dn, & + ftc_node(i_up),ftc_node(i_dn), & + h_node(i_up),h_node(i_dn), & + dftc_dtheta_node(i_up), dftc_dtheta_node(i_dn), & + dpsi_dtheta_node(i_up), dpsi_dtheta_node(i_dn), & + k_eff(j), & + A_term(j), & + B_term(j)) + + ! Path is between rhizosphere shells + + do j = n_hypool_ag+3,n_hypool_tot-1 + + i_up = j+1 + i_dn = j + ishell_up = i_up - (n_hypool_tot-nshell) + ishell_dn = i_dn - (n_hypool_tot-nshell) + + kmax_dn = site_hydr%kmax_lower_shell(ilayer,ishell_dn)*aroot_frac_plant + kmax_up = site_hydr%kmax_upper_shell(ilayer,ishell_up)*aroot_frac_plant + + call GetImTaylorKAB(kmax_up,kmax_dn, & + ftc_node(i_up),ftc_node(i_dn), & + h_node(i_up),h_node(i_dn), & + dftc_dtheta_node(i_up), dftc_dtheta_node(i_dn), & + dpsi_dtheta_node(i_up), dpsi_dtheta_node(i_dn), & + k_eff(j), & + A_term(j), & + B_term(j)) + + end do + + ! ------------------------------------------------------------------------------- + ! Part 3. + ! Loop through nodes again, build matrix + ! ------------------------------------------------------------------------------- + + tris_a(1) = 0._r8 + tris_b(1) = A_term(1) - denh2o*v_node(1)/dt_substep + tris_c(1) = B_term(1) + tris_r(1) = q_top_eff - k_eff(1)*(h_node(2)-h_node(1)) + + + do i = 2,n_hypool_tot-1 + j = i + tris_a(i) = -A_term(j-1) + tris_b(i) = A_term(j) - B_term(j-1) - denh2o*v_node(i)/dt_substep + tris_c(i) = B_term(j) + tris_r(i) = -k_eff(j)*(h_node(i+1)-h_node(i)) + & + k_eff(j-1)*(h_node(i)-h_node(i-1)) + + end do + + i = n_hypool_tot + j = n_hypool_tot + tris_a(i) = -A_term(j-1) + tris_b(i) = -B_term(j-1) - denh2o*v_node(i)/dt_substep + tris_c(i) = 0._r8 + tris_r(i) = k_eff(j-1)*(h_node(i)-h_node(i-1)) + + + ! Calculate the change in theta + + call Hydraulics_Tridiagonal(tris_a, tris_b, tris_c, tris_r, dth_node, tri_ierr) + + if(tri_ierr == 1) then + solution_found = .false. + error_code = 2 + error_arr(:) = 0._r8 + exit + end if + + ! If we have not broken from the substep loop, + ! that means this sub-step has been acceptable, and we may + ! go ahead and update the water content for the integrator + + th_node(:) = th_node(:) + dth_node(:) + + ! Mass error (flux - change) + ! Total water mass in the plant at the beginning of this solve [kg h2o] + w_tot_end = sum(th_node(:)*v_node(:))*denh2o + + wb_step_err = (q_top_eff*dt_substep) - (w_tot_beg-w_tot_end) + + if(abs(wb_step_err)>max_wb_step_err .or. any(dth_node(:).ne.dth_node(:)) )then + solution_found = .false. + error_code = 1 + error_arr(:) = 0._r8 + exit + else + ! Note: this is somewhat of a default true. And the sub-steps + ! will keep going unless its changed and broken out of + ! the loop. + solution_found = .true. + error_code = 0 + end if + + ! If desired, check and trap water contents + ! that are negative + if(trap_neg_wc) then + if( any(th_node(:)<0._r8) ) then + solution_found = .false. + error_code = 3 + error_arr(:) = th_node(:) + exit + end if + end if - end do - - - ! Same updates as loop above, but for rhizosphere shells - - do i = n_hypool_plant+1,n_hypool_tot - psi_node(i) = site_hydr%wrf_soil(ilayer)%p%psi_from_th(th_node(i)) - h_node(i) = mpa_per_pa*denh2o*grav_earth*z_node(i) + psi_node(i) - ftc_node(i) = site_hydr%wkf_soil(ilayer)%p%ftc_from_psi(psi_node(i)) - dpsi_dtheta_node(i) = site_hydr%wrf_soil(ilayer)%p%dpsidth_from_th(th_node(i)) - dftc_dpsi = site_hydr%wkf_soil(ilayer)%p%dftcdpsi_from_psi(psi_node(i)) - dftc_dtheta_node(i) = dftc_dpsi * dpsi_dtheta_node(i) - end do - - !-------------------------------------------------------------------------------- - ! Part 2. Effective conductances over the path-length and Flux terms - ! over the node-to-node paths - !-------------------------------------------------------------------------------- - - ! Path is between the leaf node and first stem node - ! ------------------------------------------------------------------------------- - - j = 1 - i_up = 2 ! upstream node index - i_dn = 1 ! downstream node index - kmax_dn = rootfr_scaler*cohort_hydr%kmax_petiole_to_leaf - kmax_up = rootfr_scaler*cohort_hydr%kmax_stem_upper(1) - - call GetImTaylorKAB(kmax_up,kmax_dn, & - ftc_node(i_up),ftc_node(i_dn), & - h_node(i_up),h_node(i_dn), & - dftc_dtheta_node(i_up), dftc_dtheta_node(i_dn), & - dpsi_dtheta_node(i_up), dpsi_dtheta_node(i_dn), & - k_eff(j), & - A_term(j), & - B_term(j)) - - - ! Path is between stem nodes - ! ------------------------------------------------------------------------------- - - do j=2,n_hypool_ag-1 - - i_up = j+1 - i_dn = j - - ! "Up" is the "upstream" node, which also uses - ! the "upper" side of its compartment for the calculation. - ! "dn" is the "downstream" node, which uses the lower - ! side of its compartment - ! This compartment is the "lower" node, but uses - ! the "higher" side of its compartment. - - kmax_dn = rootfr_scaler*cohort_hydr%kmax_stem_lower(i_dn-n_hypool_leaf) - kmax_up = rootfr_scaler*cohort_hydr%kmax_stem_upper(i_up-n_hypool_leaf) - - call GetImTaylorKAB(kmax_up,kmax_dn, & - ftc_node(i_up),ftc_node(i_dn), & - h_node(i_up),h_node(i_dn), & - dftc_dtheta_node(i_up), dftc_dtheta_node(i_dn), & - dpsi_dtheta_node(i_up), dpsi_dtheta_node(i_dn), & - k_eff(j), & - A_term(j), & - B_term(j)) - - end do - - - ! Path is between lowest stem and transporting root - - j = n_hypool_ag - i_up = j+1 - i_dn = j - kmax_dn = rootfr_scaler*cohort_hydr%kmax_stem_lower(n_hypool_stem) - kmax_up = rootfr_scaler*cohort_hydr%kmax_troot_upper - - call GetImTaylorKAB(kmax_up,kmax_dn, & - ftc_node(i_up),ftc_node(i_dn), & - h_node(i_up),h_node(i_dn), & - dftc_dtheta_node(i_up), dftc_dtheta_node(i_dn), & - dpsi_dtheta_node(i_up), dpsi_dtheta_node(i_dn), & - k_eff(j), & - A_term(j), & - B_term(j)) - - ! Path is between the transporting root - ! and the absorbing root for this layer - ! NOTE: No need to scale by root fraction - ! even if in parallel mode, already parallel! - - j = n_hypool_ag+1 - i_up = j+1 - i_dn = j - kmax_dn = cohort_hydr%kmax_troot_lower(ilayer) - kmax_up = cohort_hydr%kmax_aroot_upper(ilayer) - - call GetImTaylorKAB(kmax_up,kmax_dn, & - ftc_node(i_up),ftc_node(i_dn), & - h_node(i_up),h_node(i_dn), & - dftc_dtheta_node(i_up), dftc_dtheta_node(i_dn), & - dpsi_dtheta_node(i_up), dpsi_dtheta_node(i_dn), & - k_eff(j), & - A_term(j), & - B_term(j)) - - ! Path is between the absorbing root - ! and the first rhizosphere shell nodes - - j = n_hypool_ag+2 - i_up = j+1 - i_dn = j - - ! Special case. Maximum conductance depends on the - ! potential gradient. - if(h_node(i_up) > h_node(i_dn) ) then - kmax_dn = 1._r8/(1._r8/cohort_hydr%kmax_aroot_lower(ilayer) + & - 1._r8/cohort_hydr%kmax_aroot_radial_in(ilayer)) - else - kmax_dn = 1._r8/(1._r8/cohort_hydr%kmax_aroot_lower(ilayer) + & - 1._r8/cohort_hydr%kmax_aroot_radial_out(ilayer)) - end if - - kmax_up = site_hydr%kmax_upper_shell(ilayer,1)*aroot_frac_plant - - call GetImTaylorKAB(kmax_up,kmax_dn, & - ftc_node(i_up),ftc_node(i_dn), & - h_node(i_up),h_node(i_dn), & - dftc_dtheta_node(i_up), dftc_dtheta_node(i_dn), & - dpsi_dtheta_node(i_up), dpsi_dtheta_node(i_dn), & - k_eff(j), & - A_term(j), & - B_term(j)) - - ! Path is between rhizosphere shells - - do j = n_hypool_ag+3,n_hypool_tot-1 - - i_up = j+1 - i_dn = j - ishell_up = i_up - (n_hypool_tot-nshell) - ishell_dn = i_dn - (n_hypool_tot-nshell) - - kmax_dn = site_hydr%kmax_lower_shell(ilayer,ishell_dn)*aroot_frac_plant - kmax_up = site_hydr%kmax_upper_shell(ilayer,ishell_up)*aroot_frac_plant - - call GetImTaylorKAB(kmax_up,kmax_dn, & - ftc_node(i_up),ftc_node(i_dn), & - h_node(i_up),h_node(i_dn), & - dftc_dtheta_node(i_up), dftc_dtheta_node(i_dn), & - dpsi_dtheta_node(i_up), dpsi_dtheta_node(i_dn), & - k_eff(j), & - A_term(j), & - B_term(j)) - - end do - - ! ------------------------------------------------------------------------------- - ! Part 3. - ! Loop through nodes again, build matrix - ! ------------------------------------------------------------------------------- - - tris_a(1) = 0._r8 - tris_b(1) = A_term(1) - denh2o*v_node(1)/dt_substep - tris_c(1) = B_term(1) - tris_r(1) = q_top_eff - k_eff(1)*(h_node(2)-h_node(1)) - - - do i = 2,n_hypool_tot-1 - j = i - tris_a(i) = -A_term(j-1) - tris_b(i) = A_term(j) - B_term(j-1) - denh2o*v_node(i)/dt_substep - tris_c(i) = B_term(j) - tris_r(i) = -k_eff(j)*(h_node(i+1)-h_node(i)) + & - k_eff(j-1)*(h_node(i)-h_node(i-1)) - - end do - - i = n_hypool_tot - j = n_hypool_tot - tris_a(i) = -A_term(j-1) - tris_b(i) = -B_term(j-1) - denh2o*v_node(i)/dt_substep - tris_c(i) = 0._r8 - tris_r(i) = k_eff(j-1)*(h_node(i)-h_node(i-1)) - - - ! Calculate the change in theta - - call Hydraulics_Tridiagonal(tris_a, tris_b, tris_c, tris_r, dth_node, tri_ierr) - - if(tri_ierr == 1) then + ! Calculate new psi for checks + do i = 1,n_hypool_plant + psi_node(i) = wrf_plant(pm_node(i),ft)%p%psi_from_th(th_node(i)) + end do + do i = n_hypool_plant+1,n_hypool_tot + psi_node(i) = site_hydr%wrf_soil(ilayer)%p%psi_from_th(th_node(i)) + end do + + ! If desired, check and trap pressures that are supersaturated + if(trap_supersat_psi) then + do i = 1,n_hypool_plant + if(psi_node(i)>wrf_plant(pm_node(i),ft)%p%get_thsat()) then solution_found = .false. - error_code = 2 - error_arr(:) = 0._r8 - exit - end if - - ! If we have not broken from the substep loop, - ! that means this sub-step has been acceptable, and we may - ! go ahead and update the water content for the integrator - - th_node(:) = th_node(:) + dth_node(:) - - ! Mass error (flux - change) - ! Total water mass in the plant at the beginning of this solve [kg h2o] - w_tot_end = sum(th_node(:)*v_node(:))*denh2o - - wb_step_err = (q_top_eff*dt_substep) - (w_tot_beg-w_tot_end) - - if(abs(wb_step_err)>max_wb_step_err .or. any(dth_node(:).ne.dth_node(:)) )then + error_code = 4 + end if + end do + do i = n_hypool_plant+1,n_hypool_tot + if(psi_node(i)>site_hydr%wrf_soil(ilayer)%p%get_thsat()) then solution_found = .false. - error_code = 1 - error_arr(:) = 0._r8 - exit - else - ! Note: this is somewhat of a default true. And the sub-steps - ! will keep going unless its changed and broken out of - ! the loop. - solution_found = .true. - error_code = 0 - end if - - ! If desired, check and trap water contents - ! that are negative - if(trap_neg_wc) then - if( any(th_node(:)<0._r8) ) then - solution_found = .false. - error_code = 3 - error_arr(:) = th_node(:) - exit - end if - end if - - ! Calculate new psi for checks - do i = 1,n_hypool_plant - psi_node(i) = wrf_plant(pm_node(i),ft)%p%psi_from_th(th_node(i)) - end do - do i = n_hypool_plant+1,n_hypool_tot - psi_node(i) = site_hydr%wrf_soil(ilayer)%p%psi_from_th(th_node(i)) - end do - - ! If desired, check and trap pressures that are supersaturated - if(trap_supersat_psi) then - do i = 1,n_hypool_plant - if(psi_node(i)>wrf_plant(pm_node(i),ft)%p%get_thsat()) then - solution_found = .false. - error_code = 4 - end if - end do - do i = n_hypool_plant+1,n_hypool_tot - if(psi_node(i)>site_hydr%wrf_soil(ilayer)%p%get_thsat()) then - solution_found = .false. - error_code = 4 - end if - end do - if(error_code==4) then - error_arr(:) = th_node(:) - end if - end if - - ! Accumulate the water balance error of the layer over the sub-steps - ! for diagnostic purposes - ! [kg/m2] - wb_err_layer = wb_err_layer + wb_step_err - - ! ------------------------------------------------------------------------- - ! Diagnostics - ! ------------------------------------------------------------------------- - - ! Sapflow at the base of the tree is the flux rate - ! between the transporting root node and the first stem node - ! (note: a path j is between node i and i+1) - ! [kg] = [kg/s] * [s] - - i = n_hypool_ag - sapflow_lyr = sapflow_lyr + dt_substep * & - (k_eff(i)*(h_node(i+1)-h_node(i)) + & ! flux at (t) - A_term(i)*dth_node(i) + & ! dq at node i - B_term(i)*dth_node(i+1)) ! dq at node i+1 - - ! Root uptake is the integrated flux between the first rhizosphere - ! shell and the absorbing root - - i = n_hypool_ag+2 - rootuptake_lyr = rootuptake_lyr + dt_substep * & - (k_eff(i)*(h_node(i+1)-h_node(i)) + & ! flux at (t) - A_term(i)*dth_node(i) + & ! dq at node i - B_term(i)*dth_node(i+1)) ! dq at node i+1 - - ! If debug mode is on, lets also track the mass fluxes across each - ! path, and keep a running average of the effective conductances - if(debug)then - do j=1,n_hypool_tot-1 - k_diag(j) = k_diag(j) + k_eff(j)*dt_substep/dt_step - flux_diag(j) = flux_diag(j) + dt_substep * ( & - k_eff(j)*(h_node(j+1)-h_node(j)) + & - A_term(j)*dth_node(j)+ B_term(j)*dth_node(j+1)) - end do - end if - - end do ! do istep = 1,nsteps (substep loop) - - iter=iter+1 - - end do - - ! ----------------------------------------------------------- - ! Do a final check on water balance error sumed over sub-steps - ! ------------------------------------------------------------ - if ( abs(wb_err_layer) > max_wb_err ) then - - write(fates_log(),*)'EDPlantHydraulics water balance error exceeds threshold of = ', max_wb_err - write(fates_log(),*)'transpiration demand: ', dt_step*q_top_eff,' kg/step/plant' - - leaf_water = cohort_hydr%th_ag(1)*cohort_hydr%v_ag(1)*denh2o - stem_water = sum(cohort_hydr%th_ag(2:n_hypool_ag) * & - cohort_hydr%v_ag(2:n_hypool_ag))*denh2o - root_water = ( cohort_hydr%th_troot*cohort_hydr%v_troot + & - sum(cohort_hydr%th_aroot(:)*cohort_hydr%v_aroot_layer(:))) * denh2o - - write(fates_log(),*) 'leaf water: ',leaf_water,' kg/plant' - write(fates_log(),*) 'stem_water: ',stem_water,' kg/plant' - write(fates_log(),*) 'root_water: ',root_water,' kg/plant' - write(fates_log(),*) 'LWP: ',cohort_hydr%psi_ag(1) - write(fates_log(),*) 'dbh: ',cohort%dbh - write(fates_log(),*) 'pft: ',cohort%pft - write(fates_log(),*) 'tree lai: ',cohort%treelai,' m2/m2 crown' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if + error_code = 4 + end if + end do + if(error_code==4) then + error_arr(:) = th_node(:) + end if + end if + ! Accumulate the water balance error of the layer over the sub-steps + ! for diagnostic purposes + ! [kg/m2] + wb_err_layer = wb_err_layer + wb_step_err + + ! ------------------------------------------------------------------------- + ! Diagnostics + ! ------------------------------------------------------------------------- + + ! Sapflow at the base of the tree is the flux rate + ! between the transporting root node and the first stem node + ! (note: a path j is between node i and i+1) + ! [kg] = [kg/s] * [s] + + i = n_hypool_ag + sapflow_lyr = sapflow_lyr + dt_substep * & + (k_eff(i)*(h_node(i+1)-h_node(i)) + & ! flux at (t) + A_term(i)*dth_node(i) + & ! dq at node i + B_term(i)*dth_node(i+1)) ! dq at node i+1 + + ! Root uptake is the integrated flux between the first rhizosphere + ! shell and the absorbing root + + i = n_hypool_ag+2 + rootuptake_lyr = rootuptake_lyr + dt_substep * & + (k_eff(i)*(h_node(i+1)-h_node(i)) + & ! flux at (t) + A_term(i)*dth_node(i) + & ! dq at node i + B_term(i)*dth_node(i+1)) ! dq at node i+1 + + ! If debug mode is on, lets also track the mass fluxes across each + ! path, and keep a running average of the effective conductances + if(debug)then + do j=1,n_hypool_tot-1 + k_diag(j) = k_diag(j) + k_eff(j)*dt_substep/dt_step + flux_diag(j) = flux_diag(j) + dt_substep * ( & + k_eff(j)*(h_node(j+1)-h_node(j)) + & + A_term(j)*dth_node(j)+ B_term(j)*dth_node(j+1)) + end do + end if - ! If we have made it to this point, supposedly we have completed the whole time-step - ! for this cohort x layer combination. It is now safe to save the delta theta - ! value and pass it back to the calling routine. The value passed back is the - ! change in theta over all sub-steps. - - dth_node(:) = th_node(:)-th_node_init(:) - - - ! Add the current soil layer's contribution to total - ! sap and root flux [kg] - sapflow = sapflow + sapflow_lyr - rootuptake(ilayer) = rootuptake_lyr - - - ! Record the layer with the most iterations, but only - ! if it greater than 1. It will default to zero - ! if no layers took extra iterations. - if( (real(iter)>cohort_hydr%iterh1) .and. (iter>1) )then - cohort_hydr%iterlayer = real(ilayer) - end if - - ! Save the number of times we refined our sub-step counts (iterh1) - cohort_hydr%iterh1 = max(cohort_hydr%iterh1,real(iter,r8)) - ! Save the number of sub-steps we ultimately used - cohort_hydr%iterh2 = max(cohort_hydr%iterh2,real(nsteps,r8)) - - ! Update water contents in the relevant plant compartments [m3/m3] - ! ------------------------------------------------------------------------------- - - ! Leaf and above-ground stems - cohort_hydr%th_ag(1:n_hypool_ag) = cohort_hydr%th_ag(1:n_hypool_ag) + dth_node(1:n_hypool_ag) - ! Transporting root - cohort_hydr%th_troot = cohort_hydr%th_troot + dth_node(n_hypool_ag+1) - ! Absorbing root - cohort_hydr%th_aroot(ilayer) = cohort_hydr%th_aroot(ilayer) + dth_node(n_hypool_ag+2) - - ! Change in water per plant [kg/plant] - dwat_plant = dwat_plant + & - (sum(dth_node(1:n_hypool_ag)*cohort_hydr%v_ag(1:n_hypool_ag)) + & - dth_node(n_hypool_ag+1)*cohort_hydr%v_troot + & - dth_node(n_hypool_ag+2)*cohort_hydr%v_aroot_layer(ilayer))*denh2o - - ! Remember the error for the cohort - wb_err_plant = wb_err_plant + wb_err_layer - - ! Save the change in water mass in the rhizosphere. Note that we did - ! not immediately update the state variables upon completing each - ! plant-layer solve. We accumulate the difference, and apply them - ! after all cohort-layers are complete. This allows each cohort - ! to experience the same water conditions (for good or bad). - - if(site_hydr%l_aroot_layer(ilayer) ilayer) - - end associate - return - end subroutine ImTaylorSolve1D + end do ! do istep = 1,nsteps (substep loop) - ! ===================================================================================== + iter=iter+1 - subroutine Report1DError(cohort, site_hydr, ilayer, z_node, v_node, & - th_node, q_top_eff, dt_step, w_tot_beg, w_tot_end, & - rootfr_scaler, aroot_frac_plant, err_code, err_arr) - - ! This routine reports what the initial condition to the 1D solve looks - ! like, and then quits. - - ! Arguments (IN) - type(ed_cohort_type),intent(in),target :: cohort - type(ed_site_hydr_type),intent(in), target :: site_hydr - integer, intent(in) :: ilayer ! soil layer index of interest - real(r8), intent(in) :: z_node(:) ! elevation of nodes - real(r8), intent(in) :: v_node(:) ! volume of nodes - real(r8), intent(in) :: th_node(:) ! water content of node - real(r8), intent(in) :: dt_step ! time [seconds] over-which to calculate solution - real(r8), intent(in) :: q_top_eff ! transpiration flux rate at upper boundary [kg -s] - real(r8), intent(in) :: w_tot_beg ! total water mass at beginning of step [kg] - real(r8), intent(in) :: w_tot_end ! total water mass at end of step [kg] - real(r8), intent(in) :: rootfr_scaler ! What is the root fraction in this layer? - real(r8), intent(in) :: aroot_frac_plant ! What fraction of total absorbring roots - ! in the soil continuum is from current plant? - integer, intent(in) :: err_code ! error code - real(r8), intent(in) :: err_arr(:) ! error diagnostic - - type(ed_cohort_hydr_type),pointer :: cohort_hydr - integer :: i - integer :: ft - real(r8) :: leaf_water - real(r8) :: stem_water - real(r8) :: troot_water - real(r8) :: aroot_water - real(r8), allocatable :: psi_node(:) - real(r8), allocatable :: h_node(:) + end do - cohort_hydr => cohort%co_hydr - ft = cohort%pft + ! ----------------------------------------------------------- + ! Do a final check on water balance error sumed over sub-steps + ! ------------------------------------------------------------ + if ( abs(wb_err_layer) > max_wb_err ) then - allocate(psi_node(size(z_node))) - allocate(h_node(size(z_node))) + write(fates_log(),*)'EDPlantHydraulics water balance error exceeds threshold of = ', max_wb_err + write(fates_log(),*)'transpiration demand: ', dt_step*q_top_eff,' kg/step/plant' - write(fates_log(),*) 'Could not find a stable solution for hydro 1D solve' - write(fates_log(),*) '' - write(fates_log(),*) 'error code: ',err_code - write(fates_log(),*) 'error diag: ',err_arr(:) + leaf_water = cohort_hydr%th_ag(1)*cohort_hydr%v_ag(1)*denh2o + stem_water = sum(cohort_hydr%th_ag(2:n_hypool_ag) * & + cohort_hydr%v_ag(2:n_hypool_ag))*denh2o + root_water = ( cohort_hydr%th_troot*cohort_hydr%v_troot + & + sum(cohort_hydr%th_aroot(:)*cohort_hydr%v_aroot_layer(:))) * denh2o - do i = 1,n_hypool_plant - psi_node(i) = wrf_plant(site_hydr%pm_node(i),ft)%p%psi_from_th(th_node(i)) - h_node(i) = mpa_per_pa*denh2o*grav_earth*z_node(i) + psi_node(i) - end do - do i = n_hypool_plant+1,n_hypool_tot - psi_node(i) = site_hydr%wrf_soil(ilayer)%p%psi_from_th(th_node(i)) - h_node(i) = mpa_per_pa*denh2o*grav_earth*z_node(i) + psi_node(i) - end do + write(fates_log(),*) 'leaf water: ',leaf_water,' kg/plant' + write(fates_log(),*) 'stem_water: ',stem_water,' kg/plant' + write(fates_log(),*) 'root_water: ',root_water,' kg/plant' + write(fates_log(),*) 'LWP: ',cohort_hydr%psi_ag(1) + write(fates_log(),*) 'dbh: ',cohort%dbh + write(fates_log(),*) 'pft: ',cohort%pft + write(fates_log(),*) 'tree lai: ',cohort%treelai,' m2/m2 crown' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if - leaf_water = sum(cohort_hydr%th_ag(1:n_hypool_leaf)* & - cohort_hydr%v_ag(1:n_hypool_leaf))*denh2o - stem_water = sum(cohort_hydr%th_ag(n_hypool_leaf+1:n_hypool_ag) * & - cohort_hydr%v_ag(n_hypool_leaf+1:n_hypool_ag))*denh2o - troot_water = (cohort_hydr%th_troot*cohort_hydr%v_troot) * denh2o - aroot_water = sum(cohort_hydr%th_aroot(:)*cohort_hydr%v_aroot_layer(:)) * denh2o - - write(fates_log(),*) 'layer: ',ilayer - write(fates_log(),*) 'wb_step_err = ',(q_top_eff*dt_step) - (w_tot_beg-w_tot_end) - write(fates_log(),*) 'leaf water: ',leaf_water,' kg/plant' - write(fates_log(),*) 'stem_water: ',stem_water,' kg/plant' - write(fates_log(),*) 'troot_water: ',troot_water - write(fates_log(),*) 'aroot_water: ',aroot_water - write(fates_log(),*) 'LWP: ',cohort_hydr%psi_ag(1) - write(fates_log(),*) 'dbh: ',cohort%dbh - write(fates_log(),*) 'pft: ',cohort%pft - write(fates_log(),*) 'z nodes: ',z_node(:) - write(fates_log(),*) 'psi_z: ',h_node(:)-psi_node(:) - write(fates_log(),*) 'vol, theta, H, kmax-' - write(fates_log(),*) 'flux: ', q_top_eff*dt_step - write(fates_log(),*) 'l:',v_node(1),th_node(1),h_node(1),psi_node(1) - write(fates_log(),*) ' ',cohort_hydr%kmax_stem_upper(1)*rootfr_scaler - write(fates_log(),*) 's:',v_node(2),th_node(2),h_node(2),psi_node(2) - write(fates_log(),*) ' ',1._r8/(1._r8/(cohort_hydr%kmax_stem_lower(1)*rootfr_scaler) + 1._r8/(cohort_hydr%kmax_troot_upper*rootfr_scaler)) - write(fates_log(),*) 't:',v_node(3),th_node(3),h_node(3) - write(fates_log(),*) ' ',1._r8/(1._r8/cohort_hydr%kmax_troot_lower(ilayer)+ 1._r8/cohort_hydr%kmax_aroot_upper(ilayer)) - write(fates_log(),*) 'a:',v_node(4),th_node(4),h_node(4) - write(fates_log(),*) ' in:',1._r8/(1._r8/cohort_hydr%kmax_aroot_radial_in(ilayer) + & - 1._r8/(site_hydr%kmax_upper_shell(ilayer,1)*aroot_frac_plant) + & - 1._r8/cohort_hydr%kmax_aroot_upper(ilayer)) - write(fates_log(),*) ' out:',1._r8/(1._r8/cohort_hydr%kmax_aroot_radial_out(ilayer) + & - 1._r8/(site_hydr%kmax_upper_shell(ilayer,1)*aroot_frac_plant) + & - 1._r8/cohort_hydr%kmax_aroot_upper(ilayer)) - write(fates_log(),*) 'r1:',v_node(5),th_node(5),h_node(5) - write(fates_log(),*) ' ',1._r8/(1._r8/(site_hydr%kmax_lower_shell(ilayer,1)*aroot_frac_plant) + 1._r8/(site_hydr%kmax_upper_shell(ilayer,2)*aroot_frac_plant)) - write(fates_log(),*) 'r2:',v_node(6),th_node(6),h_node(6) - write(fates_log(),*) ' ',1._r8/(1._r8/(site_hydr%kmax_lower_shell(ilayer,2)*aroot_frac_plant) + 1._r8/(site_hydr%kmax_upper_shell(ilayer,3)*aroot_frac_plant)) - write(fates_log(),*) 'r3:',v_node(7),th_node(7),h_node(7) - write(fates_log(),*) ' ',1._r8/(1._r8/(site_hydr%kmax_lower_shell(ilayer,3)*aroot_frac_plant) + 1._r8/(site_hydr%kmax_upper_shell(ilayer,4)*aroot_frac_plant)) - write(fates_log(),*) 'r4:',v_node(8),th_node(8),h_node(8) - write(fates_log(),*) ' ',1._r8/(1._r8/(site_hydr%kmax_lower_shell(ilayer,4)*aroot_frac_plant) + 1._r8/(site_hydr%kmax_upper_shell(ilayer,5)*aroot_frac_plant)) - write(fates_log(),*) 'r5:',v_node(9),th_node(9),h_node(9) - write(fates_log(),*) 'kmax_aroot_radial_out: ',cohort_hydr%kmax_aroot_radial_out(ilayer) - write(fates_log(),*) 'surf area of root: ',2._r8 * pi_const * EDPftvarcon_inst%hydr_rs2(ft) * cohort_hydr%l_aroot_layer(ilayer) - write(fates_log(),*) 'aroot_frac_plant: ',aroot_frac_plant,cohort_hydr%l_aroot_layer(ilayer),site_hydr%l_aroot_layer(ilayer) - write(fates_log(),*) 'kmax_upper_shell: ',site_hydr%kmax_lower_shell(ilayer,:)*aroot_frac_plant - write(fates_log(),*) 'kmax_lower_shell: ',site_hydr%kmax_upper_shell(ilayer,:)*aroot_frac_plant - write(fates_log(),*) '' - write(fates_log(),*) 'tree lai: ',cohort%treelai,' m2/m2 crown' - write(fates_log(),*) 'area and area to volume ratios' - write(fates_log(),*) '' - write(fates_log(),*) 'a:',v_node(4) - write(fates_log(),*) ' ',2._r8 * pi_const * EDPftvarcon_inst%hydr_rs2(ft) * cohort_hydr%l_aroot_layer(ilayer) - write(fates_log(),*) 'r1:',v_node(5) - write(fates_log(),*) ' ',2._r8 * pi_const * site_hydr%r_out_shell(ilayer,1) * cohort_hydr%l_aroot_layer(ilayer) - write(fates_log(),*) 'r2:',v_node(6) - write(fates_log(),*) ' ' - write(fates_log(),*) 'r3:',v_node(7) - write(fates_log(),*) ' ' - write(fates_log(),*) 'r4:',v_node(8) - write(fates_log(),*) ' ' - write(fates_log(),*) 'r5:',v_node(9) - - write(fates_log(),*) 'inner shell kmaxs: ',site_hydr%kmax_lower_shell(:,1)*aroot_frac_plant - - - - - - deallocate(psi_node) - deallocate(h_node) - - - ! Most likely you will want to end-run after this routine, but maybe not... + ! If we have made it to this point, supposedly we have completed the whole time-step + ! for this cohort x layer combination. It is now safe to save the delta theta + ! value and pass it back to the calling routine. The value passed back is the + ! change in theta over all sub-steps. - return - end subroutine Report1DError - - ! ================================================================================= - - subroutine GetImTaylorKAB(kmax_up,kmax_dn, & - ftc_up,ftc_dn, & - h_up,h_dn, & - dftc_dtheta_up, dftc_dtheta_dn, & - dpsi_dtheta_up, dpsi_dtheta_dn, & - k_eff, & - a_term, & - b_term) - - ! ----------------------------------------------------------------------------- - ! This routine will return the effective conductance "K", as well - ! as two terms needed to calculate the implicit solution (using taylor - ! first order expansion). The two terms are generically named A & B. - ! Thus the name "KAB". These quantities are specific not to the nodes - ! themselves, but to the path between the nodes, defined as positive - ! direction towards atmosphere, from "up"stream side (closer to soil) - ! and the "d"ow"n" stream side (closer to air) - ! ----------------------------------------------------------------------------- - ! Arguments - real(r8),intent(in) :: kmax_dn, kmax_up ! max conductance [kg s-1 Mpa-1] - real(r8),intent(inout) :: ftc_dn, ftc_up ! frac total conductance [-] - real(r8),intent(in) :: h_dn, h_up ! total potential [Mpa] - real(r8),intent(inout) :: dftc_dtheta_dn, dftc_dtheta_up ! Derivative - ! of FTC wrt relative water content - real(r8),intent(in) :: dpsi_dtheta_dn, dpsi_dtheta_up ! Derivative of matric potential - ! wrt relative water content - real(r8),intent(out) :: k_eff ! effective conductance over path [kg s-1 Mpa-1] - real(r8),intent(out) :: a_term ! "A" term for path (See tech note) - real(r8),intent(out) :: b_term ! "B" term for path (See tech note) - - ! Locals - real(r8) :: h_diff ! Total potential difference [MPa] - - - ! Calculate difference in total potential over the path [MPa] - h_diff = h_up - h_dn - - ! If we do enable "upstream K", then we are saying that - ! the fractional loss of conductivity is dictated - ! by the upstream side of the flow. In this case, - ! the change in ftc is only non-zero on that side, and is - ! zero'd otherwise. - - if(do_upstream_k) then - - if (h_diff>0._r8) then - ftc_dn = ftc_up - dftc_dtheta_dn = 0._r8 - else - ftc_up = ftc_dn - dftc_dtheta_up = 0._r8 - end if + dth_node(:) = th_node(:)-th_node_init(:) - end if - ! Calculate total effective conductance over path [kg s-1 MPa-1] - k_eff = 1._r8/(1._r8/(ftc_up*kmax_up)+1._r8/(ftc_dn*kmax_dn)) + ! Add the current soil layer's contribution to total + ! sap and root flux [kg] + sapflow = sapflow + sapflow_lyr + rootuptake(ilayer) = rootuptake_lyr - ! "A" term, which operates on the downstream node (closer to atm) - a_term = k_eff**2.0_r8 * h_diff * kmax_dn**(-1.0_r8) * ftc_dn**(-2.0_r8) & - * dftc_dtheta_dn - k_eff * dpsi_dtheta_dn - - ! "B" term, which operates on the upstream node (further from atm) - b_term = k_eff**2.0_r8 * h_diff * kmax_up**(-1.0_r8) * ftc_up**(-2.0_r8) & - * dftc_dtheta_up + k_eff * dpsi_dtheta_up - - + ! Record the layer with the most iterations, but only + ! if it greater than 1. It will default to zero + ! if no layers took extra iterations. + if( (real(iter)>cohort_hydr%iterh1) .and. (iter>1) )then + cohort_hydr%iterlayer = real(ilayer) + end if - return - end subroutine GetImTaylorKAB + ! Save the number of times we refined our sub-step counts (iterh1) + cohort_hydr%iterh1 = max(cohort_hydr%iterh1,real(iter,r8)) + ! Save the number of sub-steps we ultimately used + cohort_hydr%iterh2 = max(cohort_hydr%iterh2,real(nsteps,r8)) + + ! Update water contents in the relevant plant compartments [m3/m3] + ! ------------------------------------------------------------------------------- + + ! Leaf and above-ground stems + cohort_hydr%th_ag(1:n_hypool_ag) = cohort_hydr%th_ag(1:n_hypool_ag) + dth_node(1:n_hypool_ag) + ! Transporting root + cohort_hydr%th_troot = cohort_hydr%th_troot + dth_node(n_hypool_ag+1) + ! Absorbing root + cohort_hydr%th_aroot(ilayer) = cohort_hydr%th_aroot(ilayer) + dth_node(n_hypool_ag+2) + + ! Change in water per plant [kg/plant] + dwat_plant = dwat_plant + & + (sum(dth_node(1:n_hypool_ag)*cohort_hydr%v_ag(1:n_hypool_ag)) + & + dth_node(n_hypool_ag+1)*cohort_hydr%v_troot + & + dth_node(n_hypool_ag+2)*cohort_hydr%v_aroot_layer(ilayer))*denh2o + + ! Remember the error for the cohort + wb_err_plant = wb_err_plant + wb_err_layer + + ! Save the change in water mass in the rhizosphere. Note that we did + ! not immediately update the state variables upon completing each + ! plant-layer solve. We accumulate the difference, and apply them + ! after all cohort-layers are complete. This allows each cohort + ! to experience the same water conditions (for good or bad). + + if(site_hydr%l_aroot_layer(ilayer) ilayer) + +end associate +return +end subroutine ImTaylorSolve1D + +! ===================================================================================== + +subroutine Report1DError(cohort, site_hydr, ilayer, z_node, v_node, & + th_node, q_top_eff, dt_step, w_tot_beg, w_tot_end, & + rootfr_scaler, aroot_frac_plant, err_code, err_arr) + + ! This routine reports what the initial condition to the 1D solve looks + ! like, and then quits. + + ! Arguments (IN) +type(ed_cohort_type),intent(in),target :: cohort +type(ed_site_hydr_type),intent(in), target :: site_hydr +integer, intent(in) :: ilayer ! soil layer index of interest +real(r8), intent(in) :: z_node(:) ! elevation of nodes +real(r8), intent(in) :: v_node(:) ! volume of nodes +real(r8), intent(in) :: th_node(:) ! water content of node +real(r8), intent(in) :: dt_step ! time [seconds] over-which to calculate solution +real(r8), intent(in) :: q_top_eff ! transpiration flux rate at upper boundary [kg -s] +real(r8), intent(in) :: w_tot_beg ! total water mass at beginning of step [kg] +real(r8), intent(in) :: w_tot_end ! total water mass at end of step [kg] +real(r8), intent(in) :: rootfr_scaler ! What is the root fraction in this layer? +real(r8), intent(in) :: aroot_frac_plant ! What fraction of total absorbring roots +! in the soil continuum is from current plant? +integer, intent(in) :: err_code ! error code +real(r8), intent(in) :: err_arr(:) ! error diagnostic + +type(ed_cohort_hydr_type),pointer :: cohort_hydr +integer :: i +integer :: ft +real(r8) :: leaf_water +real(r8) :: stem_water +real(r8) :: troot_water +real(r8) :: aroot_water +real(r8), allocatable :: psi_node(:) +real(r8), allocatable :: h_node(:) + +cohort_hydr => cohort%co_hydr +ft = cohort%pft + +allocate(psi_node(size(z_node))) +allocate(h_node(size(z_node))) + +write(fates_log(),*) 'Could not find a stable solution for hydro 1D solve' +write(fates_log(),*) '' +write(fates_log(),*) 'error code: ',err_code +write(fates_log(),*) 'error diag: ',err_arr(:) + +do i = 1,n_hypool_plant + psi_node(i) = wrf_plant(site_hydr%pm_node(i),ft)%p%psi_from_th(th_node(i)) + h_node(i) = mpa_per_pa*denh2o*grav_earth*z_node(i) + psi_node(i) +end do +do i = n_hypool_plant+1,n_hypool_tot + psi_node(i) = site_hydr%wrf_soil(ilayer)%p%psi_from_th(th_node(i)) + h_node(i) = mpa_per_pa*denh2o*grav_earth*z_node(i) + psi_node(i) +end do + + +leaf_water = sum(cohort_hydr%th_ag(1:n_hypool_leaf)* & + cohort_hydr%v_ag(1:n_hypool_leaf))*denh2o +stem_water = sum(cohort_hydr%th_ag(n_hypool_leaf+1:n_hypool_ag) * & + cohort_hydr%v_ag(n_hypool_leaf+1:n_hypool_ag))*denh2o +troot_water = (cohort_hydr%th_troot*cohort_hydr%v_troot) * denh2o +aroot_water = sum(cohort_hydr%th_aroot(:)*cohort_hydr%v_aroot_layer(:)) * denh2o + +write(fates_log(),*) 'layer: ',ilayer +write(fates_log(),*) 'wb_step_err = ',(q_top_eff*dt_step) - (w_tot_beg-w_tot_end) +write(fates_log(),*) 'leaf water: ',leaf_water,' kg/plant' +write(fates_log(),*) 'stem_water: ',stem_water,' kg/plant' +write(fates_log(),*) 'troot_water: ',troot_water +write(fates_log(),*) 'aroot_water: ',aroot_water +write(fates_log(),*) 'LWP: ',cohort_hydr%psi_ag(1) +write(fates_log(),*) 'dbh: ',cohort%dbh +write(fates_log(),*) 'pft: ',cohort%pft +write(fates_log(),*) 'z nodes: ',z_node(:) +write(fates_log(),*) 'psi_z: ',h_node(:)-psi_node(:) +write(fates_log(),*) 'vol, theta, H, kmax-' +write(fates_log(),*) 'flux: ', q_top_eff*dt_step +write(fates_log(),*) 'l:',v_node(1),th_node(1),h_node(1),psi_node(1) +write(fates_log(),*) ' ',cohort_hydr%kmax_stem_upper(1)*rootfr_scaler +write(fates_log(),*) 's:',v_node(2),th_node(2),h_node(2),psi_node(2) +write(fates_log(),*) ' ',1._r8/(1._r8/(cohort_hydr%kmax_stem_lower(1)*rootfr_scaler) + 1._r8/(cohort_hydr%kmax_troot_upper*rootfr_scaler)) +write(fates_log(),*) 't:',v_node(3),th_node(3),h_node(3) +write(fates_log(),*) ' ',1._r8/(1._r8/cohort_hydr%kmax_troot_lower(ilayer)+ 1._r8/cohort_hydr%kmax_aroot_upper(ilayer)) +write(fates_log(),*) 'a:',v_node(4),th_node(4),h_node(4) +write(fates_log(),*) ' in:',1._r8/(1._r8/cohort_hydr%kmax_aroot_radial_in(ilayer) + & + 1._r8/(site_hydr%kmax_upper_shell(ilayer,1)*aroot_frac_plant) + & + 1._r8/cohort_hydr%kmax_aroot_upper(ilayer)) +write(fates_log(),*) ' out:',1._r8/(1._r8/cohort_hydr%kmax_aroot_radial_out(ilayer) + & + 1._r8/(site_hydr%kmax_upper_shell(ilayer,1)*aroot_frac_plant) + & + 1._r8/cohort_hydr%kmax_aroot_upper(ilayer)) +write(fates_log(),*) 'r1:',v_node(5),th_node(5),h_node(5) +write(fates_log(),*) ' ',1._r8/(1._r8/(site_hydr%kmax_lower_shell(ilayer,1)*aroot_frac_plant) + 1._r8/(site_hydr%kmax_upper_shell(ilayer,2)*aroot_frac_plant)) +write(fates_log(),*) 'r2:',v_node(6),th_node(6),h_node(6) +write(fates_log(),*) ' ',1._r8/(1._r8/(site_hydr%kmax_lower_shell(ilayer,2)*aroot_frac_plant) + 1._r8/(site_hydr%kmax_upper_shell(ilayer,3)*aroot_frac_plant)) +write(fates_log(),*) 'r3:',v_node(7),th_node(7),h_node(7) +write(fates_log(),*) ' ',1._r8/(1._r8/(site_hydr%kmax_lower_shell(ilayer,3)*aroot_frac_plant) + 1._r8/(site_hydr%kmax_upper_shell(ilayer,4)*aroot_frac_plant)) +write(fates_log(),*) 'r4:',v_node(8),th_node(8),h_node(8) +write(fates_log(),*) ' ',1._r8/(1._r8/(site_hydr%kmax_lower_shell(ilayer,4)*aroot_frac_plant) + 1._r8/(site_hydr%kmax_upper_shell(ilayer,5)*aroot_frac_plant)) +write(fates_log(),*) 'r5:',v_node(9),th_node(9),h_node(9) +write(fates_log(),*) 'kmax_aroot_radial_out: ',cohort_hydr%kmax_aroot_radial_out(ilayer) +write(fates_log(),*) 'surf area of root: ',2._r8 * pi_const * EDPftvarcon_inst%hydr_rs2(ft) * cohort_hydr%l_aroot_layer(ilayer) +write(fates_log(),*) 'aroot_frac_plant: ',aroot_frac_plant,cohort_hydr%l_aroot_layer(ilayer),site_hydr%l_aroot_layer(ilayer) +write(fates_log(),*) 'kmax_upper_shell: ',site_hydr%kmax_lower_shell(ilayer,:)*aroot_frac_plant +write(fates_log(),*) 'kmax_lower_shell: ',site_hydr%kmax_upper_shell(ilayer,:)*aroot_frac_plant +write(fates_log(),*) '' +write(fates_log(),*) 'tree lai: ',cohort%treelai,' m2/m2 crown' +write(fates_log(),*) 'area and area to volume ratios' +write(fates_log(),*) '' +write(fates_log(),*) 'a:',v_node(4) +write(fates_log(),*) ' ',2._r8 * pi_const * EDPftvarcon_inst%hydr_rs2(ft) * cohort_hydr%l_aroot_layer(ilayer) +write(fates_log(),*) 'r1:',v_node(5) +write(fates_log(),*) ' ',2._r8 * pi_const * site_hydr%r_out_shell(ilayer,1) * cohort_hydr%l_aroot_layer(ilayer) +write(fates_log(),*) 'r2:',v_node(6) +write(fates_log(),*) ' ' +write(fates_log(),*) 'r3:',v_node(7) +write(fates_log(),*) ' ' +write(fates_log(),*) 'r4:',v_node(8) +write(fates_log(),*) ' ' +write(fates_log(),*) 'r5:',v_node(9) + +write(fates_log(),*) 'inner shell kmaxs: ',site_hydr%kmax_lower_shell(:,1)*aroot_frac_plant + + + + + +deallocate(psi_node) +deallocate(h_node) + + +! Most likely you will want to end-run after this routine, but maybe not... + +return +end subroutine Report1DError + +! ================================================================================= + +subroutine GetImTaylorKAB(kmax_up,kmax_dn, & + ftc_up,ftc_dn, & + h_up,h_dn, & + dftc_dtheta_up, dftc_dtheta_dn, & + dpsi_dtheta_up, dpsi_dtheta_dn, & + k_eff, & + a_term, & + b_term) + + ! ----------------------------------------------------------------------------- + ! This routine will return the effective conductance "K", as well + ! as two terms needed to calculate the implicit solution (using taylor + ! first order expansion). The two terms are generically named A & B. + ! Thus the name "KAB". These quantities are specific not to the nodes + ! themselves, but to the path between the nodes, defined as positive + ! direction towards atmosphere, from "up"stream side (closer to soil) + ! and the "d"ow"n" stream side (closer to air) + ! ----------------------------------------------------------------------------- + ! Arguments +real(r8),intent(in) :: kmax_dn, kmax_up ! max conductance [kg s-1 Mpa-1] +real(r8),intent(inout) :: ftc_dn, ftc_up ! frac total conductance [-] +real(r8),intent(in) :: h_dn, h_up ! total potential [Mpa] +real(r8),intent(inout) :: dftc_dtheta_dn, dftc_dtheta_up ! Derivative +! of FTC wrt relative water content +real(r8),intent(in) :: dpsi_dtheta_dn, dpsi_dtheta_up ! Derivative of matric potential +! wrt relative water content +real(r8),intent(out) :: k_eff ! effective conductance over path [kg s-1 Mpa-1] +real(r8),intent(out) :: a_term ! "A" term for path (See tech note) +real(r8),intent(out) :: b_term ! "B" term for path (See tech note) + +! Locals +real(r8) :: h_diff ! Total potential difference [MPa] + + +! Calculate difference in total potential over the path [MPa] +h_diff = h_up - h_dn + +! If we do enable "upstream K", then we are saying that +! the fractional loss of conductivity is dictated +! by the upstream side of the flow. In this case, +! the change in ftc is only non-zero on that side, and is +! zero'd otherwise. + +if(do_upstream_k) then + + if (h_diff>0._r8) then + ftc_dn = ftc_up + dftc_dtheta_dn = 0._r8 + else + ftc_up = ftc_dn + dftc_dtheta_up = 0._r8 + end if + +end if + +! Calculate total effective conductance over path [kg s-1 MPa-1] +k_eff = 1._r8/(1._r8/(ftc_up*kmax_up)+1._r8/(ftc_dn*kmax_dn)) + +! "A" term, which operates on the downstream node (closer to atm) +a_term = k_eff**2.0_r8 * h_diff * kmax_dn**(-1.0_r8) * ftc_dn**(-2.0_r8) & + * dftc_dtheta_dn - k_eff * dpsi_dtheta_dn + + +! "B" term, which operates on the upstream node (further from atm) +b_term = k_eff**2.0_r8 * h_diff * kmax_up**(-1.0_r8) * ftc_up**(-2.0_r8) & + * dftc_dtheta_up + k_eff * dpsi_dtheta_up + + + +return +end subroutine GetImTaylorKAB + +! ===================================================================================== + +subroutine GetKAndDKDPsi(kmax_dn,kmax_up, & + h_dn,h_up, & + ftc_dn,ftc_up, & + dftc_dpsi_dn, & + dftc_dpsi_up, & + dk_dpsi_dn, & + dk_dpsi_up, & + k_eff) + + ! ----------------------------------------------------------------------------- + ! This routine will return the effective conductance "K", as well + ! as two terms needed to calculate the implicit solution (using taylor + ! first order expansion). The two terms are generically named A & B. + ! Thus the name "KAB". These quantities are specific not to the nodes + ! themselves, but to the path between the nodes, defined as positive + ! direction from "up"per (closer to atm) and "lo"wer (further from atm). + ! ----------------------------------------------------------------------------- + +real(r8),intent(in) :: kmax_dn ! max conductance (downstream) [kg s-1 Mpa-1] +real(r8),intent(in) :: kmax_up ! max conductance (upstream) [kg s-1 Mpa-1] +real(r8),intent(in) :: h_dn ! total potential (downstream) [MPa] +real(r8),intent(in) :: h_up ! total potential (upstream) [Mpa] +real(r8),intent(in) :: ftc_dn ! frac total cond (downstream) [-] +real(r8),intent(in) :: ftc_up ! frac total cond (upstream) [-] +real(r8),intent(in) :: dftc_dpsi_dn ! derivative ftc / theta (downstream) +real(r8),intent(in) :: dftc_dpsi_up ! derivative ftc / theta (upstream) +! of FTC wrt relative water content +real(r8),intent(out) :: dk_dpsi_dn ! change in effective conductance from the +! downstream pressure node +real(r8),intent(out) :: dk_dpsi_up ! change in effective conductance from the +! upstream pressure node +real(r8),intent(out) :: k_eff ! effective conductance over path [kg s-1 Mpa-1] + +! Locals +real(r8) :: h_diff ! Total potential difference [MPa] +! the effective fraction of total +! conductivity is either governed +! by the upstream node, or by both +! with a harmonic average +real(r8) :: ftc_dnx ! frac total cond (downstream) [-] (local copy) +real(r8) :: ftc_upx ! frac total cond (upstream) [-] (local copy) +real(r8) :: dftc_dpsi_dnx ! derivative ftc / theta (downstream) (local copy) +real(r8) :: dftc_dpsi_upx ! derivative ftc / theta (upstream) (local copy) - subroutine GetKAndDKDPsi(kmax_dn,kmax_up, & - h_dn,h_up, & - ftc_dn,ftc_up, & - dftc_dpsi_dn, & - dftc_dpsi_up, & - dk_dpsi_dn, & - dk_dpsi_up, & - k_eff) - - ! ----------------------------------------------------------------------------- - ! This routine will return the effective conductance "K", as well - ! as two terms needed to calculate the implicit solution (using taylor - ! first order expansion). The two terms are generically named A & B. - ! Thus the name "KAB". These quantities are specific not to the nodes - ! themselves, but to the path between the nodes, defined as positive - ! direction from "up"per (closer to atm) and "lo"wer (further from atm). - ! ----------------------------------------------------------------------------- - - real(r8),intent(in) :: kmax_dn ! max conductance (downstream) [kg s-1 Mpa-1] - real(r8),intent(in) :: kmax_up ! max conductance (upstream) [kg s-1 Mpa-1] - real(r8),intent(in) :: h_dn ! total potential (downstream) [MPa] - real(r8),intent(in) :: h_up ! total potential (upstream) [Mpa] - real(r8),intent(in) :: ftc_dn ! frac total cond (downstream) [-] - real(r8),intent(in) :: ftc_up ! frac total cond (upstream) [-] - real(r8),intent(in) :: dftc_dpsi_dn ! derivative ftc / theta (downstream) - real(r8),intent(in) :: dftc_dpsi_up ! derivative ftc / theta (upstream) - ! of FTC wrt relative water content - real(r8),intent(out) :: dk_dpsi_dn ! change in effective conductance from the - ! downstream pressure node - real(r8),intent(out) :: dk_dpsi_up ! change in effective conductance from the - ! upstream pressure node - real(r8),intent(out) :: k_eff ! effective conductance over path [kg s-1 Mpa-1] - ! Locals - real(r8) :: h_diff ! Total potential difference [MPa] - ! the effective fraction of total - ! conductivity is either governed - ! by the upstream node, or by both - ! with a harmonic average - real(r8) :: ftc_dnx ! frac total cond (downstream) [-] (local copy) - real(r8) :: ftc_upx ! frac total cond (upstream) [-] (local copy) - real(r8) :: dftc_dpsi_dnx ! derivative ftc / theta (downstream) (local copy) - real(r8) :: dftc_dpsi_upx ! derivative ftc / theta (upstream) (local copy) - - - - ! We use the local copies of the FTC in our calculations - ! because we don't want to over-write the global values. This prevents - ! us from overwriting FTC on nodes that have more than one connection - - ftc_dnx = ftc_dn - ftc_upx = ftc_up - dftc_dpsi_dnx = dftc_dpsi_dn - dftc_dpsi_upx = dftc_dpsi_up - - ! Calculate difference in total potential over the path [MPa] - - h_diff = h_up - h_dn - - ! If we do enable "upstream K", then we are saying that - ! the fractional loss of conductivity is dictated - ! by the upstream side of the flow. In this case, - ! the change in ftc is only non-zero on that side, and is - ! zero'd otherwise. - - if(do_upstream_k) then - - if (h_diff>0._r8) then - ftc_dnx = ftc_up - dftc_dpsi_dnx = 0._r8 - else - ftc_upx = ftc_dn - dftc_dpsi_upx = 0._r8 - end if - end if +! We use the local copies of the FTC in our calculations +! because we don't want to over-write the global values. This prevents +! us from overwriting FTC on nodes that have more than one connection - ! Calculate total effective conductance over path [kg s-1 MPa-1] - k_eff = 1._r8/(1._r8/(ftc_upx*kmax_up)+1._r8/(ftc_dnx*kmax_dn)) +ftc_dnx = ftc_dn +ftc_upx = ftc_up +dftc_dpsi_dnx = dftc_dpsi_dn +dftc_dpsi_upx = dftc_dpsi_up - dk_dpsi_dn = k_eff**2._r8 * kmax_dn**(-1._r8) * ftc_dnx**(-2._r8) * dftc_dpsi_dnx +! Calculate difference in total potential over the path [MPa] - dk_dpsi_up = k_eff**2._r8 * kmax_up**(-1._r8) * ftc_upx**(-2._r8) * dftc_dpsi_upx - +h_diff = h_up - h_dn - return - end subroutine GetKAndDKDPsi - +! If we do enable "upstream K", then we are saying that +! the fractional loss of conductivity is dictated +! by the upstream side of the flow. In this case, +! the change in ftc is only non-zero on that side, and is +! zero'd otherwise. + +if(do_upstream_k) then + + if (h_diff>0._r8) then + ftc_dnx = ftc_up + dftc_dpsi_dnx = 0._r8 + else + ftc_upx = ftc_dn + dftc_dpsi_upx = 0._r8 + end if + +end if + +! Calculate total effective conductance over path [kg s-1 MPa-1] +k_eff = 1._r8/(1._r8/(ftc_upx*kmax_up)+1._r8/(ftc_dnx*kmax_dn)) + +dk_dpsi_dn = k_eff**2._r8 * kmax_dn**(-1._r8) * ftc_dnx**(-2._r8) * dftc_dpsi_dnx + +dk_dpsi_up = k_eff**2._r8 * kmax_up**(-1._r8) * ftc_upx**(-2._r8) * dftc_dpsi_upx + + +return +end subroutine GetKAndDKDPsi + + +subroutine AccumulateMortalityWaterStorage(csite,ccohort,delta_n) + + ! --------------------------------------------------------------------------- + ! This subroutine accounts for the water bound in plants that have + ! just died. This water is accumulated at the site level for all plants + ! that die. + ! In another routine, this pool is reduced as water vapor flux, and + ! passed to the HLM. + ! --------------------------------------------------------------------------- + + ! Arguments + +type(ed_site_type), intent(inout), target :: csite +type(ed_cohort_type) , intent(inout), target :: ccohort +real(r8), intent(in) :: delta_n ! Loss in number density +! for this cohort /ha/day + +real(r8) :: delta_w !water change due to mortality Kg/m2 +! Locals +type(ed_site_hydr_type), pointer :: csite_hydr +type(ed_cohort_hydr_type), pointer :: ccohort_hydr + +ccohort_hydr => ccohort%co_hydr +csite_hydr => csite%si_hydr +delta_w = (sum(ccohort_hydr%th_ag(:)*ccohort_hydr%v_ag(:)) + & + ccohort_hydr%th_troot*ccohort_hydr%v_troot + & + sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:)))* & + denh2o*delta_n*AREA_INV + +csite_hydr%h2oveg_dead = csite_hydr%h2oveg_dead + delta_w + + +csite_hydr%h2oveg = csite_hydr%h2oveg - delta_w + +return +end subroutine AccumulateMortalityWaterStorage + +!-------------------------------------------------------------------------------! - subroutine AccumulateMortalityWaterStorage(csite,ccohort,delta_n) +subroutine RecruitWaterStorage(nsites,sites,bc_out) - ! --------------------------------------------------------------------------- - ! This subroutine accounts for the water bound in plants that have - ! just died. This water is accumulated at the site level for all plants - ! that die. - ! In another routine, this pool is reduced as water vapor flux, and - ! passed to the HLM. - ! --------------------------------------------------------------------------- + ! --------------------------------------------------------------------------- + ! This subroutine accounts for the water bound in plants that have + ! just recruited. This water is accumulated at the site level for all plants + ! that recruit. + ! Because this water is taken from the soil in hydraulics_bc, which will not + ! be called until the next timestep, this water is subtracted out of + ! plant_stored_h2o_si to ensure HLM water balance at the beg_curr_day timestep. + ! plant_stored_h2o_si will include this water when calculated in hydraulics_bc + ! at the next timestep, when it gets pulled from the soil water. + ! --------------------------------------------------------------------------- - ! Arguments + ! Arguments +integer, intent(in) :: nsites +type(ed_site_type), intent(inout), target :: sites(nsites) +type(bc_out_type), intent(inout) :: bc_out(nsites) - type(ed_site_type), intent(inout), target :: csite - type(ed_cohort_type) , intent(inout), target :: ccohort - real(r8), intent(in) :: delta_n ! Loss in number density - ! for this cohort /ha/day +! Locals +type(ed_cohort_type), pointer :: currentCohort +type(ed_patch_type), pointer :: currentPatch +type(ed_cohort_hydr_type), pointer :: ccohort_hydr +type(ed_site_hydr_type), pointer :: csite_hydr +integer :: s - real(r8) :: delta_w !water change due to mortality Kg/m2 - ! Locals - type(ed_site_hydr_type), pointer :: csite_hydr - type(ed_cohort_hydr_type), pointer :: ccohort_hydr +if( hlm_use_planthydro.eq.ifalse ) return - ccohort_hydr => ccohort%co_hydr - csite_hydr => csite%si_hydr - delta_w = (sum(ccohort_hydr%th_ag(:)*ccohort_hydr%v_ag(:)) + & - ccohort_hydr%th_troot*ccohort_hydr%v_troot + & - sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:)))* & - denh2o*delta_n*AREA_INV +do s = 1,nsites - csite_hydr%h2oveg_dead = csite_hydr%h2oveg_dead + delta_w + csite_hydr => sites(s)%si_hydr + csite_hydr%h2oveg_recruit = 0.0_r8 + currentPatch => sites(s)%oldest_patch + do while(associated(currentPatch)) + currentCohort=>currentPatch%tallest + do while(associated(currentCohort)) + ccohort_hydr => currentCohort%co_hydr + if(ccohort_hydr%is_newly_recruited) then + csite_hydr%h2oveg_recruit = csite_hydr%h2oveg_recruit + & + (sum(ccohort_hydr%th_ag(:)*ccohort_hydr%v_ag(:)) + & + ccohort_hydr%th_troot*ccohort_hydr%v_troot + & + sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:)))* & + denh2o*currentCohort%n + end if + currentCohort => currentCohort%shorter + enddo !cohort + currentPatch => currentPatch%younger + enddo !end patch loop + csite_hydr%h2oveg_recruit = csite_hydr%h2oveg_recruit * AREA_INV - csite_hydr%h2oveg = csite_hydr%h2oveg - delta_w +end do - return - end subroutine AccumulateMortalityWaterStorage +return +end subroutine RecruitWaterStorage - !-------------------------------------------------------------------------------! +! ===================================================================================== - subroutine RecruitWaterStorage(nsites,sites,bc_out) +! ===================================================================================== +! Utility Functions +! ===================================================================================== - ! --------------------------------------------------------------------------- - ! This subroutine accounts for the water bound in plants that have - ! just recruited. This water is accumulated at the site level for all plants - ! that recruit. - ! Because this water is taken from the soil in hydraulics_bc, which will not - ! be called until the next timestep, this water is subtracted out of - ! plant_stored_h2o_si to ensure HLM water balance at the beg_curr_day timestep. - ! plant_stored_h2o_si will include this water when calculated in hydraulics_bc - ! at the next timestep, when it gets pulled from the soil water. - ! --------------------------------------------------------------------------- +subroutine bisect_rootfr(a, b, lower_init, upper_init, xtol, ytol, crootfr, x_new) + ! + ! !DESCRIPTION: Bisection routine for getting the inverse of the cumulative root + ! distribution. No analytical soln bc crootfr ~ exp(ax) + exp(bx). + ! + ! !USES: + ! + ! !ARGUMENTS +real(r8) , intent(in) :: a, b ! pft root distribution constants +real(r8) , intent(in) :: lower_init ! lower bound of initial x estimate [m] +real(r8) , intent(in) :: upper_init ! upper bound of initial x estimate [m] +real(r8) , intent(in) :: xtol ! error tolerance for x_new [m] +real(r8) , intent(in) :: ytol ! error tolerance for crootfr [-] +real(r8) , intent(in) :: crootfr ! cumulative root fraction at x_new [-] +real(r8) , intent(out) :: x_new ! soil depth [m] +! +! !LOCAL VARIABLES: +real(r8) :: lower ! lower bound x estimate [m] +real(r8) :: upper ! upper bound x estimate [m] +real(r8) :: y_lo ! corresponding y value at lower +real(r8) :: f_lo ! y difference between lower bound guess and target y +real(r8) :: y_hi ! corresponding y value at upper +real(r8) :: f_hi ! y difference between upper bound guess and target y +real(r8) :: y_new ! corresponding y value at x.new +real(r8) :: f_new ! y difference between new y guess at x.new and target y +real(r8) :: chg ! difference between x upper and lower bounds (approach 0 in bisection) +!---------------------------------------------------------------------- + +lower = lower_init +upper = upper_init +f_lo = zeng2001_crootfr(a, b, lower) - crootfr +f_hi = zeng2001_crootfr(a, b, upper) - crootfr +chg = upper - lower +do while(abs(chg) .gt. xtol) + x_new = 0.5_r8*(lower + upper) + f_new = zeng2001_crootfr(a, b, x_new) - crootfr + if(abs(f_new) .le. ytol) then + EXIT + end if + if((f_lo * f_new) .lt. 0._r8) upper = x_new + if((f_hi * f_new) .lt. 0._r8) lower = x_new + chg = upper - lower +end do +end subroutine bisect_rootfr + +! ===================================================================================== + +function zeng2001_crootfr(a, b, z, z_max) result(crootfr) + + ! !ARGUMENTS: +real(r8) , intent(in) :: a,b ! pft parameters +real(r8) , intent(in) :: z ! soil depth (m) +real(r8) , intent(in), optional :: z_max ! max soil depth (m) +! +real(r8) :: crootfr_max + +! !RESULT +real(r8) :: crootfr ! cumulative root fraction +! +!------------------------------------------------------------------------ +crootfr = 1._r8 - .5_r8*(exp(-a*z) + exp(-b*z)) + + +! If a maximum rooting depth is provided, then +! we force everything to sum to unity. We do this by +! simply dividing through by the maximum possible +! root fraction. + +if(present(z_max))then + crootfr_max = 1._r8 - .5_r8*(exp(-a*z_max) + exp(-b*z_max)) + crootfr = crootfr/crootfr_max +end if + +if(debug)then + if(present(z_max))then + if((crootfr_max1.0_r8) )then + write(fates_log(),*) 'problem scaling crootfr in zeng2001' + write(fates_log(),*) 'z_max: ',z_max + write(fates_log(),*) 'crootfr_max: ',crootfr_max + end if + end if +end if - ! Arguments - integer, intent(in) :: nsites - type(ed_site_type), intent(inout), target :: sites(nsites) - type(bc_out_type), intent(inout) :: bc_out(nsites) - ! Locals - type(ed_cohort_type), pointer :: currentCohort - type(ed_patch_type), pointer :: currentPatch - type(ed_cohort_hydr_type), pointer :: ccohort_hydr - type(ed_site_hydr_type), pointer :: csite_hydr - integer :: s +return - if( hlm_use_planthydro.eq.ifalse ) return +end function zeng2001_crootfr - do s = 1,nsites +! ===================================================================================== - csite_hydr => sites(s)%si_hydr - csite_hydr%h2oveg_recruit = 0.0_r8 - currentPatch => sites(s)%oldest_patch - do while(associated(currentPatch)) - currentCohort=>currentPatch%tallest - do while(associated(currentCohort)) - ccohort_hydr => currentCohort%co_hydr - if(ccohort_hydr%is_newly_recruited) then - csite_hydr%h2oveg_recruit = csite_hydr%h2oveg_recruit + & - (sum(ccohort_hydr%th_ag(:)*ccohort_hydr%v_ag(:)) + & - ccohort_hydr%th_troot*ccohort_hydr%v_troot + & - sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:)))* & - denh2o*currentCohort%n - end if - currentCohort => currentCohort%shorter - enddo !cohort - currentPatch => currentPatch%younger - enddo !end patch loop - - csite_hydr%h2oveg_recruit = csite_hydr%h2oveg_recruit * AREA_INV +subroutine shellGeom(l_aroot, rs1, area_site, dz, r_out_shell, r_node_shell, v_shell) + ! + ! !DESCRIPTION: Updates size of 'representative' rhizosphere -- node radii, volumes. + ! As fine root biomass (and thus absorbing root length) increases, this characteristic + ! rhizosphere shrinks even though the total volume of soil surrounding fine roots remains + ! the same. + ! + ! !USES: - end do + ! + ! !ARGUMENTS: +real(r8) , intent(in) :: l_aroot ! Total length of absorbing roots +! for the whole site, this layer (m) +real(r8) , intent(in) :: rs1 ! Fine root radius (m) +real(r8) , intent(in) :: area_site ! Area of site (10,000 m2) +real(r8) , intent(in) :: dz ! Width of current soil layer (m) +real(r8) , intent(out) :: r_out_shell(:) ! Outer radius of each shell (m) +real(r8) , intent(out) :: r_node_shell(:) ! Radius of the shell's midpoint +real(r8) , intent(out) :: v_shell(:) ! volume of the rhizosphere shells (m3/ha) +! for this layer +! +! !LOCAL VARIABLES: +integer :: k ! rhizosphere shell indicies +integer :: nshells ! We don't use the global because of unit testing +!----------------------------------------------------------------------- + + +nshells = size(r_out_shell,dim=1) + +! update outer radii of column-level rhizosphere shells (same across patches and cohorts) +r_out_shell(nshells) = (pi_const*l_aroot/(area_site*dz))**(-0.5_r8) ! eqn(8) S98 +if(nshells > 1) then + do k = 1,nshells-1 + r_out_shell(k) = rs1*(r_out_shell(nshells)/rs1)**((real(k,r8))/real(nshells,r8)) ! eqn(7) S98 + enddo +end if + +! set nodal (midpoint) radii of these shells +! BOC...not doing this as it requires PFT-specific fine root thickness, but this is at column level +r_node_shell(1) = 0.5_r8*(rs1 + r_out_shell(1)) +!r_node_shell(1) = 0.5_r8*(r_out_shell(1)) + +do k = 2,nshells + r_node_shell(k) = 0.5_r8*(r_out_shell(k-1) + r_out_shell(k)) +enddo + +! update volumes +do k = 1,nshells + if(k == 1) then + v_shell(k) = pi_const*l_aroot*(r_out_shell(k)**2._r8 - rs1**2._r8) + else + v_shell(k) = pi_const*l_aroot*(r_out_shell(k)**2._r8 - r_out_shell(k-1)**2._r8) + end if +enddo + +return +end subroutine shellGeom + +! ===================================================================================== + +function xylemtaper(p, dz) result(chi_tapnotap) + + ! !ARGUMENTS: +real(r8) , intent(in) :: p ! Taper exponent (see EDPftvar hydr_p_taper) [-] +real(r8) , intent(in) :: dz ! hydraulic distance from petiole to node of interest [m] +! +! !LOCAL VARIABLES: +real(r8) :: atap,btap ! scaling exponents for total conductance ~ tree size (ratio of stem radius to terminal twig radius) +real(r8) :: anotap,bnotap ! same as atap, btap, but not acounting for xylem taper (Savage et al. (2010) p = 0) +! NOTE: these scaling exponents were digitized from Fig 2a of Savage et al. (2010) +! Savage VM, Bentley LP, Enquist BJ, Sperry JS, Smith DD, Reich PB, von Allmen EI. 2010. +! Hydraulic trade-offs and space filling enable better predictions of vascular structure +! and function in plants. Proceedings of the National Academy of Sciences 107(52): 22722-22727. +real(r8) :: lN=0.04_r8 ! petiole length [m] +real(r8) :: little_n=2._r8 ! number of daughter branches per parent branch, assumed constant throughout tree (self-similarity) [-] +real(r8) :: big_n ! number of branching levels (allowed here to take on non-integer values): increases with tree size [-] +real(r8) :: ktap ! hydraulic conductance along the pathway, accounting for xylem taper [kg s-1 MPa-1] +real(r8) :: knotap ! hydraulic conductance along the pathway, not accounting for xylem taper [kg s-1 MPa-1] +real(r8) :: num ! temporary +real(r8) :: den ! temporary +! +! !RESULT +real(r8) :: chi_tapnotap ! ratio of total tree conductance accounting for xylem taper to that without, over interval dz +! +!------------------------------------------------------------------------ + +anotap = 7.19903e-13_r8 +bnotap = 1.326105578_r8 +if (p >= 1.0_r8) then + btap = 2.00586217_r8 + atap = 1.82513E-12_r8 +else if (p >= (1._r8/3._r8) .AND. p < 1._r8) then + btap = 1.854812819_r8 + atap = 6.66908E-13_r8 +else if (p >= (1._r8/6._r8) .AND. p < (1._r8/3._r8)) then + btap = 1.628179741_r8 + atap = 6.58345E-13_r8 +else + btap = bnotap + atap = anotap +end if + +num = 3._r8*log(1._r8 - dz/lN * (1._r8-little_n**(1._r8/3._r8))) +den = log(little_n) +big_n = num/den - 1._r8 +ktap = atap * (little_n**(big_N* btap/2._r8)) +knotap = anotap * (little_n**(big_N*bnotap/2._r8)) +chi_tapnotap = ktap / knotap + +return + +end function xylemtaper + +! ===================================================================================== + +subroutine Hydraulics_Tridiagonal(a, b, c, r, u, ierr) + ! + ! !DESCRIPTION: An abbreviated version of biogeophys/TridiagonalMod.F90 + ! + ! This solves the form: + ! + ! a(i)*u(i-1) + b(i)*u(i) + c(i)*u(i+1) = r(i) + ! + ! It assumed that coefficient a(1) and c(N) DNE as there is + ! no u(0) or u(N-1). + ! + ! !USES: + ! + ! !ARGUMENTS +real(r8), intent(in) :: a(:) ! "a" left off diagonal of tridiagonal matrix +real(r8), intent(in) :: b(:) ! "b" diagonal column of tridiagonal matrix +real(r8), intent(in) :: c(:) ! "c" right off diagonal of tridiagonal matrix +real(r8), intent(in) :: r(:) ! "r" forcing term of tridiagonal matrix +real(r8), intent(out) :: u(:) ! solution +integer, intent(out) :: ierr ! flag: 0=passed, 1=failed +! +! !LOCAL VARIABLES: +real(r8) :: bet ! temporary +real(r8) :: gam(10) ! temporary +integer :: k ! index +integer :: N ! Size of the matrix +real(r8) :: err ! solution error, in units of [m3/m3] +real(r8) :: rel_err ! relative error, normalized by delta theta +real(r8), parameter :: allowable_rel_err = 0.0001_r8 + +!---------------------------------------------------------------------- +N=size(r,dim=1) +bet = b(1) +do k=1,N + if(k == 1) then + u(k) = r(k) / bet + else + gam(k) = c(k-1) / bet + bet = b(k) - a(k) * gam(k) + u(k) = (r(k) - a(k)*u(k-1)) / bet + end if +enddo + +do k=N-1,1,-1 + u(k) = u(k) - gam(k+1) * u(k+1) +enddo + +! If debug mode, calculate error on the forward solution +ierr = 0 +if(debug)then + do k=1,N + if(k==1)then + err = abs(r(k) - (b(k)*u(k)+c(k)*u(k+1))) + elseif(knearzero)then + rel_err = abs(err/u(k)) + if( ((rel_err > allowable_rel_err) .and. (err > max_wb_step_err)) .or. & + (err /= err) )then + write(fates_log(),*) 'Tri-diagonal solve produced solution with' + write(fates_log(),*) 'non-negligable error.' + write(fates_log(),*) 'Compartment: ',k + write(fates_log(),*) 'Error in forward solution: ',err + write(fates_log(),*) 'Estimated delta theta: ',u(k) + write(fates_log(),*) 'Rel Error: ',rel_err + write(fates_log(),*) 'Reducing time-step' + ierr = 1 + end if + end if + end do +end if + +end subroutine Hydraulics_Tridiagonal + +! ===================================================================================== + +subroutine MatSolve2D(bc_in,site_hydr,cohort,cohort_hydr, & + tmx,qtop, & + sapflow,rootuptake,wb_err_plant , dwat_plant, & + dth_layershell_site) + + + ! --------------------------------------------------------------------------------- + ! This solution to the plant water flux equations casts all the fluxes through a + ! cohort, and the rhizosphere shells in ALL layers as a single system of equations. + ! If thinking of the plant's above ground components as one dimension, and the soil + ! layers as another, this is a somewhat 2D system (hence "Matrix" in the name). + ! To improve the quality of the solution and reduce solver error, this also + ! uses a Newton iteration. See technical documentation for a full derivation + ! of the mathematics. However, in brief, we can describe the flux balance through + ! any node, considering flux paths labeled j, through that node in set J. + ! This is an implicit solve, so we balance the change in water mass (defined by + ! volume V, density rho, and water content theta) with the flux (q) esitmated + ! at the next time-step q^(t+1). Note that we continue to solve this equation, using + ! updated values of water content and pressure (psi), by balancing our fluxes with + ! the total of previous (theta_p) and remaining (theta_r) water contents. + ! + ! rho V rho V + ! ----- Del theta_p + ----- Del theta_r = Sum ( q^(t+1) ) + ! Del t Del t J + ! + ! The flux at t+1, is simply the current flux (q) and a first order Taylor + ! expanion (i.e. forward-euler) estimate with the current derivative based + ! on the current value of theta and psi. + ! Note also, that the solution is in terms of the matric potential, psi. This + ! conversion from theta to psi, requires this derivative (Jacobian) to also + ! contain not just the rate of change of flux wrt psi, but the change in theta + ! wrt psi (self term, no cross node terms). + ! + ! ----------------------------------------------------------------------------------- - return - end subroutine RecruitWaterStorage - ! ===================================================================================== + ! ARGUMENTS: + ! ----------------------------------------------------------------------------------- +type(bc_in_type),intent(in) :: bc_in +type(ed_site_hydr_type), intent(inout),target :: site_hydr ! ED site_hydr structure +type(ed_cohort_hydr_type), target :: cohort_hydr +type(ed_cohort_type) , intent(inout), target :: cohort +real(r8),intent(in) :: tmx ! time interval to integrate over [s] +real(r8),intent(in) :: qtop +real(r8),intent(out) :: sapflow ! time integrated mass flux between transp-root and stem [kg] +real(r8),intent(out) :: rootuptake(:) ! time integrated mass flux between rhizosphere and aroot [kg] - ! ===================================================================================== - ! Utility Functions - ! ===================================================================================== - subroutine bisect_rootfr(a, b, lower_init, upper_init, xtol, ytol, crootfr, x_new) - ! - ! !DESCRIPTION: Bisection routine for getting the inverse of the cumulative root - ! distribution. No analytical soln bc crootfr ~ exp(ax) + exp(bx). - ! - ! !USES: - ! - ! !ARGUMENTS - real(r8) , intent(in) :: a, b ! pft root distribution constants - real(r8) , intent(in) :: lower_init ! lower bound of initial x estimate [m] - real(r8) , intent(in) :: upper_init ! upper bound of initial x estimate [m] - real(r8) , intent(in) :: xtol ! error tolerance for x_new [m] - real(r8) , intent(in) :: ytol ! error tolerance for crootfr [-] - real(r8) , intent(in) :: crootfr ! cumulative root fraction at x_new [-] - real(r8) , intent(out) :: x_new ! soil depth [m] - ! - ! !LOCAL VARIABLES: - real(r8) :: lower ! lower bound x estimate [m] - real(r8) :: upper ! upper bound x estimate [m] - real(r8) :: y_lo ! corresponding y value at lower - real(r8) :: f_lo ! y difference between lower bound guess and target y - real(r8) :: y_hi ! corresponding y value at upper - real(r8) :: f_hi ! y difference between upper bound guess and target y - real(r8) :: y_new ! corresponding y value at x.new - real(r8) :: f_new ! y difference between new y guess at x.new and target y - real(r8) :: chg ! difference between x upper and lower bounds (approach 0 in bisection) - !---------------------------------------------------------------------- - - lower = lower_init - upper = upper_init - f_lo = zeng2001_crootfr(a, b, lower) - crootfr - f_hi = zeng2001_crootfr(a, b, upper) - crootfr - chg = upper - lower - do while(abs(chg) .gt. xtol) - x_new = 0.5_r8*(lower + upper) - f_new = zeng2001_crootfr(a, b, x_new) - crootfr - if(abs(f_new) .le. ytol) then - EXIT - end if - if((f_lo * f_new) .lt. 0._r8) upper = x_new - if((f_hi * f_new) .lt. 0._r8) lower = x_new - chg = upper - lower - end do - end subroutine bisect_rootfr +real(r8),intent(out) :: wb_err_plant ! total error over plant, transpiration +! should match change in storage [kg/m2] +real(r8),intent(out) :: dwat_plant ! total change in water mass for the plant [kg] +real(r8),intent(inout) :: dth_layershell_site(:,:) - ! ===================================================================================== +integer :: nsteps ! Number of rounds of attempts we have made +integer :: i ! generic index (sometimes node index) +integer :: inode ! node index +integer :: k ! generic node index +integer :: j_bc ! layer of bc +integer :: j, icnx ! soil layer and connection indices +integer :: id_dn, id_up ! Node indices on each side of flux path +integer :: ishell ! rhizosphere shell index + +integer :: icnv ! Convergence flag for each solve, see flag definitions +! below. + +real(r8) :: aroot_frac_plant ! Fraction of rhizosphere this plant "owns" + +real(r8) :: dqflx_dpsi_dn ! Derivative, change in mass flux per change +! in matric potential of the down-stream node +! [kg s-1 Mpa-1] + +real(r8) :: dqflx_dpsi_up ! Derivative, change in mass flux per change +! in matric potential of the up-stream node +! [kg s-1 Mpa-1] + +real(r8) :: dk_dpsi_dn ! change in effective conductance from the +! downstream pressure node +real(r8) :: dk_dpsi_up ! change in effective conductance from the +! upstream pressure node + +real(r8) :: residual_amax ! maximum absolute mass balance residual over all +! nodes, +! used for determining convergence. At the point + +real(r8) :: rsdx ! Temporary residual while determining max value + + +real(r8) :: rlfx_soil ! Pressure update reduction factor for soil compartments +real(r8) :: rlfx_plnt ! Pressure update reduction factor for plant comparmtents +real(r8) :: rlfx_soil0 ! Base relaxation factor for the current iteration round +real(r8) :: rlfx_plnt0 ! "" + +real(r8) :: tm ! Total time integrated after each substep [s] +real(r8) :: dtime ! Total time to be integrated this step [s] +real(r8) :: w_tot_beg ! total plant water prior to solve [kg] +real(r8) :: w_tot_end ! total plant water at end of solve [kg] +logical :: continue_search +real(r8) :: k_eff ! Effective conductivity over the current pathway +! between two nodes. Factors in fractional +! loss of conductivity on each side of the pathway, and the material maximum +! conductivity on each side [kg/s/MPa] +integer :: icnx_ar ! Connection index of the aroot <-> rhizosphere shell + +integer :: nsd ! node index of highest residual +integer :: nwtn_iter ! number of (Newton) iterations on each substep + +! to get a succesfull Newton solve. +integer :: kshell ! rhizosphere shell index, 1->nshell + +integer :: info +integer :: nstep !number of time steps + + +! This is a convergence test. This is the maximum difference +! allowed between the flux balance and the change in storage +! on a node. [kg/s] *Note, 1.e-9 = 1 ug/s +real(r8), parameter :: max_allowed_residual = 1.e-8_r8 + +! Maximum number of times we re-try a round of Newton +! iterations, each time decreasing the time-step and +! potentially reducing relaxation factors +integer, parameter :: max_newton_rounds = 10 + +! dtime will shrink at the following rate (halving) [s]: +! 1800,900,450,225,112.5,56.25,28.125,14.0625,7.03125,3.515625, +! 1.7578125,0.87890625,0.439453125,0.2197265625,0.10986328125, +! 0.054931640625,0.0274658203125,0.01373291015625,0.006866455078125, +! 0.0034332275390625,0.00171661376953125, + + +! Maximum number of Newton iterations in each round +integer, parameter :: max_newton_iter = 100 + +! Flag definitions for convergence flag (icnv) +! icnv = 1 fail the round due to either wacky math, or +! too many Newton iterations +! icnv = 2 continue onto next iteration, +! icnv = 3 acceptable solution + + +integer, parameter :: icnv_fail_round = 1 +integer, parameter :: icnv_pass_round = 2 + +! Timestep reduction factor when a round of +! newton iterations fail. + +real(r8), parameter :: dtime_rf = 0.5_r8 + +! These are the initial relaxation factors at the beginning +! of the large time-step. These may or may not shrink on +! subsequent rounds, and may or may not grow over subsequent +! iterations within rounds +real(r8), parameter :: rlfx_soil_init = 1.0 ! Initial Pressure update +! reduction factor for soil compartments +real(r8), parameter :: rlfx_plnt_init = 1.0 ! Initial Pressure update +! reduction factor for plant comparmtents +real(r8), parameter :: dpsi_scap = 0.2 ! Changes in psi (for soil) larger than this +! will be subject to a capping routine +real(r8), parameter :: dpsi_pcap = 0.3 ! Change sin psi (for plants) larger than this +! will be subject to a capping routine +real(r8), parameter :: rlfx_plnt_shrink = 1.0 ! Shrink the starting plant relaxtion factor +! by this multipliler each round +real(r8), parameter :: rlfx_soil_shrink = 1.0 ! Shrink the starting soil relaxtion factor +! by this multipliler each round +logical, parameter :: reset_on_fail = .false. ! If a round of Newton iterations is unable +! to find a solution, you can either reset +! to the beginning of the large timestep (true), or +! to the beginning of the current substep (false) + +logical, parameter :: allow_lenient_lastiter = .true. ! If this is true, when the newton iteration +! reaches its last allowed attempt, the +! error tolerance will be increased (the bar lowered) by 10x + + + +associate(conn_up => site_hydr%conn_up, & + conn_dn => site_hydr%conn_dn, & + kmax_up => site_hydr%kmax_up, & + kmax_dn => site_hydr%kmax_dn, & + q_flux => site_hydr%q_flux, & + residual => site_hydr%residual, & + ajac => site_hydr%ajac, & + ipiv => site_hydr%ipiv, & + th_node => site_hydr%th_node, & + th_node_prev => site_hydr%th_node_prev, & + th_node_init => site_hydr%th_node_init, & + psi_node => site_hydr%psi_node, & + pm_node => site_hydr%pm_node, & + ftc_node => site_hydr%ftc_node, & + z_node => site_hydr%z_node, & + v_node => site_hydr%v_node, & + dth_node => site_hydr%dth_node, & + node_layer => site_hydr%node_layer, & + h_node => site_hydr%h_node, & + dftc_dpsi_node => site_hydr%dftc_dpsi_node, & + ft => cohort%pft) + + + !for debug only +nstep = get_nstep() + + +! This NaN's the scratch arrays +call site_hydr%FlushSiteScratch() + +! This is the maximum number of iterations needed for this cohort +! (each soil layer has a different number, this saves the max) +cohort_hydr%iterh1 = 0 +cohort_hydr%iterh2 = 0 + +! These are output fluxes from the subroutine, total integrated +! mass fluxes [kg] over the time-step. sapflow is the integrated +! flux between the transporting root and the 1st stem compartment. +! The rootuptake is the integrated flux between the 1st rhizosphere +! and absorbing roots +sapflow = 0._r8 +rootuptake(:) = 0._r8 + +! Chnage in water content, over all substeps [m3/m3] +dth_node(:) = 0._r8 + +! Transfer node heights, volumes and initial water contents for +! the transporting root and above ground compartments to the +! complete node vector + +do i = 1,n_hypool_ag+n_hypool_troot + if (i<=n_hypool_ag) then + z_node(i) = cohort_hydr%z_node_ag(i) + v_node(i) = cohort_hydr%v_ag(i) + th_node_init(i) = cohort_hydr%th_ag(i) + elseif (i>n_hypool_ag) then + z_node(i) = cohort_hydr%z_node_troot + v_node(i) = cohort_hydr%v_troot + th_node_init(i) = cohort_hydr%th_troot + end if +end do + +! Transfer node-heights, volumes and intiial water contents +! for below-ground components, +! from the cohort structures, into the complete node vector +i = n_hypool_ag + n_hypool_troot + +do j = 1,site_hydr%nlevrhiz + + ! Calculate the fraction of the soil layer + ! folume that this plant's rhizosphere accounts forPath is across the upper an lower rhizosphere comparment + ! on each side of the nodes. Since there is no flow across the outer + ! node to the edge, we ignore that last half compartment + aroot_frac_plant = cohort_hydr%l_aroot_layer(j)/site_hydr%l_aroot_layer(j) + + do k = 1, n_hypool_aroot + nshell + i = i + 1 + if (k==1) then + z_node(i) = -site_hydr%zi_rhiz(j) + v_node(i) = cohort_hydr%v_aroot_layer(j) + th_node_init(i) = cohort_hydr%th_aroot(j) + else + kshell = k-1 + z_node(i) = -site_hydr%zi_rhiz(j) + ! The volume of the Rhizosphere for a single plant + v_node(i) = site_hydr%v_shell(j,kshell)*aroot_frac_plant + th_node_init(i) = site_hydr%h2osoi_liqvol_shell(j,kshell) + end if + enddo - function zeng2001_crootfr(a, b, z, z_max) result(crootfr) +enddo - ! !ARGUMENTS: - real(r8) , intent(in) :: a,b ! pft parameters - real(r8) , intent(in) :: z ! soil depth (m) - real(r8) , intent(in), optional :: z_max ! max soil depth (m) - ! - real(r8) :: crootfr_max - ! !RESULT - real(r8) :: crootfr ! cumulative root fraction - ! - !------------------------------------------------------------------------ - crootfr = 1._r8 - .5_r8*(exp(-a*z) + exp(-b*z)) +! Total water mass in the plant at the beginning of this solve [kg h2o] +w_tot_beg = sum(th_node_init(:)*v_node(:))*denh2o - ! If a maximum rooting depth is provided, then - ! we force everything to sum to unity. We do this by - ! simply dividing through by the maximum possible - ! root fraction. +! Initialize variables and flags that track +! the progress of the solve - if(present(z_max))then - crootfr_max = 1._r8 - .5_r8*(exp(-a*z_max) + exp(-b*z_max)) - crootfr = crootfr/crootfr_max - end if +tm = 0 +nsteps = 0 +th_node_prev(:) = th_node_init(:) +th_node(:) = th_node_init(:) +dtime = tmx +rlfx_plnt0 = rlfx_plnt_init +rlfx_soil0 = rlfx_soil_init +rlfx_plnt = rlfx_plnt0 +rlfx_soil = rlfx_soil0 - if(debug)then - if(present(z_max))then - if((crootfr_max1.0_r8) )then - write(fates_log(),*) 'problem scaling crootfr in zeng2001' - write(fates_log(),*) 'z_max: ',z_max - write(fates_log(),*) 'crootfr_max: ',crootfr_max - end if - end if - end if +outerloop: do while( tm < tmx ) + ! The solve may reduce the time-step, the shorter + ! time-steps may not be perfectly divisible into + ! the remaining time. If so, then make sure we + ! don't overshoot - return + dtime = min(dtime,tmx-tm) - end function zeng2001_crootfr + ! Advance time forward + tm = tm + dtime + ! If we have not exceeded our max number + ! of retrying rounds of Newton iterations, reduce + ! time and try a new round - ! ===================================================================================== + if( nsteps > max_newton_rounds ) then - subroutine shellGeom(l_aroot, rs1, area_site, dz, r_out_shell, r_node_shell, v_shell) - ! - ! !DESCRIPTION: Updates size of 'representative' rhizosphere -- node radii, volumes. - ! As fine root biomass (and thus absorbing root length) increases, this characteristic - ! rhizosphere shrinks even though the total volume of soil surrounding fine roots remains - ! the same. - ! - ! !USES: + ! Complete failure to converge even with re-trying + ! iterations with smaller timesteps - ! - ! !ARGUMENTS: - real(r8) , intent(in) :: l_aroot ! Total length of absorbing roots - ! for the whole site, this layer (m) - real(r8) , intent(in) :: rs1 ! Fine root radius (m) - real(r8) , intent(in) :: area_site ! Area of site (10,000 m2) - real(r8) , intent(in) :: dz ! Width of current soil layer (m) - real(r8) , intent(out) :: r_out_shell(:) ! Outer radius of each shell (m) - real(r8) , intent(out) :: r_node_shell(:) ! Radius of the shell's midpoint - real(r8) , intent(out) :: v_shell(:) ! volume of the rhizosphere shells (m3/ha) - ! for this layer - ! - ! !LOCAL VARIABLES: - integer :: k ! rhizosphere shell indicies - integer :: nshells ! We don't use the global because of unit testing - !----------------------------------------------------------------------- + write(fates_log(),*) 'Newton hydraulics solve' + write(fates_log(),*) 'could not converge on a solution.' + write(fates_log(),*) 'Perhaps try increasing iteration cap,' + write(fates_log(),*) 'and decreasing relaxation factors.' + write(fates_log(),*) 'pft: ',ft,' dbh: ',cohort%dbh + call endrun(msg=errMsg(sourcefile, __LINE__)) - - nshells = size(r_out_shell,dim=1) - - ! update outer radii of column-level rhizosphere shells (same across patches and cohorts) - r_out_shell(nshells) = (pi_const*l_aroot/(area_site*dz))**(-0.5_r8) ! eqn(8) S98 - if(nshells > 1) then - do k = 1,nshells-1 - r_out_shell(k) = rs1*(r_out_shell(nshells)/rs1)**((real(k,r8))/real(nshells,r8)) ! eqn(7) S98 - enddo - end if - - ! set nodal (midpoint) radii of these shells - ! BOC...not doing this as it requires PFT-specific fine root thickness, but this is at column level - r_node_shell(1) = 0.5_r8*(rs1 + r_out_shell(1)) - !r_node_shell(1) = 0.5_r8*(r_out_shell(1)) - - do k = 2,nshells - r_node_shell(k) = 0.5_r8*(r_out_shell(k-1) + r_out_shell(k)) - enddo - - ! update volumes - do k = 1,nshells - if(k == 1) then - v_shell(k) = pi_const*l_aroot*(r_out_shell(k)**2._r8 - rs1**2._r8) - else - v_shell(k) = pi_const*l_aroot*(r_out_shell(k)**2._r8 - r_out_shell(k-1)**2._r8) - end if - enddo + endif - return - end subroutine shellGeom - ! ===================================================================================== + ! This is the newton search loop - function xylemtaper(p, dz) result(chi_tapnotap) + continue_search = .true. + nwtn_iter = 0 + newtonloop: do while(continue_search) - ! !ARGUMENTS: - real(r8) , intent(in) :: p ! Taper exponent (see EDPftvar hydr_p_taper) [-] - real(r8) , intent(in) :: dz ! hydraulic distance from petiole to node of interest [m] - ! - ! !LOCAL VARIABLES: - real(r8) :: atap,btap ! scaling exponents for total conductance ~ tree size (ratio of stem radius to terminal twig radius) - real(r8) :: anotap,bnotap ! same as atap, btap, but not acounting for xylem taper (Savage et al. (2010) p = 0) - ! NOTE: these scaling exponents were digitized from Fig 2a of Savage et al. (2010) - ! Savage VM, Bentley LP, Enquist BJ, Sperry JS, Smith DD, Reich PB, von Allmen EI. 2010. - ! Hydraulic trade-offs and space filling enable better predictions of vascular structure - ! and function in plants. Proceedings of the National Academy of Sciences 107(52): 22722-22727. - real(r8) :: lN=0.04_r8 ! petiole length [m] - real(r8) :: little_n=2._r8 ! number of daughter branches per parent branch, assumed constant throughout tree (self-similarity) [-] - real(r8) :: big_n ! number of branching levels (allowed here to take on non-integer values): increases with tree size [-] - real(r8) :: ktap ! hydraulic conductance along the pathway, accounting for xylem taper [kg s-1 MPa-1] - real(r8) :: knotap ! hydraulic conductance along the pathway, not accounting for xylem taper [kg s-1 MPa-1] - real(r8) :: num ! temporary - real(r8) :: den ! temporary - ! - ! !RESULT - real(r8) :: chi_tapnotap ! ratio of total tree conductance accounting for xylem taper to that without, over interval dz - ! - !------------------------------------------------------------------------ - - anotap = 7.19903e-13_r8 - bnotap = 1.326105578_r8 - if (p >= 1.0_r8) then - btap = 2.00586217_r8 - atap = 1.82513E-12_r8 - else if (p >= (1._r8/3._r8) .AND. p < 1._r8) then - btap = 1.854812819_r8 - atap = 6.66908E-13_r8 - else if (p >= (1._r8/6._r8) .AND. p < (1._r8/3._r8)) then - btap = 1.628179741_r8 - atap = 6.58345E-13_r8 - else - btap = bnotap - atap = anotap - end if + nwtn_iter = nwtn_iter + 1 - num = 3._r8*log(1._r8 - dz/lN * (1._r8-little_n**(1._r8/3._r8))) - den = log(little_n) - big_n = num/den - 1._r8 - ktap = atap * (little_n**(big_N* btap/2._r8)) - knotap = anotap * (little_n**(big_N*bnotap/2._r8)) - chi_tapnotap = ktap / knotap + ! The Jacobian and the residual are incremented, + ! and the Jacobian is sparse, thus they both need + ! to be zerod. + ajac(:,:) = 0._r8 + residual(:) = 0._r8 - return + do k=1,site_hydr%num_nodes - end function xylemtaper - - ! ===================================================================================== - - subroutine Hydraulics_Tridiagonal(a, b, c, r, u, ierr) - ! - ! !DESCRIPTION: An abbreviated version of biogeophys/TridiagonalMod.F90 - ! - ! This solves the form: - ! - ! a(i)*u(i-1) + b(i)*u(i) + c(i)*u(i+1) = r(i) - ! - ! It assumed that coefficient a(1) and c(N) DNE as there is - ! no u(0) or u(N-1). - ! - ! !USES: - ! - ! !ARGUMENTS - real(r8), intent(in) :: a(:) ! "a" left off diagonal of tridiagonal matrix - real(r8), intent(in) :: b(:) ! "b" diagonal column of tridiagonal matrix - real(r8), intent(in) :: c(:) ! "c" right off diagonal of tridiagonal matrix - real(r8), intent(in) :: r(:) ! "r" forcing term of tridiagonal matrix - real(r8), intent(out) :: u(:) ! solution - integer, intent(out) :: ierr ! flag: 0=passed, 1=failed - ! - ! !LOCAL VARIABLES: - real(r8) :: bet ! temporary - real(r8) :: gam(10) ! temporary - integer :: k ! index - integer :: N ! Size of the matrix - real(r8) :: err ! solution error, in units of [m3/m3] - real(r8) :: rel_err ! relative error, normalized by delta theta - real(r8), parameter :: allowable_rel_err = 0.0001_r8 - - !---------------------------------------------------------------------- - N=size(r,dim=1) - bet = b(1) - do k=1,N - if(k == 1) then - u(k) = r(k) / bet - else - gam(k) = c(k-1) / bet - bet = b(k) - a(k) * gam(k) - u(k) = (r(k) - a(k)*u(k-1)) / bet - end if - enddo + ! This is the storage gained from previous newton iterations. + residual(k) = residual(k) + denh2o*v_node(k)*(th_node(k) - th_node_prev(k))/dtime - do k=N-1,1,-1 - u(k) = u(k) - gam(k+1) * u(k+1) - enddo + if(pm_node(k) == rhiz_p_media) then - ! If debug mode, calculate error on the forward solution - ierr = 0 - if(debug)then - do k=1,N - if(k==1)then - err = abs(r(k) - (b(k)*u(k)+c(k)*u(k+1))) - elseif(knearzero)then - rel_err = abs(err/u(k)) - if( ((rel_err > allowable_rel_err) .and. (err > max_wb_step_err)) .or. & - (err /= err) )then - write(fates_log(),*) 'Tri-diagonal solve produced solution with' - write(fates_log(),*) 'non-negligable error.' - write(fates_log(),*) 'Compartment: ',k - write(fates_log(),*) 'Error in forward solution: ',err - write(fates_log(),*) 'Estimated delta theta: ',u(k) - write(fates_log(),*) 'Rel Error: ',rel_err - write(fates_log(),*) 'Reducing time-step' - ierr = 1 - end if - end if - end do - end if + j = node_layer(k) + psi_node(k) = site_hydr%wrf_soil(j)%p%psi_from_th(th_node(k)) - end subroutine Hydraulics_Tridiagonal + ! Get total potential [Mpa] + h_node(k) = mpa_per_pa*denh2o*grav_earth*z_node(k) + psi_node(k) + ! Get Fraction of Total Conductivity [-] + ftc_node(k) = site_hydr%wkf_soil(j)%p%ftc_from_psi(psi_node(k)) + ! deriv ftc wrt psi + dftc_dpsi_node(k) = site_hydr%wkf_soil(j)%p%dftcdpsi_from_psi(psi_node(k)) - ! ===================================================================================== + else - subroutine MatSolve2D(bc_in,site_hydr,cohort,cohort_hydr, & - tmx,qtop, & - sapflow,rootuptake,wb_err_plant , dwat_plant, & - dth_layershell_site) - - - ! --------------------------------------------------------------------------------- - ! This solution to the plant water flux equations casts all the fluxes through a - ! cohort, and the rhizosphere shells in ALL layers as a single system of equations. - ! If thinking of the plant's above ground components as one dimension, and the soil - ! layers as another, this is a somewhat 2D system (hence "Matrix" in the name). - ! To improve the quality of the solution and reduce solver error, this also - ! uses a Newton iteration. See technical documentation for a full derivation - ! of the mathematics. However, in brief, we can describe the flux balance through - ! any node, considering flux paths labeled j, through that node in set J. - ! This is an implicit solve, so we balance the change in water mass (defined by - ! volume V, density rho, and water content theta) with the flux (q) esitmated - ! at the next time-step q^(t+1). Note that we continue to solve this equation, using - ! updated values of water content and pressure (psi), by balancing our fluxes with - ! the total of previous (theta_p) and remaining (theta_r) water contents. - ! - ! rho V rho V - ! ----- Del theta_p + ----- Del theta_r = Sum ( q^(t+1) ) - ! Del t Del t J - ! - ! The flux at t+1, is simply the current flux (q) and a first order Taylor - ! expanion (i.e. forward-euler) estimate with the current derivative based - ! on the current value of theta and psi. - ! Note also, that the solution is in terms of the matric potential, psi. This - ! conversion from theta to psi, requires this derivative (Jacobian) to also - ! contain not just the rate of change of flux wrt psi, but the change in theta - ! wrt psi (self term, no cross node terms). - ! - ! ----------------------------------------------------------------------------------- + psi_node(k) = wrf_plant(pm_node(k),ft)%p%psi_from_th(th_node(k)) + ! Get total potential [Mpa] + h_node(k) = mpa_per_pa*denh2o*grav_earth*z_node(k) + psi_node(k) + ! Get Fraction of Total Conductivity [-] + ftc_node(k) = wkf_plant(pm_node(k),ft)%p%ftc_from_psi(psi_node(k)) + ! deriv ftc wrt psi + dftc_dpsi_node(k) = wkf_plant(pm_node(k),ft)%p%dftcdpsi_from_psi(psi_node(k)) - - ! ARGUMENTS: - ! ----------------------------------------------------------------------------------- - type(bc_in_type),intent(in) :: bc_in - type(ed_site_hydr_type), intent(inout),target :: site_hydr ! ED site_hydr structure - type(ed_cohort_hydr_type), target :: cohort_hydr - type(ed_cohort_type) , intent(inout), target :: cohort - real(r8),intent(in) :: tmx ! time interval to integrate over [s] - real(r8),intent(in) :: qtop - real(r8),intent(out) :: sapflow ! time integrated mass flux between transp-root and stem [kg] - real(r8),intent(out) :: rootuptake(:) ! time integrated mass flux between rhizosphere and aroot [kg] - - - real(r8),intent(out) :: wb_err_plant ! total error over plant, transpiration - ! should match change in storage [kg/m2] - real(r8),intent(out) :: dwat_plant ! total change in water mass for the plant [kg] - real(r8),intent(inout) :: dth_layershell_site(:,:) - - integer :: nsteps ! Number of rounds of attempts we have made - integer :: i ! generic index (sometimes node index) - integer :: inode ! node index - integer :: k ! generic node index - integer :: j_bc ! layer of bc - integer :: j, icnx ! soil layer and connection indices - integer :: id_dn, id_up ! Node indices on each side of flux path - integer :: ishell ! rhizosphere shell index - - integer :: icnv ! Convergence flag for each solve, see flag definitions - ! below. - - real(r8) :: aroot_frac_plant ! Fraction of rhizosphere this plant "owns" - - real(r8) :: dqflx_dpsi_dn ! Derivative, change in mass flux per change - ! in matric potential of the down-stream node - ! [kg s-1 Mpa-1] - - real(r8) :: dqflx_dpsi_up ! Derivative, change in mass flux per change - ! in matric potential of the up-stream node - ! [kg s-1 Mpa-1] - - real(r8) :: dk_dpsi_dn ! change in effective conductance from the - ! downstream pressure node - real(r8) :: dk_dpsi_up ! change in effective conductance from the - ! upstream pressure node - - real(r8) :: residual_amax ! maximum absolute mass balance residual over all - ! nodes, - ! used for determining convergence. At the point - - real(r8) :: rsdx ! Temporary residual while determining max value - - - real(r8) :: rlfx_soil ! Pressure update reduction factor for soil compartments - real(r8) :: rlfx_plnt ! Pressure update reduction factor for plant comparmtents - real(r8) :: rlfx_soil0 ! Base relaxation factor for the current iteration round - real(r8) :: rlfx_plnt0 ! "" - - real(r8) :: tm ! Total time integrated after each substep [s] - real(r8) :: dtime ! Total time to be integrated this step [s] - real(r8) :: w_tot_beg ! total plant water prior to solve [kg] - real(r8) :: w_tot_end ! total plant water at end of solve [kg] - logical :: continue_search - real(r8) :: k_eff ! Effective conductivity over the current pathway - ! between two nodes. Factors in fractional - ! loss of conductivity on each side of the pathway, and the material maximum - ! conductivity on each side [kg/s/MPa] - integer :: icnx_ar ! Connection index of the aroot <-> rhizosphere shell - - integer :: nsd ! node index of highest residual - integer :: nwtn_iter ! number of (Newton) iterations on each substep - - ! to get a succesfull Newton solve. - integer :: kshell ! rhizosphere shell index, 1->nshell - - integer :: info - integer :: nstep !number of time steps - - - ! This is a convergence test. This is the maximum difference - ! allowed between the flux balance and the change in storage - ! on a node. [kg/s] *Note, 1.e-9 = 1 ug/s - real(r8), parameter :: max_allowed_residual = 1.e-8_r8 - - ! Maximum number of times we re-try a round of Newton - ! iterations, each time decreasing the time-step and - ! potentially reducing relaxation factors - integer, parameter :: max_newton_rounds = 10 - - ! dtime will shrink at the following rate (halving) [s]: - ! 1800,900,450,225,112.5,56.25,28.125,14.0625,7.03125,3.515625, - ! 1.7578125,0.87890625,0.439453125,0.2197265625,0.10986328125, - ! 0.054931640625,0.0274658203125,0.01373291015625,0.006866455078125, - ! 0.0034332275390625,0.00171661376953125, - - - ! Maximum number of Newton iterations in each round - integer, parameter :: max_newton_iter = 100 - - ! Flag definitions for convergence flag (icnv) - ! icnv = 1 fail the round due to either wacky math, or - ! too many Newton iterations - ! icnv = 2 continue onto next iteration, - ! icnv = 3 acceptable solution - - - integer, parameter :: icnv_fail_round = 1 - integer, parameter :: icnv_pass_round = 2 - - ! Timestep reduction factor when a round of - ! newton iterations fail. - - real(r8), parameter :: dtime_rf = 0.5_r8 - - ! These are the initial relaxation factors at the beginning - ! of the large time-step. These may or may not shrink on - ! subsequent rounds, and may or may not grow over subsequent - ! iterations within rounds - real(r8), parameter :: rlfx_soil_init = 1.0 ! Initial Pressure update - ! reduction factor for soil compartments - real(r8), parameter :: rlfx_plnt_init = 1.0 ! Initial Pressure update - ! reduction factor for plant comparmtents - real(r8), parameter :: dpsi_scap = 0.2 ! Changes in psi (for soil) larger than this - ! will be subject to a capping routine - real(r8), parameter :: dpsi_pcap = 0.3 ! Change sin psi (for plants) larger than this - ! will be subject to a capping routine - real(r8), parameter :: rlfx_plnt_shrink = 1.0 ! Shrink the starting plant relaxtion factor - ! by this multipliler each round - real(r8), parameter :: rlfx_soil_shrink = 1.0 ! Shrink the starting soil relaxtion factor - ! by this multipliler each round - logical, parameter :: reset_on_fail = .false. ! If a round of Newton iterations is unable - ! to find a solution, you can either reset - ! to the beginning of the large timestep (true), or - ! to the beginning of the current substep (false) - - logical, parameter :: allow_lenient_lastiter = .true. ! If this is true, when the newton iteration - ! reaches its last allowed attempt, the - ! error tolerance will be increased (the bar lowered) by 10x - - - - associate(conn_up => site_hydr%conn_up, & - conn_dn => site_hydr%conn_dn, & - kmax_up => site_hydr%kmax_up, & - kmax_dn => site_hydr%kmax_dn, & - q_flux => site_hydr%q_flux, & - residual => site_hydr%residual, & - ajac => site_hydr%ajac, & - ipiv => site_hydr%ipiv, & - th_node => site_hydr%th_node, & - th_node_prev => site_hydr%th_node_prev, & - th_node_init => site_hydr%th_node_init, & - psi_node => site_hydr%psi_node, & - pm_node => site_hydr%pm_node, & - ftc_node => site_hydr%ftc_node, & - z_node => site_hydr%z_node, & - v_node => site_hydr%v_node, & - dth_node => site_hydr%dth_node, & - node_layer => site_hydr%node_layer, & - h_node => site_hydr%h_node, & - dftc_dpsi_node => site_hydr%dftc_dpsi_node, & - ft => cohort%pft) - - - !for debug only - nstep = get_nstep() - - - ! This NaN's the scratch arrays - call site_hydr%FlushSiteScratch() - - ! This is the maximum number of iterations needed for this cohort - ! (each soil layer has a different number, this saves the max) - cohort_hydr%iterh1 = 0 - cohort_hydr%iterh2 = 0 - - ! These are output fluxes from the subroutine, total integrated - ! mass fluxes [kg] over the time-step. sapflow is the integrated - ! flux between the transporting root and the 1st stem compartment. - ! The rootuptake is the integrated flux between the 1st rhizosphere - ! and absorbing roots - sapflow = 0._r8 - rootuptake(:) = 0._r8 - - ! Chnage in water content, over all substeps [m3/m3] - dth_node(:) = 0._r8 - - ! Transfer node heights, volumes and initial water contents for - ! the transporting root and above ground compartments to the - ! complete node vector - - do i = 1,n_hypool_ag+n_hypool_troot - if (i<=n_hypool_ag) then - z_node(i) = cohort_hydr%z_node_ag(i) - v_node(i) = cohort_hydr%v_ag(i) - th_node_init(i) = cohort_hydr%th_ag(i) - elseif (i>n_hypool_ag) then - z_node(i) = cohort_hydr%z_node_troot - v_node(i) = cohort_hydr%v_troot - th_node_init(i) = cohort_hydr%th_troot end if - end do - - ! Transfer node-heights, volumes and intiial water contents - ! for below-ground components, - ! from the cohort structures, into the complete node vector - i = n_hypool_ag + n_hypool_troot - - do j = 1,site_hydr%nlevrhiz - - ! Calculate the fraction of the soil layer - ! folume that this plant's rhizosphere accounts forPath is across the upper an lower rhizosphere comparment - ! on each side of the nodes. Since there is no flow across the outer - ! node to the edge, we ignore that last half compartment - aroot_frac_plant = cohort_hydr%l_aroot_layer(j)/site_hydr%l_aroot_layer(j) - - do k = 1, n_hypool_aroot + nshell - i = i + 1 - if (k==1) then - z_node(i) = -site_hydr%zi_rhiz(j) - v_node(i) = cohort_hydr%v_aroot_layer(j) - th_node_init(i) = cohort_hydr%th_aroot(j) - else - kshell = k-1 - z_node(i) = -site_hydr%zi_rhiz(j) - ! The volume of the Rhizosphere for a single plant - v_node(i) = site_hydr%v_shell(j,kshell)*aroot_frac_plant - th_node_init(i) = site_hydr%h2osoi_liqvol_shell(j,kshell) - end if - enddo + + ! Fill the self-term on the Jacobian's diagonal with the + ! the change in storage wrt change in psi. + + if(pm_node(k) == rhiz_p_media) then + j = node_layer(k) + ajac(k,k) = -denh2o*v_node(k)/(site_hydr%wrf_soil(j)%p%dpsidth_from_th(th_node(k))*dtime) + else + ajac(k,k) = -denh2o*v_node(k)/(wrf_plant(pm_node(k),ft)%p%dpsidth_from_th(th_node(k))*dtime) + endif enddo - ! Total water mass in the plant at the beginning of this solve [kg h2o] - w_tot_beg = sum(th_node_init(:)*v_node(:))*denh2o - - - ! Initialize variables and flags that track - ! the progress of the solve - - tm = 0 - nsteps = 0 - th_node_prev(:) = th_node_init(:) - th_node(:) = th_node_init(:) - dtime = tmx - rlfx_plnt0 = rlfx_plnt_init - rlfx_soil0 = rlfx_soil_init - rlfx_plnt = rlfx_plnt0 - rlfx_soil = rlfx_soil0 - - outerloop: do while( tm < tmx ) - - ! The solve may reduce the time-step, the shorter - ! time-steps may not be perfectly divisible into - ! the remaining time. If so, then make sure we - ! don't overshoot - - dtime = min(dtime,tmx-tm) - - ! Advance time forward - tm = tm + dtime - ! If we have not exceeded our max number - ! of retrying rounds of Newton iterations, reduce - ! time and try a new round - - if( nsteps > max_newton_rounds ) then - - ! Complete failure to converge even with re-trying - ! iterations with smaller timesteps - - write(fates_log(),*) 'Newton hydraulics solve' - write(fates_log(),*) 'could not converge on a solution.' - write(fates_log(),*) 'Perhaps try increasing iteration cap,' - write(fates_log(),*) 'and decreasing relaxation factors.' - write(fates_log(),*) 'pft: ',ft,' dbh: ',cohort%dbh - call endrun(msg=errMsg(sourcefile, __LINE__)) - - endif - - - ! This is the newton search loop - - continue_search = .true. - nwtn_iter = 0 - newtonloop: do while(continue_search) - - nwtn_iter = nwtn_iter + 1 - - ! The Jacobian and the residual are incremented, - ! and the Jacobian is sparse, thus they both need - ! to be zerod. - ajac(:,:) = 0._r8 - residual(:) = 0._r8 - - do k=1,site_hydr%num_nodes - - ! This is the storage gained from previous newton iterations. - residual(k) = residual(k) + denh2o*v_node(k)*(th_node(k) - th_node_prev(k))/dtime - - if(pm_node(k) == rhiz_p_media) then - - j = node_layer(k) - psi_node(k) = site_hydr%wrf_soil(j)%p%psi_from_th(th_node(k)) - - ! Get total potential [Mpa] - h_node(k) = mpa_per_pa*denh2o*grav_earth*z_node(k) + psi_node(k) - ! Get Fraction of Total Conductivity [-] - ftc_node(k) = site_hydr%wkf_soil(j)%p%ftc_from_psi(psi_node(k)) - ! deriv ftc wrt psi - dftc_dpsi_node(k) = site_hydr%wkf_soil(j)%p%dftcdpsi_from_psi(psi_node(k)) - - else - - psi_node(k) = wrf_plant(pm_node(k),ft)%p%psi_from_th(th_node(k)) - ! Get total potential [Mpa] - h_node(k) = mpa_per_pa*denh2o*grav_earth*z_node(k) + psi_node(k) - ! Get Fraction of Total Conductivity [-] - ftc_node(k) = wkf_plant(pm_node(k),ft)%p%ftc_from_psi(psi_node(k)) - ! deriv ftc wrt psi - dftc_dpsi_node(k) = wkf_plant(pm_node(k),ft)%p%dftcdpsi_from_psi(psi_node(k)) - - end if - - ! Fill the self-term on the Jacobian's diagonal with the - ! the change in storage wrt change in psi. - - if(pm_node(k) == rhiz_p_media) then - j = node_layer(k) - ajac(k,k) = -denh2o*v_node(k)/(site_hydr%wrf_soil(j)%p%dpsidth_from_th(th_node(k))*dtime) - else - ajac(k,k) = -denh2o*v_node(k)/(wrf_plant(pm_node(k),ft)%p%dpsidth_from_th(th_node(k))*dtime) - endif - - enddo - - - ! Calculations of maximum conductance for upstream and downstream sides - ! of each connection. This IS dependant on total potential h_node - ! because of the root-soil radial conductance. - - call SetMaxCondConnections(site_hydr, cohort_hydr, h_node, kmax_dn, kmax_up) - - ! calculate boundary fluxes - do icnx=1,site_hydr%num_connections - - id_dn = conn_dn(icnx) - id_up = conn_up(icnx) - - ! The row (first index) of the Jacobian (ajac) represents the - ! the node for which we are calculating the water balance - ! The column (second index) of the Jacobian represents the nodes - ! on which the pressure differentials effect the water balance - ! of the node of the first index. - ! This will get the effective K, and may modify FTC depending - ! on the flow direction - - call GetKAndDKDPsi(kmax_dn(icnx), & - kmax_up(icnx), & - h_node(id_dn), & - h_node(id_up), & - ftc_node(id_dn), & - ftc_node(id_up), & - dftc_dpsi_node(id_dn), & - dftc_dpsi_node(id_up), & - dk_dpsi_dn, & - dk_dpsi_up, & - k_eff) - - q_flux(icnx) = k_eff*(h_node(id_up)-h_node(id_dn)) - - ! See equation (22) in technical documentation - ! Add fluxes at current time to the residual - residual(id_dn) = residual(id_dn) - q_flux(icnx) - residual(id_up) = residual(id_up) + q_flux(icnx) - - ! This is the Jacobian term related to the pressure changes on the down-stream side - ! and these are applied to both the up and downstream sides (oppositely) - ! This should be used for the down-stream on thr second index) - dqflx_dpsi_dn = -k_eff + (h_node(id_up)-h_node(id_dn)) * dk_dpsi_dn - - ! This is the Jacobian term related to the pressure changes on the up-stream side - ! and these are applied to both the up and downstream sides (oppositely) - dqflx_dpsi_up = k_eff + (h_node(id_up)-h_node(id_dn)) * dk_dpsi_up - - ! Down-stream node's contribution to the down-stream node's mass balance - ajac(id_dn,id_dn) = ajac(id_dn,id_dn) + dqflx_dpsi_dn - - ! Down-stream node's contribution to the up-stream node's mass balance - ajac(id_up,id_dn) = ajac(id_up,id_dn) - dqflx_dpsi_dn - - ! Up-stream node's contribution to the down-stream node's mass balance - ajac(id_dn,id_up) = ajac(id_dn,id_up) + dqflx_dpsi_up - - ! Up-stream node's contribution to the up-stream node's mass balance - ajac(id_up,id_up) = ajac(id_up,id_up) - dqflx_dpsi_up - - - - enddo - - ! Add the transpiration flux (known, retrieved from photosynthesis scheme) - ! to the mass balance on the leaf (1st) node. This is constant over - ! the time-step, so no Jacobian term needed (yet) - - residual(1) = residual(1) + qtop - - - ! Start off assuming things will pass, then find numerous - ! ways to see if it failed - icnv = icnv_pass_round - - - ! If we have performed any Newton iterations, then the residual - ! may reflect a flux that balances (equals) the change in storage. If this is - ! true, then the residual is zero, and we are done with the sub-step. If it is - ! not nearly zero, then we must continue our search and perform another solve. - - residual_amax = 0._r8 - nsd = 0 - do k = 1, site_hydr%num_nodes - rsdx = abs(residual(k)) - ! check NaNs - if( rsdx /= rsdx ) then - icnv = icnv_fail_round - exit - endif - if( rsdx > residual_amax ) then - residual_amax = rsdx - nsd = k - endif - enddo - if ( nwtn_iter > max_newton_iter) then - icnv = icnv_fail_round - write(fates_log(),*) 'Newton hydraulics solve failed',residual_amax,nsd,tm - endif - - ! Three scenarios: - ! 1) the residual is 0, everything is great, leave iteration loop - ! 2) the residual is not 0, but we have not taken too many steps - ! and the matrix solve did not fail. Perform an inversion and keep - ! searching. - ! 3) the residual is not 0, and either - ! we have taken too many newton steps or the solver won't return - ! a real solution. - ! Shorten time-step, reset time to 0, reset relaxation factors - ! and try a new round of newton (if not exceeded) - - - if( icnv == icnv_fail_round ) then - - ! If the newton iteration fails, we go back - ! to restart the time-stepping loop with shorter sub-steps. - ! Therefore, we set the time elapsed (tm) to zero, - ! shorten the timstep (dtime) and re-initialize the water - ! contents to the starting amount. - - if(reset_on_fail) then - tm = 0._r8 - th_node(:) = th_node_init(:) - th_node_prev(:) = th_node_init(:) - cohort_hydr%iterh1 = 0 - else - tm = tm - dtime - th_node(:) = th_node_prev(:) - !* No need to update the th_node_prev, it is the - ! same since we are just re-starting the current - ! step - end if - nsteps = nsteps + 1 - dtime = dtime * dtime_rf - rlfx_plnt0 = rlfx_plnt_init*rlfx_plnt_shrink**real(nsteps,r8) - rlfx_soil0 = rlfx_soil_init*rlfx_soil_shrink**real(nsteps,r8) - rlfx_plnt = rlfx_plnt0 - rlfx_soil = rlfx_soil0 - nwtn_iter = 0 - cohort_hydr%iterh1 = cohort_hydr%iterh1 + 1 - cycle outerloop - - else - - ! On the last iteration, we temporarily lower the bar (if opted for) - ! and allow a pass if the residual is within 10x of the typical allowed residual - if ( allow_lenient_lastiter ) then - if ( nwtn_iter == max_newton_iter .and. residual_amax < 10*max_allowed_residual ) then - exit newtonloop - end if - end if - - if( sum(residual(:)) < max_allowed_residual .and. residual_amax < max_allowed_residual ) then - - ! We have succesffully found a solution - ! in this newton iteration. - exit newtonloop - else - ! Move ahead and calculate another solution - ! and continue the search. Residual isn't zero - ! but no reason not to continue searching - - ! Record that we performed a solve (this is total iterations) - cohort_hydr%iterh2 = cohort_hydr%iterh2 + 1 - - ! --------------------------------------------------------------------------- - ! From Lapack documentation - ! - ! subroutine dgesv(integer N (in), - ! integer NRHS (in), - ! real(r8), dimension( lda, * ) A (in/out), - ! integer LDA (in), - ! integer, dimension( * ) IPIV (out), - ! real(r8), dimension( ldb, * ) B (in/out), - ! integer LDB (in), - ! integer INFO (out) ) - ! - ! DGESV computes the solution to a real system of linear equations - ! A * X = B, where A is an N-by-N matrix and X and B are N-by-NRHS matrices. - ! The LU decomposition with partial pivoting and row interchanges is - ! used to factor A as A = P * L * U, - ! where P is a permutation matrix, L is unit lower triangular, and U is - ! upper triangular. The factored form of A is then used to solve the - ! system of equations A * X = B. - ! - ! N is the number of linear equations, i.e., the order of the - ! matrix A. N >= 0. - ! - ! NRHS is the number of right hand sides, i.e., the number of columns - ! of the matrix B. NRHS >= 0. - ! - ! A: - ! On entry, the N-by-N coefficient matrix A. - ! On exit, the factors L and U from the factorization - ! A = P*L*U; the unit diagonal elements of L are not stored. - ! - ! LDA is the leading dimension of the array A. LDA >= max(1,N). - ! - ! IPIV is the pivot indices that define the permutation matrix P; - ! row i of the matrix was interchanged with row IPIV(i). - ! - ! B - ! On entry, the N-by-NRHS matrix of right hand side matrix B. - ! On exit, if INFO = 0, the N-by-NRHS solution matrix X. - ! - ! LDB is the leading dimension of the array B. LDB >= max(1,N). - ! - ! INFO: - ! = 0: successful exit - ! < 0: if INFO = -i, the i-th argument had an illegal value - ! > 0: if INFO = i, U(i,i) is exactly zero. The factorization - ! has been completed, but the factor U is exactly - ! singular, so the solution could not be computed. - ! --------------------------------------------------------------------------- - !cohort_hydr%iterh2 = cohort_hydr%iterh2 - - call DGESV(site_hydr%num_nodes,1,ajac,site_hydr%num_nodes,ipiv,residual,site_hydr%num_nodes,info) - - - if ( info < 0 ) then - write(fates_log(),*) 'illegal value generated in DGESV() linear' - write(fates_log(),*) 'system solver, see node: ',-info - call endrun(msg=errMsg(sourcefile, __LINE__)) - END IF - if ( info > 0 ) then - write(fates_log(),*) 'the factorization of linear system in DGESV() generated' - write(fates_log(),*) 'a singularity at node: ',info - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - ! Update the previous water content state to be the current - ! th_node_prev(:) = th_node(:) - - ! If info == 0, then - ! lapack was able to generate a solution. - ! For A * X = B, - ! Where the residual() was B, DGESV() returns - ! the solution X into the residual array. - - ! Update the matric potential of each node. Since this is a search - ! we update matric potential as only a fraction of delta psi (residual) - - do k = 1, site_hydr%num_nodes - - if(pm_node(k) == rhiz_p_media) then - j = node_layer(k) - if(abs(residual(k)) < dpsi_scap) then - psi_node(k) = psi_node(k) + residual(k) * rlfx_soil - else - psi_node(k) = psi_node(k) + 2._r8*sign(dpsi_scap,residual(k)) - dpsi_scap*dpsi_scap/residual(k) - endif - th_node(k) = site_hydr%wrf_soil(j)%p%th_from_psi(psi_node(k)) - else - if(abs(residual(k)) < dpsi_pcap) then - psi_node(k) = psi_node(k) + residual(k) * rlfx_plnt - else - psi_node(k) = psi_node(k) + 2._r8*sign(dpsi_pcap,residual(k)) - dpsi_pcap*dpsi_pcap/residual(k) - endif - th_node(k) = wrf_plant(pm_node(k),ft)%p%th_from_psi(psi_node(k)) - endif - - enddo - - ! Increase relaxation factors for next iteration - rlfx_plnt = min(1._r8,rlfx_plnt0 + & - (1.0-rlfx_plnt0)*real(nwtn_iter,r8)/real(max_newton_iter-3,r8)) - rlfx_soil = min(1._r8,rlfx_soil0 + & - (1.0-rlfx_soil0)*real(nwtn_iter,r8)/real(max_newton_iter-3,r8)) + ! Calculations of maximum conductance for upstream and downstream sides + ! of each connection. This IS dependant on total potential h_node + ! because of the root-soil radial conductance. - end if - end if + call SetMaxCondConnections(site_hydr, cohort_hydr, h_node, kmax_dn, kmax_up) - end do newtonloop + ! calculate boundary fluxes + do icnx=1,site_hydr%num_connections - ! If we are here, that means we succesfully finished - ! a solve with minimal error. More substeps may be required though - ! ------------------------------------------------------------------------------ + id_dn = conn_dn(icnx) + id_up = conn_up(icnx) - ! If there are any sub-steps left, we need to update - ! the initial water content - th_node_prev(:) = th_node(:) - + ! The row (first index) of the Jacobian (ajac) represents the + ! the node for which we are calculating the water balance + ! The column (second index) of the Jacobian represents the nodes + ! on which the pressure differentials effect the water balance + ! of the node of the first index. + ! This will get the effective K, and may modify FTC depending + ! on the flow direction - ! Reset relaxation factors - rlfx_plnt = rlfx_plnt0 - rlfx_soil = rlfx_soil0 + call GetKAndDKDPsi(kmax_dn(icnx), & + kmax_up(icnx), & + h_node(id_dn), & + h_node(id_up), & + ftc_node(id_dn), & + ftc_node(id_up), & + dftc_dpsi_node(id_dn), & + dftc_dpsi_node(id_up), & + dk_dpsi_dn, & + dk_dpsi_up, & + k_eff) - end do outerloop + q_flux(icnx) = k_eff*(h_node(id_up)-h_node(id_dn)) - if(cohort_hydr%iterh1>1._r8) then - write(fates_log(),*) "hydro solve info: i1: ",cohort_hydr%iterh1,"i2: ",cohort_hydr%iterh2 - end if + ! See equation (22) in technical documentation + ! Add fluxes at current time to the residual + residual(id_dn) = residual(id_dn) - q_flux(icnx) + residual(id_up) = residual(id_up) + q_flux(icnx) + + ! This is the Jacobian term related to the pressure changes on the down-stream side + ! and these are applied to both the up and downstream sides (oppositely) + ! This should be used for the down-stream on thr second index) + dqflx_dpsi_dn = -k_eff + (h_node(id_up)-h_node(id_dn)) * dk_dpsi_dn + + ! This is the Jacobian term related to the pressure changes on the up-stream side + ! and these are applied to both the up and downstream sides (oppositely) + dqflx_dpsi_up = k_eff + (h_node(id_up)-h_node(id_dn)) * dk_dpsi_up + + ! Down-stream node's contribution to the down-stream node's mass balance + ajac(id_dn,id_dn) = ajac(id_dn,id_dn) + dqflx_dpsi_dn + + ! Down-stream node's contribution to the up-stream node's mass balance + ajac(id_up,id_dn) = ajac(id_up,id_dn) - dqflx_dpsi_dn + + ! Up-stream node's contribution to the down-stream node's mass balance + ajac(id_dn,id_up) = ajac(id_dn,id_up) + dqflx_dpsi_up + + ! Up-stream node's contribution to the up-stream node's mass balance + ajac(id_up,id_up) = ajac(id_up,id_up) - dqflx_dpsi_up - ! Save flux diagnostics - ! ------------------------------------------------------ - - sapflow = sapflow + q_flux(n_hypool_ag)*tmx - do j = 1,site_hydr%nlevrhiz - ! Connection betwen the 1st rhizosphere and absorbing roots - icnx_ar = n_hypool_ag + (j-1)*(nshell+1)+2 - rootuptake(j) = q_flux(icnx_ar)*tmx - enddo - - ! Update the total change in water content - dth_node(:) = dth_node(:) + (th_node(:) - th_node_init(:)) - - ! Update state variables in plant compartments - cohort_hydr%th_ag(1:n_hypool_ag) = cohort_hydr%th_ag(1:n_hypool_ag) + dth_node(1:n_hypool_ag) - cohort_hydr%th_troot = cohort_hydr%th_troot + dth_node(n_hypool_ag+1) - - ! Change in water per plant [kg/plant] - dwat_plant = sum(dth_node(1:n_hypool_ag+n_hypool_troot)*v_node(1:n_hypool_ag+n_hypool_troot))*denh2o - - inode = n_hypool_ag+n_hypool_troot - do j = 1,site_hydr%nlevrhiz - do k = 1, 1 + nshell - inode = inode + 1 - if(k==1) then - cohort_hydr%th_aroot(j) = cohort_hydr%th_aroot(j)+dth_node(inode) - dwat_plant = dwat_plant + (dth_node(inode) * v_node(inode))*denh2o - else - ishell = k-1 - dth_layershell_site(j,ishell) = dth_layershell_site(j,ishell) + & - dth_node(inode) * cohort_hydr%l_aroot_layer(j) * & - cohort%n / site_hydr%l_aroot_layer(j) - - endif - enddo enddo - - ! Total water mass in the plant at the end of this solve [kg h2o] - w_tot_end = sum(th_node(:)*v_node(:))*denh2o - - ! Mass error (flux - change) [kg/m2] - wb_err_plant = (qtop*tmx)-(w_tot_beg-w_tot_end) + ! Add the transpiration flux (known, retrieved from photosynthesis scheme) + ! to the mass balance on the leaf (1st) node. This is constant over + ! the time-step, so no Jacobian term needed (yet) - end associate + residual(1) = residual(1) + qtop - return - end subroutine MatSolve2D - ! ===================================================================================== - - function SumBetweenDepths(site_hydr,depth_t,depth_b,array_in) result(depth_sum) - - ! This function sums the quantity in array_in between depth_t (top) - ! and depth_b. It assumes many things. Firstly, that the depth coordinates - ! for array_in do match site_hydr%zi_rhiz (on rhizosphere layers), and that - ! those coordinates are positive down. - - type(ed_site_hydr_type), intent(in) :: site_hydr - real(r8),intent(in) :: depth_t ! Top Depth (positive coordinate) - real(r8),intent(in) :: depth_b ! Bottom depth (positive coordinate) - real(r8),intent(in) :: array_in(:) ! Quantity to be summed (flux?mass?) - real(r8) :: depth_sum ! The summed result we return in units (/depth) - integer :: i_rhiz_t ! Layer index of top full layer - integer :: i_rhiz_b ! layer index of bottom full layer - integer :: nlevrhiz ! Number of rhizosphere layers (not shells) - real(r8) :: frac ! Fraction of partial layer, by depth - - i_rhiz_t = count((site_hydr%zi_rhiz-site_hydr%dz_rhiz)nlevrhiz) then - return - end if - - ! Sum all fully encased layers - if(i_rhiz_b>=i_rhiz_t)then - depth_sum = depth_sum + sum(array_in(i_rhiz_t:i_rhiz_b)) - end if - - ! Find fraction contribution from top partial layer (if any) - if(i_rhiz_t>1) then - frac = (site_hydr%zi_rhiz(i_rhiz_t-1)-depth_t)/site_hydr%dz_rhiz(i_rhiz_t-1) - depth_sum = depth_sum + frac*array_in(i_rhiz_t-1) - end if - - ! Find fraction contribution from bottom partial layer (if any) - if(i_rhiz_b residual_amax ) then + residual_amax = rsdx + nsd = k + endif + enddo + if ( nwtn_iter > max_newton_iter) then + icnv = icnv_fail_round + write(fates_log(),*) 'Newton hydraulics solve failed',residual_amax,nsd,tm + endif + + ! Three scenarios: + ! 1) the residual is 0, everything is great, leave iteration loop + ! 2) the residual is not 0, but we have not taken too many steps + ! and the matrix solve did not fail. Perform an inversion and keep + ! searching. + ! 3) the residual is not 0, and either + ! we have taken too many newton steps or the solver won't return + ! a real solution. + ! Shorten time-step, reset time to 0, reset relaxation factors + ! and try a new round of newton (if not exceeded) + + + if( icnv == icnv_fail_round ) then + + ! If the newton iteration fails, we go back + ! to restart the time-stepping loop with shorter sub-steps. + ! Therefore, we set the time elapsed (tm) to zero, + ! shorten the timstep (dtime) and re-initialize the water + ! contents to the starting amount. + + if(reset_on_fail) then + tm = 0._r8 + th_node(:) = th_node_init(:) + th_node_prev(:) = th_node_init(:) + cohort_hydr%iterh1 = 0 + else + tm = tm - dtime + th_node(:) = th_node_prev(:) + !* No need to update the th_node_prev, it is the + ! same since we are just re-starting the current + ! step + end if + nsteps = nsteps + 1 + dtime = dtime * dtime_rf + rlfx_plnt0 = rlfx_plnt_init*rlfx_plnt_shrink**real(nsteps,r8) + rlfx_soil0 = rlfx_soil_init*rlfx_soil_shrink**real(nsteps,r8) + rlfx_plnt = rlfx_plnt0 + rlfx_soil = rlfx_soil0 + nwtn_iter = 0 + cohort_hydr%iterh1 = cohort_hydr%iterh1 + 1 + cycle outerloop + + else + + ! On the last iteration, we temporarily lower the bar (if opted for) + ! and allow a pass if the residual is within 10x of the typical allowed residual + if ( allow_lenient_lastiter ) then + if ( nwtn_iter == max_newton_iter .and. residual_amax < 10*max_allowed_residual ) then + exit newtonloop + end if + end if - end subroutine SetMaxCondConnections - - ! ===================================================================================== + if( sum(residual(:)) < max_allowed_residual .and. residual_amax < max_allowed_residual ) then + + ! We have succesffully found a solution + ! in this newton iteration. + exit newtonloop + else + ! Move ahead and calculate another solution + ! and continue the search. Residual isn't zero + ! but no reason not to continue searching + + ! Record that we performed a solve (this is total iterations) + cohort_hydr%iterh2 = cohort_hydr%iterh2 + 1 + + ! --------------------------------------------------------------------------- + ! From Lapack documentation + ! + ! subroutine dgesv(integer N (in), + ! integer NRHS (in), + ! real(r8), dimension( lda, * ) A (in/out), + ! integer LDA (in), + ! integer, dimension( * ) IPIV (out), + ! real(r8), dimension( ldb, * ) B (in/out), + ! integer LDB (in), + ! integer INFO (out) ) + ! + ! DGESV computes the solution to a real system of linear equations + ! A * X = B, where A is an N-by-N matrix and X and B are N-by-NRHS matrices. + ! The LU decomposition with partial pivoting and row interchanges is + ! used to factor A as A = P * L * U, + ! where P is a permutation matrix, L is unit lower triangular, and U is + ! upper triangular. The factored form of A is then used to solve the + ! system of equations A * X = B. + ! + ! N is the number of linear equations, i.e., the order of the + ! matrix A. N >= 0. + ! + ! NRHS is the number of right hand sides, i.e., the number of columns + ! of the matrix B. NRHS >= 0. + ! + ! A: + ! On entry, the N-by-N coefficient matrix A. + ! On exit, the factors L and U from the factorization + ! A = P*L*U; the unit diagonal elements of L are not stored. + ! + ! LDA is the leading dimension of the array A. LDA >= max(1,N). + ! + ! IPIV is the pivot indices that define the permutation matrix P; + ! row i of the matrix was interchanged with row IPIV(i). + ! + ! B + ! On entry, the N-by-NRHS matrix of right hand side matrix B. + ! On exit, if INFO = 0, the N-by-NRHS solution matrix X. + ! + ! LDB is the leading dimension of the array B. LDB >= max(1,N). + ! + ! INFO: + ! = 0: successful exit + ! < 0: if INFO = -i, the i-th argument had an illegal value + ! > 0: if INFO = i, U(i,i) is exactly zero. The factorization + ! has been completed, but the factor U is exactly + ! singular, so the solution could not be computed. + ! --------------------------------------------------------------------------- + !cohort_hydr%iterh2 = cohort_hydr%iterh2 + + call DGESV(site_hydr%num_nodes,1,ajac,site_hydr%num_nodes,ipiv,residual,site_hydr%num_nodes,info) + + + if ( info < 0 ) then + write(fates_log(),*) 'illegal value generated in DGESV() linear' + write(fates_log(),*) 'system solver, see node: ',-info + call endrun(msg=errMsg(sourcefile, __LINE__)) + END IF + if ( info > 0 ) then + write(fates_log(),*) 'the factorization of linear system in DGESV() generated' + write(fates_log(),*) 'a singularity at node: ',info + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if - subroutine InitHydroGlobals() - - ! This routine allocates the Water Transfer Functions (WTFs) - ! which include both water retention functions (WRFs) - ! as well as the water conductance (K) functions (WKFs) - ! But, this is only for plants! These functions have specific - ! parameters, potentially, for each plant functional type and - ! each organ (pft x organ), but this can be used globally (across - ! all sites on the node (machine) to save memory. These functions - ! are also applied to soils, but since soil properties vary with - ! soil layer and location, those functions are bound to the site - ! structure, and are therefore not "global". - - ! Define - class(wrf_type_vg), pointer :: wrf_vg - class(wkf_type_vg), pointer :: wkf_vg - class(wrf_type_cch), pointer :: wrf_cch - class(wkf_type_tfs), pointer :: wkf_tfs - class(wrf_type_tfs), pointer :: wrf_tfs - - integer :: ft ! PFT index - integer :: pm ! plant media index - integer :: inode ! compartment node index - real(r8) :: cap_corr ! correction for nonzero psi0x (TFS) - real(r8) :: cap_slp ! slope of capillary region of curve - real(r8) :: cap_int ! intercept of capillary region of curve - - if(hlm_use_planthydro.eq.ifalse) return - - ! we allocate from stomata_p_media, which should be zero - - allocate(wrf_plant(stomata_p_media:n_plant_media,numpft)) - allocate(wkf_plant(stomata_p_media:n_plant_media,numpft)) - - ! ----------------------------------------------------------------------------------- - ! Initialize the Water Retention Functions - ! ----------------------------------------------------------------------------------- + ! Update the previous water content state to be the current + ! th_node_prev(:) = th_node(:) + + ! If info == 0, then + ! lapack was able to generate a solution. + ! For A * X = B, + ! Where the residual() was B, DGESV() returns + ! the solution X into the residual array. + + ! Update the matric potential of each node. Since this is a search + ! we update matric potential as only a fraction of delta psi (residual) + + do k = 1, site_hydr%num_nodes + + if(pm_node(k) == rhiz_p_media) then + j = node_layer(k) + if(abs(residual(k)) < dpsi_scap) then + psi_node(k) = psi_node(k) + residual(k) * rlfx_soil + else + psi_node(k) = psi_node(k) + 2._r8*sign(dpsi_scap,residual(k)) - dpsi_scap*dpsi_scap/residual(k) + endif + th_node(k) = site_hydr%wrf_soil(j)%p%th_from_psi(psi_node(k)) + else + if(abs(residual(k)) < dpsi_pcap) then + psi_node(k) = psi_node(k) + residual(k) * rlfx_plnt + else + psi_node(k) = psi_node(k) + 2._r8*sign(dpsi_pcap,residual(k)) - dpsi_pcap*dpsi_pcap/residual(k) + endif + th_node(k) = wrf_plant(pm_node(k),ft)%p%th_from_psi(psi_node(k)) + endif + + enddo + + ! Increase relaxation factors for next iteration + rlfx_plnt = min(1._r8,rlfx_plnt0 + & + (1.0-rlfx_plnt0)*real(nwtn_iter,r8)/real(max_newton_iter-3,r8)) + rlfx_soil = min(1._r8,rlfx_soil0 + & + (1.0-rlfx_soil0)*real(nwtn_iter,r8)/real(max_newton_iter-3,r8)) - select case(plant_wrf_type) - case(van_genuchten_type) - do ft = 1,numpft - do pm = 1, n_plant_media - allocate(wrf_vg) - wrf_plant(pm,ft)%p => wrf_vg - call wrf_vg%set_wrf_param([alpha_vg, psd_vg, th_sat_vg, th_res_vg]) - end do - end do - case(campbell_type) - do ft = 1,numpft - do pm = 1,n_plant_media - allocate(wrf_cch) - wrf_plant(pm,ft)%p => wrf_cch - call wrf_cch%set_wrf_param([EDPftvarcon_inst%hydr_thetas_node(ft,pm), & - EDPftvarcon_inst%hydr_pinot_node(ft,pm), & - 9._r8]) - end do - end do - case(tfs_type) - do ft = 1,numpft - do pm = 1,n_plant_media - allocate(wrf_tfs) - wrf_plant(pm,ft)%p => wrf_tfs - - if (pm.eq.leaf_p_media) then ! Leaf tissue - cap_slp = 0.0_r8 - cap_int = 0.0_r8 - cap_corr = 1.0_r8 - else ! Non leaf tissues - cap_slp = (hydr_psi0 - hydr_psicap )/(1.0_r8 - rwccap(pm)) - cap_int = -cap_slp + hydr_psi0 - cap_corr = -cap_int/cap_slp - end if - - call wrf_tfs%set_wrf_param([EDPftvarcon_inst%hydr_thetas_node(ft,pm), & - EDPftvarcon_inst%hydr_resid_node(ft,pm), & - EDPftvarcon_inst%hydr_pinot_node(ft,pm), & - EDPftvarcon_inst%hydr_epsil_node(ft,pm), & - rwcft(pm), & - cap_corr, & - cap_int, & - cap_slp,real(pm,r8)]) - end do - end do + end if + end if - end select + end do newtonloop - ! ----------------------------------------------------------------------------------- - ! Initialize the Water Conductance (K) Functions - ! ----------------------------------------------------------------------------------- + ! If we are here, that means we succesfully finished + ! a solve with minimal error. More substeps may be required though + ! ------------------------------------------------------------------------------ - select case(plant_wkf_type) - case(van_genuchten_type) - do ft = 1,numpft - do pm = 1, n_plant_media - allocate(wkf_vg) - wkf_plant(pm,ft)%p => wkf_vg - call wkf_vg%set_wkf_param([alpha_vg, psd_vg, th_sat_vg, th_res_vg, tort_vg]) - end do - - end do - case(campbell_type) - write(fates_log(),*) 'campbell/clapp-hornberger conductance not used in plants' - call endrun(msg=errMsg(sourcefile, __LINE__)) - case(tfs_type) - do ft = 1,numpft - do pm = 1, n_plant_media - allocate(wkf_tfs) - wkf_plant(pm,ft)%p => wkf_tfs - call wkf_tfs%set_wkf_param([EDPftvarcon_inst%hydr_p50_node(ft,pm), & - EDPftvarcon_inst%hydr_avuln_node(ft,pm)]) - end do - end do - end select + ! If there are any sub-steps left, we need to update + ! the initial water content + th_node_prev(:) = th_node(:) - ! There is only 1 stomata conductance hypothesis which uses the p50 and - ! vulnerability parameters - ! ----------------------------------------------------------------------------------- - do ft = 1,numpft - allocate(wkf_tfs) - wkf_plant(stomata_p_media,ft)%p => wkf_tfs - call wkf_tfs%set_wkf_param([EDPftvarcon_inst%hydr_p50_gs(ft), & - EDPftvarcon_inst%hydr_avuln_gs(ft)]) + ! Reset relaxation factors + rlfx_plnt = rlfx_plnt0 + rlfx_soil = rlfx_soil0 + +end do outerloop + +if(cohort_hydr%iterh1>1._r8) then + write(fates_log(),*) "hydro solve info: i1: ",cohort_hydr%iterh1,"i2: ",cohort_hydr%iterh2 +end if + +! Save flux diagnostics +! ------------------------------------------------------ + +sapflow = sapflow + q_flux(n_hypool_ag)*tmx + +do j = 1,site_hydr%nlevrhiz + ! Connection betwen the 1st rhizosphere and absorbing roots + icnx_ar = n_hypool_ag + (j-1)*(nshell+1)+2 + rootuptake(j) = q_flux(icnx_ar)*tmx +enddo + + +! Update the total change in water content +dth_node(:) = dth_node(:) + (th_node(:) - th_node_init(:)) + +! Update state variables in plant compartments +cohort_hydr%th_ag(1:n_hypool_ag) = cohort_hydr%th_ag(1:n_hypool_ag) + dth_node(1:n_hypool_ag) +cohort_hydr%th_troot = cohort_hydr%th_troot + dth_node(n_hypool_ag+1) + +! Change in water per plant [kg/plant] +dwat_plant = sum(dth_node(1:n_hypool_ag+n_hypool_troot)*v_node(1:n_hypool_ag+n_hypool_troot))*denh2o + +inode = n_hypool_ag+n_hypool_troot +do j = 1,site_hydr%nlevrhiz + do k = 1, 1 + nshell + inode = inode + 1 + if(k==1) then + cohort_hydr%th_aroot(j) = cohort_hydr%th_aroot(j)+dth_node(inode) + dwat_plant = dwat_plant + (dth_node(inode) * v_node(inode))*denh2o + else + ishell = k-1 + dth_layershell_site(j,ishell) = dth_layershell_site(j,ishell) + & + dth_node(inode) * cohort_hydr%l_aroot_layer(j) * & + cohort%n / site_hydr%l_aroot_layer(j) + + endif + enddo +enddo + +! Total water mass in the plant at the end of this solve [kg h2o] +w_tot_end = sum(th_node(:)*v_node(:))*denh2o + +! Mass error (flux - change) [kg/m2] +wb_err_plant = (qtop*tmx)-(w_tot_beg-w_tot_end) + + +end associate + +return +end subroutine MatSolve2D + +! ===================================================================================== + +function SumBetweenDepths(site_hydr,depth_t,depth_b,array_in) result(depth_sum) + + ! This function sums the quantity in array_in between depth_t (top) + ! and depth_b. It assumes many things. Firstly, that the depth coordinates + ! for array_in do match site_hydr%zi_rhiz (on rhizosphere layers), and that + ! those coordinates are positive down. + +type(ed_site_hydr_type), intent(in) :: site_hydr +real(r8),intent(in) :: depth_t ! Top Depth (positive coordinate) +real(r8),intent(in) :: depth_b ! Bottom depth (positive coordinate) +real(r8),intent(in) :: array_in(:) ! Quantity to be summed (flux?mass?) +real(r8) :: depth_sum ! The summed result we return in units (/depth) +integer :: i_rhiz_t ! Layer index of top full layer +integer :: i_rhiz_b ! layer index of bottom full layer +integer :: nlevrhiz ! Number of rhizosphere layers (not shells) +real(r8) :: frac ! Fraction of partial layer, by depth + +i_rhiz_t = count((site_hydr%zi_rhiz-site_hydr%dz_rhiz)nlevrhiz) then + return +end if + +! Sum all fully encased layers +if(i_rhiz_b>=i_rhiz_t)then + depth_sum = depth_sum + sum(array_in(i_rhiz_t:i_rhiz_b)) +end if + +! Find fraction contribution from top partial layer (if any) +if(i_rhiz_t>1) then + frac = (site_hydr%zi_rhiz(i_rhiz_t-1)-depth_t)/site_hydr%dz_rhiz(i_rhiz_t-1) + depth_sum = depth_sum + frac*array_in(i_rhiz_t-1) +end if + +! Find fraction contribution from bottom partial layer (if any) +if(i_rhiz_b wrf_vg + call wrf_vg%set_wrf_param([alpha_vg, psd_vg, th_sat_vg, th_res_vg]) + end do + end do +case(campbell_type) + do ft = 1,numpft + do pm = 1,n_plant_media + allocate(wrf_cch) + wrf_plant(pm,ft)%p => wrf_cch + call wrf_cch%set_wrf_param([EDPftvarcon_inst%hydr_thetas_node(ft,pm), & + EDPftvarcon_inst%hydr_pinot_node(ft,pm), & + 9._r8]) end do + end do +case(tfs_type) + do ft = 1,numpft + do pm = 1,n_plant_media + allocate(wrf_tfs) + wrf_plant(pm,ft)%p => wrf_tfs + + if (pm.eq.leaf_p_media) then ! Leaf tissue + cap_slp = 0.0_r8 + cap_int = 0.0_r8 + cap_corr = 1.0_r8 + else ! Non leaf tissues + cap_slp = (hydr_psi0 - hydr_psicap )/(1.0_r8 - rwccap(pm)) + cap_int = -cap_slp + hydr_psi0 + cap_corr = -cap_int/cap_slp + end if - - return - end subroutine InitHydroGlobals - - !! subroutine UpdateLWPMemFLCMin(ccohort_hydr) - - ! This code may be re-introduced at a later date (rgk 08-2019) - - ! SET COHORT-LEVEL BTRAN FOR USE IN NEXT TIMESTEP - ! first update the leaf water potential memory - !! do t=2, numLWPmem - !!ccohort_hydr%lwp_mem(t-1) = ccohort_hydr%lwp_mem(t) - !!end do - !!ccohort_hydr%lwp_mem(numLWPmem) = ccohort_hydr%psi_ag(1) - !!call flc_gs_from_psi(cCohort, ccohort_hydr%psi_ag(1)) - - !!refill_rate = -log(0.5)/(ccohort_hydr%refill_days*24._r8*3600._r8) ! s-1 - !!do k=1,n_hypool_ag - !!ccohort_hydr%flc_min_ag(k) = min(ccohort_hydr%flc_min_ag(k), ccohort_hydr%flc_ag(k)) - !!if(ccohort_hydr%psi_ag(k) >= ccohort_hydr%refill_thresh .and. & - !! ccohort_hydr%flc_ag(k) > ccohort_hydr%flc_min_ag(k)) then ! then refilling - !! ccohort_hydr%flc_min_ag(k) = ccohort_hydr%flc_ag(k) - & - !! (ccohort_hydr%flc_ag(k) - ccohort_hydr%flc_min_ag(k))*exp(-refill_rate*dtime) - !!end if - !!end do - !!do k=1,n_hypool_troot - !!ccohort_hydr%flc_min_troot(k) = min(ccohort_hydr%flc_min_troot(k), ccohort_hydr%flc_troot(k)) - !!if(ccohort_hydr%psi_troot(k) >= ccohort_hydr%refill_thresh .and. & - !! ccohort_hydr%flc_troot(k) > ccohort_hydr%flc_min_troot(k)) then ! then refilling - !! ccohort_hydr%flc_min_troot(k) = ccohort_hydr%flc_troot(k) - & - !! (ccohort_hydr%flc_troot(k) - ccohort_hydr%flc_min_troot(k))*exp(-refill_rate*dtime) - !!end if - !!end do - !!do j=1,site_hydr%nlevrhiz - !!ccohort_hydr%flc_min_aroot(j) = min(ccohort_hydr%flc_min_aroot(j), ccohort_hydr%flc_aroot(j)) - !!if(ccohort_hydr%psi_aroot(j) >= ccohort_hydr%refill_thresh .and. & - !! ccohort_hydr%flc_aroot(j) > ccohort_hydr%flc_min_aroot(j)) then ! then refilling - !! ccohort_hydr%flc_min_aroot(j) = ccohort_hydr%flc_aroot(j) - & - !! (ccohort_hydr%flc_aroot(j) - ccohort_hydr%flc_min_aroot(j))*exp(-refill_rate*dtime) - !!end if - !!end do - !!end subroutine UpdateLWPMemFLCMin + call wrf_tfs%set_wrf_param([EDPftvarcon_inst%hydr_thetas_node(ft,pm), & + EDPftvarcon_inst%hydr_resid_node(ft,pm), & + EDPftvarcon_inst%hydr_pinot_node(ft,pm), & + EDPftvarcon_inst%hydr_epsil_node(ft,pm), & + rwcft(pm), & + cap_corr, & + cap_int, & + cap_slp,real(pm,r8)]) + end do + end do + +end select + +! ----------------------------------------------------------------------------------- +! Initialize the Water Conductance (K) Functions +! ----------------------------------------------------------------------------------- + +select case(plant_wkf_type) +case(van_genuchten_type) + do ft = 1,numpft + do pm = 1, n_plant_media + allocate(wkf_vg) + wkf_plant(pm,ft)%p => wkf_vg + call wkf_vg%set_wkf_param([alpha_vg, psd_vg, th_sat_vg, th_res_vg, tort_vg]) + end do + + end do +case(campbell_type) + write(fates_log(),*) 'campbell/clapp-hornberger conductance not used in plants' + call endrun(msg=errMsg(sourcefile, __LINE__)) +case(tfs_type) + do ft = 1,numpft + do pm = 1, n_plant_media + allocate(wkf_tfs) + wkf_plant(pm,ft)%p => wkf_tfs + call wkf_tfs%set_wkf_param([EDPftvarcon_inst%hydr_p50_node(ft,pm), & + EDPftvarcon_inst%hydr_avuln_node(ft,pm)]) + end do + end do +end select + +! There is only 1 stomata conductance hypothesis which uses the p50 and +! vulnerability parameters +! ----------------------------------------------------------------------------------- + +do ft = 1,numpft + allocate(wkf_tfs) + wkf_plant(stomata_p_media,ft)%p => wkf_tfs + call wkf_tfs%set_wkf_param([EDPftvarcon_inst%hydr_p50_gs(ft), & + EDPftvarcon_inst%hydr_avuln_gs(ft)]) +end do + + +return +end subroutine InitHydroGlobals + +!! subroutine UpdateLWPMemFLCMin(ccohort_hydr) + +! This code may be re-introduced at a later date (rgk 08-2019) + +! SET COHORT-LEVEL BTRAN FOR USE IN NEXT TIMESTEP +! first update the leaf water potential memory +!! do t=2, numLWPmem +!!ccohort_hydr%lwp_mem(t-1) = ccohort_hydr%lwp_mem(t) +!!end do +!!ccohort_hydr%lwp_mem(numLWPmem) = ccohort_hydr%psi_ag(1) +!!call flc_gs_from_psi(cCohort, ccohort_hydr%psi_ag(1)) + +!!refill_rate = -log(0.5)/(ccohort_hydr%refill_days*24._r8*3600._r8) ! s-1 +!!do k=1,n_hypool_ag +!!ccohort_hydr%flc_min_ag(k) = min(ccohort_hydr%flc_min_ag(k), ccohort_hydr%flc_ag(k)) +!!if(ccohort_hydr%psi_ag(k) >= ccohort_hydr%refill_thresh .and. & +!! ccohort_hydr%flc_ag(k) > ccohort_hydr%flc_min_ag(k)) then ! then refilling +!! ccohort_hydr%flc_min_ag(k) = ccohort_hydr%flc_ag(k) - & +!! (ccohort_hydr%flc_ag(k) - ccohort_hydr%flc_min_ag(k))*exp(-refill_rate*dtime) +!!end if +!!end do +!!do k=1,n_hypool_troot +!!ccohort_hydr%flc_min_troot(k) = min(ccohort_hydr%flc_min_troot(k), ccohort_hydr%flc_troot(k)) +!!if(ccohort_hydr%psi_troot(k) >= ccohort_hydr%refill_thresh .and. & +!! ccohort_hydr%flc_troot(k) > ccohort_hydr%flc_min_troot(k)) then ! then refilling +!! ccohort_hydr%flc_min_troot(k) = ccohort_hydr%flc_troot(k) - & +!! (ccohort_hydr%flc_troot(k) - ccohort_hydr%flc_min_troot(k))*exp(-refill_rate*dtime) +!!end if +!!end do +!!do j=1,site_hydr%nlevrhiz +!!ccohort_hydr%flc_min_aroot(j) = min(ccohort_hydr%flc_min_aroot(j), ccohort_hydr%flc_aroot(j)) +!!if(ccohort_hydr%psi_aroot(j) >= ccohort_hydr%refill_thresh .and. & +!! ccohort_hydr%flc_aroot(j) > ccohort_hydr%flc_min_aroot(j)) then ! then refilling +!! ccohort_hydr%flc_min_aroot(j) = ccohort_hydr%flc_aroot(j) - & +!! (ccohort_hydr%flc_aroot(j) - ccohort_hydr%flc_min_aroot(j))*exp(-refill_rate*dtime) +!!end if +!!end do +!!end subroutine UpdateLWPMemFLCMin From 8b553d46e592c8719b225da074585e11cefa6710 Mon Sep 17 00:00:00 2001 From: Rosie Fisher Date: Wed, 25 Nov 2020 17:15:59 +0100 Subject: [PATCH 155/209] Update main/EDInitMod.F90 CDK8 Co-authored-by: Charlie Koven --- main/EDInitMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index f010574ac8..f13994e8ea 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -333,7 +333,7 @@ subroutine set_site_properties( nsites, sites,bc_in ) write(fates_log(),*) 'removing small pft patches',s,ft,sites(s)%area_pft(ft) sites(s)%area_pft(ft)=0.0_r8 ! remove tiny patches to prevent numerical errors in terminate patches - endif + endif if(sites(s)%area_pft(ft).lt.0._r8)then write(fates_log(),*) 'negative area',s,ft,sites(s)%area_pft(ft) call endrun(msg=errMsg(sourcefile, __LINE__)) From 6dbca8894f9a0c7ba7fa0790a2e92da164d2bae2 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 25 Nov 2020 09:21:21 -0700 Subject: [PATCH 156/209] auto indenting all of FatesPlantRespPhotosynthMod.F90 --- biogeophys/FatesPlantRespPhotosynthMod.F90 | 3576 ++++++++++---------- 1 file changed, 1788 insertions(+), 1788 deletions(-) diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index 6f74e95979..e7a0de9bfb 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -1,81 +1,81 @@ module FATESPlantRespPhotosynthMod - - !------------------------------------------------------------------------------------- - ! !DESCRIPTION: - ! Calculates the plant respiration and photosynthetic fluxes for the FATES model - ! This code is similar to and was originally based off of the 'photosynthesis' - ! subroutine in the CLM model. - ! - ! Parameter for activation and deactivation energies were taken from: - ! Activation energy, from: - ! Bernacchi et al (2001) Plant, Cell and Environment 24:253-259 - ! Bernacchi et al (2003) Plant, Cell and Environment 26:1419-1430 - ! except TPU from: Harley et al (1992) Plant, Cell and Environment 15:271-282 - ! High temperature deactivation, from: - ! Leuning (2002) Plant, Cell and Environment 25:1205-1210 - ! The factor "c" scales the deactivation to a value of 1.0 at 25C - ! Photosynthesis and stomatal conductance parameters, from: - ! Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 - ! ------------------------------------------------------------------------------------ - - ! !USES: - - use FatesGlobals, only : endrun => fates_endrun - use FatesGlobals, only : fates_log - use FatesConstantsMod, only : r8 => fates_r8 - use FatesConstantsMod, only : itrue - use FatesConstantsMod, only : nearzero - use FatesInterfaceTypesMod, only : hlm_use_planthydro - use FatesInterfaceTypesMod, only : hlm_parteh_mode - use FatesInterfaceTypesMod, only : numpft - use FatesInterfaceTypesMod, only : nleafage - use EDTypesMod, only : maxpft - use EDTypesMod, only : nlevleaf - use EDTypesMod, only : nclmax - use PRTGenericMod, only : max_nleafage - use EDTypesMod, only : do_fates_salinity - use EDParamsMod, only : q10_mr - use PRTGenericMod, only : prt_carbon_allom_hyp - use PRTGenericMod, only : prt_cnp_flex_allom_hyp - use PRTGenericMod, only : all_carbon_elements - use PRTGenericMod, only : nitrogen_element - use PRTGenericMod, only : leaf_organ - use PRTGenericMod, only : fnrt_organ - use PRTGenericMod, only : sapw_organ - use PRTGenericMod, only : store_organ - use PRTGenericMod, only : repro_organ - use PRTGenericMod, only : struct_organ - use EDParamsMod, only : ED_val_base_mr_20, stomatal_model - use PRTParametersMod, only : prt_params - - ! CIME Globals - use shr_log_mod , only : errMsg => shr_log_errMsg - - implicit none - private - - public :: FatesPlantRespPhotosynthDrive ! Called by the HLM-Fates interface - - character(len=*), parameter, private :: sourcefile = & - __FILE__ - !------------------------------------------------------------------------------------- - - ! maximum stomatal resistance [s/m] (used across several procedures) - real(r8),parameter :: rsmax0 = 2.e8_r8 - - logical :: debug = .false. - !------------------------------------------------------------------------------------- - - ! Ratio of H2O/CO2 gas diffusion in stomatal airspace (approximate) - real(r8),parameter :: h2o_co2_stoma_diffuse_ratio = 1.6_r8 - - ! Ratio of H2O/CO2 gass diffusion in the leaf boundary layer (approximate) - real(r8),parameter :: h2o_co2_bl_diffuse_ratio = 1.4_r8 + + !------------------------------------------------------------------------------------- + ! !DESCRIPTION: + ! Calculates the plant respiration and photosynthetic fluxes for the FATES model + ! This code is similar to and was originally based off of the 'photosynthesis' + ! subroutine in the CLM model. + ! + ! Parameter for activation and deactivation energies were taken from: + ! Activation energy, from: + ! Bernacchi et al (2001) Plant, Cell and Environment 24:253-259 + ! Bernacchi et al (2003) Plant, Cell and Environment 26:1419-1430 + ! except TPU from: Harley et al (1992) Plant, Cell and Environment 15:271-282 + ! High temperature deactivation, from: + ! Leuning (2002) Plant, Cell and Environment 25:1205-1210 + ! The factor "c" scales the deactivation to a value of 1.0 at 25C + ! Photosynthesis and stomatal conductance parameters, from: + ! Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 + ! ------------------------------------------------------------------------------------ + + ! !USES: + + use FatesGlobals, only : endrun => fates_endrun + use FatesGlobals, only : fates_log + use FatesConstantsMod, only : r8 => fates_r8 + use FatesConstantsMod, only : itrue + use FatesConstantsMod, only : nearzero + use FatesInterfaceTypesMod, only : hlm_use_planthydro + use FatesInterfaceTypesMod, only : hlm_parteh_mode + use FatesInterfaceTypesMod, only : numpft + use FatesInterfaceTypesMod, only : nleafage + use EDTypesMod, only : maxpft + use EDTypesMod, only : nlevleaf + use EDTypesMod, only : nclmax + use PRTGenericMod, only : max_nleafage + use EDTypesMod, only : do_fates_salinity + use EDParamsMod, only : q10_mr + use PRTGenericMod, only : prt_carbon_allom_hyp + use PRTGenericMod, only : prt_cnp_flex_allom_hyp + use PRTGenericMod, only : all_carbon_elements + use PRTGenericMod, only : nitrogen_element + use PRTGenericMod, only : leaf_organ + use PRTGenericMod, only : fnrt_organ + use PRTGenericMod, only : sapw_organ + use PRTGenericMod, only : store_organ + use PRTGenericMod, only : repro_organ + use PRTGenericMod, only : struct_organ + use EDParamsMod, only : ED_val_base_mr_20, stomatal_model + use PRTParametersMod, only : prt_params + + ! CIME Globals + use shr_log_mod , only : errMsg => shr_log_errMsg + + implicit none + private + + public :: FatesPlantRespPhotosynthDrive ! Called by the HLM-Fates interface + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !------------------------------------------------------------------------------------- + + ! maximum stomatal resistance [s/m] (used across several procedures) + real(r8),parameter :: rsmax0 = 2.e8_r8 + + logical :: debug = .false. + !------------------------------------------------------------------------------------- + + ! Ratio of H2O/CO2 gas diffusion in stomatal airspace (approximate) + real(r8),parameter :: h2o_co2_stoma_diffuse_ratio = 1.6_r8 + + ! Ratio of H2O/CO2 gass diffusion in the leaf boundary layer (approximate) + real(r8),parameter :: h2o_co2_bl_diffuse_ratio = 1.4_r8 contains - + !-------------------------------------------------------------------------------------- - + subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! ----------------------------------------------------------------------------------- @@ -105,7 +105,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) use FatesConstantsMod, only : rgas => rgas_J_K_kmol use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm use FatesParameterDerivedMod, only : param_derived - + use FatesAllometryMod, only : bleaf, bstore_allom use FatesAllometryMod, only : storage_fraction_of_target use FatesAllometryMod, only : set_root_fraction @@ -149,21 +149,21 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! net leaf photosynthesis averaged over sun and shade leaves. [umol CO2/m**2/s] real(r8) :: anet_av_z(nlevleaf,maxpft,nclmax) - + ! Mask used to determine which leaf-layer biophysical rates have been ! used already logical :: rate_mask_z(nlevleaf,maxpft,nclmax) real(r8) :: vcmax_z ! leaf layer maximum rate of carboxylation - ! (umol co2/m**2/s) + ! (umol co2/m**2/s) real(r8) :: jmax_z ! leaf layer maximum electron transport rate - ! (umol electrons/m**2/s) + ! (umol electrons/m**2/s) real(r8) :: tpu_z ! leaf layer triose phosphate utilization rate - ! (umol CO2/m**2/s) + ! (umol CO2/m**2/s) real(r8) :: kp_z ! leaf layer initial slope of CO2 response - ! curve (C4 plants) + ! curve (C4 plants) real(r8) :: c13disc_z(nclmax,maxpft,nlevleaf) ! carbon 13 in newly assimilated carbon at leaf level - + real(r8) :: mm_kco2 ! Michaelis-Menten constant for CO2 (Pa) real(r8) :: mm_ko2 ! Michaelis-Menten constant for O2 (Pa) real(r8) :: co2_cpoint ! CO2 compensation point (Pa) @@ -177,12 +177,12 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) real(r8) :: leaf_frac ! ratio of to leaf biomass to total alive biomass real(r8) :: tcsoi ! Temperature response function for root respiration. real(r8) :: tcwood ! Temperature response function for wood - + real(r8) :: elai ! exposed LAI (patch scale) real(r8) :: live_stem_n ! Live stem (above-ground sapwood) - ! nitrogen content (kgN/plant) + ! nitrogen content (kgN/plant) real(r8) :: live_croot_n ! Live coarse root (below-ground sapwood) - ! nitrogen content (kgN/plant) + ! nitrogen content (kgN/plant) real(r8) :: sapw_c ! Sapwood carbon (kgC/plant) real(r8) :: store_c_target ! Target storage carbon (kgC/plant) real(r8) :: fnrt_c ! Fine root carbon (kgC/plant) @@ -190,29 +190,29 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) real(r8) :: leaf_c ! Leaf carbon (kgC/plant) real(r8) :: leaf_n ! leaf nitrogen content (kgN/plant) real(r8) :: g_sb_leaves ! Mean combined (stomata+boundary layer) leaf conductance [m/s] - ! over all of the patch's leaves. The "sb" refers to the combined - ! "s"tomatal and "b"oundary layer. - ! This quantity is relevant on leaf surfaces. It does not - ! have units of /m2 leaf per say, but is implicitly on leaf surfaces + ! over all of the patch's leaves. The "sb" refers to the combined + ! "s"tomatal and "b"oundary layer. + ! This quantity is relevant on leaf surfaces. It does not + ! have units of /m2 leaf per say, but is implicitly on leaf surfaces real(r8) :: r_sb_leaves ! Mean leaf resistance over all the patch's leaves [s/m] - ! This is the direct reciprocal of g_sb_leaves + ! This is the direct reciprocal of g_sb_leaves real(r8) :: r_stomata ! Mean stomatal resistance across all leaves in the patch [s/m] real(r8) :: maintresp_reduction_factor ! factor by which to reduce maintenance - ! respiration when storage pools are low + ! respiration when storage pools are low real(r8) :: b_leaf ! leaf biomass kgC real(r8) :: frac ! storage pool as a fraction of target leaf biomass real(r8) :: check_elai ! This is a check on the effective LAI that is calculated - ! over each cohort x layer. + ! over each cohort x layer. real(r8) :: cohort_eleaf_area ! This is the effective leaf area [m2] reported by each cohort real(r8) :: lnc_top ! Leaf nitrogen content per unit area at canopy top [gN/m2] real(r8) :: lmr25top ! canopy top leaf maint resp rate at 25C - ! for this plant or pft (umol CO2/m**2/s) + ! for this plant or pft (umol CO2/m**2/s) real(r8) :: leaf_inc ! LAI-only portion of the vegetation increment of dinc_ed real(r8) :: lai_canopy_above ! the LAI in the canopy layers above the layer of interest real(r8) :: lai_layers_above ! the LAI in the leaf layers, within the current canopy, - ! above the leaf layer of interest + ! above the leaf layer of interest real(r8) :: lai_current ! the LAI in the current leaf layer real(r8) :: cumulative_lai ! the cumulative LAI, top down, to the leaf layer of interest @@ -250,1742 +250,1742 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) associate( & c3psn => EDPftvarcon_inst%c3psn , & slatop => prt_params%slatop , & ! specific leaf area at top of canopy, - ! projected area basis [m^2/gC] + ! projected area basis [m^2/gC] woody => prt_params%woody, & ! Is vegetation woody or not? stomatal_intercept => EDPftvarcon_inst%stomatal_intercept ) !Unstressed minimum stomatal conductance - do s = 1,nsites - - ! Multi-layer parameters scaled by leaf nitrogen profile. - ! Loop through each canopy layer to calculate nitrogen profile using - ! cumulative lai at the midpoint of the layer - - - - ! Pre-process some variables that are PFT dependent - ! but not environmentally dependent - ! ------------------------------------------------------------------------ - - allocate(rootfr_ft(numpft, bc_in(s)%nlevsoil)) - - do ft = 1,numpft - call set_root_fraction(rootfr_ft(ft,:), ft, & - bc_in(s)%zi_sisl) - end do - - - ifp = 0 - currentpatch => sites(s)%oldest_patch - do while (associated(currentpatch)) - if(currentpatch%nocomp_pft_label.ne.0)then - ifp = ifp+1 - NCL_p = currentPatch%NCL_p - - ! Part I. Zero output boundary conditions - ! --------------------------------------------------------------------------- - bc_out(s)%rssun_pa(ifp) = 0._r8 - bc_out(s)%rssha_pa(ifp) = 0._r8 - - g_sb_leaves = 0._r8 - check_elai = 0._r8 - - ! Part II. Filter out patches - ! Patch level filter flag for photosynthesis calculations - ! has a short memory, flags: - ! 1 = patch has not been called - ! 2 = patch is currently marked for photosynthesis - ! 3 = patch has been called for photosynthesis already - ! --------------------------------------------------------------------------- - if(bc_in(s)%filter_photo_pa(ifp)==2)then - - - ! Part III. Calculate the number of sublayers for each pft and layer. - ! And then identify which layer/pft combinations have things in them. - ! Output: - ! currentPatch%ncan(:,:) - ! currentPatch%canopy_mask(:,:) - call UpdateCanopyNCanNRadPresent(currentPatch) - - - ! Part IV. Identify some environmentally derived parameters: - ! These quantities are biologically irrelevant - ! Michaelis-Menten constant for CO2 (Pa) - ! Michaelis-Menten constant for O2 (Pa) - ! CO2 compensation point (Pa) - ! leaf boundary layer conductance of h20 - ! constrained vapor pressure - call GetCanopyGasParameters(bc_in(s)%forc_pbot, & ! in - bc_in(s)%oair_pa(ifp), & ! in - bc_in(s)%t_veg_pa(ifp), & ! in - bc_in(s)%tgcm_pa(ifp), & ! in - bc_in(s)%eair_pa(ifp), & ! in - bc_in(s)%esat_tv_pa(ifp), & ! in - bc_in(s)%rb_pa(ifp), & ! in - mm_kco2, & ! out - mm_ko2, & ! out - co2_cpoint, & ! out - cf, & ! out - gb_mol, & ! out - ceair) ! out - - - - - ! ------------------------------------------------------------------------ - ! Part VI: Loop over all leaf layers. - ! The concept of leaf layers is a result of the radiative transfer scheme. - ! A leaf layer has uniform radiation environment. Leaf layers are a group - ! of vegetation surfaces (stems and leaves) which inhabit the same - ! canopy-layer "CL", have the same functional type "ft" and within those - ! two partitions are further partitioned into vertical layers where - ! downwelling radiation attenuates in order. - ! In this phase we loop over the leaf layers and calculate the - ! photosynthesis and respiration of the layer (since all biophysical - ! properties are homogeneous). After this step, we can loop through - ! our cohort list, associate each cohort with its list of leaf-layers - ! and transfer these quantities to the cohort. - ! With plant hydraulics, we must realize that photosynthesis and - ! respiration will be different for leaves of each cohort in the leaf - ! layers, as they will have there own hydraulic limitations. - ! NOTE: Only need to flush mask on the number of used pfts, not the whole - ! scratch space. - ! ------------------------------------------------------------------------ - rate_mask_z(:,1:numpft,:) = .false. - - if(currentPatch%countcohorts > 0.0)then ! Ignore empty patches - - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) ! Cohort loop - - ! Identify the canopy layer (cl), functional type (ft) - ! and the leaf layer (IV) for this cohort - ft = currentCohort%pft - cl = currentCohort%canopy_layer - - call bleaf(currentCohort%dbh,currentCohort%pft,currentCohort%canopy_trim,store_c_target) -! call bstore_allom(currentCohort%dbh,currentCohort%pft, & -! currentCohort%canopy_trim,store_c_target) - - call storage_fraction_of_target(store_c_target, & + do s = 1,nsites + + ! Multi-layer parameters scaled by leaf nitrogen profile. + ! Loop through each canopy layer to calculate nitrogen profile using + ! cumulative lai at the midpoint of the layer + + + + ! Pre-process some variables that are PFT dependent + ! but not environmentally dependent + ! ------------------------------------------------------------------------ + + allocate(rootfr_ft(numpft, bc_in(s)%nlevsoil)) + + do ft = 1,numpft + call set_root_fraction(rootfr_ft(ft,:), ft, & + bc_in(s)%zi_sisl) + end do + + + ifp = 0 + currentpatch => sites(s)%oldest_patch + do while (associated(currentpatch)) + if(currentpatch%nocomp_pft_label.ne.0)then + ifp = ifp+1 + NCL_p = currentPatch%NCL_p + + ! Part I. Zero output boundary conditions + ! --------------------------------------------------------------------------- + bc_out(s)%rssun_pa(ifp) = 0._r8 + bc_out(s)%rssha_pa(ifp) = 0._r8 + + g_sb_leaves = 0._r8 + check_elai = 0._r8 + + ! Part II. Filter out patches + ! Patch level filter flag for photosynthesis calculations + ! has a short memory, flags: + ! 1 = patch has not been called + ! 2 = patch is currently marked for photosynthesis + ! 3 = patch has been called for photosynthesis already + ! --------------------------------------------------------------------------- + if(bc_in(s)%filter_photo_pa(ifp)==2)then + + + ! Part III. Calculate the number of sublayers for each pft and layer. + ! And then identify which layer/pft combinations have things in them. + ! Output: + ! currentPatch%ncan(:,:) + ! currentPatch%canopy_mask(:,:) + call UpdateCanopyNCanNRadPresent(currentPatch) + + + ! Part IV. Identify some environmentally derived parameters: + ! These quantities are biologically irrelevant + ! Michaelis-Menten constant for CO2 (Pa) + ! Michaelis-Menten constant for O2 (Pa) + ! CO2 compensation point (Pa) + ! leaf boundary layer conductance of h20 + ! constrained vapor pressure + call GetCanopyGasParameters(bc_in(s)%forc_pbot, & ! in + bc_in(s)%oair_pa(ifp), & ! in + bc_in(s)%t_veg_pa(ifp), & ! in + bc_in(s)%tgcm_pa(ifp), & ! in + bc_in(s)%eair_pa(ifp), & ! in + bc_in(s)%esat_tv_pa(ifp), & ! in + bc_in(s)%rb_pa(ifp), & ! in + mm_kco2, & ! out + mm_ko2, & ! out + co2_cpoint, & ! out + cf, & ! out + gb_mol, & ! out + ceair) ! out + + + + + ! ------------------------------------------------------------------------ + ! Part VI: Loop over all leaf layers. + ! The concept of leaf layers is a result of the radiative transfer scheme. + ! A leaf layer has uniform radiation environment. Leaf layers are a group + ! of vegetation surfaces (stems and leaves) which inhabit the same + ! canopy-layer "CL", have the same functional type "ft" and within those + ! two partitions are further partitioned into vertical layers where + ! downwelling radiation attenuates in order. + ! In this phase we loop over the leaf layers and calculate the + ! photosynthesis and respiration of the layer (since all biophysical + ! properties are homogeneous). After this step, we can loop through + ! our cohort list, associate each cohort with its list of leaf-layers + ! and transfer these quantities to the cohort. + ! With plant hydraulics, we must realize that photosynthesis and + ! respiration will be different for leaves of each cohort in the leaf + ! layers, as they will have there own hydraulic limitations. + ! NOTE: Only need to flush mask on the number of used pfts, not the whole + ! scratch space. + ! ------------------------------------------------------------------------ + rate_mask_z(:,1:numpft,:) = .false. + + if(currentPatch%countcohorts > 0.0)then ! Ignore empty patches + + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) ! Cohort loop + + ! Identify the canopy layer (cl), functional type (ft) + ! and the leaf layer (IV) for this cohort + ft = currentCohort%pft + cl = currentCohort%canopy_layer + + call bleaf(currentCohort%dbh,currentCohort%pft,currentCohort%canopy_trim,store_c_target) + ! call bstore_allom(currentCohort%dbh,currentCohort%pft, & + ! currentCohort%canopy_trim,store_c_target) + + call storage_fraction_of_target(store_c_target, & currentCohort%prt%GetState(store_organ, all_carbon_elements), & frac) - call lowstorage_maintresp_reduction(frac,currentCohort%pft, & - maintresp_reduction_factor) - - ! are there any leaves of this pft in this layer? - if(currentPatch%canopy_mask(cl,ft) == 1)then - - ! Loop over leaf-layers - do iv = 1,currentCohort%nv - - ! ------------------------------------------------------------ - ! If we are doing plant hydro-dynamics (or any run-type - ! where cohorts may generate different photosynthetic rates - ! of other cohorts in the same canopy-pft-layer combo), - ! we re-calculate the leaf biophysical rates for the - ! cohort-layer combo of interest. - ! but in the vanilla case, we only re-calculate if it has - ! not been done yet. - ! Other cases where we need to solve for every cohort - ! in every leaf layer: nutrient dynamic mode, multiple leaf - ! age classes - ! ------------------------------------------------------------ - - if ( .not.rate_mask_z(iv,ft,cl) .or. & + call lowstorage_maintresp_reduction(frac,currentCohort%pft, & + maintresp_reduction_factor) + + ! are there any leaves of this pft in this layer? + if(currentPatch%canopy_mask(cl,ft) == 1)then + + ! Loop over leaf-layers + do iv = 1,currentCohort%nv + + ! ------------------------------------------------------------ + ! If we are doing plant hydro-dynamics (or any run-type + ! where cohorts may generate different photosynthetic rates + ! of other cohorts in the same canopy-pft-layer combo), + ! we re-calculate the leaf biophysical rates for the + ! cohort-layer combo of interest. + ! but in the vanilla case, we only re-calculate if it has + ! not been done yet. + ! Other cases where we need to solve for every cohort + ! in every leaf layer: nutrient dynamic mode, multiple leaf + ! age classes + ! ------------------------------------------------------------ + + if ( .not.rate_mask_z(iv,ft,cl) .or. & (hlm_use_planthydro.eq.itrue) .or. & (nleafage > 1) .or. & (hlm_parteh_mode .ne. prt_carbon_allom_hyp ) ) then - + if (hlm_use_planthydro.eq.itrue ) then - - stomatal_intercept_btran = max( cf/rsmax0,stomatal_intercept(ft)*currentCohort%co_hydr%btran ) - btran_eff = currentCohort%co_hydr%btran - - ! dinc_ed is the total vegetation area index of each "leaf" layer - ! we convert to the leaf only portion of the increment - ! ------------------------------------------------------ - leaf_inc = dinc_ed * & - currentCohort%treelai/(currentCohort%treelai+currentCohort%treesai) - - ! Now calculate the cumulative top-down lai of the current layer's midpoint - lai_canopy_above = sum(currentPatch%canopy_layer_tlai(1:cl-1)) - lai_layers_above = leaf_inc * (iv-1) - lai_current = min(leaf_inc, currentCohort%treelai - lai_layers_above) - cumulative_lai = lai_canopy_above + lai_layers_above + 0.5*lai_current - - else - - stomatal_intercept_btran = max( cf/rsmax0,stomatal_intercept(ft)*currentPatch%btran_ft(ft) ) - - btran_eff = currentPatch%btran_ft(ft) - ! For consistency sake, we use total LAI here, and not exposed - ! if the plant is under-snow, it will be effectively dormant for - ! the purposes of nscaler - - cumulative_lai = sum(currentPatch%canopy_layer_tlai(1:cl-1)) + & - sum(currentPatch%tlai_profile(cl,ft,1:iv-1)) + & - 0.5*currentPatch%tlai_profile(cl,ft,iv) - - - end if - - if(do_fates_salinity)then - btran_eff = btran_eff*currentPatch%bstress_sal_ft(ft) - endif - - - ! Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 used - ! kn = 0.11. Here, derive kn from vcmax25 as in Lloyd et al - ! (2010) Biogeosciences, 7, 1833-1859 - - kn = decay_coeff_kn(ft,currentCohort%vcmax25top) - - ! Scale for leaf nitrogen profile - nscaler = exp(-kn * cumulative_lai) - - ! Leaf maintenance respiration to match the base rate used in CN - ! but with the new temperature functions for C3 and C4 plants. - - ! CN respiration has units: g C / g N [leaf] / s. This needs to be - ! converted from g C / g N [leaf] / s to umol CO2 / m**2 [leaf] / s - - ! Then scale this value at the top of the canopy for canopy depth - ! Leaf nitrogen concentration at the top of the canopy (g N leaf / m**2 leaf) - select case(hlm_parteh_mode) - case (prt_carbon_allom_hyp) - - lnc_top = prt_params%nitr_stoich_p1(ft,leaf_organ)/slatop(ft) - - case (prt_cnp_flex_allom_hyp) - - leaf_c = currentCohort%prt%GetState(leaf_organ, all_carbon_elements) - if( (leaf_c*slatop(ft)) > nearzero) then - leaf_n = currentCohort%prt%GetState(leaf_organ, nitrogen_element) - lnc_top = leaf_n / (slatop(ft) * leaf_c ) - else - lnc_top = prt_params%nitr_stoich_p1(ft,leaf_organ)/slatop(ft) - end if - - ! If one wants to break coupling with dynamic N conentrations, - ! use the stoichiometry parameter - ! lnc_top = prt_params%nitr_stoich_p1(ft,leaf_organ)/slatop(ft) - - end select - - lmr25top = 2.525e-6_r8 * (1.5_r8 ** ((25._r8 - 20._r8)/10._r8)) - lmr25top = lmr25top * lnc_top / (umolC_to_kgC * g_per_kg) - - - ! Part VII: Calculate dark respiration (leaf maintenance) for this layer - call LeafLayerMaintenanceRespiration( lmr25top, & ! in - nscaler, & ! in - ft, & ! in - bc_in(s)%t_veg_pa(ifp), & ! in - lmr_z(iv,ft,cl)) ! out - - ! Part VII: Calculate (1) maximum rate of carboxylation (vcmax), - ! (2) maximum electron transport rate, (3) triose phosphate - ! utilization rate and (4) the initial slope of CO2 response curve - ! (C4 plants). Earlier we calculated their base rates as dictated - ! by their plant functional type and some simple scaling rules for - ! nitrogen limitation baesd on canopy position (not prognostic). - ! These rates are the specific rates used in the actual photosynthesis - ! calculations that take localized environmental effects (temperature) - ! into consideration. - - - - call LeafLayerBiophysicalRates(currentPatch%ed_parsun_z(cl,ft,iv), & ! in - ft, & ! in - currentCohort%vcmax25top, & ! in - currentCohort%jmax25top, & ! in - currentCohort%tpu25top, & ! in - currentCohort%kp25top, & ! in - nscaler, & ! in - bc_in(s)%t_veg_pa(ifp), & ! in - btran_eff, & ! in - vcmax_z, & ! out - jmax_z, & ! out - tpu_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 - tpu_z, & ! in - kp_z, & ! in - bc_in(s)%t_veg_pa(ifp), & ! in - bc_in(s)%esat_tv_pa(ifp), & ! in - bc_in(s)%forc_pbot, & ! in - bc_in(s)%cair_pa(ifp), & ! in - bc_in(s)%oair_pa(ifp), & ! in - btran_eff, & ! in - stomatal_intercept_btran, & ! in - cf, & ! in - gb_mol, & ! in - ceair, & ! in - mm_kco2, & ! in - mm_ko2, & ! in - co2_cpoint, & ! in - lmr_z(iv,ft,cl), & ! in - currentPatch%psn_z(cl,ft,iv), & ! out - rs_z(iv,ft,cl), & ! out - anet_av_z(iv,ft,cl), & ! out - c13disc_z(cl,ft,iv)) ! out - - rate_mask_z(iv,ft,cl) = .true. - end if - end do - - ! Zero cohort flux accumulators. - currentCohort%npp_tstep = 0.0_r8 - currentCohort%resp_tstep = 0.0_r8 - currentCohort%gpp_tstep = 0.0_r8 - currentCohort%rdark = 0.0_r8 - currentCohort%resp_m = 0.0_r8 - currentCohort%ts_net_uptake = 0.0_r8 - currentCohort%c13disc_clm = 0.0_r8 - - ! --------------------------------------------------------------- - ! Part VII: Transfer leaf flux rates (like maintenance respiration, - ! carbon assimilation and conductance) that are defined by the - ! leaf layer (which is area independent, ie /m2) onto each cohort - ! (where the rates become per cohort, ie /individual). Most likely - ! a sum over layers. - ! --------------------------------------------------------------- - nv = currentCohort%nv - call ScaleLeafLayerFluxToCohort(nv, & !in - currentPatch%psn_z(cl,ft,1:nv), & !in - lmr_z(1:nv,ft,cl), & !in - rs_z(1:nv,ft,cl), & !in - currentPatch%elai_profile(cl,ft,1:nv), & !in - c13disc_z(cl, ft, 1:nv), & !in - currentCohort%c_area, & !in - currentCohort%n, & !in - bc_in(s)%rb_pa(ifp), & !in - maintresp_reduction_factor, & !in - currentCohort%g_sb_laweight, & !out - currentCohort%gpp_tstep, & !out - currentCohort%rdark, & !out - currentCohort%c13disc_clm, & !out - cohort_eleaf_area) !out - - ! Net Uptake does not need to be scaled, just transfer directly - currentCohort%ts_net_uptake(1:nv) = anet_av_z(1:nv,ft,cl) * umolC_to_kgC - - else - - ! In this case, the cohort had no leaves, - ! so no productivity,conductance, transpiration uptake - ! or dark respiration - cohort_eleaf_area = 0.0_r8 - currentCohort%gpp_tstep = 0.0_r8 - currentCohort%rdark = 0.0_r8 - currentCohort%g_sb_laweight = 0.0_r8 - currentCohort%ts_net_uptake(:) = 0.0_r8 - - end if ! if(currentPatch%canopy_mask(cl,ft) == 1)then - - - ! ------------------------------------------------------------------ - ! Part VIII: Calculate maintenance respiration in the sapwood and - ! fine root pools. - ! ------------------------------------------------------------------ - - ! Calculate the amount of nitrogen in the above and below ground - ! stem and root pools, used for maint resp - ! We are using the fine-root C:N ratio as an approximation for - ! the sapwood pools. - ! Units are in (kgN/plant) - ! ------------------------------------------------------------------ - - sapw_c = currentCohort%prt%GetState(sapw_organ, all_carbon_elements) - fnrt_c = currentCohort%prt%GetState(fnrt_organ, all_carbon_elements) - - select case(hlm_parteh_mode) - case (prt_carbon_allom_hyp) - - live_stem_n = prt_params%allom_agb_frac(currentCohort%pft) * & + + stomatal_intercept_btran = max( cf/rsmax0,stomatal_intercept(ft)*currentCohort%co_hydr%btran ) + btran_eff = currentCohort%co_hydr%btran + + ! dinc_ed is the total vegetation area index of each "leaf" layer + ! we convert to the leaf only portion of the increment + ! ------------------------------------------------------ + leaf_inc = dinc_ed * & + currentCohort%treelai/(currentCohort%treelai+currentCohort%treesai) + + ! Now calculate the cumulative top-down lai of the current layer's midpoint + lai_canopy_above = sum(currentPatch%canopy_layer_tlai(1:cl-1)) + lai_layers_above = leaf_inc * (iv-1) + lai_current = min(leaf_inc, currentCohort%treelai - lai_layers_above) + cumulative_lai = lai_canopy_above + lai_layers_above + 0.5*lai_current + + else + + stomatal_intercept_btran = max( cf/rsmax0,stomatal_intercept(ft)*currentPatch%btran_ft(ft) ) + + btran_eff = currentPatch%btran_ft(ft) + ! For consistency sake, we use total LAI here, and not exposed + ! if the plant is under-snow, it will be effectively dormant for + ! the purposes of nscaler + + cumulative_lai = sum(currentPatch%canopy_layer_tlai(1:cl-1)) + & + sum(currentPatch%tlai_profile(cl,ft,1:iv-1)) + & + 0.5*currentPatch%tlai_profile(cl,ft,iv) + + + end if + + if(do_fates_salinity)then + btran_eff = btran_eff*currentPatch%bstress_sal_ft(ft) + endif + + + ! Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 used + ! kn = 0.11. Here, derive kn from vcmax25 as in Lloyd et al + ! (2010) Biogeosciences, 7, 1833-1859 + + kn = decay_coeff_kn(ft,currentCohort%vcmax25top) + + ! Scale for leaf nitrogen profile + nscaler = exp(-kn * cumulative_lai) + + ! Leaf maintenance respiration to match the base rate used in CN + ! but with the new temperature functions for C3 and C4 plants. + + ! CN respiration has units: g C / g N [leaf] / s. This needs to be + ! converted from g C / g N [leaf] / s to umol CO2 / m**2 [leaf] / s + + ! Then scale this value at the top of the canopy for canopy depth + ! Leaf nitrogen concentration at the top of the canopy (g N leaf / m**2 leaf) + select case(hlm_parteh_mode) + case (prt_carbon_allom_hyp) + + lnc_top = prt_params%nitr_stoich_p1(ft,leaf_organ)/slatop(ft) + + case (prt_cnp_flex_allom_hyp) + + leaf_c = currentCohort%prt%GetState(leaf_organ, all_carbon_elements) + if( (leaf_c*slatop(ft)) > nearzero) then + leaf_n = currentCohort%prt%GetState(leaf_organ, nitrogen_element) + lnc_top = leaf_n / (slatop(ft) * leaf_c ) + else + lnc_top = prt_params%nitr_stoich_p1(ft,leaf_organ)/slatop(ft) + end if + + ! If one wants to break coupling with dynamic N conentrations, + ! use the stoichiometry parameter + ! lnc_top = prt_params%nitr_stoich_p1(ft,leaf_organ)/slatop(ft) + + end select + + lmr25top = 2.525e-6_r8 * (1.5_r8 ** ((25._r8 - 20._r8)/10._r8)) + lmr25top = lmr25top * lnc_top / (umolC_to_kgC * g_per_kg) + + + ! Part VII: Calculate dark respiration (leaf maintenance) for this layer + call LeafLayerMaintenanceRespiration( lmr25top, & ! in + nscaler, & ! in + ft, & ! in + bc_in(s)%t_veg_pa(ifp), & ! in + lmr_z(iv,ft,cl)) ! out + + ! Part VII: Calculate (1) maximum rate of carboxylation (vcmax), + ! (2) maximum electron transport rate, (3) triose phosphate + ! utilization rate and (4) the initial slope of CO2 response curve + ! (C4 plants). Earlier we calculated their base rates as dictated + ! by their plant functional type and some simple scaling rules for + ! nitrogen limitation baesd on canopy position (not prognostic). + ! These rates are the specific rates used in the actual photosynthesis + ! calculations that take localized environmental effects (temperature) + ! into consideration. + + + + call LeafLayerBiophysicalRates(currentPatch%ed_parsun_z(cl,ft,iv), & ! in + ft, & ! in + currentCohort%vcmax25top, & ! in + currentCohort%jmax25top, & ! in + currentCohort%tpu25top, & ! in + currentCohort%kp25top, & ! in + nscaler, & ! in + bc_in(s)%t_veg_pa(ifp), & ! in + btran_eff, & ! in + vcmax_z, & ! out + jmax_z, & ! out + tpu_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 + tpu_z, & ! in + kp_z, & ! in + bc_in(s)%t_veg_pa(ifp), & ! in + bc_in(s)%esat_tv_pa(ifp), & ! in + bc_in(s)%forc_pbot, & ! in + bc_in(s)%cair_pa(ifp), & ! in + bc_in(s)%oair_pa(ifp), & ! in + btran_eff, & ! in + stomatal_intercept_btran, & ! in + cf, & ! in + gb_mol, & ! in + ceair, & ! in + mm_kco2, & ! in + mm_ko2, & ! in + co2_cpoint, & ! in + lmr_z(iv,ft,cl), & ! in + currentPatch%psn_z(cl,ft,iv), & ! out + rs_z(iv,ft,cl), & ! out + anet_av_z(iv,ft,cl), & ! out + c13disc_z(cl,ft,iv)) ! out + + rate_mask_z(iv,ft,cl) = .true. + end if + end do + + ! Zero cohort flux accumulators. + currentCohort%npp_tstep = 0.0_r8 + currentCohort%resp_tstep = 0.0_r8 + currentCohort%gpp_tstep = 0.0_r8 + currentCohort%rdark = 0.0_r8 + currentCohort%resp_m = 0.0_r8 + currentCohort%ts_net_uptake = 0.0_r8 + currentCohort%c13disc_clm = 0.0_r8 + + ! --------------------------------------------------------------- + ! Part VII: Transfer leaf flux rates (like maintenance respiration, + ! carbon assimilation and conductance) that are defined by the + ! leaf layer (which is area independent, ie /m2) onto each cohort + ! (where the rates become per cohort, ie /individual). Most likely + ! a sum over layers. + ! --------------------------------------------------------------- + nv = currentCohort%nv + call ScaleLeafLayerFluxToCohort(nv, & !in + currentPatch%psn_z(cl,ft,1:nv), & !in + lmr_z(1:nv,ft,cl), & !in + rs_z(1:nv,ft,cl), & !in + currentPatch%elai_profile(cl,ft,1:nv), & !in + c13disc_z(cl, ft, 1:nv), & !in + currentCohort%c_area, & !in + currentCohort%n, & !in + bc_in(s)%rb_pa(ifp), & !in + maintresp_reduction_factor, & !in + currentCohort%g_sb_laweight, & !out + currentCohort%gpp_tstep, & !out + currentCohort%rdark, & !out + currentCohort%c13disc_clm, & !out + cohort_eleaf_area) !out + + ! Net Uptake does not need to be scaled, just transfer directly + currentCohort%ts_net_uptake(1:nv) = anet_av_z(1:nv,ft,cl) * umolC_to_kgC + + else + + ! In this case, the cohort had no leaves, + ! so no productivity,conductance, transpiration uptake + ! or dark respiration + cohort_eleaf_area = 0.0_r8 + currentCohort%gpp_tstep = 0.0_r8 + currentCohort%rdark = 0.0_r8 + currentCohort%g_sb_laweight = 0.0_r8 + currentCohort%ts_net_uptake(:) = 0.0_r8 + + end if ! if(currentPatch%canopy_mask(cl,ft) == 1)then + + + ! ------------------------------------------------------------------ + ! Part VIII: Calculate maintenance respiration in the sapwood and + ! fine root pools. + ! ------------------------------------------------------------------ + + ! Calculate the amount of nitrogen in the above and below ground + ! stem and root pools, used for maint resp + ! We are using the fine-root C:N ratio as an approximation for + ! the sapwood pools. + ! Units are in (kgN/plant) + ! ------------------------------------------------------------------ + + sapw_c = currentCohort%prt%GetState(sapw_organ, all_carbon_elements) + fnrt_c = currentCohort%prt%GetState(fnrt_organ, all_carbon_elements) + + select case(hlm_parteh_mode) + case (prt_carbon_allom_hyp) + + live_stem_n = prt_params%allom_agb_frac(currentCohort%pft) * & sapw_c * prt_params%nitr_stoich_p1(ft,sapw_organ) - - live_croot_n = (1.0_r8-prt_params%allom_agb_frac(currentCohort%pft)) * & + + live_croot_n = (1.0_r8-prt_params%allom_agb_frac(currentCohort%pft)) * & sapw_c * prt_params%nitr_stoich_p1(ft,sapw_organ) - fnrt_n = fnrt_c * prt_params%nitr_stoich_p1(ft,fnrt_organ) - - case(prt_cnp_flex_allom_hyp) - - live_stem_n = prt_params%allom_agb_frac(currentCohort%pft) * & - currentCohort%prt%GetState(sapw_organ, nitrogen_element) - - live_croot_n = (1.0_r8-prt_params%allom_agb_frac(currentCohort%pft)) * & - currentCohort%prt%GetState(sapw_organ, nitrogen_element) - - fnrt_n = currentCohort%prt%GetState(fnrt_organ, nitrogen_element) - - ! If one wants to break coupling with dynamic N conentrations, - ! use the stoichiometry parameter - ! - ! live_stem_n = prt_params%allom_agb_frac(currentCohort%pft) * & - ! sapw_c * prt_params%nitr_stoich_p1(ft,sapw_organ) - ! live_croot_n = (1.0_r8-prt_params%allom_agb_frac(currentCohort%pft)) * & - ! sapw_c * prt_params%nitr_stoich_p1(ft,sapw_organ) - ! fnrt_n = fnrt_c * prt_params%nitr_stoich_p1(ft,fnrt_organ) - - - case default - - - end select - - !------------------------------------------------------------------------------ - ! Calculate Whole Plant Respiration - ! (this doesn't really need to be in this iteration at all, surely?) - ! Response: (RGK 12-2016): I think the positioning of these calls is - ! appropriate as of now. Maintenance calculations in sapwood and roots - ! vary by cohort and with changing temperature at the minimum, and there are - ! no sub-pools chopping up those pools any finer that need to be dealt with. - !------------------------------------------------------------------------------ - - ! Live stem MR (kgC/plant/s) (above ground sapwood) - ! ------------------------------------------------------------------ - if ( int(woody(ft)) == itrue) then - tcwood = q10_mr**((bc_in(s)%t_veg_pa(ifp)-tfrz - 20.0_r8)/10.0_r8) - ! kgC/s = kgN * kgC/kgN/s - currentCohort%livestem_mr = live_stem_n * ED_val_base_mr_20 * tcwood * maintresp_reduction_factor - else - currentCohort%livestem_mr = 0._r8 - end if - - - ! Fine Root MR (kgC/plant/s) - ! ------------------------------------------------------------------ - currentCohort%froot_mr = 0._r8 - do j = 1,bc_in(s)%nlevsoil - tcsoi = q10_mr**((bc_in(s)%t_soisno_sl(j)-tfrz - 20.0_r8)/10.0_r8) - currentCohort%froot_mr = currentCohort%froot_mr + & + fnrt_n = fnrt_c * prt_params%nitr_stoich_p1(ft,fnrt_organ) + + case(prt_cnp_flex_allom_hyp) + + live_stem_n = prt_params%allom_agb_frac(currentCohort%pft) * & + currentCohort%prt%GetState(sapw_organ, nitrogen_element) + + live_croot_n = (1.0_r8-prt_params%allom_agb_frac(currentCohort%pft)) * & + currentCohort%prt%GetState(sapw_organ, nitrogen_element) + + fnrt_n = currentCohort%prt%GetState(fnrt_organ, nitrogen_element) + + ! If one wants to break coupling with dynamic N conentrations, + ! use the stoichiometry parameter + ! + ! live_stem_n = prt_params%allom_agb_frac(currentCohort%pft) * & + ! sapw_c * prt_params%nitr_stoich_p1(ft,sapw_organ) + ! live_croot_n = (1.0_r8-prt_params%allom_agb_frac(currentCohort%pft)) * & + ! sapw_c * prt_params%nitr_stoich_p1(ft,sapw_organ) + ! fnrt_n = fnrt_c * prt_params%nitr_stoich_p1(ft,fnrt_organ) + + + case default + + + end select + + !------------------------------------------------------------------------------ + ! Calculate Whole Plant Respiration + ! (this doesn't really need to be in this iteration at all, surely?) + ! Response: (RGK 12-2016): I think the positioning of these calls is + ! appropriate as of now. Maintenance calculations in sapwood and roots + ! vary by cohort and with changing temperature at the minimum, and there are + ! no sub-pools chopping up those pools any finer that need to be dealt with. + !------------------------------------------------------------------------------ + + ! Live stem MR (kgC/plant/s) (above ground sapwood) + ! ------------------------------------------------------------------ + if ( int(woody(ft)) == itrue) then + tcwood = q10_mr**((bc_in(s)%t_veg_pa(ifp)-tfrz - 20.0_r8)/10.0_r8) + ! kgC/s = kgN * kgC/kgN/s + currentCohort%livestem_mr = live_stem_n * ED_val_base_mr_20 * tcwood * maintresp_reduction_factor + else + currentCohort%livestem_mr = 0._r8 + end if + + + ! Fine Root MR (kgC/plant/s) + ! ------------------------------------------------------------------ + currentCohort%froot_mr = 0._r8 + do j = 1,bc_in(s)%nlevsoil + tcsoi = q10_mr**((bc_in(s)%t_soisno_sl(j)-tfrz - 20.0_r8)/10.0_r8) + currentCohort%froot_mr = currentCohort%froot_mr + & fnrt_n * ED_val_base_mr_20 * tcsoi * rootfr_ft(ft,j) * maintresp_reduction_factor - enddo - - ! Coarse Root MR (kgC/plant/s) (below ground sapwood) - ! ------------------------------------------------------------------ - if ( int(woody(ft)) == itrue) then - currentCohort%livecroot_mr = 0._r8 - do j = 1,bc_in(s)%nlevsoil - ! Soil temperature used to adjust base rate of MR - tcsoi = q10_mr**((bc_in(s)%t_soisno_sl(j)-tfrz - 20.0_r8)/10.0_r8) - currentCohort%livecroot_mr = currentCohort%livecroot_mr + & + enddo + + ! Coarse Root MR (kgC/plant/s) (below ground sapwood) + ! ------------------------------------------------------------------ + if ( int(woody(ft)) == itrue) then + currentCohort%livecroot_mr = 0._r8 + do j = 1,bc_in(s)%nlevsoil + ! Soil temperature used to adjust base rate of MR + tcsoi = q10_mr**((bc_in(s)%t_soisno_sl(j)-tfrz - 20.0_r8)/10.0_r8) + currentCohort%livecroot_mr = currentCohort%livecroot_mr + & live_croot_n * ED_val_base_mr_20 * tcsoi * & rootfr_ft(ft,j) * maintresp_reduction_factor - enddo - else - currentCohort%livecroot_mr = 0._r8 - end if - - - ! ------------------------------------------------------------------ - ! Part IX: Perform some unit conversions (rate to integrated) and - ! calcualate some fluxes that are sums and nets of the base fluxes - ! ------------------------------------------------------------------ - - if ( debug ) write(fates_log(),*) 'EDPhoto 904 ', currentCohort%resp_m - if ( debug ) write(fates_log(),*) 'EDPhoto 905 ', currentCohort%rdark - if ( debug ) write(fates_log(),*) 'EDPhoto 906 ', currentCohort%livestem_mr - if ( debug ) write(fates_log(),*) 'EDPhoto 907 ', currentCohort%livecroot_mr - if ( debug ) write(fates_log(),*) 'EDPhoto 908 ', currentCohort%froot_mr - - - - ! add on whole plant respiration values in kgC/indiv/s-1 - currentCohort%resp_m = currentCohort%livestem_mr + & - currentCohort%livecroot_mr + & - currentCohort%froot_mr - - ! no drought response right now.. something like: - ! resp_m = resp_m * (1.0_r8 - currentPatch%btran_ft(currentCohort%pft) * & - ! EDPftvarcon_inst%resp_drought_response(ft)) - - currentCohort%resp_m = currentCohort%resp_m + currentCohort%rdark - - ! convert from kgC/indiv/s to kgC/indiv/timestep - currentCohort%resp_m = currentCohort%resp_m * dtime - currentCohort%gpp_tstep = currentCohort%gpp_tstep * dtime - currentCohort%ts_net_uptake = currentCohort%ts_net_uptake * dtime - - if ( debug ) write(fates_log(),*) 'EDPhoto 911 ', currentCohort%gpp_tstep - if ( debug ) write(fates_log(),*) 'EDPhoto 912 ', currentCohort%resp_tstep - if ( debug ) write(fates_log(),*) 'EDPhoto 913 ', currentCohort%resp_m - - - currentCohort%resp_g_tstep = prt_params%grperc(ft) * & - (max(0._r8,currentCohort%gpp_tstep - currentCohort%resp_m)) - - - currentCohort%resp_tstep = currentCohort%resp_m + & - currentCohort%resp_g_tstep ! kgC/indiv/ts - currentCohort%npp_tstep = currentCohort%gpp_tstep - & - currentCohort%resp_tstep ! kgC/indiv/ts - - ! Accumulate the combined conductance (stomatal+leaf boundary layer) - ! Note that currentCohort%g_sb_laweight is weighted by the leaf area - ! of each cohort and has units of [m/s] * [m2 leaf] - - g_sb_leaves = g_sb_leaves + currentCohort%g_sb_laweight - - ! Accumulate the total effective leaf area from all cohorts - ! in this patch. Normalize by canopy area outside the loop - check_elai = check_elai + cohort_eleaf_area - - currentCohort => currentCohort%shorter - - enddo ! end cohort loop. - end if !count_cohorts is more than zero. - - check_elai = check_elai / currentPatch%total_canopy_area - elai = calc_areaindex(currentPatch,'elai') - - ! Normalize canopy total conductance by the effective LAI - ! The value here was integrated over each cohort x leaf layer - ! and was weighted by m2 of effective leaf area for each layer - - if(check_elai>tiny(check_elai)) then - - ! Normalize the leaf-area weighted canopy conductance - ! The denominator is the total effective leaf area in the canopy, - ! units of [m/s]*[m2] / [m2] = [m/s] - g_sb_leaves = g_sb_leaves / (elai*currentPatch%total_canopy_area) - - if( g_sb_leaves > (1._r8/rsmax0) ) then - - ! Combined mean leaf resistance is the inverse of mean leaf conductance - r_sb_leaves = 1.0_r8/g_sb_leaves - - if (r_sb_leaves currentPatch%younger - end do - - deallocate(rootfr_ft) - - end do !site loop - - end associate - end subroutine FatesPlantRespPhotosynthDrive - - ! ======================================================================================= - - subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in - parsun_lsl, & ! in - parsha_lsl, & ! in - laisun_lsl, & ! in - laisha_lsl, & ! in - canopy_area_lsl, & ! in - ft, & ! in - vcmax, & ! in - jmax, & ! in - tpu, & ! in - co2_rcurve_islope, & ! in - veg_tempk, & ! in - veg_esat, & ! in - can_press, & ! in - can_co2_ppress, & ! in - can_o2_ppress, & ! in - btran, & ! in - stomatal_intercept_btran, & ! in - cf, & ! in - gb_mol, & ! in - ceair, & ! in - mm_kco2, & ! in - mm_ko2, & ! in - co2_cpoint, & ! in - lmr, & ! in - psn_out, & ! out - rstoma_out, & ! out - anet_av_out, & ! out - c13disc_z) ! out - - ! ------------------------------------------------------------------------------------ - ! This subroutine calculates photosynthesis and stomatal conductance within each leaf - ! sublayer. - ! A note on naming conventions: As this subroutine is called for every - ! leaf-sublayer, many of the arguments are specific to that "leaf sub layer" - ! (LSL), those variables are given a dimension tag "_lsl" - ! Other arguments or variables may be indicative of scales broader than the LSL. - ! ------------------------------------------------------------------------------------ - - use EDPftvarcon , only : EDPftvarcon_inst - - - ! Arguments - ! ------------------------------------------------------------------------------------ - real(r8), intent(in) :: f_sun_lsl ! - real(r8), intent(in) :: parsun_lsl ! Absorbed PAR in sunlist leaves - real(r8), intent(in) :: parsha_lsl ! Absorved PAR in shaded leaves - real(r8), intent(in) :: laisun_lsl ! LAI in sunlit leaves - real(r8), intent(in) :: laisha_lsl ! LAI in shaded leaves - real(r8), intent(in) :: canopy_area_lsl ! - integer, intent(in) :: ft ! (plant) Functional Type Index - real(r8), intent(in) :: vcmax ! maximum rate of carboxylation (umol co2/m**2/s) - real(r8), intent(in) :: jmax ! maximum electron transport rate (umol electrons/m**2/s) - real(r8), intent(in) :: tpu ! triose phosphate utilization rate (umol CO2/m**2/s) - real(r8), intent(in) :: co2_rcurve_islope ! initial slope of CO2 response curve (C4 plants) - real(r8), intent(in) :: veg_tempk ! vegetation temperature - real(r8), intent(in) :: veg_esat ! saturation vapor pressure at veg_tempk (Pa) - - ! Important Note on the following gas pressures. This photosynthesis scheme will iteratively - ! solve for the co2 partial pressure at the leaf surface (ie in the stomata). The reference - ! point for these input values are NOT within that boundary layer that separates the stomata from - ! the canopy air space. The reference point for these is on the outside of that boundary - ! layer. This routine, which operates at the leaf scale, makes no assumptions about what the - ! scale of the refernce is, it could be lower atmosphere, it could be within the canopy - ! but most likely it is the closest value one can get to the edge of the leaf's boundary - ! layer. We use the convention "can_" because a reference point of within the canopy - ! ia a best reasonable scenario of where we can get that information from. - - real(r8), intent(in) :: can_press ! Air pressure NEAR the surface of the leaf (Pa) - real(r8), intent(in) :: can_co2_ppress ! Partial pressure of CO2 NEAR the leaf surface (Pa) - real(r8), intent(in) :: can_o2_ppress ! Partial pressure of O2 NEAR the leaf surface (Pa) - real(r8), intent(in) :: btran ! transpiration wetness factor (0 to 1) - real(r8), intent(in) :: stomatal_intercept_btran !water-stressed minimum stomatal conductance (umol H2O/m**2/s) - real(r8), intent(in) :: cf ! s m**2/umol -> s/m (ideal gas conversion) [umol/m3] - real(r8), intent(in) :: gb_mol ! leaf boundary layer conductance (umol /m**2/s) - real(r8), intent(in) :: ceair ! vapor pressure of air, constrained (Pa) - real(r8), intent(in) :: mm_kco2 ! Michaelis-Menten constant for CO2 (Pa) - real(r8), intent(in) :: mm_ko2 ! Michaelis-Menten constant for O2 (Pa) - real(r8), intent(in) :: co2_cpoint ! CO2 compensation point (Pa) - real(r8), intent(in) :: lmr ! Leaf Maintenance Respiration (umol CO2/m**2/s) - - real(r8), intent(out) :: psn_out ! carbon assimilated in this leaf layer umolC/m2/s - real(r8), intent(out) :: rstoma_out ! stomatal resistance (1/gs_lsl) (s/m) - real(r8), intent(out) :: anet_av_out ! net leaf photosynthesis (umol CO2/m**2/s) - ! averaged over sun and shade leaves. - real(r8), intent(out) :: c13disc_z ! carbon 13 in newly assimilated carbon - - ! Locals - ! ------------------------------------------------------------------------ - integer :: c3c4_path_index ! Index for which photosynthetic pathway - ! is active. C4 = 0, C3 = 1 - integer :: sunsha ! Index for differentiating sun and shade - real(r8) :: gstoma ! Stomatal Conductance of this leaf layer (m/s) - real(r8) :: agross ! co-limited gross leaf photosynthesis (umol CO2/m**2/s) - real(r8) :: anet ! net leaf photosynthesis (umol CO2/m**2/s) - real(r8) :: je ! electron transport rate (umol electrons/m**2/s) - real(r8) :: qabs ! PAR absorbed by PS II (umol photons/m**2/s) - real(r8) :: aquad,bquad,cquad ! terms for quadratic equations - real(r8) :: r1,r2 ! roots of quadratic equation - real(r8) :: co2_inter_c ! intercellular leaf CO2 (Pa) - real(r8) :: co2_inter_c_old ! intercellular leaf CO2 (Pa) (previous iteration) - logical :: loop_continue ! Loop control variable - integer :: niter ! iteration loop index - real(r8) :: gs_mol ! leaf stomatal conductance (umol H2O/m**2/s) - real(r8) :: gs ! leaf stomatal conductance (m/s) - real(r8) :: hs ! fractional humidity at leaf surface (dimensionless) - real(r8) :: gs_mol_err ! gs_mol for error check - real(r8) :: ac ! Rubisco-limited gross photosynthesis (umol CO2/m**2/s) - real(r8) :: aj ! RuBP-limited gross photosynthesis (umol CO2/m**2/s) - real(r8) :: ap ! product-limited (C3) or CO2-limited - ! (C4) gross photosynthesis (umol CO2/m**2/s) - real(r8) :: ai ! intermediate co-limited photosynthesis (umol CO2/m**2/s) - real(r8) :: leaf_co2_ppress ! CO2 partial pressure at leaf surface (Pa) - real(r8) :: init_co2_inter_c ! First guess intercellular co2 specific to C path - real(r8) :: term ! intermediate variable in Medlyn stomatal conductance model - real(r8) :: vpd ! water vapor deficit in Medlyn stomatal model (KPa) - - - ! Parameters - ! ------------------------------------------------------------------------ - ! Fraction of light absorbed by non-photosynthetic pigments - real(r8),parameter :: fnps = 0.15_r8 - - ! For plants with no leaves, a miniscule amount of conductance - ! can happen through the stems, at a partial rate of cuticular conductance - real(r8),parameter :: stem_cuticle_loss_frac = 0.1_r8 - - ! empirical curvature parameter for electron transport rate - real(r8),parameter :: theta_psii = 0.7_r8 - - ! First guess on ratio between intercellular co2 and the atmosphere - ! an iterator converges on actual - real(r8),parameter :: init_a2l_co2_c3 = 0.7_r8 - real(r8),parameter :: init_a2l_co2_c4 = 0.4_r8 - - ! quantum efficiency, used only for C4 (mol CO2 / mol photons) (index 0) - real(r8),parameter,dimension(0:1) :: quant_eff = [0.05_r8,0.0_r8] - - ! empirical curvature parameter for ac, aj photosynthesis co-limitation. - ! Changed theta_cj and theta_ip to 0.999 to effectively remove smoothing logic - ! following Anthony Walker's findings from MAAT. - real(r8),parameter,dimension(0:1) :: theta_cj = [0.999_r8,0.999_r8] - - ! empirical curvature parameter for ap photosynthesis co-limitation - real(r8),parameter :: theta_ip = 0.999_r8 - - associate( bb_slope => EDPftvarcon_inst%bb_slope ,& ! slope of BB relationship, unitless - medlyn_slope=> EDPftvarcon_inst%medlyn_slope , & ! Slope for Medlyn stomatal conductance model method, the unit is KPa^0.5 - stomatal_intercept=> EDPftvarcon_inst%stomatal_intercept ) !Unstressed minimum stomatal conductance, the unit is umol/m**2/s - - ! photosynthetic pathway: 0. = c4, 1. = c3 - c3c4_path_index = nint(EDPftvarcon_inst%c3psn(ft)) - - if (c3c4_path_index == 1) then - init_co2_inter_c = init_a2l_co2_c3 * can_co2_ppress - else - init_co2_inter_c = init_a2l_co2_c4 * can_co2_ppress - end if - - ! Part III: Photosynthesis and Conductance - ! ---------------------------------------------------------------------------------- - - if ( parsun_lsl <= 0._r8 ) then ! night time - - anet_av_out = -lmr - psn_out = 0._r8 + enddo + else + currentCohort%livecroot_mr = 0._r8 + end if - ! The cuticular conductance already factored in maximum resistance as a bound - ! no need to re-bound it - - rstoma_out = cf/stomatal_intercept_btran - - c13disc_z = 0.0_r8 !carbon 13 discrimination in night time carbon flux, note value of 1.0 is used in CLM - - else ! day time (a little bit more complicated ...) - - !is there leaf area? - (NV can be larger than 0 with only stem area if deciduous) - if ( laisun_lsl + laisha_lsl > 0._r8 ) then - - !Loop aroun shaded and unshaded leaves - psn_out = 0._r8 ! psn is accumulated across sun and shaded leaves. - rstoma_out = 0._r8 ! 1/rs is accumulated across sun and shaded leaves. - anet_av_out = 0._r8 - gstoma = 0._r8 - - do sunsha = 1,2 - ! Electron transport rate for C3 plants. - ! Convert par from W/m2 to umol photons/m**2/s using the factor 4.6 - ! Convert from units of par absorbed per unit ground area to par - ! absorbed per unit leaf area. - - if(sunsha == 1)then !sunlit - if(( laisun_lsl * canopy_area_lsl) > 0.0000000001_r8)then - - qabs = parsun_lsl / (laisun_lsl * canopy_area_lsl ) - qabs = qabs * 0.5_r8 * (1._r8 - fnps) * 4.6_r8 - - else - qabs = 0.0_r8 - end if - else - qabs = parsha_lsl / (laisha_lsl * canopy_area_lsl) + ! ------------------------------------------------------------------ + ! Part IX: Perform some unit conversions (rate to integrated) and + ! calcualate some fluxes that are sums and nets of the base fluxes + ! ------------------------------------------------------------------ + + if ( debug ) write(fates_log(),*) 'EDPhoto 904 ', currentCohort%resp_m + if ( debug ) write(fates_log(),*) 'EDPhoto 905 ', currentCohort%rdark + if ( debug ) write(fates_log(),*) 'EDPhoto 906 ', currentCohort%livestem_mr + if ( debug ) write(fates_log(),*) 'EDPhoto 907 ', currentCohort%livecroot_mr + if ( debug ) write(fates_log(),*) 'EDPhoto 908 ', currentCohort%froot_mr + + + + ! add on whole plant respiration values in kgC/indiv/s-1 + currentCohort%resp_m = currentCohort%livestem_mr + & + currentCohort%livecroot_mr + & + currentCohort%froot_mr + + ! no drought response right now.. something like: + ! resp_m = resp_m * (1.0_r8 - currentPatch%btran_ft(currentCohort%pft) * & + ! EDPftvarcon_inst%resp_drought_response(ft)) + + currentCohort%resp_m = currentCohort%resp_m + currentCohort%rdark + + ! convert from kgC/indiv/s to kgC/indiv/timestep + currentCohort%resp_m = currentCohort%resp_m * dtime + currentCohort%gpp_tstep = currentCohort%gpp_tstep * dtime + currentCohort%ts_net_uptake = currentCohort%ts_net_uptake * dtime + + if ( debug ) write(fates_log(),*) 'EDPhoto 911 ', currentCohort%gpp_tstep + if ( debug ) write(fates_log(),*) 'EDPhoto 912 ', currentCohort%resp_tstep + if ( debug ) write(fates_log(),*) 'EDPhoto 913 ', currentCohort%resp_m + + + currentCohort%resp_g_tstep = prt_params%grperc(ft) * & + (max(0._r8,currentCohort%gpp_tstep - currentCohort%resp_m)) + + + currentCohort%resp_tstep = currentCohort%resp_m + & + currentCohort%resp_g_tstep ! kgC/indiv/ts + currentCohort%npp_tstep = currentCohort%gpp_tstep - & + currentCohort%resp_tstep ! kgC/indiv/ts + + ! Accumulate the combined conductance (stomatal+leaf boundary layer) + ! Note that currentCohort%g_sb_laweight is weighted by the leaf area + ! of each cohort and has units of [m/s] * [m2 leaf] + + g_sb_leaves = g_sb_leaves + currentCohort%g_sb_laweight + + ! Accumulate the total effective leaf area from all cohorts + ! in this patch. Normalize by canopy area outside the loop + check_elai = check_elai + cohort_eleaf_area + + currentCohort => currentCohort%shorter + + enddo ! end cohort loop. + end if !count_cohorts is more than zero. + + check_elai = check_elai / currentPatch%total_canopy_area + elai = calc_areaindex(currentPatch,'elai') + + ! Normalize canopy total conductance by the effective LAI + ! The value here was integrated over each cohort x leaf layer + ! and was weighted by m2 of effective leaf area for each layer + + if(check_elai>tiny(check_elai)) then + + ! Normalize the leaf-area weighted canopy conductance + ! The denominator is the total effective leaf area in the canopy, + ! units of [m/s]*[m2] / [m2] = [m/s] + g_sb_leaves = g_sb_leaves / (elai*currentPatch%total_canopy_area) + + if( g_sb_leaves > (1._r8/rsmax0) ) then + + ! Combined mean leaf resistance is the inverse of mean leaf conductance + r_sb_leaves = 1.0_r8/g_sb_leaves + + if (r_sb_leaves currentPatch%younger + end do + + deallocate(rootfr_ft) + + end do !site loop + + end associate +end subroutine FatesPlantRespPhotosynthDrive + +! ======================================================================================= + +subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in + parsun_lsl, & ! in + parsha_lsl, & ! in + laisun_lsl, & ! in + laisha_lsl, & ! in + canopy_area_lsl, & ! in + ft, & ! in + vcmax, & ! in + jmax, & ! in + tpu, & ! in + co2_rcurve_islope, & ! in + veg_tempk, & ! in + veg_esat, & ! in + can_press, & ! in + can_co2_ppress, & ! in + can_o2_ppress, & ! in + btran, & ! in + stomatal_intercept_btran, & ! in + cf, & ! in + gb_mol, & ! in + ceair, & ! in + mm_kco2, & ! in + mm_ko2, & ! in + co2_cpoint, & ! in + lmr, & ! in + psn_out, & ! out + rstoma_out, & ! out + anet_av_out, & ! out + c13disc_z) ! out + + ! ------------------------------------------------------------------------------------ + ! This subroutine calculates photosynthesis and stomatal conductance within each leaf + ! sublayer. + ! A note on naming conventions: As this subroutine is called for every + ! leaf-sublayer, many of the arguments are specific to that "leaf sub layer" + ! (LSL), those variables are given a dimension tag "_lsl" + ! Other arguments or variables may be indicative of scales broader than the LSL. + ! ------------------------------------------------------------------------------------ + + use EDPftvarcon , only : EDPftvarcon_inst + + + ! Arguments + ! ------------------------------------------------------------------------------------ + real(r8), intent(in) :: f_sun_lsl ! + real(r8), intent(in) :: parsun_lsl ! Absorbed PAR in sunlist leaves + real(r8), intent(in) :: parsha_lsl ! Absorved PAR in shaded leaves + real(r8), intent(in) :: laisun_lsl ! LAI in sunlit leaves + real(r8), intent(in) :: laisha_lsl ! LAI in shaded leaves + real(r8), intent(in) :: canopy_area_lsl ! + integer, intent(in) :: ft ! (plant) Functional Type Index + real(r8), intent(in) :: vcmax ! maximum rate of carboxylation (umol co2/m**2/s) + real(r8), intent(in) :: jmax ! maximum electron transport rate (umol electrons/m**2/s) + real(r8), intent(in) :: tpu ! triose phosphate utilization rate (umol CO2/m**2/s) + real(r8), intent(in) :: co2_rcurve_islope ! initial slope of CO2 response curve (C4 plants) + real(r8), intent(in) :: veg_tempk ! vegetation temperature + real(r8), intent(in) :: veg_esat ! saturation vapor pressure at veg_tempk (Pa) + + ! Important Note on the following gas pressures. This photosynthesis scheme will iteratively + ! solve for the co2 partial pressure at the leaf surface (ie in the stomata). The reference + ! point for these input values are NOT within that boundary layer that separates the stomata from + ! the canopy air space. The reference point for these is on the outside of that boundary + ! layer. This routine, which operates at the leaf scale, makes no assumptions about what the + ! scale of the refernce is, it could be lower atmosphere, it could be within the canopy + ! but most likely it is the closest value one can get to the edge of the leaf's boundary + ! layer. We use the convention "can_" because a reference point of within the canopy + ! ia a best reasonable scenario of where we can get that information from. + + real(r8), intent(in) :: can_press ! Air pressure NEAR the surface of the leaf (Pa) + real(r8), intent(in) :: can_co2_ppress ! Partial pressure of CO2 NEAR the leaf surface (Pa) + real(r8), intent(in) :: can_o2_ppress ! Partial pressure of O2 NEAR the leaf surface (Pa) + real(r8), intent(in) :: btran ! transpiration wetness factor (0 to 1) + real(r8), intent(in) :: stomatal_intercept_btran !water-stressed minimum stomatal conductance (umol H2O/m**2/s) + real(r8), intent(in) :: cf ! s m**2/umol -> s/m (ideal gas conversion) [umol/m3] + real(r8), intent(in) :: gb_mol ! leaf boundary layer conductance (umol /m**2/s) + real(r8), intent(in) :: ceair ! vapor pressure of air, constrained (Pa) + real(r8), intent(in) :: mm_kco2 ! Michaelis-Menten constant for CO2 (Pa) + real(r8), intent(in) :: mm_ko2 ! Michaelis-Menten constant for O2 (Pa) + real(r8), intent(in) :: co2_cpoint ! CO2 compensation point (Pa) + real(r8), intent(in) :: lmr ! Leaf Maintenance Respiration (umol CO2/m**2/s) + + real(r8), intent(out) :: psn_out ! carbon assimilated in this leaf layer umolC/m2/s + real(r8), intent(out) :: rstoma_out ! stomatal resistance (1/gs_lsl) (s/m) + real(r8), intent(out) :: anet_av_out ! net leaf photosynthesis (umol CO2/m**2/s) + ! averaged over sun and shade leaves. + real(r8), intent(out) :: c13disc_z ! carbon 13 in newly assimilated carbon + + ! Locals + ! ------------------------------------------------------------------------ + integer :: c3c4_path_index ! Index for which photosynthetic pathway + ! is active. C4 = 0, C3 = 1 + integer :: sunsha ! Index for differentiating sun and shade + real(r8) :: gstoma ! Stomatal Conductance of this leaf layer (m/s) + real(r8) :: agross ! co-limited gross leaf photosynthesis (umol CO2/m**2/s) + real(r8) :: anet ! net leaf photosynthesis (umol CO2/m**2/s) + real(r8) :: je ! electron transport rate (umol electrons/m**2/s) + real(r8) :: qabs ! PAR absorbed by PS II (umol photons/m**2/s) + real(r8) :: aquad,bquad,cquad ! terms for quadratic equations + real(r8) :: r1,r2 ! roots of quadratic equation + real(r8) :: co2_inter_c ! intercellular leaf CO2 (Pa) + real(r8) :: co2_inter_c_old ! intercellular leaf CO2 (Pa) (previous iteration) + logical :: loop_continue ! Loop control variable + integer :: niter ! iteration loop index + real(r8) :: gs_mol ! leaf stomatal conductance (umol H2O/m**2/s) + real(r8) :: gs ! leaf stomatal conductance (m/s) + real(r8) :: hs ! fractional humidity at leaf surface (dimensionless) + real(r8) :: gs_mol_err ! gs_mol for error check + real(r8) :: ac ! Rubisco-limited gross photosynthesis (umol CO2/m**2/s) + real(r8) :: aj ! RuBP-limited gross photosynthesis (umol CO2/m**2/s) + real(r8) :: ap ! product-limited (C3) or CO2-limited + ! (C4) gross photosynthesis (umol CO2/m**2/s) + real(r8) :: ai ! intermediate co-limited photosynthesis (umol CO2/m**2/s) + real(r8) :: leaf_co2_ppress ! CO2 partial pressure at leaf surface (Pa) + real(r8) :: init_co2_inter_c ! First guess intercellular co2 specific to C path + real(r8) :: term ! intermediate variable in Medlyn stomatal conductance model + real(r8) :: vpd ! water vapor deficit in Medlyn stomatal model (KPa) + + + ! Parameters + ! ------------------------------------------------------------------------ + ! Fraction of light absorbed by non-photosynthetic pigments + real(r8),parameter :: fnps = 0.15_r8 + + ! For plants with no leaves, a miniscule amount of conductance + ! can happen through the stems, at a partial rate of cuticular conductance + real(r8),parameter :: stem_cuticle_loss_frac = 0.1_r8 + + ! empirical curvature parameter for electron transport rate + real(r8),parameter :: theta_psii = 0.7_r8 + + ! First guess on ratio between intercellular co2 and the atmosphere + ! an iterator converges on actual + real(r8),parameter :: init_a2l_co2_c3 = 0.7_r8 + real(r8),parameter :: init_a2l_co2_c4 = 0.4_r8 + + ! quantum efficiency, used only for C4 (mol CO2 / mol photons) (index 0) + real(r8),parameter,dimension(0:1) :: quant_eff = [0.05_r8,0.0_r8] + + ! empirical curvature parameter for ac, aj photosynthesis co-limitation. + ! Changed theta_cj and theta_ip to 0.999 to effectively remove smoothing logic + ! following Anthony Walker's findings from MAAT. + real(r8),parameter,dimension(0:1) :: theta_cj = [0.999_r8,0.999_r8] + + ! empirical curvature parameter for ap photosynthesis co-limitation + real(r8),parameter :: theta_ip = 0.999_r8 + + associate( bb_slope => EDPftvarcon_inst%bb_slope ,& ! slope of BB relationship, unitless + medlyn_slope=> EDPftvarcon_inst%medlyn_slope , & ! Slope for Medlyn stomatal conductance model method, the unit is KPa^0.5 + stomatal_intercept=> EDPftvarcon_inst%stomatal_intercept ) !Unstressed minimum stomatal conductance, the unit is umol/m**2/s + + ! photosynthetic pathway: 0. = c4, 1. = c3 + c3c4_path_index = nint(EDPftvarcon_inst%c3psn(ft)) + + if (c3c4_path_index == 1) then + init_co2_inter_c = init_a2l_co2_c3 * can_co2_ppress + else + init_co2_inter_c = init_a2l_co2_c4 * can_co2_ppress + end if + + ! Part III: Photosynthesis and Conductance + ! ---------------------------------------------------------------------------------- + + if ( parsun_lsl <= 0._r8 ) then ! night time + + anet_av_out = -lmr + psn_out = 0._r8 + + ! The cuticular conductance already factored in maximum resistance as a bound + ! no need to re-bound it + + rstoma_out = cf/stomatal_intercept_btran + + c13disc_z = 0.0_r8 !carbon 13 discrimination in night time carbon flux, note value of 1.0 is used in CLM + + else ! day time (a little bit more complicated ...) + + !is there leaf area? - (NV can be larger than 0 with only stem area if deciduous) + if ( laisun_lsl + laisha_lsl > 0._r8 ) then + + !Loop aroun shaded and unshaded leaves + psn_out = 0._r8 ! psn is accumulated across sun and shaded leaves. + rstoma_out = 0._r8 ! 1/rs is accumulated across sun and shaded leaves. + anet_av_out = 0._r8 + gstoma = 0._r8 + + do sunsha = 1,2 + ! Electron transport rate for C3 plants. + ! Convert par from W/m2 to umol photons/m**2/s using the factor 4.6 + ! Convert from units of par absorbed per unit ground area to par + ! absorbed per unit leaf area. + + if(sunsha == 1)then !sunlit + if(( laisun_lsl * canopy_area_lsl) > 0.0000000001_r8)then + + qabs = parsun_lsl / (laisun_lsl * canopy_area_lsl ) qabs = qabs * 0.5_r8 * (1._r8 - fnps) * 4.6_r8 + else + qabs = 0.0_r8 end if + else - !convert the absorbed par into absorbed par per m2 of leaf, - ! so it is consistant with the vcmax and lmr numbers. - aquad = theta_psii - bquad = -(qabs + jmax) - cquad = qabs * jmax - call quadratic_f (aquad, bquad, cquad, r1, r2) - je = min(r1,r2) - - ! Initialize intercellular co2 - co2_inter_c = init_co2_inter_c - - niter = 0 - loop_continue = .true. - do while(loop_continue) - ! Increment iteration counter. Stop if too many iterations - niter = niter + 1 - - ! Save old co2_inter_c - co2_inter_c_old = co2_inter_c - - ! Photosynthesis limitation rate calculations - if (c3c4_path_index == 1)then - - ! C3: Rubisco-limited photosynthesis - ac = vcmax * max(co2_inter_c-co2_cpoint, 0._r8) / & - (co2_inter_c+mm_kco2 * (1._r8+can_o2_ppress / mm_ko2 )) - - ! C3: RuBP-limited photosynthesis - aj = je * max(co2_inter_c-co2_cpoint, 0._r8) / & - (4._r8*co2_inter_c+8._r8*co2_cpoint) - - ! C3: Product-limited photosynthesis - ap = 3._r8 * tpu - - else - - ! C4: Rubisco-limited photosynthesis - ac = vcmax - - ! C4: RuBP-limited photosynthesis - if(sunsha == 1)then !sunlit - !guard against /0's in the night. - if((laisun_lsl * canopy_area_lsl) > 0.0000000001_r8) then - aj = quant_eff(c3c4_path_index) * parsun_lsl * 4.6_r8 - !convert from per cohort to per m2 of leaf) - aj = aj / (laisun_lsl * canopy_area_lsl) - else - aj = 0._r8 - end if - else - aj = quant_eff(c3c4_path_index) * parsha_lsl * 4.6_r8 - aj = aj / (laisha_lsl * canopy_area_lsl) - end if + qabs = parsha_lsl / (laisha_lsl * canopy_area_lsl) + qabs = qabs * 0.5_r8 * (1._r8 - fnps) * 4.6_r8 - ! C4: PEP carboxylase-limited (CO2-limited) - ap = co2_rcurve_islope * max(co2_inter_c, 0._r8) / can_press - - end if + end if - ! Gross photosynthesis smoothing calculations. First co-limit ac and aj. Then co-limit ap - aquad = theta_cj(c3c4_path_index) - bquad = -(ac + aj) - cquad = ac * aj - call quadratic_f (aquad, bquad, cquad, r1, r2) - ai = min(r1,r2) + !convert the absorbed par into absorbed par per m2 of leaf, + ! so it is consistant with the vcmax and lmr numbers. + aquad = theta_psii + bquad = -(qabs + jmax) + cquad = qabs * jmax + call quadratic_f (aquad, bquad, cquad, r1, r2) + je = min(r1,r2) - aquad = theta_ip - bquad = -(ai + ap) - cquad = ai * ap - call quadratic_f (aquad, bquad, cquad, r1, r2) - agross = min(r1,r2) + ! Initialize intercellular co2 + co2_inter_c = init_co2_inter_c - ! Net carbon assimilation. Exit iteration if an < 0 - anet = agross - lmr - if (anet < 0._r8) then - loop_continue = .false. - end if + niter = 0 + loop_continue = .true. + do while(loop_continue) + ! Increment iteration counter. Stop if too many iterations + niter = niter + 1 - ! Quadratic gs_mol calculation with an known. Valid for an >= 0. - ! With an <= 0, then gs_mol = stomatal_intercept_btran - leaf_co2_ppress = can_co2_ppress- h2o_co2_bl_diffuse_ratio/gb_mol * anet * can_press - leaf_co2_ppress = max(leaf_co2_ppress,1.e-06_r8) - if ( stomatal_model == 2 ) then - !stomatal conductance calculated from Medlyn et al. (2011), the numerical & - !implementation was adapted from the equations in CLM5.0 - vpd = max((veg_esat - ceair), 50._r8) * 0.001_r8 !addapted from CLM5. Put some constraint on VPD - !when Medlyn stomatal conductance is being used, the unit is KPa. Ignoring the constraint will cause errors when model runs. - term = h2o_co2_stoma_diffuse_ratio * anet / (leaf_co2_ppress / can_press) - aquad = 1.0_r8 - bquad = -(2.0 * (stomatal_intercept_btran+ term) + (medlyn_slope(ft) * term)**2 / & - (gb_mol * vpd )) - cquad = stomatal_intercept_btran*stomatal_intercept_btran + & - (2.0*stomatal_intercept_btran + term * & - (1.0 - medlyn_slope(ft)* medlyn_slope(ft) / vpd)) * term - - call quadratic_f (aquad, bquad, cquad, r1, r2) - gs_mol = max(r1,r2) - - else if ( stomatal_model == 1 ) then !stomatal conductance calculated from Ball et al. (1987) - aquad = leaf_co2_ppress - bquad = leaf_co2_ppress*(gb_mol - stomatal_intercept_btran) - bb_slope(ft) * anet * can_press - cquad = -gb_mol*(leaf_co2_ppress*stomatal_intercept_btran + & - bb_slope(ft)*anet*can_press * ceair/ veg_esat ) + ! Save old co2_inter_c + co2_inter_c_old = co2_inter_c + + ! Photosynthesis limitation rate calculations + if (c3c4_path_index == 1)then + + ! C3: Rubisco-limited photosynthesis + ac = vcmax * max(co2_inter_c-co2_cpoint, 0._r8) / & + (co2_inter_c+mm_kco2 * (1._r8+can_o2_ppress / mm_ko2 )) + + ! C3: RuBP-limited photosynthesis + aj = je * max(co2_inter_c-co2_cpoint, 0._r8) / & + (4._r8*co2_inter_c+8._r8*co2_cpoint) + + ! C3: Product-limited photosynthesis + ap = 3._r8 * tpu - call quadratic_f (aquad, bquad, cquad, r1, r2) - gs_mol = max(r1,r2) - end if - ! Derive new estimate for co2_inter_c - co2_inter_c = can_co2_ppress - anet * can_press * & - (h2o_co2_bl_diffuse_ratio*gs_mol+h2o_co2_stoma_diffuse_ratio*gb_mol) / (gb_mol*gs_mol) - - ! Check for co2_inter_c convergence. Delta co2_inter_c/pair = mol/mol. - ! Multiply by 10**6 to convert to umol/mol (ppm). Exit iteration if - ! convergence criteria of +/- 1 x 10**-6 ppm is met OR if at least ten - ! iterations (niter=10) are completed - - if ((abs(co2_inter_c-co2_inter_c_old)/can_press*1.e06_r8 <= 2.e-06_r8) & - .or. niter == 5) then - loop_continue = .false. - end if - end do !iteration loop - - ! End of co2_inter_c iteration. Check for an < 0, in which case - ! gs_mol =stomatal_intercept_btran - if (anet < 0._r8) then - gs_mol = stomatal_intercept_btran - end if - - ! Final estimates for leaf_co2_ppress and co2_inter_c - ! (needed for early exit of co2_inter_c iteration when an < 0) - leaf_co2_ppress = can_co2_ppress - h2o_co2_bl_diffuse_ratio/gb_mol * anet * can_press - leaf_co2_ppress = max(leaf_co2_ppress,1.e-06_r8) - co2_inter_c = can_co2_ppress - anet * can_press * & - (h2o_co2_bl_diffuse_ratio*gs_mol+h2o_co2_stoma_diffuse_ratio*gb_mol) / (gb_mol*gs_mol) - - ! Convert gs_mol (umol /m**2/s) to gs (m/s) and then to rs (s/m) - gs = gs_mol / cf - - ! estimate carbon 13 discrimination in leaf level carbon - ! flux Liang WEI and Hang ZHOU 2018, based on - ! Ubierna and Farquhar, 2014 doi:10.1111/pce.12346, using the simplified model: - ! $\Delta ^{13} C = \alpha_s + (b - \alpha_s) \cdot \frac{C_i}{C_a}$ - ! just hard code b and \alpha_s for now, might move to parameter set in future - ! b = 27.0 alpha_s = 4.4 - ! TODO, not considering C4 or CAM right now, may need to address this - ! note co2_inter_c is intracelluar CO2, not intercelluar - c13disc_z = 4.4_r8 + (27.0_r8 - 4.4_r8) * & - min (can_co2_ppress, max (co2_inter_c, 0._r8)) / can_co2_ppress - - ! Accumulate total photosynthesis umol/m2 ground/s-1. - ! weight per unit sun and sha leaves. - if(sunsha == 1)then !sunlit - psn_out = psn_out + agross * f_sun_lsl - anet_av_out = anet_av_out + anet * f_sun_lsl - gstoma = gstoma + 1._r8/(min(1._r8/gs, rsmax0)) * f_sun_lsl else - psn_out = psn_out + agross * (1.0_r8-f_sun_lsl) - anet_av_out = anet_av_out + anet * (1.0_r8-f_sun_lsl) - gstoma = gstoma + & - 1._r8/(min(1._r8/gs, rsmax0)) * (1.0_r8-f_sun_lsl) - end if - - ! Make sure iterative solution is correct - if (gs_mol < 0._r8) then - write (fates_log(),*)'Negative stomatal conductance:' - write (fates_log(),*)'gs_mol= ',gs_mol - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - ! Compare with Medlyn model: gs_mol = 1.6*(1+m/sqrt(vpd)) * an/leaf_co2_ppress*p + b - if ( stomatal_model == 2 ) then - gs_mol_err = h2o_co2_stoma_diffuse_ratio*(1 + medlyn_slope(ft)/sqrt(vpd))*max(anet,0._r8)/leaf_co2_ppress*can_press + stomatal_intercept_btran - ! Compare with Ball-Berry model: gs_mol = m * an * hs/leaf_co2_ppress*p + b - else if ( stomatal_model == 1 ) then - hs = (gb_mol*ceair + gs_mol* veg_esat ) / ((gb_mol+gs_mol)*veg_esat ) - gs_mol_err = bb_slope(ft)*max(anet, 0._r8)*hs/leaf_co2_ppress*can_press + stomatal_intercept_btran - end if - if (abs(gs_mol-gs_mol_err) > 1.e-01_r8) then - write (fates_log(),*) 'Stomatal model error check - stomatal conductance error:' - write (fates_log(),*) gs_mol, gs_mol_err - end if - - enddo !sunsha loop - - ! This is the stomatal resistance of the leaf layer - rstoma_out = 1._r8/gstoma - - else - - ! No leaf area. This layer is present only because of stems. - ! Net assimilation is zero, not negative because there are - ! no leaves to even respire - ! (leaves are off, or have reduced to 0) - - psn_out = 0._r8 - anet_av_out = 0._r8 - - rstoma_out = min(rsmax0,cf/(stem_cuticle_loss_frac*stomatal_intercept(ft))) - c13disc_z = 0.0_r8 - - end if !is there leaf area? - - - end if ! night or day - - - end associate - return - end subroutine LeafLayerPhotosynthesis - - ! ===================================================================================== - - subroutine ScaleLeafLayerFluxToCohort(nv, & ! in currentCohort%nv - psn_llz, & ! in %psn_z(1:currentCohort%nv,ft,cl) - lmr_llz, & ! in lmr_z(1:currentCohort%nv,ft,cl) - rs_llz, & ! in rs_z(1:currentCohort%nv,ft,cl) - elai_llz, & ! in %elai_profile(cl,ft,1:currentCohort%nv) - c13disc_llz, & ! in c13disc_z(cl, ft, 1:currentCohort%nv) - c_area, & ! in currentCohort%c_area - nplant, & ! in currentCohort%n - rb, & ! in bc_in(s)%rb_pa(ifp) - maintresp_reduction_factor, & ! in - g_sb_laweight, & ! out currentCohort%g_sb_laweight [m/s] [m2-leaf] - gpp, & ! out currentCohort%gpp_tstep - rdark, & ! out currentCohort%rdark - c13disc_clm, & ! out currentCohort%c13disc_clm - cohort_eleaf_area ) ! out [m2] - - ! ------------------------------------------------------------------------------------ - ! This subroutine effectively integrates leaf carbon fluxes over the - ! leaf layers to give cohort totals. - ! Some arguments have the suffix "_llz". This indicates that the vector - ! is stratefied in the leaf-layer (ll) dimension, and is a portion of the calling - ! array which has the "_z" tag, thus "llz". - ! ------------------------------------------------------------------------------------ - - use FatesConstantsMod, only : umolC_to_kgC - - ! Arguments - integer, intent(in) :: nv ! number of active leaf layers - real(r8), intent(in) :: psn_llz(nv) ! layer photosynthesis rate (GPP) [umolC/m2leaf/s] - real(r8), intent(in) :: lmr_llz(nv) ! layer dark respiration rate [umolC/m2leaf/s] - real(r8), intent(in) :: rs_llz(nv) ! leaf layer stomatal resistance [s/m] - real(r8), intent(in) :: elai_llz(nv) ! exposed LAI per layer [m2 leaf/ m2 pft footprint] - real(r8), intent(in) :: c13disc_llz(nv) ! leaf layer c13 discrimination, weighted mean - real(r8), intent(in) :: c_area ! crown area m2/m2 - real(r8), intent(in) :: nplant ! indiv/m2 - real(r8), intent(in) :: rb ! leaf boundary layer resistance (s/m) - real(r8), intent(in) :: maintresp_reduction_factor ! factor by which to reduce maintenance respiration - real(r8), intent(out) :: g_sb_laweight ! Combined conductance (stomatal + boundary layer) for the cohort - ! weighted by leaf area [m/s]*[m2] - real(r8), intent(out) :: gpp ! GPP (kgC/indiv/s) - real(r8), intent(out) :: rdark ! Dark Leaf Respiration (kgC/indiv/s) - real(r8), intent(out) :: cohort_eleaf_area ! Effective leaf area of the cohort [m2] - real(r8), intent(out) :: c13disc_clm ! unpacked Cohort level c13 discrimination - real(r8) :: sum_weight ! sum of weight for unpacking d13c flux (c13disc_z) from - ! (canopy_layer, pft, leaf_layer) matrix to cohort (c13disc_clm) - - ! GPP IN THIS SUBROUTINE IS A RATE. THE CALLING ARGUMENT IS GPP_TSTEP. AFTER THIS - ! CALL THE RATE WILL BE MULTIPLIED BY THE INTERVAL TO GIVE THE INTEGRATED QUANT. - - ! Locals - integer :: il ! leaf layer index - real(r8) :: cohort_layer_eleaf_area ! the effective leaf area of the cohort's current layer [m2] - - cohort_eleaf_area = 0.0_r8 - g_sb_laweight = 0.0_r8 - gpp = 0.0_r8 - rdark = 0.0_r8 - - do il = 1, nv ! Loop over the leaf layers this cohort participates in - - - ! Cohort's total effective leaf area in this layer [m2] - ! leaf area index of the layer [m2/m2 ground] * [m2 ground] - ! elai_llz is the LAI for the whole PFT. Multiplying this by the ground - ! area this cohort contributes, give the cohort's portion of the leaf - ! area in this layer - cohort_layer_eleaf_area = elai_llz(il) * c_area - - ! Increment the cohort's total effective leaf area [m2] - cohort_eleaf_area = cohort_eleaf_area + cohort_layer_eleaf_area - - ! Leaf conductance (stomatal and boundary layer) - ! This should be the weighted average over the leaf surfaces. - ! Since this is relevant to the stomata, its weighting should be based - ! on total leaf area, and not really footprint area - ! [m/s] * [m2 cohort's leaf layer] - g_sb_laweight = g_sb_laweight + 1.0_r8/(rs_llz(il)+rb) * cohort_layer_eleaf_area - - ! GPP [umolC/m2leaf/s] * [m2 leaf ] -> [umolC/s] (This is cohort group sum) - gpp = gpp + psn_llz(il) * cohort_layer_eleaf_area - - ! Dark respiration - ! [umolC/m2leaf/s] * [m2 leaf] (This is the cohort group sum) - rdark = rdark + lmr_llz(il) * cohort_layer_eleaf_area - - end do - - - - if (nv > 1) then - ! 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 + ! C4: Rubisco-limited photosynthesis + ac = vcmax + ! C4: RuBP-limited photosynthesis + if(sunsha == 1)then !sunlit + !guard against /0's in the night. + if((laisun_lsl * canopy_area_lsl) > 0.0000000001_r8) then + aj = quant_eff(c3c4_path_index) * parsun_lsl * 4.6_r8 + !convert from per cohort to per m2 of leaf) + aj = aj / (laisun_lsl * canopy_area_lsl) + else + aj = 0._r8 + end if + else + aj = quant_eff(c3c4_path_index) * parsha_lsl * 4.6_r8 + aj = aj / (laisha_lsl * canopy_area_lsl) + 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 - ! ----------------------------------------------------------------------------------- + ! C4: PEP carboxylase-limited (CO2-limited) + ap = co2_rcurve_islope * max(co2_inter_c, 0._r8) / can_press - ! ----------------------------------------------------------------------------------- - ! Convert dark respiration and GPP from [umol/s] to [kgC/plant/s] - ! Also, apply the maintenance respiration reduction factor - ! ----------------------------------------------------------------------------------- - - rdark = rdark * umolC_to_kgC * maintresp_reduction_factor / nplant - gpp = gpp * umolC_to_kgC / nplant - - if ( debug ) then - write(fates_log(),*) 'EDPhoto 816 ', gpp - write(fates_log(),*) 'EDPhoto 817 ', psn_llz(1:nv) - write(fates_log(),*) 'EDPhoto 820 ', nv - write(fates_log(),*) 'EDPhoto 821 ', elai_llz(1:nv) - write(fates_log(),*) 'EDPhoto 843 ', rdark - write(fates_log(),*) 'EDPhoto 873 ', nv - write(fates_log(),*) 'EDPhoto 874 ', cohort_eleaf_area - endif - - return - end subroutine ScaleLeafLayerFluxToCohort - - ! ===================================================================================== - - function ft1_f(tl, ha) result(ans) - ! - !!DESCRIPTION: - ! photosynthesis temperature response - ! - ! !REVISION HISTORY - ! Jinyun Tang separated it out from Photosynthesis, Feb. 07/2013 - ! 7/23/16: Copied over from CLM by Ryan Knox - ! - !!USES - use FatesConstantsMod, only : rgas => rgas_J_K_kmol - use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm - ! - ! !ARGUMENTS: - real(r8), intent(in) :: tl ! leaf temperature in photosynthesis temperature function (K) - real(r8), intent(in) :: ha ! activation energy in photosynthesis temperature function (J/mol) - ! - ! !LOCAL VARIABLES: - real(r8) :: ans - !------------------------------------------------------------------------------- + end if - ans = exp( ha / (rgas*1.e-3_r8*(tfrz+25._r8)) * (1._r8 - (tfrz+25._r8)/tl) ) + ! Gross photosynthesis smoothing calculations. First co-limit ac and aj. Then co-limit ap + aquad = theta_cj(c3c4_path_index) + bquad = -(ac + aj) + cquad = ac * aj + call quadratic_f (aquad, bquad, cquad, r1, r2) + ai = min(r1,r2) - return - end function ft1_f + aquad = theta_ip + bquad = -(ai + ap) + cquad = ai * ap + call quadratic_f (aquad, bquad, cquad, r1, r2) + agross = min(r1,r2) - ! ===================================================================================== - - function fth_f(tl,hd,se,scaleFactor) result(ans) - ! - !!DESCRIPTION: - !photosynthesis temperature inhibition - ! - ! !REVISION HISTORY - ! Jinyun Tang separated it out from Photosynthesis, Feb. 07/2013 - ! 7/23/16: Copied over from CLM by Ryan Knox - ! - use FatesConstantsMod, only : rgas => rgas_J_K_kmol - use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm + ! Net carbon assimilation. Exit iteration if an < 0 + anet = agross - lmr + if (anet < 0._r8) then + loop_continue = .false. + end if - ! - ! !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 - !------------------------------------------------------------------------------- + ! Quadratic gs_mol calculation with an known. Valid for an >= 0. + ! With an <= 0, then gs_mol = stomatal_intercept_btran + leaf_co2_ppress = can_co2_ppress- h2o_co2_bl_diffuse_ratio/gb_mol * anet * can_press + leaf_co2_ppress = max(leaf_co2_ppress,1.e-06_r8) + if ( stomatal_model == 2 ) then + !stomatal conductance calculated from Medlyn et al. (2011), the numerical & + !implementation was adapted from the equations in CLM5.0 + vpd = max((veg_esat - ceair), 50._r8) * 0.001_r8 !addapted from CLM5. Put some constraint on VPD + !when Medlyn stomatal conductance is being used, the unit is KPa. Ignoring the constraint will cause errors when model runs. + term = h2o_co2_stoma_diffuse_ratio * anet / (leaf_co2_ppress / can_press) + aquad = 1.0_r8 + bquad = -(2.0 * (stomatal_intercept_btran+ term) + (medlyn_slope(ft) * term)**2 / & + (gb_mol * vpd )) + cquad = stomatal_intercept_btran*stomatal_intercept_btran + & + (2.0*stomatal_intercept_btran + term * & + (1.0 - medlyn_slope(ft)* medlyn_slope(ft) / vpd)) * term - ans = scaleFactor / ( 1._r8 + exp( (-hd+se*tl) / (rgas*1.e-3_r8*tl) ) ) + call quadratic_f (aquad, bquad, cquad, r1, r2) + gs_mol = max(r1,r2) - return - end function fth_f + else if ( stomatal_model == 1 ) then !stomatal conductance calculated from Ball et al. (1987) + aquad = leaf_co2_ppress + bquad = leaf_co2_ppress*(gb_mol - stomatal_intercept_btran) - bb_slope(ft) * anet * can_press + cquad = -gb_mol*(leaf_co2_ppress*stomatal_intercept_btran + & + bb_slope(ft)*anet*can_press * ceair/ veg_esat ) - ! ===================================================================================== + call quadratic_f (aquad, bquad, cquad, r1, r2) + gs_mol = max(r1,r2) + end if + ! Derive new estimate for co2_inter_c + co2_inter_c = can_co2_ppress - anet * can_press * & + (h2o_co2_bl_diffuse_ratio*gs_mol+h2o_co2_stoma_diffuse_ratio*gb_mol) / (gb_mol*gs_mol) - 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 + ! Check for co2_inter_c convergence. Delta co2_inter_c/pair = mol/mol. + ! Multiply by 10**6 to convert to umol/mol (ppm). Exit iteration if + ! convergence criteria of +/- 1 x 10**-6 ppm is met OR if at least ten + ! iterations (niter=10) are completed + + if ((abs(co2_inter_c-co2_inter_c_old)/can_press*1.e06_r8 <= 2.e-06_r8) & + .or. niter == 5) then + loop_continue = .false. + end if + end do !iteration loop + + ! End of co2_inter_c iteration. Check for an < 0, in which case + ! gs_mol =stomatal_intercept_btran + if (anet < 0._r8) then + gs_mol = stomatal_intercept_btran + end if + + ! Final estimates for leaf_co2_ppress and co2_inter_c + ! (needed for early exit of co2_inter_c iteration when an < 0) + leaf_co2_ppress = can_co2_ppress - h2o_co2_bl_diffuse_ratio/gb_mol * anet * can_press + leaf_co2_ppress = max(leaf_co2_ppress,1.e-06_r8) + co2_inter_c = can_co2_ppress - anet * can_press * & + (h2o_co2_bl_diffuse_ratio*gs_mol+h2o_co2_stoma_diffuse_ratio*gb_mol) / (gb_mol*gs_mol) + + ! Convert gs_mol (umol /m**2/s) to gs (m/s) and then to rs (s/m) + gs = gs_mol / cf + + ! estimate carbon 13 discrimination in leaf level carbon + ! flux Liang WEI and Hang ZHOU 2018, based on + ! Ubierna and Farquhar, 2014 doi:10.1111/pce.12346, using the simplified model: + ! $\Delta ^{13} C = \alpha_s + (b - \alpha_s) \cdot \frac{C_i}{C_a}$ + ! just hard code b and \alpha_s for now, might move to parameter set in future + ! b = 27.0 alpha_s = 4.4 + ! TODO, not considering C4 or CAM right now, may need to address this + ! note co2_inter_c is intracelluar CO2, not intercelluar + c13disc_z = 4.4_r8 + (27.0_r8 - 4.4_r8) * & + min (can_co2_ppress, max (co2_inter_c, 0._r8)) / can_co2_ppress + + ! Accumulate total photosynthesis umol/m2 ground/s-1. + ! weight per unit sun and sha leaves. + if(sunsha == 1)then !sunlit + psn_out = psn_out + agross * f_sun_lsl + anet_av_out = anet_av_out + anet * f_sun_lsl + gstoma = gstoma + 1._r8/(min(1._r8/gs, rsmax0)) * f_sun_lsl + else + psn_out = psn_out + agross * (1.0_r8-f_sun_lsl) + anet_av_out = anet_av_out + anet * (1.0_r8-f_sun_lsl) + gstoma = gstoma + & + 1._r8/(min(1._r8/gs, rsmax0)) * (1.0_r8-f_sun_lsl) + end if + + ! Make sure iterative solution is correct + if (gs_mol < 0._r8) then + write (fates_log(),*)'Negative stomatal conductance:' + write (fates_log(),*)'gs_mol= ',gs_mol + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + ! Compare with Medlyn model: gs_mol = 1.6*(1+m/sqrt(vpd)) * an/leaf_co2_ppress*p + b + if ( stomatal_model == 2 ) then + gs_mol_err = h2o_co2_stoma_diffuse_ratio*(1 + medlyn_slope(ft)/sqrt(vpd))*max(anet,0._r8)/leaf_co2_ppress*can_press + stomatal_intercept_btran + ! Compare with Ball-Berry model: gs_mol = m * an * hs/leaf_co2_ppress*p + b + else if ( stomatal_model == 1 ) then + hs = (gb_mol*ceair + gs_mol* veg_esat ) / ((gb_mol+gs_mol)*veg_esat ) + gs_mol_err = bb_slope(ft)*max(anet, 0._r8)*hs/leaf_co2_ppress*can_press + stomatal_intercept_btran + end if + + if (abs(gs_mol-gs_mol_err) > 1.e-01_r8) then + write (fates_log(),*) 'Stomatal model error check - stomatal conductance error:' + write (fates_log(),*) gs_mol, gs_mol_err + end if + + enddo !sunsha loop + + ! This is the stomatal resistance of the leaf layer + rstoma_out = 1._r8/gstoma - use FatesConstantsMod, only : rgas => rgas_J_K_kmol - use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm - - ! - ! !ARGUMENTS: - real(r8), intent(in) :: hd ! deactivation energy in photosynthesis temp function (J/mol) - real(r8), intent(in) :: se ! entropy term in photosynthesis temp function (J/mol/K) - ! - ! !LOCAL VARIABLES: - real(r8) :: ans - !------------------------------------------------------------------------------- - - ans = 1._r8 + exp( (-hd+se*(tfrz+25._r8)) / (rgas*1.e-3_r8*(tfrz+25._r8)) ) - - return - end function fth25_f - - ! ===================================================================================== - - subroutine quadratic_f (a, b, c, r1, r2) - ! - ! !DESCRIPTION: - !==============================================================================! - !----------------- Solve quadratic equation for its two roots -----------------! - !==============================================================================! - ! Solution from Press et al (1986) Numerical Recipes: The Art of Scientific - ! Computing (Cambridge University Press, Cambridge), pp. 145. - ! - ! !REVISION HISTORY: - ! 4/5/10: Adapted from /home/bonan/ecm/psn/An_gs_iterative.f90 by Keith Oleson - ! 7/23/16: Copied over from CLM by Ryan Knox - ! - ! !USES: - ! - ! !ARGUMENTS: - real(r8), intent(in) :: a,b,c ! Terms for quadratic equation - real(r8), intent(out) :: r1,r2 ! Roots of quadratic equation - ! - ! !LOCAL VARIABLES: - real(r8) :: q ! Temporary term for quadratic solution - !------------------------------------------------------------------------------ - - if (a == 0._r8) then - write (fates_log(),*) 'Quadratic solution error: a = ',a - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - if (b >= 0._r8) then - q = -0.5_r8 * (b + sqrt(b*b - 4._r8*a*c)) - else - q = -0.5_r8 * (b - sqrt(b*b - 4._r8*a*c)) - end if - - r1 = q / a - if (q /= 0._r8) then - r2 = c / q - else - r2 = 1.e36_r8 - end if - - end subroutine quadratic_f - - ! ==================================================================================== - - subroutine quadratic_fast (a, b, c, r1, r2) - ! - ! !DESCRIPTION: - !==============================================================================! - !----------------- Solve quadratic equation for its two roots -----------------! - ! THIS METHOD SIMPLY REMOVES THE DIV0 CHECK AND ERROR REPORTING ! - !==============================================================================! - ! Solution from Press et al (1986) Numerical Recipes: The Art of Scientific - ! Computing (Cambridge University Press, Cambridge), pp. 145. - ! - ! !REVISION HISTORY: - ! 4/5/10: Adapted from /home/bonan/ecm/psn/An_gs_iterative.f90 by Keith Oleson - ! 7/23/16: Copied over from CLM by Ryan Knox - ! - ! !USES: - ! - ! !ARGUMENTS: - real(r8), intent(in) :: a,b,c ! Terms for quadratic equation - real(r8), intent(out) :: r1,r2 ! Roots of quadratic equation - ! - ! !LOCAL VARIABLES: - real(r8) :: q ! Temporary term for quadratic solution - !------------------------------------------------------------------------------ - - ! 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). - ! --------------------------------------------------------------------------------- - - - use EDTypesMod , only : ed_patch_type - use EDTypesMod , only : ed_cohort_type - - ! Arguments - type(ed_patch_type), target :: currentPatch - type(ed_cohort_type), pointer :: currentCohort - - ! Locals - integer :: cl ! Canopy Layer Index - integer :: ft ! Function Type Index - integer :: iv ! index of the exposed leaf layer for each canopy layer and pft - - ! Loop through the cohorts in this patch, associate each cohort with a layer and PFT - ! and use the cohort's memory of how many layer's it takes up to assign the maximum - ! of the layer/pft index it is in - ! --------------------------------------------------------------------------------- - - currentPatch%ncan(:,:) = 0 - ! redo the canopy structure algorithm to get round a - ! bug that is happening for site 125, FT13. - currentCohort => currentPatch%tallest - do while(associated(currentCohort)) - - currentPatch%ncan(currentCohort%canopy_layer,currentCohort%pft) = & - max(currentPatch%ncan(currentCohort%canopy_layer,currentCohort%pft), & - currentCohort%NV) - - currentCohort => currentCohort%shorter - - enddo !cohort - - ! NRAD = NCAN ... - currentPatch%nrad = currentPatch%ncan - - ! Now loop through and identify which layer and pft combo has scattering elements - do cl = 1,nclmax - do ft = 1,numpft - currentPatch%canopy_mask(cl,ft) = 0 - do iv = 1, currentPatch%nrad(cl,ft); - if(currentPatch%canopy_area_profile(cl,ft,iv) > 0._r8)then - currentPatch%canopy_mask(cl,ft) = 1 - end if - end do !iv - enddo !ft - enddo !cl - - return - end subroutine UpdateCanopyNCanNRadPresent - - ! ==================================================================================== - - subroutine GetCanopyGasParameters(can_press, & - can_o2_partialpress, & - veg_tempk, & - air_tempk, & - air_vpress, & - veg_esat, & - rb, & - mm_kco2, & - mm_ko2, & - co2_cpoint, & - cf, & - gb_mol, & - ceair) - - ! --------------------------------------------------------------------------------- - ! This subroutine calculates the specific Michaelis Menten Parameters (pa) for CO2 - ! and O2, as well as the CO2 compentation point. - ! --------------------------------------------------------------------------------- - - use FatesConstantsMod, only: umol_per_mol - use FatesConstantsMod, only: mmol_per_mol - use FatesConstantsMod, only: umol_per_kmol - use FatesConstantsMod, only : rgas => rgas_J_K_kmol - - ! Arguments - real(r8), intent(in) :: can_press ! Air pressure within the canopy (Pa) - real(r8), intent(in) :: can_o2_partialpress ! Partial press of o2 in the canopy (Pa) - real(r8), intent(in) :: veg_tempk ! The temperature of the vegetation (K) - real(r8), intent(in) :: air_tempk ! Temperature of canopy air (K) - real(r8), intent(in) :: air_vpress ! Vapor pressure of canopy air (Pa) - real(r8), intent(in) :: veg_esat ! Saturated vapor pressure at veg surf (Pa) - real(r8), intent(in) :: rb ! Leaf Boundary layer resistance (s/m) - - real(r8), intent(out) :: mm_kco2 ! Michaelis-Menten constant for CO2 (Pa) - real(r8), intent(out) :: mm_ko2 ! Michaelis-Menten constant for O2 (Pa) - real(r8), intent(out) :: co2_cpoint ! CO2 compensation point (Pa) - real(r8), intent(out) :: cf ! conversion factor between molar form and velocity form - ! of conductance and resistance: [umol/m3] - real(r8), intent(out) :: gb_mol ! leaf boundary layer conductance (umol H2O/m**2/s) - real(r8), intent(out) :: ceair ! vapor pressure of air, constrained (Pa) - - ! Locals - real(r8) :: kc25 ! Michaelis-Menten constant for CO2 at 25C (Pa) - real(r8) :: ko25 ! Michaelis-Menten constant for O2 at 25C (Pa) - real(r8) :: sco ! relative specificity of rubisco - real(r8) :: cp25 ! CO2 compensation point at 25C (Pa) - - ! --------------------------------------------------------------------------------- - ! Intensive values (per mol of air) - ! kc, ko, currentPatch, from: Bernacchi et al (2001) - ! Plant, Cell and Environment 24:253-259 - ! --------------------------------------------------------------------------------- - - real(r8), parameter :: mm_kc25_umol_per_mol = 404.9_r8 - real(r8), parameter :: mm_ko25_mmol_per_mol = 278.4_r8 - real(r8), parameter :: co2_cpoint_umol_per_mol = 42.75_r8 - - ! Activation energy, from: - ! Bernacchi et al (2001) Plant, Cell and Environment 24:253-259 - ! Bernacchi et al (2003) Plant, Cell and Environment 26:1419-1430 - ! except TPU from: Harley et al (1992) Plant, Cell and Environment 15:271-282 - - real(r8), parameter :: kcha = 79430._r8 ! activation energy for kc (J/mol) - real(r8), parameter :: koha = 36380._r8 ! activation energy for ko (J/mol) - real(r8), parameter :: cpha = 37830._r8 ! activation energy for cp (J/mol) - - - ! Derive sco from currentPatch and O2 using present-day O2 (0.209 mol/mol) and re-calculate - ! currentPatch to account for variation in O2 using currentPatch = 0.5 O2 / sco - - ! FIXME (RGK 11-30-2016 THere are more constants here, but I don't have enough information - ! about what they are or do, so I can't give them more descriptive names. Someone please - ! fill this in when possible) - - kc25 = ( mm_kc25_umol_per_mol / umol_per_mol ) * can_press - ko25 = ( mm_ko25_mmol_per_mol / mmol_per_mol ) * can_press - sco = 0.5_r8 * 0.209_r8 / (co2_cpoint_umol_per_mol / umol_per_mol ) - cp25 = 0.5_r8 * can_o2_partialpress / sco - - if( veg_tempk.gt.150_r8 .and. veg_tempk.lt.350_r8 )then - mm_kco2 = kc25 * ft1_f(veg_tempk, kcha) - mm_ko2 = ko25 * ft1_f(veg_tempk, koha) - co2_cpoint = cp25 * ft1_f(veg_tempk, cpha) - else - mm_kco2 = 1.0_r8 - mm_ko2 = 1.0_r8 - co2_cpoint = 1.0_r8 - end if - - ! --------------------------------------------------------------------------------- - ! - ! cf is the conversion factor between molar form and velocity form - ! of conductance and resistance: [umol/m3] - ! - ! i.e. - ! [m/s] * [umol/m3] -> [umol/m2/s] - ! - ! Breakdown of the conversion factor: [ umol / m3 ] - ! - ! Rgas [J /K /kmol] - ! Air Potential Temperature [ K ] - ! Canopy Pressure [ Pa ] - ! conversion: umol/kmol = 1e9 - ! - ! [ Pa * K * kmol umol/kmol / J K ] = [ Pa * umol / J ] - ! since: 1 Pa = 1 N / m2 - ! [ Pa * umol / J ] = [ N * umol / J m2 ] - ! since: 1 J = 1 N * m - ! [ N * umol / J m2 ] = [ N * umol / N m3 ] - ! [ umol / m3 ] - ! - ! -------------------------------------------------------------------------------- - - cf = can_press/(rgas * air_tempk )*umol_per_kmol - gb_mol = (1._r8/ rb) * cf - - ! Constrain eair >= 0.05*esat_tv so that solution does not blow up. This ensures - ! that hs does not go to zero. Also eair <= veg_esat so that hs <= 1 - ceair = min( max(air_vpress, 0.05_r8*veg_esat ),veg_esat ) - - - - return - end subroutine GetCanopyGasParameters - - ! ==================================================================================== - - subroutine LeafLayerMaintenanceRespiration(lmr25top_ft, & - nscaler, & - ft, & - veg_tempk, & - lmr) - - use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm - use EDPftvarcon , only : EDPftvarcon_inst - - ! Arguments - real(r8), intent(in) :: lmr25top_ft ! canopy top leaf maint resp rate at 25C - ! for this pft (umol CO2/m**2/s) - integer, intent(in) :: ft ! (plant) Functional Type Index - real(r8), intent(in) :: nscaler ! Scale for leaf nitrogen profile - real(r8), intent(in) :: veg_tempk ! vegetation temperature - real(r8), intent(out) :: lmr ! Leaf Maintenance Respiration (umol CO2/m**2/s) - - ! Locals - real(r8) :: lmr25 ! leaf layer: leaf maintenance respiration rate at 25C (umol CO2/m**2/s) - - ! Parameter - real(r8), parameter :: lmrha = 46390._r8 ! activation energy for lmr (J/mol) - real(r8), parameter :: lmrhd = 150650._r8 ! deactivation energy for lmr (J/mol) - real(r8), parameter :: lmrse = 490._r8 ! entropy term for lmr (J/mol/K) - real(r8), parameter :: lmrc = 1.15912391_r8 ! scaling factor for high - ! temperature inhibition (25 C = 1.0) - - - - - - ! Part I: Leaf Maintenance respiration: umol CO2 / m**2 [leaf] / s - ! ---------------------------------------------------------------------------------- - lmr25 = lmr25top_ft * nscaler - - if ( nint(EDpftvarcon_inst%c3psn(ft)) == 1)then - lmr = lmr25 * ft1_f(veg_tempk, lmrha) * & - fth_f(veg_tempk, lmrhd, lmrse, lmrc) - else - lmr = lmr25 * 2._r8**((veg_tempk-(tfrz+25._r8))/10._r8) - lmr = lmr / (1._r8 + exp( 1.3_r8*(veg_tempk-(tfrz+55._r8)) )) - end if - - ! Any hydrodynamic limitations could go here, currently none - ! lmr = lmr * (nothing) - - end subroutine LeafLayerMaintenanceRespiration - - ! ==================================================================================== - - subroutine LeafLayerBiophysicalRates( parsun_lsl, & - ft, & - vcmax25top_ft, & - jmax25top_ft, & - tpu25top_ft, & - co2_rcurve_islope25top_ft, & - nscaler, & - veg_tempk, & - btran, & - vcmax, & - jmax, & - tpu, & - 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, - ! tpu: triose phosphate utilization rate and - ! co2_rcurve_islope: initial slope of CO2 response curve (C4 plants) - ! --------------------------------------------------------------------------------- - - use EDPftvarcon , only : EDPftvarcon_inst - use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm - - ! Arguments - ! ------------------------------------------------------------------------------ - - real(r8), intent(in) :: parsun_lsl ! PAR absorbed in sunlit leaves for this layer - integer, intent(in) :: ft ! (plant) Functional Type Index - real(r8), intent(in) :: nscaler ! Scale for leaf nitrogen profile - real(r8), intent(in) :: vcmax25top_ft ! canopy top maximum rate of carboxylation at 25C - ! for this pft (umol CO2/m**2/s) - real(r8), intent(in) :: jmax25top_ft ! canopy top maximum electron transport rate at 25C - ! for this pft (umol electrons/m**2/s) - real(r8), intent(in) :: tpu25top_ft ! canopy top triose phosphate utilization rate at 25C - ! for this pft (umol CO2/m**2/s) - real(r8), intent(in) :: co2_rcurve_islope25top_ft ! initial slope of CO2 response curve - ! (C4 plants) at 25C, canopy top, this pft - real(r8), intent(in) :: veg_tempk ! vegetation temperature - real(r8), intent(in) :: btran ! transpiration wetness factor (0 to 1) - - real(r8), intent(out) :: vcmax ! maximum rate of carboxylation (umol co2/m**2/s) - real(r8), intent(out) :: jmax ! maximum electron transport rate - ! (umol electrons/m**2/s) - real(r8), intent(out) :: tpu ! triose phosphate utilization rate - ! (umol CO2/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) :: tpu25 ! leaf layer: triose phosphate utilization rate at 25C - ! (umol CO2/m**2/s) - real(r8) :: co2_rcurve_islope25 ! leaf layer: Initial slope of CO2 response curve - ! (C4 plants) at 25C - - - ! Parameters - ! --------------------------------------------------------------------------------- - real(r8) :: vcmaxha ! activation energy for vcmax (J/mol) - real(r8) :: jmaxha ! activation energy for jmax (J/mol) - real(r8) :: tpuha ! activation energy for tpu (J/mol) - real(r8) :: vcmaxhd ! deactivation energy for vcmax (J/mol) - real(r8) :: jmaxhd ! deactivation energy for jmax (J/mol) - real(r8) :: tpuhd ! deactivation energy for tpu (J/mol) - real(r8) :: vcmaxse ! entropy term for vcmax (J/mol/K) - real(r8) :: jmaxse ! entropy term for jmax (J/mol/K) - real(r8) :: tpuse ! entropy term for tpu (J/mol/K) - real(r8) :: vcmaxc ! scaling factor for high temperature inhibition (25 C = 1.0) - real(r8) :: jmaxc ! scaling factor for high temperature inhibition (25 C = 1.0) - real(r8) :: tpuc ! scaling factor for high temperature inhibition (25 C = 1.0) - - vcmaxha = EDPftvarcon_inst%vcmaxha(FT) - jmaxha = EDPftvarcon_inst%jmaxha(FT) - tpuha = EDPftvarcon_inst%tpuha(FT) - - vcmaxhd = EDPftvarcon_inst%vcmaxhd(FT) - jmaxhd = EDPftvarcon_inst%jmaxhd(FT) - tpuhd = EDPftvarcon_inst%tpuhd(FT) - - vcmaxse = EDPftvarcon_inst%vcmaxse(FT) - jmaxse = EDPftvarcon_inst%jmaxse(FT) - tpuse = EDPftvarcon_inst%tpuse(FT) - - vcmaxc = fth25_f(vcmaxhd, vcmaxse) - jmaxc = fth25_f(jmaxhd, jmaxse) - tpuc = fth25_f(tpuhd, tpuse) - - if ( parsun_lsl <= 0._r8) then ! night time - vcmax = 0._r8 - jmax = 0._r8 - tpu = 0._r8 - co2_rcurve_islope = 0._r8 - else ! day time - - ! Vcmax25top was already calculated to derive the nscaler function - vcmax25 = vcmax25top_ft * nscaler - jmax25 = jmax25top_ft * nscaler - tpu25 = tpu25top_ft * nscaler - co2_rcurve_islope25 = co2_rcurve_islope25top_ft * nscaler - - ! Adjust for temperature - vcmax = vcmax25 * ft1_f(veg_tempk, vcmaxha) * fth_f(veg_tempk, vcmaxhd, vcmaxse, vcmaxc) - jmax = jmax25 * ft1_f(veg_tempk, jmaxha) * fth_f(veg_tempk, jmaxhd, jmaxse, jmaxc) - tpu = tpu25 * ft1_f(veg_tempk, tpuha) * fth_f(veg_tempk, tpuhd, tpuse, tpuc) - - if (nint(EDPftvarcon_inst%c3psn(ft)) /= 1) then - vcmax = vcmax25 * 2._r8**((veg_tempk-(tfrz+25._r8))/10._r8) - vcmax = vcmax / (1._r8 + exp( 0.2_r8*((tfrz+15._r8)-veg_tempk ) )) - vcmax = vcmax / (1._r8 + exp( 0.3_r8*(veg_tempk-(tfrz+40._r8)) )) + + ! No leaf area. This layer is present only because of stems. + ! Net assimilation is zero, not negative because there are + ! no leaves to even respire + ! (leaves are off, or have reduced to 0) + + psn_out = 0._r8 + anet_av_out = 0._r8 + + rstoma_out = min(rsmax0,cf/(stem_cuticle_loss_frac*stomatal_intercept(ft))) + c13disc_z = 0.0_r8 + + end if !is there leaf area? + + + end if ! night or day + + +end associate +return +end subroutine LeafLayerPhotosynthesis + +! ===================================================================================== + +subroutine ScaleLeafLayerFluxToCohort(nv, & ! in currentCohort%nv + psn_llz, & ! in %psn_z(1:currentCohort%nv,ft,cl) + lmr_llz, & ! in lmr_z(1:currentCohort%nv,ft,cl) + rs_llz, & ! in rs_z(1:currentCohort%nv,ft,cl) + elai_llz, & ! in %elai_profile(cl,ft,1:currentCohort%nv) + c13disc_llz, & ! in c13disc_z(cl, ft, 1:currentCohort%nv) + c_area, & ! in currentCohort%c_area + nplant, & ! in currentCohort%n + rb, & ! in bc_in(s)%rb_pa(ifp) + maintresp_reduction_factor, & ! in + g_sb_laweight, & ! out currentCohort%g_sb_laweight [m/s] [m2-leaf] + gpp, & ! out currentCohort%gpp_tstep + rdark, & ! out currentCohort%rdark + c13disc_clm, & ! out currentCohort%c13disc_clm + cohort_eleaf_area ) ! out [m2] + + ! ------------------------------------------------------------------------------------ + ! This subroutine effectively integrates leaf carbon fluxes over the + ! leaf layers to give cohort totals. + ! Some arguments have the suffix "_llz". This indicates that the vector + ! is stratefied in the leaf-layer (ll) dimension, and is a portion of the calling + ! array which has the "_z" tag, thus "llz". + ! ------------------------------------------------------------------------------------ + +use FatesConstantsMod, only : umolC_to_kgC + +! Arguments +integer, intent(in) :: nv ! number of active leaf layers +real(r8), intent(in) :: psn_llz(nv) ! layer photosynthesis rate (GPP) [umolC/m2leaf/s] +real(r8), intent(in) :: lmr_llz(nv) ! layer dark respiration rate [umolC/m2leaf/s] +real(r8), intent(in) :: rs_llz(nv) ! leaf layer stomatal resistance [s/m] +real(r8), intent(in) :: elai_llz(nv) ! exposed LAI per layer [m2 leaf/ m2 pft footprint] +real(r8), intent(in) :: c13disc_llz(nv) ! leaf layer c13 discrimination, weighted mean +real(r8), intent(in) :: c_area ! crown area m2/m2 +real(r8), intent(in) :: nplant ! indiv/m2 +real(r8), intent(in) :: rb ! leaf boundary layer resistance (s/m) +real(r8), intent(in) :: maintresp_reduction_factor ! factor by which to reduce maintenance respiration +real(r8), intent(out) :: g_sb_laweight ! Combined conductance (stomatal + boundary layer) for the cohort +! weighted by leaf area [m/s]*[m2] +real(r8), intent(out) :: gpp ! GPP (kgC/indiv/s) +real(r8), intent(out) :: rdark ! Dark Leaf Respiration (kgC/indiv/s) +real(r8), intent(out) :: cohort_eleaf_area ! Effective leaf area of the cohort [m2] +real(r8), intent(out) :: c13disc_clm ! unpacked Cohort level c13 discrimination +real(r8) :: sum_weight ! sum of weight for unpacking d13c flux (c13disc_z) from +! (canopy_layer, pft, leaf_layer) matrix to cohort (c13disc_clm) + +! GPP IN THIS SUBROUTINE IS A RATE. THE CALLING ARGUMENT IS GPP_TSTEP. AFTER THIS +! CALL THE RATE WILL BE MULTIPLIED BY THE INTERVAL TO GIVE THE INTEGRATED QUANT. + +! Locals +integer :: il ! leaf layer index +real(r8) :: cohort_layer_eleaf_area ! the effective leaf area of the cohort's current layer [m2] + +cohort_eleaf_area = 0.0_r8 +g_sb_laweight = 0.0_r8 +gpp = 0.0_r8 +rdark = 0.0_r8 + +do il = 1, nv ! Loop over the leaf layers this cohort participates in + + + ! Cohort's total effective leaf area in this layer [m2] + ! leaf area index of the layer [m2/m2 ground] * [m2 ground] + ! elai_llz is the LAI for the whole PFT. Multiplying this by the ground + ! area this cohort contributes, give the cohort's portion of the leaf + ! area in this layer + cohort_layer_eleaf_area = elai_llz(il) * c_area + + ! Increment the cohort's total effective leaf area [m2] + cohort_eleaf_area = cohort_eleaf_area + cohort_layer_eleaf_area + + ! Leaf conductance (stomatal and boundary layer) + ! This should be the weighted average over the leaf surfaces. + ! Since this is relevant to the stomata, its weighting should be based + ! on total leaf area, and not really footprint area + ! [m/s] * [m2 cohort's leaf layer] + g_sb_laweight = g_sb_laweight + 1.0_r8/(rs_llz(il)+rb) * cohort_layer_eleaf_area + + ! GPP [umolC/m2leaf/s] * [m2 leaf ] -> [umolC/s] (This is cohort group sum) + gpp = gpp + psn_llz(il) * cohort_layer_eleaf_area + + ! Dark respiration + ! [umolC/m2leaf/s] * [m2 leaf] (This is the cohort group sum) + rdark = rdark + lmr_llz(il) * cohort_layer_eleaf_area + +end do + + + +if (nv > 1) then + ! 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 + +return +end subroutine ScaleLeafLayerFluxToCohort + +! ===================================================================================== + +function ft1_f(tl, ha) result(ans) + ! + !!DESCRIPTION: + ! photosynthesis temperature response + ! + ! !REVISION HISTORY + ! Jinyun Tang separated it out from Photosynthesis, Feb. 07/2013 + ! 7/23/16: Copied over from CLM by Ryan Knox + ! + !!USES +use FatesConstantsMod, only : rgas => rgas_J_K_kmol +use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm +! +! !ARGUMENTS: +real(r8), intent(in) :: tl ! leaf temperature in photosynthesis temperature function (K) +real(r8), intent(in) :: ha ! activation energy in photosynthesis temperature function (J/mol) +! +! !LOCAL VARIABLES: +real(r8) :: ans +!------------------------------------------------------------------------------- + +ans = exp( ha / (rgas*1.e-3_r8*(tfrz+25._r8)) * (1._r8 - (tfrz+25._r8)/tl) ) + +return +end function ft1_f + +! ===================================================================================== + +function fth_f(tl,hd,se,scaleFactor) result(ans) + ! + !!DESCRIPTION: + !photosynthesis temperature inhibition + ! + ! !REVISION HISTORY + ! Jinyun Tang separated it out from Photosynthesis, Feb. 07/2013 + ! 7/23/16: Copied over from CLM by Ryan Knox + ! +use FatesConstantsMod, only : rgas => rgas_J_K_kmol +use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm + +! +! !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) ) ) + +return +end function fth_f + +! ===================================================================================== + +function fth25_f(hd,se)result(ans) + ! + !!DESCRIPTION: + ! scaling factor for photosynthesis temperature inhibition + ! + ! !REVISION HISTORY: + ! Jinyun Tang separated it out from Photosynthesis, Feb. 07/2013 + ! 7/23/16: Copied over from CLM by Ryan Knox + ! + !!USES + +use FatesConstantsMod, only : rgas => rgas_J_K_kmol +use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm + +! +! !ARGUMENTS: +real(r8), intent(in) :: hd ! deactivation energy in photosynthesis temp function (J/mol) +real(r8), intent(in) :: se ! entropy term in photosynthesis temp function (J/mol/K) +! +! !LOCAL VARIABLES: +real(r8) :: ans +!------------------------------------------------------------------------------- + +ans = 1._r8 + exp( (-hd+se*(tfrz+25._r8)) / (rgas*1.e-3_r8*(tfrz+25._r8)) ) + +return +end function fth25_f + +! ===================================================================================== + +subroutine quadratic_f (a, b, c, r1, r2) + ! + ! !DESCRIPTION: + !==============================================================================! + !----------------- Solve quadratic equation for its two roots -----------------! + !==============================================================================! + ! Solution from Press et al (1986) Numerical Recipes: The Art of Scientific + ! Computing (Cambridge University Press, Cambridge), pp. 145. + ! + ! !REVISION HISTORY: + ! 4/5/10: Adapted from /home/bonan/ecm/psn/An_gs_iterative.f90 by Keith Oleson + ! 7/23/16: Copied over from CLM by Ryan Knox + ! + ! !USES: + ! + ! !ARGUMENTS: +real(r8), intent(in) :: a,b,c ! Terms for quadratic equation +real(r8), intent(out) :: r1,r2 ! Roots of quadratic equation +! +! !LOCAL VARIABLES: +real(r8) :: q ! Temporary term for quadratic solution +!------------------------------------------------------------------------------ + +if (a == 0._r8) then + write (fates_log(),*) 'Quadratic solution error: a = ',a + call endrun(msg=errMsg(sourcefile, __LINE__)) +end if + +if (b >= 0._r8) then + q = -0.5_r8 * (b + sqrt(b*b - 4._r8*a*c)) +else + q = -0.5_r8 * (b - sqrt(b*b - 4._r8*a*c)) +end if + +r1 = q / a +if (q /= 0._r8) then + r2 = c / q +else + r2 = 1.e36_r8 +end if + +end subroutine quadratic_f + +! ==================================================================================== + +subroutine quadratic_fast (a, b, c, r1, r2) + ! + ! !DESCRIPTION: + !==============================================================================! + !----------------- Solve quadratic equation for its two roots -----------------! + ! THIS METHOD SIMPLY REMOVES THE DIV0 CHECK AND ERROR REPORTING ! + !==============================================================================! + ! Solution from Press et al (1986) Numerical Recipes: The Art of Scientific + ! Computing (Cambridge University Press, Cambridge), pp. 145. + ! + ! !REVISION HISTORY: + ! 4/5/10: Adapted from /home/bonan/ecm/psn/An_gs_iterative.f90 by Keith Oleson + ! 7/23/16: Copied over from CLM by Ryan Knox + ! + ! !USES: + ! + ! !ARGUMENTS: +real(r8), intent(in) :: a,b,c ! Terms for quadratic equation +real(r8), intent(out) :: r1,r2 ! Roots of quadratic equation +! +! !LOCAL VARIABLES: +real(r8) :: q ! Temporary term for quadratic solution +!------------------------------------------------------------------------------ + +! 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). + ! --------------------------------------------------------------------------------- + + +use EDTypesMod , only : ed_patch_type +use EDTypesMod , only : ed_cohort_type + +! Arguments +type(ed_patch_type), target :: currentPatch +type(ed_cohort_type), pointer :: currentCohort + +! Locals +integer :: cl ! Canopy Layer Index +integer :: ft ! Function Type Index +integer :: iv ! index of the exposed leaf layer for each canopy layer and pft + +! Loop through the cohorts in this patch, associate each cohort with a layer and PFT +! and use the cohort's memory of how many layer's it takes up to assign the maximum +! of the layer/pft index it is in +! --------------------------------------------------------------------------------- + +currentPatch%ncan(:,:) = 0 +! redo the canopy structure algorithm to get round a +! bug that is happening for site 125, FT13. +currentCohort => currentPatch%tallest +do while(associated(currentCohort)) + + currentPatch%ncan(currentCohort%canopy_layer,currentCohort%pft) = & + max(currentPatch%ncan(currentCohort%canopy_layer,currentCohort%pft), & + currentCohort%NV) + + currentCohort => currentCohort%shorter + +enddo !cohort + +! NRAD = NCAN ... +currentPatch%nrad = currentPatch%ncan + +! Now loop through and identify which layer and pft combo has scattering elements +do cl = 1,nclmax + do ft = 1,numpft + currentPatch%canopy_mask(cl,ft) = 0 + do iv = 1, currentPatch%nrad(cl,ft); + if(currentPatch%canopy_area_profile(cl,ft,iv) > 0._r8)then + currentPatch%canopy_mask(cl,ft) = 1 end if - !q10 response of product limited psn. - co2_rcurve_islope = co2_rcurve_islope25 * 2._r8**((veg_tempk-(tfrz+25._r8))/10._r8) - end if - - ! Adjust for water limitations - vcmax = vcmax * btran - - return - end subroutine LeafLayerBiophysicalRates - - subroutine lowstorage_maintresp_reduction(frac, pft, maintresp_reduction_factor) - - ! This subroutine reduces maintenance respiration rates when storage pool is low. The premise - ! of this is that mortality of plants increases when storage is low because they are not able - ! to repair tissues, generate defense compounds, etc. This reduction is reflected in a reduced - ! maintenance demand. The output of this function takes the form of a curve between 0 and 1, - ! and the curvature of the function is determined by a parameter. - - ! Uses - use EDPftvarcon , only : EDPftvarcon_inst - - ! Arguments - ! ------------------------------------------------------------------------------ - real(r8), intent(in) :: frac ! ratio of storage to target leaf biomass - integer, intent(in) :: pft ! what pft is this cohort? - real(r8), intent(out) :: maintresp_reduction_factor ! the factor by which to reduce maintenance respiration - - ! -------------------------------------------------------------------------------- - ! Parameters are at the PFT level: - ! fates_maintresp_reduction_curvature controls the curvature of this. - ! If this parameter is zero, then there is no reduction until the plant dies at storage = 0. - ! If this parameter is one, then there is a linear reduction in respiration below the storage point. - ! Intermediate values will give some (concave-downwards) curvature. - ! - ! maintresp_reduction_intercept controls the maximum amount of throttling. - ! zero means no throttling at any point, so it turns this mechanism off completely and so - ! allows an entire cohort to die via negative carbon-induced termination mortality. - ! one means complete throttling, so no maintenance respiration at all, when out of carbon. - ! --------------------------------------------------------------------------------- - - if( frac .lt. 1._r8 )then - if ( EDPftvarcon_inst%maintresp_reduction_curvature(pft) .ne. 1._r8 ) then - maintresp_reduction_factor = (1._r8 - EDPftvarcon_inst%maintresp_reduction_intercept(pft)) + & - EDPftvarcon_inst%maintresp_reduction_intercept(pft) * & - (1._r8 - EDPftvarcon_inst%maintresp_reduction_curvature(pft)**frac) & - / (1._r8-EDPftvarcon_inst%maintresp_reduction_curvature(pft)) - else ! avoid nan answer for linear case - maintresp_reduction_factor = (1._r8 - EDPftvarcon_inst%maintresp_reduction_intercept(pft)) + & - EDPftvarcon_inst%maintresp_reduction_intercept(pft) * frac - endif - - else - maintresp_reduction_factor = 1._r8 - endif - - - end subroutine lowstorage_maintresp_reduction - - end module FATESPlantRespPhotosynthMod + 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 +! except TPU from: Harley et al (1992) Plant, Cell and Environment 15:271-282 + +real(r8), parameter :: kcha = 79430._r8 ! activation energy for kc (J/mol) +real(r8), parameter :: koha = 36380._r8 ! activation energy for ko (J/mol) +real(r8), parameter :: cpha = 37830._r8 ! activation energy for cp (J/mol) + + +! Derive sco from currentPatch and O2 using present-day O2 (0.209 mol/mol) and re-calculate +! currentPatch to account for variation in O2 using currentPatch = 0.5 O2 / sco + +! FIXME (RGK 11-30-2016 THere are more constants here, but I don't have enough information +! about what they are or do, so I can't give them more descriptive names. Someone please +! fill this in when possible) + +kc25 = ( mm_kc25_umol_per_mol / umol_per_mol ) * can_press +ko25 = ( mm_ko25_mmol_per_mol / mmol_per_mol ) * can_press +sco = 0.5_r8 * 0.209_r8 / (co2_cpoint_umol_per_mol / umol_per_mol ) +cp25 = 0.5_r8 * can_o2_partialpress / sco + +if( veg_tempk.gt.150_r8 .and. veg_tempk.lt.350_r8 )then + mm_kco2 = kc25 * ft1_f(veg_tempk, kcha) + mm_ko2 = ko25 * ft1_f(veg_tempk, koha) + co2_cpoint = cp25 * ft1_f(veg_tempk, cpha) +else + mm_kco2 = 1.0_r8 + mm_ko2 = 1.0_r8 + co2_cpoint = 1.0_r8 +end if + +! --------------------------------------------------------------------------------- +! +! cf is the conversion factor between molar form and velocity form +! of conductance and resistance: [umol/m3] +! +! i.e. +! [m/s] * [umol/m3] -> [umol/m2/s] +! +! Breakdown of the conversion factor: [ umol / m3 ] +! +! Rgas [J /K /kmol] +! Air Potential Temperature [ K ] +! Canopy Pressure [ Pa ] +! conversion: umol/kmol = 1e9 +! +! [ Pa * K * kmol umol/kmol / J K ] = [ Pa * umol / J ] +! since: 1 Pa = 1 N / m2 +! [ Pa * umol / J ] = [ N * umol / J m2 ] +! since: 1 J = 1 N * m +! [ N * umol / J m2 ] = [ N * umol / N m3 ] +! [ umol / m3 ] +! +! -------------------------------------------------------------------------------- + +cf = can_press/(rgas * air_tempk )*umol_per_kmol +gb_mol = (1._r8/ rb) * cf + +! Constrain eair >= 0.05*esat_tv so that solution does not blow up. This ensures +! that hs does not go to zero. Also eair <= veg_esat so that hs <= 1 +ceair = min( max(air_vpress, 0.05_r8*veg_esat ),veg_esat ) + + + +return +end subroutine GetCanopyGasParameters + +! ==================================================================================== + +subroutine LeafLayerMaintenanceRespiration(lmr25top_ft, & + nscaler, & + ft, & + veg_tempk, & + lmr) + +use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm +use EDPftvarcon , only : EDPftvarcon_inst + +! Arguments +real(r8), intent(in) :: lmr25top_ft ! canopy top leaf maint resp rate at 25C +! for this pft (umol CO2/m**2/s) +integer, intent(in) :: ft ! (plant) Functional Type Index +real(r8), intent(in) :: nscaler ! Scale for leaf nitrogen profile +real(r8), intent(in) :: veg_tempk ! vegetation temperature +real(r8), intent(out) :: lmr ! Leaf Maintenance Respiration (umol CO2/m**2/s) + +! Locals +real(r8) :: lmr25 ! leaf layer: leaf maintenance respiration rate at 25C (umol CO2/m**2/s) + +! Parameter +real(r8), parameter :: lmrha = 46390._r8 ! activation energy for lmr (J/mol) +real(r8), parameter :: lmrhd = 150650._r8 ! deactivation energy for lmr (J/mol) +real(r8), parameter :: lmrse = 490._r8 ! entropy term for lmr (J/mol/K) +real(r8), parameter :: lmrc = 1.15912391_r8 ! scaling factor for high +! temperature inhibition (25 C = 1.0) + + + + + +! Part I: Leaf Maintenance respiration: umol CO2 / m**2 [leaf] / s +! ---------------------------------------------------------------------------------- +lmr25 = lmr25top_ft * nscaler + +if ( nint(EDpftvarcon_inst%c3psn(ft)) == 1)then + lmr = lmr25 * ft1_f(veg_tempk, lmrha) * & + fth_f(veg_tempk, lmrhd, lmrse, lmrc) +else + lmr = lmr25 * 2._r8**((veg_tempk-(tfrz+25._r8))/10._r8) + lmr = lmr / (1._r8 + exp( 1.3_r8*(veg_tempk-(tfrz+55._r8)) )) +end if + +! Any hydrodynamic limitations could go here, currently none +! lmr = lmr * (nothing) + +end subroutine LeafLayerMaintenanceRespiration + +! ==================================================================================== + +subroutine LeafLayerBiophysicalRates( parsun_lsl, & + ft, & + vcmax25top_ft, & + jmax25top_ft, & + tpu25top_ft, & + co2_rcurve_islope25top_ft, & + nscaler, & + veg_tempk, & + btran, & + vcmax, & + jmax, & + tpu, & + 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, + ! tpu: triose phosphate utilization rate and + ! co2_rcurve_islope: initial slope of CO2 response curve (C4 plants) + ! --------------------------------------------------------------------------------- + +use EDPftvarcon , only : EDPftvarcon_inst +use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm + +! Arguments +! ------------------------------------------------------------------------------ + +real(r8), intent(in) :: parsun_lsl ! PAR absorbed in sunlit leaves for this layer +integer, intent(in) :: ft ! (plant) Functional Type Index +real(r8), intent(in) :: nscaler ! Scale for leaf nitrogen profile +real(r8), intent(in) :: vcmax25top_ft ! canopy top maximum rate of carboxylation at 25C +! for this pft (umol CO2/m**2/s) +real(r8), intent(in) :: jmax25top_ft ! canopy top maximum electron transport rate at 25C +! for this pft (umol electrons/m**2/s) +real(r8), intent(in) :: tpu25top_ft ! canopy top triose phosphate utilization rate at 25C +! for this pft (umol CO2/m**2/s) +real(r8), intent(in) :: co2_rcurve_islope25top_ft ! initial slope of CO2 response curve +! (C4 plants) at 25C, canopy top, this pft +real(r8), intent(in) :: veg_tempk ! vegetation temperature +real(r8), intent(in) :: btran ! transpiration wetness factor (0 to 1) + +real(r8), intent(out) :: vcmax ! maximum rate of carboxylation (umol co2/m**2/s) +real(r8), intent(out) :: jmax ! maximum electron transport rate +! (umol electrons/m**2/s) +real(r8), intent(out) :: tpu ! triose phosphate utilization rate +! (umol CO2/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) :: tpu25 ! leaf layer: triose phosphate utilization rate at 25C +! (umol CO2/m**2/s) +real(r8) :: co2_rcurve_islope25 ! leaf layer: Initial slope of CO2 response curve +! (C4 plants) at 25C + + +! Parameters +! --------------------------------------------------------------------------------- +real(r8) :: vcmaxha ! activation energy for vcmax (J/mol) +real(r8) :: jmaxha ! activation energy for jmax (J/mol) +real(r8) :: tpuha ! activation energy for tpu (J/mol) +real(r8) :: vcmaxhd ! deactivation energy for vcmax (J/mol) +real(r8) :: jmaxhd ! deactivation energy for jmax (J/mol) +real(r8) :: tpuhd ! deactivation energy for tpu (J/mol) +real(r8) :: vcmaxse ! entropy term for vcmax (J/mol/K) +real(r8) :: jmaxse ! entropy term for jmax (J/mol/K) +real(r8) :: tpuse ! entropy term for tpu (J/mol/K) +real(r8) :: vcmaxc ! scaling factor for high temperature inhibition (25 C = 1.0) +real(r8) :: jmaxc ! scaling factor for high temperature inhibition (25 C = 1.0) +real(r8) :: tpuc ! scaling factor for high temperature inhibition (25 C = 1.0) + +vcmaxha = EDPftvarcon_inst%vcmaxha(FT) +jmaxha = EDPftvarcon_inst%jmaxha(FT) +tpuha = EDPftvarcon_inst%tpuha(FT) + +vcmaxhd = EDPftvarcon_inst%vcmaxhd(FT) +jmaxhd = EDPftvarcon_inst%jmaxhd(FT) +tpuhd = EDPftvarcon_inst%tpuhd(FT) + +vcmaxse = EDPftvarcon_inst%vcmaxse(FT) +jmaxse = EDPftvarcon_inst%jmaxse(FT) +tpuse = EDPftvarcon_inst%tpuse(FT) + +vcmaxc = fth25_f(vcmaxhd, vcmaxse) +jmaxc = fth25_f(jmaxhd, jmaxse) +tpuc = fth25_f(tpuhd, tpuse) + +if ( parsun_lsl <= 0._r8) then ! night time + vcmax = 0._r8 + jmax = 0._r8 + tpu = 0._r8 + co2_rcurve_islope = 0._r8 +else ! day time + + ! Vcmax25top was already calculated to derive the nscaler function + vcmax25 = vcmax25top_ft * nscaler + jmax25 = jmax25top_ft * nscaler + tpu25 = tpu25top_ft * nscaler + co2_rcurve_islope25 = co2_rcurve_islope25top_ft * nscaler + + ! Adjust for temperature + vcmax = vcmax25 * ft1_f(veg_tempk, vcmaxha) * fth_f(veg_tempk, vcmaxhd, vcmaxse, vcmaxc) + jmax = jmax25 * ft1_f(veg_tempk, jmaxha) * fth_f(veg_tempk, jmaxhd, jmaxse, jmaxc) + tpu = tpu25 * ft1_f(veg_tempk, tpuha) * fth_f(veg_tempk, tpuhd, tpuse, tpuc) + + if (nint(EDPftvarcon_inst%c3psn(ft)) /= 1) then + vcmax = vcmax25 * 2._r8**((veg_tempk-(tfrz+25._r8))/10._r8) + vcmax = vcmax / (1._r8 + exp( 0.2_r8*((tfrz+15._r8)-veg_tempk ) )) + vcmax = vcmax / (1._r8 + exp( 0.3_r8*(veg_tempk-(tfrz+40._r8)) )) + end if + !q10 response of product limited psn. + co2_rcurve_islope = co2_rcurve_islope25 * 2._r8**((veg_tempk-(tfrz+25._r8))/10._r8) +end if + +! Adjust for water limitations +vcmax = vcmax * btran + +return +end subroutine LeafLayerBiophysicalRates + +subroutine lowstorage_maintresp_reduction(frac, pft, maintresp_reduction_factor) + + ! This subroutine reduces maintenance respiration rates when storage pool is low. The premise + ! of this is that mortality of plants increases when storage is low because they are not able + ! to repair tissues, generate defense compounds, etc. This reduction is reflected in a reduced + ! maintenance demand. The output of this function takes the form of a curve between 0 and 1, + ! and the curvature of the function is determined by a parameter. + + ! Uses +use EDPftvarcon , only : EDPftvarcon_inst + +! Arguments +! ------------------------------------------------------------------------------ +real(r8), intent(in) :: frac ! ratio of storage to target leaf biomass +integer, intent(in) :: pft ! what pft is this cohort? +real(r8), intent(out) :: maintresp_reduction_factor ! the factor by which to reduce maintenance respiration + +! -------------------------------------------------------------------------------- +! Parameters are at the PFT level: +! fates_maintresp_reduction_curvature controls the curvature of this. +! If this parameter is zero, then there is no reduction until the plant dies at storage = 0. +! If this parameter is one, then there is a linear reduction in respiration below the storage point. +! Intermediate values will give some (concave-downwards) curvature. +! +! maintresp_reduction_intercept controls the maximum amount of throttling. +! zero means no throttling at any point, so it turns this mechanism off completely and so +! allows an entire cohort to die via negative carbon-induced termination mortality. +! one means complete throttling, so no maintenance respiration at all, when out of carbon. +! --------------------------------------------------------------------------------- + +if( frac .lt. 1._r8 )then + if ( EDPftvarcon_inst%maintresp_reduction_curvature(pft) .ne. 1._r8 ) then + maintresp_reduction_factor = (1._r8 - EDPftvarcon_inst%maintresp_reduction_intercept(pft)) + & + EDPftvarcon_inst%maintresp_reduction_intercept(pft) * & + (1._r8 - EDPftvarcon_inst%maintresp_reduction_curvature(pft)**frac) & + / (1._r8-EDPftvarcon_inst%maintresp_reduction_curvature(pft)) + else ! avoid nan answer for linear case + maintresp_reduction_factor = (1._r8 - EDPftvarcon_inst%maintresp_reduction_intercept(pft)) + & + EDPftvarcon_inst%maintresp_reduction_intercept(pft) * frac + endif + +else + maintresp_reduction_factor = 1._r8 +endif + + +end subroutine lowstorage_maintresp_reduction + +end module FATESPlantRespPhotosynthMod From ba597bd052c64339ca029f29330bc6c156013522 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 25 Nov 2020 09:25:38 -0700 Subject: [PATCH 157/209] ading comments on arbitrary initialization in SP mode --- main/EDInitMod.F90 | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index f13994e8ea..64e3fe87bf 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -1,4 +1,4 @@ -module EDInitMod +1;95;0cmodule EDInitMod ! ============================================================================ ! Contains all modules to set up the ED structure. @@ -717,6 +717,9 @@ subroutine init_cohorts( site_in, patch_in, bc_in) if(hlm_use_sp.eq.itrue)then init = itrue + ! At this point, we do not know the bc_in values of tlai tsai and htop, + ! so this is initializing to an arbitrary value for the very first timestep. + ! Not sure if there's a way around this or not. call assign_cohort_SP_properties(temp_cohort, 0.5_r8,0.2_r8, 0.1_r8,patch_in%area,init,c_leaf) else From 29d528b42d1bfeb3aba520a81ef71c289b7f5f19 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 26 Nov 2020 07:11:58 -0700 Subject: [PATCH 158/209] comments on pft_areafracweighting from HT --- biogeochem/EDPhysiologyMod.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index b624167af9..13ab71d25f 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1409,6 +1409,7 @@ subroutine satellite_phenology(currentSite, bc_in) end do !hlm_pft ! weight for total area in each patch/fates_pft + ! this is needed because the area of pft_areafrac does not need to sum to 1.0 if(currentPatch%area.gt.0.0_r8)then currentSite%sp_tlai(fates_pft) = currentSite%sp_tlai(fates_pft) & /(currentPatch%area/area) From 9f1d7e5aadf3ff7e9dbbe8ec015ddeec607e9d4e Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 26 Nov 2020 07:12:32 -0700 Subject: [PATCH 159/209] removing type in EDInit --- main/EDInitMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 64e3fe87bf..06185a4669 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -1,4 +1,4 @@ -1;95;0cmodule EDInitMod +module EDInitMod ! ============================================================================ ! Contains all modules to set up the ED structure. From d38a25a66a1066cfa7f81a2fa430d025806a64a9 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 9 Apr 2021 16:38:19 -0700 Subject: [PATCH 160/209] cleaning up merge for successful build --- biogeochem/EDCanopyStructureMod.F90 | 2 +- biogeochem/EDPatchDynamicsMod.F90 | 2 +- main/EDInitMod.F90 | 2 +- main/EDPftvarcon.F90 | 3 ++- 4 files changed, 5 insertions(+), 4 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 3460871e7f..d4527c3e97 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -2194,7 +2194,7 @@ function NumPotentialCanopyLayers(currentPatch,site_spread,include_substory) res ! If so we need to make another layer. if(arealayer > currentPatch%area)then z = z + 1 - if(hlm_use_sp)then + if(hlm_use_sp.eq.itrue)then write(fates_log(),*) 'SPmode, canopy_layer full:',arealayer,currentPatch%area end if diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index d776db593e..ad034dd8a4 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -1276,7 +1276,7 @@ subroutine set_patchno( currentSite ) currentPatch => currentPatch%younger enddo - if(hlm_use_sp)then + if(hlm_use_sp.eq.itrue)then patchno = 1 currentPatch => currentSite%oldest_patch do while(associated(currentPatch)) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 1c2385c8f9..007d6dd68b 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -312,7 +312,7 @@ subroutine set_site_properties( nsites, sites,bc_in ) sites(s)%acc_NI = acc_NI sites(s)%NF = 0.0_r8 - sites(s)%frac_burnt = 0.0_r8 + sites(s)%NF_successful = 0.0_r8 if(hlm_use_fixed_biogeog.eq.itrue)then ! MAPPING OF FATES PFTs on to HLM_PFTs diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index 6ca06b3f43..d57233cbdb 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -629,7 +629,8 @@ subroutine Register_PFT(this, fates_params) pftmap_dim_names(2) = dimension_name_hlm_pftno name = 'fates_hlm_pft_map' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & dimension_names=pftmap_dim_names, lower_bounds=dim_lower_bound) + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & + dimension_names=pftmap_dim_names, lower_bounds=dim_lower_bound) end subroutine Register_PFT From 0fc7a17b5e413efe081cd228de88de42fccd9793 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Mon, 12 Apr 2021 11:23:02 -0600 Subject: [PATCH 161/209] allocating sp_mode related variables to start at zero --- main/FatesInterfaceMod.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index e7c4bf1cc8..e90a694770 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -476,13 +476,13 @@ subroutine allocate_bcin(bc_in, nlevsoil_in, nlevdecomp_in, num_lu_harvest_cats) allocate(bc_in%hlm_harvest_catnames(0)) end if - allocate(bc_in%pft_areafrac(maxpft)) + allocate(bc_in%pft_areafrac(0:maxpft)) ! Variables for SP mode. if(hlm_use_sp.eq.itrue) then - allocate(bc_in%hlm_sp_tlai(maxpft)) - allocate(bc_in%hlm_sp_tsai(maxpft)) - allocate(bc_in%hlm_sp_htop(maxpft)) + allocate(bc_in%hlm_sp_tlai(0:maxpft)) + allocate(bc_in%hlm_sp_tsai(0:maxpft)) + allocate(bc_in%hlm_sp_htop(0:maxpft)) end if return end subroutine allocate_bcin From 588ac1291c6aa746f7960a35fe2c2e9b8daeec31 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 21 Apr 2021 16:10:32 -0600 Subject: [PATCH 162/209] removing the nocomp_pft_label check as the was resulting in invalid zero indexing --- biogeochem/EDCanopyStructureMod.F90 | 4 ++-- main/EDInitMod.F90 | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index d4527c3e97..eefb94291b 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1922,10 +1922,10 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) currentPatch => sites(s)%oldest_patch c = fcolumn(s) do while(associated(currentPatch)) - if(currentPatch%nocomp_pft_label.ne.0)then + !if(currentPatch%nocomp_pft_label.ne.0)then ! only increase ifp for veg patches, not bareground (in SP mode) ifp = ifp+1 - endif ! stay with ifp=0 for bareground patch. + !endif ! stay with ifp=0 for bareground patch. if ( currentPatch%total_canopy_area-currentPatch%area > 0.000001_r8 ) then write(fates_log(),*) 'ED: canopy area bigger than area',currentPatch%total_canopy_area ,currentPatch%area currentPatch%total_canopy_area = currentPatch%area diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 007d6dd68b..05a17d7a9c 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -133,7 +133,7 @@ subroutine init_site_vars( site_in, bc_in ) allocate(site_in%dz_soil(site_in%nlevsoil)) allocate(site_in%z_soil(site_in%nlevsoil)) - allocate(site_in%area_pft(1:numpft)) + allocate(site_in%area_pft(0:numpft)) ! Changing to zero indexing allocate(site_in%use_this_pft(1:numpft)) ! SP mode @@ -486,7 +486,7 @@ subroutine init_patches( nsites, sites, bc_in) if(hlm_use_nocomp.eq.itrue)then num_new_patches = numpft if(hlm_use_sp.eq.itrue)then - num_new_patches = numpft + 1 ! bare ground patch in SP mode. + !num_new_patches = numpft + 1 ! bare ground patch in SP mode. start_patch = 0 ! start at the bare ground patch endif ! allocate(newppft(numpft)) From 7fba81e143046a870e913e40c79ac4131368b952 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Mon, 10 May 2021 15:59:26 -0700 Subject: [PATCH 163/209] adding hui's logic to exclude sai calculation from lai during sp mode --- biogeochem/EDCanopyStructureMod.F90 | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index eefb94291b..a86c6cc022 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -55,7 +55,7 @@ module EDCanopyStructureMod public :: canopy_summarization public :: update_hlm_dynamics - logical, parameter :: debug=.false. + logical, parameter :: debug=.true. character(len=*), parameter, private :: sourcefile = & __FILE__ @@ -1478,6 +1478,7 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) real(r8) :: lai ! summed lai for checking m2 m-2 real(r8) :: snow_depth_avg ! avg snow over whole site real(r8) :: leaf_c ! leaf carbon [kg] + real(r8) :: saicheck ! diagnostic check for Satellite phenology mode !---------------------------------------------------------------------- @@ -1534,10 +1535,24 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) currentCohort%n, currentCohort%canopy_layer, & currentPatch%canopy_layer_tlai,currentCohort%vcmax25top ) + if (hlm_use_sp .eq. ifalse) then currentCohort%treesai = tree_sai(currentCohort%pft, currentCohort%dbh, currentCohort%canopy_trim, & currentCohort%c_area, currentCohort%n, currentCohort%canopy_layer, & currentPatch%canopy_layer_tlai, currentCohort%treelai , & currentCohort%vcmax25top,4) + else + ! If we are using satellite phenology, conduct a check against the calculated sai + saicheck = tree_sai(currentCohort%pft, currentCohort%dbh, currentCohort%canopy_trim, & + currentCohort%c_area, currentCohort%n, currentCohort%canopy_layer, & + currentPatch%canopy_layer_tlai, currentCohort%treelai , & + currentCohort%vcmax25top,4) + + if ( debug ) write(fates_log(), *) 'SP mode: sai check: ', saicheck - currentCohort%treesai + + end if + + if ( debug ) write(fates_log(), *) 'currentCohort%treesai: ', currentCohort%treesai + if ( debug ) write(fates_log(), *) 'currentCohort%treelai: ', currentCohort%treelai currentCohort%lai = currentCohort%treelai *currentCohort%c_area/currentPatch%total_canopy_area currentCohort%sai = currentCohort%treesai *currentCohort%c_area/currentPatch%total_canopy_area From 1d215b8f5d57200554b880ffe391a038d41b41d9 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Mon, 17 May 2021 14:36:21 -0700 Subject: [PATCH 164/209] adding sp mode check in create_cohort to avoid setting sai as well --- biogeochem/EDCanopyStructureMod.F90 | 15 ++++++++++++++- biogeochem/EDCohortDynamicsMod.F90 | 6 ++++++ 2 files changed, 20 insertions(+), 1 deletion(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index a86c6cc022..b8f12f210f 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1547,10 +1547,12 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) currentPatch%canopy_layer_tlai, currentCohort%treelai , & currentCohort%vcmax25top,4) - if ( debug ) write(fates_log(), *) 'SP mode: sai check: ', saicheck - currentCohort%treesai + if ( debug ) write(fates_log(), *) 'SP mode: sai check: ', saicheck end if + if ( debug ) write(fates_log(), *) 'currentCohort%canopy_layer: ', cl + if ( debug ) write(fates_log(), *) 'currentCohort%pft: ', ft if ( debug ) write(fates_log(), *) 'currentCohort%treesai: ', currentCohort%treesai if ( debug ) write(fates_log(), *) 'currentCohort%treelai: ', currentCohort%treelai @@ -1615,6 +1617,9 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) currentCohort%lai currentPatch%tsai_profile(1,ft,iv) = currentPatch%tsai_profile(1,ft,iv) + frac_canopy(iv) * & currentCohort%sai + if ( debug ) write(fates_log(), *) 'currentCohort%pft,iv: ', ft,iv + if ( debug ) write(fates_log(), *) 'currentPatch%tlai_profile(1,ft,iv): ', currentPatch%tlai_profile(1,ft,iv) + if ( debug ) write(fates_log(), *) 'currentPatch%tsai_profile(1,ft,iv): ', currentPatch%tsai_profile(1,ft,iv) !snow burial !write(fates_log(), *) 'calc snow' @@ -2008,6 +2013,14 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) bc_out(s)%esai_pa(ifp) = calc_areaindex(currentPatch,'esai') bc_out(s)%tsai_pa(ifp) = calc_areaindex(currentPatch,'tsai') + !if(debug) then + ! write(fates_log(),*) 'ifp: ', ifp + ! write(fates_log(),*) 'bc_out(s)%elai_pa(ifp): ', bc_out(s)%elai_pa(ifp) + ! write(fates_log(),*) 'bc_out(s)%tlai_pa(ifp): ', bc_out(s)%tlai_pa(ifp) + ! write(fates_log(),*) 'bc_out(s)%esai_pa(ifp): ', bc_out(s)%esai_pa(ifp) + ! write(fates_log(),*) 'bc_out(s)%tsai_pa(ifp): ', bc_out(s)%tsai_pa(ifp) + !end if + ! Fraction of vegetation free of snow. This is used to flag those ! patches which shall under-go photosynthesis ! INTERF-TODO: we may want to stop using frac_veg_nosno_alb and let diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index ae9983f356..74b7a32ee7 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -278,9 +278,13 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & new_cohort%n, new_cohort%canopy_layer, & patchptr%canopy_layer_tlai,new_cohort%vcmax25top ) + write(fates_log(),*) 'create_cohort: calling tree_sai' + + if(hlm_use_sp.eq.ifalse)then new_cohort%treesai = tree_sai(new_cohort%pft, new_cohort%dbh, new_cohort%canopy_trim, & new_cohort%c_area, new_cohort%n, new_cohort%canopy_layer, & patchptr%canopy_layer_tlai, new_cohort%treelai,new_cohort%vcmax25top,2 ) + end if new_cohort%lai = new_cohort%treelai * new_cohort%c_area/patchptr%area @@ -1304,6 +1308,8 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) currentCohort%treelai = tree_lai(leaf_c, currentCohort%pft, currentCohort%c_area, newn, & currentCohort%canopy_layer, currentPatch%canopy_layer_tlai, & currentCohort%vcmax25top) + + write(fates_log(),*) 'fuse_cohort: calling tree_sai' currentCohort%treesai = tree_sai(currentCohort%pft, currentCohort%dbh, currentCohort%canopy_trim, & currentCohort%c_area, newn, currentCohort%canopy_layer, & currentPatch%canopy_layer_tlai, currentCohort%treelai,currentCohort%vcmax25top,1 ) From 62cbbe7372e2a387cc02bf6ea8fa1fb36a0f94d1 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Mon, 24 May 2021 17:00:48 -0700 Subject: [PATCH 165/209] trying Hui's suggested fix per issue 745 --- biogeophys/EDSurfaceAlbedoMod.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index c59f81b47f..ebc01b1b69 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -133,7 +133,8 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) 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)= 1.0_r8 + bc_out(s)%ftid_parb(ifp,ib)= 0.0_r8 bc_out(s)%ftii_parb(ifp,ib)= 1.0_r8 enddo From e9a5da90fb74b1db8993b7b35cf2589c20d6e2e1 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 2 Jun 2021 17:57:08 -0600 Subject: [PATCH 166/209] removing nocomp pft label check in radiation restart update --- main/FatesRestartInterfaceMod.F90 | 3 --- 1 file changed, 3 deletions(-) diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 1328edef8c..dc521649c8 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -2922,7 +2922,6 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) ifp = 0 currentpatch => sites(s)%oldest_patch do while (associated(currentpatch)) - if(currentpatch%nocomp_pft_label.gt.0)then ifp = ifp+1 currentPatch%f_sun (:,:,:) = 0._r8 @@ -2986,8 +2985,6 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) endif ! is there vegetation? end if ! if the vegetation and zenith filter is active - - end if ! not bare ground currentPatch => currentPatch%younger end do ! Loop linked-list patches enddo ! Loop Sites From 58c33ee2232e9d602948e29417b030e2289afc44 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 3 Jun 2021 12:16:08 -0600 Subject: [PATCH 167/209] correcting logic check for ST3 mode --- main/EDMainMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index c7bdc30f41..6903ee85b2 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -264,7 +264,7 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in, bc_out) !********************************************************************************* do_patch_dynamics = itrue - if(hlm_use_ed_st3.eq.ifalse)then + if(hlm_use_ed_st3.eq.itrue)then do_patch_dynamics = ifalse end if From d901f9f36450d5b7f19dca257a668e865e5eb6dd Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 4 Jun 2021 09:45:57 -0600 Subject: [PATCH 168/209] removing redundeant newparea call and deallocation which was causing hydro enabled failures --- main/EDInitMod.F90 | 2 -- 1 file changed, 2 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 05a17d7a9c..19907e4842 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -492,7 +492,6 @@ subroutine init_patches( nsites, sites, bc_in) ! allocate(newppft(numpft)) else !default num_new_patches = 1 - newparea = area end if !nocomp is_first_patch = itrue @@ -647,7 +646,6 @@ subroutine init_patches( nsites, sites, bc_in) sitep => sites(s) call updateSizeDepRhizHydProps(sitep, bc_in(s)) end do - deallocate(recall_older_patch) end if return From 0010efeed963432008d4da73a11433bcacfc3ca0 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 11 Jun 2021 14:01:24 -0600 Subject: [PATCH 169/209] adding c_area to restart interface --- main/FatesRestartInterfaceMod.F90 | 26 +++++++++++++++++++++++++- 1 file changed, 25 insertions(+), 1 deletion(-) diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index dc521649c8..acdbdab904 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -18,6 +18,7 @@ module FatesRestartInterfaceMod use FatesInterfaceTypesMod, only : bc_in_type use FatesInterfaceTypesMod, only : bc_out_type use FatesInterfaceTypesMod, only : hlm_use_planthydro + use FatesInterfaceTypesMod, only : hlm_use_sp use FatesInterfaceTypesMod, only : fates_maxElementsPerSite use EDCohortDynamicsMod, only : UpdateCohortBioPhysRates use FatesHydraulicsMemMod, only : nshell @@ -113,6 +114,7 @@ module FatesRestartInterfaceMod integer :: ir_frmort_co integer :: ir_smort_co integer :: ir_asmort_co + integer :: ir_c_area_co integer :: ir_daily_n_uptake_co integer :: ir_daily_p_uptake_co @@ -1008,6 +1010,15 @@ subroutine define_restart_vars(this, initialize_variables) hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_errfates_mbal) + ! Only register satellite phenology related restart variables if it is turned on! + + if(hlm_use_sp .eq. itrue) then + call this%set_restart_var(vname='fates_cohort_area', vtype=cohort_r8, & + long_name='area of the fates cohort', & + units='m2', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_c_area_co ) + end if + ! Only register hydraulics restart variables if it is turned on! @@ -1683,6 +1694,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_imortcflux_si => this%rvars(ir_imortcflux_si)%r81d, & rio_fmortcflux_cano_si => this%rvars(ir_fmortcflux_cano_si)%r81d, & rio_fmortcflux_usto_si => this%rvars(ir_fmortcflux_usto_si)%r81d) + !rio_c_area_co => this%rvars(ir_c_area_co)%r81d) totalCohorts = 0 @@ -1905,6 +1917,11 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_isnew_co(io_idx_co) = old_cohort endif + if (hlm_use_sp .eq. itrue) then + !rio_c_area_co(io_idx_co) = ccohort%c_area + this%rvars(ir_c_area_co)%r81d(io_idx_co) = ccohort%c_area + end if + if ( debug ) then write(fates_log(),*) 'CLTV offsetNumCohorts II ',io_idx_co, & cohortsperpatch @@ -2101,7 +2118,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) end do end do end if - + enddo if ( debug ) then @@ -2322,6 +2339,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) use EDTypesMod, only : maxSWb use FatesInterfaceTypesMod, only : numpft use FatesInterfaceTypesMod, only : fates_maxElementsPerPatch + use EDPhysiologyMod, only : assign_cohort_sp_properties use EDTypesMod, only : numWaterMem use EDTypesMod, only : num_vegtemp_mem use FatesSizeAgeTypeIndicesMod, only : get_age_class_index @@ -2474,6 +2492,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) rio_imortcflux_si => this%rvars(ir_imortcflux_si)%r81d, & rio_fmortcflux_cano_si => this%rvars(ir_fmortcflux_cano_si)%r81d, & rio_fmortcflux_usto_si => this%rvars(ir_fmortcflux_usto_si)%r81d) + !rio_c_area_co => this%rvars(ir_c_area_co)%r81d) totalcohorts = 0 @@ -2678,6 +2697,11 @@ subroutine get_restart_vectors(this, nc, nsites, sites) n_hypool_ag, & ir_hydro_err_growturn_ag_covec,io_idx_co) end if + + if (hlm_use_sp .eq. itrue) then + !ccohort%c_area = rio_c_area_co(io_idx_co) + ccohort%c_area = this%rvars(ir_c_area_co)%r81d(io_idx_co) + end if io_idx_co = io_idx_co + 1 From 7fe7af7e7298db25e55d45e5cc43157a79ea38db Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 23 Jun 2021 15:49:12 -0700 Subject: [PATCH 170/209] adding instantaneous gpp and npp to restart --- main/FatesRestartInterfaceMod.F90 | 670 +++++++++++++++--------------- 1 file changed, 342 insertions(+), 328 deletions(-) diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index acdbdab904..50984091ed 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -15,7 +15,7 @@ module FatesRestartInterfaceMod use FatesIOVariableKindMod, only : fates_io_variable_kind_type use FatesRestartVariableMod, only : fates_restart_variable_type use FatesInterfaceTypesMod, only : nlevcoage - use FatesInterfaceTypesMod, only : bc_in_type + use FatesInterfaceTypesMod, only : bc_in_type use FatesInterfaceTypesMod, only : bc_out_type use FatesInterfaceTypesMod, only : hlm_use_planthydro use FatesInterfaceTypesMod, only : hlm_use_sp @@ -72,11 +72,11 @@ module FatesRestartInterfaceMod ! ls: layer sublayer dimension (fine discretization of upper,lower) ! wm: the number of memory slots for water (currently 10) ! ------------------------------------------------------------- - - + + ! Indices to the restart variable object - integer :: ir_npatch_si + integer :: ir_npatch_si integer :: ir_cd_status_si integer :: ir_dd_status_si integer :: ir_nchill_days_si @@ -115,6 +115,8 @@ module FatesRestartInterfaceMod integer :: ir_smort_co integer :: ir_asmort_co integer :: ir_c_area_co + integer :: ir_gpp_tstep_co + integer :: ir_npp_tstep_co integer :: ir_daily_n_uptake_co integer :: ir_daily_p_uptake_co @@ -125,7 +127,7 @@ module FatesRestartInterfaceMod integer :: ir_daily_p_demand_co integer :: ir_daily_n_need_co integer :: ir_daily_p_need_co - + !Logging integer :: ir_lmort_direct_co integer :: ir_lmort_collateral_co @@ -206,7 +208,7 @@ module FatesRestartInterfaceMod ! Hydraulic indices integer :: ir_hydro_th_ag_covec integer :: ir_hydro_th_troot - integer :: ir_hydro_th_aroot_covec + integer :: ir_hydro_th_aroot_covec integer :: ir_hydro_liqvol_shell_si integer :: ir_hydro_err_growturn_aroot integer :: ir_hydro_err_growturn_ag_covec @@ -223,12 +225,12 @@ module FatesRestartInterfaceMod ! integer constants for storing logical data integer, parameter, public :: old_cohort = 0 - integer, parameter, public :: new_cohort = 1 + integer, parameter, public :: new_cohort = 1 real(r8), parameter, public :: flushinvalid = -9999.0 real(r8), parameter, public :: flushzero = 0.0 real(r8), parameter, public :: flushone = 1.0 - + ! Local debug flag logical, parameter, public :: debug=.false. @@ -255,20 +257,20 @@ module FatesRestartInterfaceMod ! Instanteate one registry of the different dimension/kinds (dk) ! All output variables will have a pointer to one of these dk's type(fates_io_variable_kind_type) :: dim_kinds(fates_restart_num_dim_kinds) - + ! This is a structure that explains where FATES patch boundaries ! on each thread point to in the host IO array, this structure is ! allocated by number of threads. This could be dynamically ! allocated, but is unlikely to change...? ! Note: history io also instanteates fates_io_dimension_type type(fates_io_dimension_type) :: dim_bounds(fates_restart_num_dimensions) - + type(restart_map_type), pointer :: restart_map(:) integer, private :: cohort_index_, column_index_ contains - + ! public functions procedure :: Init procedure :: SetThreadBoundsEach @@ -281,7 +283,7 @@ module FatesRestartInterfaceMod procedure :: create_patchcohort_structure procedure :: get_restart_vectors procedure :: update_3dpatch_radiation - + ! private work functions procedure, private :: init_dim_kinds_maps procedure, private :: set_dim_indices @@ -297,15 +299,15 @@ module FatesRestartInterfaceMod end type fates_restart_interface_type - + contains ! ===================================================================================== - + subroutine Init(this, num_threads, fates_bounds) - + use FatesIODimensionsMod, only : fates_bounds_type, column, cohort implicit none @@ -330,13 +332,13 @@ subroutine Init(this, num_threads, fates_bounds) ! Allocate the mapping between FATES indices and the IO indices allocate(this%restart_map(num_threads)) - - end subroutine Init + + end subroutine Init ! ====================================================================== subroutine SetThreadBoundsEach(this, thread_index, thread_bounds) - + use FatesIODimensionsMod, only : fates_bounds_type implicit none @@ -347,25 +349,25 @@ subroutine SetThreadBoundsEach(this, thread_index, thread_bounds) type(fates_bounds_type), intent(in) :: thread_bounds integer :: index - + index = this%cohort_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%cohort_begin, thread_bounds%cohort_end) - + index = this%column_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%column_begin, thread_bounds%column_end) - + end subroutine SetThreadBoundsEach ! =================================================================================== subroutine assemble_restart_output_types(this) - + use FatesIOVariableKindMod, only : site_r8, site_int, cohort_r8, cohort_int implicit none - + class(fates_restart_interface_type), intent(inout) :: this call this%init_dim_kinds_maps() @@ -379,7 +381,7 @@ subroutine assemble_restart_output_types(this) end subroutine assemble_restart_output_types ! =================================================================================== - + subroutine set_dim_indices(this, dk_name, idim, dim_index) use FatesIOVariableKindMod , only : iotype_index @@ -428,13 +430,13 @@ subroutine set_cohort_index(this, index) integer, intent(in) :: index this%cohort_index_ = index end subroutine set_cohort_index - + integer function cohort_index(this) implicit none class(fates_restart_interface_type), intent(in) :: this cohort_index = this%cohort_index_ end function cohort_index - + ! ======================================================================= subroutine set_column_index(this, index) @@ -443,17 +445,17 @@ subroutine set_column_index(this, index) integer, intent(in) :: index this%column_index_ = index end subroutine set_column_index - + integer function column_index(this) implicit none class(fates_restart_interface_type), intent(in) :: this column_index = this%column_index_ end function column_index - + ! ======================================================================= subroutine init_dim_kinds_maps(this) - + ! ---------------------------------------------------------------------------------- ! This subroutine simply initializes the structures that define the different ! array and type formats for different IO variables @@ -468,9 +470,9 @@ subroutine init_dim_kinds_maps(this) ! ! ---------------------------------------------------------------------------------- use FatesIOVariableKindMod, only : site_r8, site_int, cohort_r8, cohort_int - + implicit none - + ! Arguments class(fates_restart_interface_type), intent(inout) :: this @@ -499,17 +501,17 @@ end subroutine init_dim_kinds_maps ! ==================================================================================== integer function num_restart_vars(this) - + implicit none class(fates_restart_interface_type), intent(in) :: this num_restart_vars = this%num_restart_vars_ - + end function num_restart_vars - + ! ==================================================================================== - + subroutine initialize_restart_vars(this) implicit none @@ -522,16 +524,16 @@ subroutine initialize_restart_vars(this) ! Allocate the list of restart output variable objects allocate(this%rvars(this%num_restart_vars())) - + ! construct the object that defines all of the IO variables call this%define_restart_vars(initialize_variables=.true.) - + end subroutine initialize_restart_vars ! ====================================================================================== subroutine flush_rvars(this,nc) - + class(fates_restart_interface_type) :: this integer,intent(in) :: nc @@ -544,17 +546,17 @@ subroutine flush_rvars(this,nc) call rvar%Flush(nc, this%dim_bounds, this%dim_kinds) end associate end do - + end subroutine flush_rvars - + ! ==================================================================================== - + subroutine define_restart_vars(this, initialize_variables) - + ! --------------------------------------------------------------------------------- - ! + ! ! REGISTRY OF RESTART OUTPUT VARIABLES ! ! Please add any restart variables to this registry. This registry will handle @@ -562,19 +564,19 @@ subroutine define_restart_vars(this, initialize_variables) ! variables. Note that restarts are only using 1D vectors in ALM and CLM. If you ! have a multi-dimensional variable that is below the cohort scale, then pack ! that variable into a cohort-sized output array by giving it a vtype "cohort_r8" - ! or "cohort_int". + ! or "cohort_int". ! ! Unlike history variables, restarts flush to zero. ! --------------------------------------------------------------------------------- - + use FatesIOVariableKindMod, only : site_r8, site_int, cohort_int, cohort_r8 implicit none - + class(fates_restart_interface_type), intent(inout) :: this logical, intent(in) :: initialize_variables ! are we 'count'ing or 'initializ'ing? integer :: ivar - - + + ivar=0 ! ----------------------------------------------------------------------------------- @@ -620,7 +622,7 @@ subroutine define_restart_vars(this, initialize_variables) call this%set_restart_var(vname='fates_acc_nesterov_id', vtype=site_r8, & long_name='a nesterov index accumulator', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_acc_ni_si ) - + call this%set_restart_var(vname='fates_gdd_site', vtype=site_r8, & long_name='growing degree days at each site', units='degC days', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_gdd_si ) @@ -646,7 +648,7 @@ subroutine define_restart_vars(this, initialize_variables) call this%set_restart_var(vname='fates_solar_zenith_flag_pa', vtype=cohort_int, & long_name='switch specifying if zenith is positive', units='unitless', flushval = flushinvalid, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_solar_zenith_flag_pa ) - + call this%set_restart_var(vname='fates_solar_zenith_angle_pa', vtype=cohort_r8, & long_name='the angle of the solar zenith for each patch', units='radians', flushval = flushinvalid, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_solar_zenith_angle_pa ) @@ -683,7 +685,7 @@ subroutine define_restart_vars(this, initialize_variables) call this%set_restart_var(vname='fates_coage', vtype=cohort_r8, & long_name='ed cohort - age in days', units='days', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_coage_co ) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_coage_co ) call this%set_restart_var(vname='fates_height', vtype=cohort_r8, & long_name='ed cohort - plant height', units='m', flushval = flushzero, & @@ -698,12 +700,12 @@ subroutine define_restart_vars(this, initialize_variables) long_name='ed cohort - target sapwood biomass set from prev year', & units='kgC/indiv', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_sapwmemory_co ) - + call this%set_restart_var(vname='fates_structmemory', vtype=cohort_r8, & long_name='ed cohort - target structural biomass set from prev year', & units='kgC/indiv', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_structmemory_co ) - + call this%set_restart_var(vname='fates_nplant', vtype=cohort_r8, & long_name='ed cohort - number of plants in the cohort', & units='/patch', flushval = flushzero, & @@ -743,7 +745,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name='ed cohort - maintenance respiration deficit', & units='kgC/indiv', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_resp_m_def_co ) - + call this%set_restart_var(vname='fates_bmort', vtype=cohort_r8, & long_name='ed cohort - background mortality rate', & units='/year', flushval = flushzero, & @@ -778,7 +780,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name='fates cohort- daily nitrogen efflux', & units='kg/plant/day', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_daily_n_efflux_co ) - + call this%set_restart_var(vname='fates_daily_p_efflux', vtype=cohort_r8, & long_name='fates cohort- daily phosphorus efflux', & units='kg/plant/day', flushval = flushzero, & @@ -803,7 +805,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name='fates cohort- daily nitrogen need', & units='kgN/plant/day', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_daily_n_need_co ) - + call this%set_restart_var(vname='fates_frmort', vtype=cohort_r8, & long_name='ed cohort - freezing mortality rate', & units='/year', flushval = flushzero, & @@ -816,7 +818,7 @@ subroutine define_restart_vars(this, initialize_variables) call this%set_restart_var(vname='fates_asmort', vtype=cohort_r8, & long_name='ed cohort - age senescence mortality rate', & - units = '/year', flushval = flushzero, & + units = '/year', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_asmort_co ) call this%set_restart_var(vname='fates_lmort_direct', vtype=cohort_r8, & @@ -827,12 +829,12 @@ subroutine define_restart_vars(this, initialize_variables) call this%set_restart_var(vname='fates_lmort_collateral', vtype=cohort_r8, & long_name='ed cohort - collateral mortality rate', & units='%/event', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_lmort_collateral_co ) - + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_lmort_collateral_co ) + call this%set_restart_var(vname='fates_lmort_in', vtype=cohort_r8, & long_name='ed cohort - mechanical mortality rate', & units='%/event', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_lmort_infra_co ) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_lmort_infra_co ) call this%set_restart_var(vname='fates_ddbhdt', vtype=cohort_r8, & long_name='ed cohort - differential: ddbh/dt', & @@ -916,23 +918,23 @@ subroutine define_restart_vars(this, initialize_variables) call this%RegisterCohortVector(symbol_base='fates_ag_cwd', vtype=cohort_r8, & long_name_base='above ground CWD', & units='kg/m2', veclength=num_elements, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_agcwd_litt) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_agcwd_litt) call this%RegisterCohortVector(symbol_base='fates_bg_cwd', vtype=cohort_r8, & long_name_base='below ground CWD', & units='kg/m2', veclength=num_elements, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_bgcwd_litt) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_bgcwd_litt) call this%RegisterCohortVector(symbol_base='fates_leaf_fines', vtype=cohort_r8, & long_name_base='above ground leaf litter', & units='kg/m2', veclength=num_elements, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_leaf_litt) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_leaf_litt) call this%RegisterCohortVector(symbol_base='fates_fnrt_fines', vtype=cohort_r8, & long_name_base='fine root litter', & units='kg/m2', veclength=num_elements, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fnrt_litt) - + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fnrt_litt) + call this%RegisterCohortVector(symbol_base='fates_seed', vtype=cohort_r8, & long_name_base='seed bank (non-germinated)', & units='kg/m2', veclength=num_elements, flushval = flushzero, & @@ -946,18 +948,18 @@ subroutine define_restart_vars(this, initialize_variables) call this%RegisterCohortVector(symbol_base='fates_ag_cwd_frag', vtype=cohort_r8, & long_name_base='above ground CWD frag flux', & units='kg/m2/day', veclength=num_elements, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_agcwd_frag_litt) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_agcwd_frag_litt) call this%RegisterCohortVector(symbol_base='fates_bg_cwd_frag', vtype=cohort_r8, & long_name_base='below ground CWD frag flux', & units='kg/m2/day', veclength=num_elements, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_bgcwd_frag_litt) - + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_bgcwd_frag_litt) + call this%RegisterCohortVector(symbol_base='fates_lfines_frag', vtype=cohort_r8, & long_name_base='frag flux from leaf fines', & units='kg/m2/day', veclength=num_elements, flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_lfines_frag_litt) - + call this%RegisterCohortVector(symbol_base='fates_rfines_frag', vtype=cohort_r8, & long_name_base='frag flux from froot fines', & units='kg/m2/day', veclength=num_elements, flushval = flushzero, & @@ -996,20 +998,20 @@ subroutine define_restart_vars(this, initialize_variables) units='kg/day/ha', veclength=num_elements, flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_uptake_flxdg) - + ! Site level Mass Balance State Accounting call this%RegisterCohortVector(symbol_base='fates_oldstock', vtype=site_r8, & long_name_base='Previous total mass of all fates state variables', & units='kg/ha', veclength=num_elements, flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_oldstock_mbal) - + call this%RegisterCohortVector(symbol_base='fates_errfates', vtype=site_r8, & long_name_base='Previous total mass of error fates state variables', & units='kg/ha', veclength=num_elements, flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_errfates_mbal) - - + + ! Only register satellite phenology related restart variables if it is turned on! if(hlm_use_sp .eq. itrue) then @@ -1017,11 +1019,19 @@ subroutine define_restart_vars(this, initialize_variables) 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_gpp_tstep', vtype=cohort_r8, & + long_name='instantaneous fates gross primary production', & + units='kgC/indiv/timestep', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_gpp_tstep_co ) + call this%set_restart_var(vname='fates_npp_tstep', vtype=cohort_r8, & + long_name='instantaneous fates net primary production', & + units='kgC/indiv/timestep', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_npp_tstep_co ) end if ! Only register hydraulics restart variables if it is turned on! - + if(hlm_use_planthydro==itrue) then if ( fates_maxElementsPerSite < (nshell * nlevsoi_hyd_max) ) then @@ -1039,32 +1049,32 @@ subroutine define_restart_vars(this, initialize_variables) call this%RegisterCohortVector(symbol_base='fates_hydro_th_ag', vtype=cohort_r8, & long_name_base='water in aboveground compartments', & units='kg/plant', veclength=n_hypool_ag, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_th_ag_covec) - + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_th_ag_covec) + call this%RegisterCohortVector(symbol_base='fates_hydro_th_troot', vtype=cohort_r8, & long_name_base='water in transporting roots', & units='kg/plant', veclength=n_hypool_troot, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_th_troot) - + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_th_troot) + call this%RegisterCohortVector(symbol_base='fates_hydro_th_aroot', vtype=cohort_r8, & long_name_base='water in absorbing roots', & units='kg/plant', veclength=nlevsoi_hyd_max, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_th_aroot_covec) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_th_aroot_covec) call this%RegisterCohortVector(symbol_base='fates_hydro_err_aroot', vtype=cohort_r8, & long_name_base='error in plant-hydro balance in absorbing roots', & units='kg/plant', veclength=nlevsoi_hyd_max, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_err_growturn_aroot) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_err_growturn_aroot) call this%RegisterCohortVector(symbol_base='fates_hydro_err_ag', vtype=cohort_r8, & long_name_base='error in plant-hydro balance above ground', & units='kg/plant', veclength=n_hypool_ag, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_err_growturn_ag_covec) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_err_growturn_ag_covec) call this%RegisterCohortVector(symbol_base='fates_hydro_err_troot', vtype=cohort_r8, & long_name_base='error in plant-hydro balance above ground', & units='kg/plant', veclength=n_hypool_troot, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_err_growturn_troot) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_err_growturn_troot) ! Site-level volumentric liquid water content (shell x layer) call this%set_restart_var(vname='fates_hydro_liqvol_shell', vtype=cohort_r8, & @@ -1077,13 +1087,13 @@ subroutine define_restart_vars(this, initialize_variables) long_name='Site level water mass used for new recruits', & units='kg', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_recruit_si ) - + ! Site-level water bound in dead plants call this%set_restart_var(vname='fates_hydro_dead_h2o', vtype=site_r8, & long_name='Site level water bound in dead plants', & units='kg', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_dead_si ) - + ! Site-level water balance error due to growth/turnover call this%set_restart_var(vname='fates_hydro_growturn_err', vtype=site_r8, & long_name='Site level error for hydraulics due to growth/turnover', & @@ -1101,7 +1111,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name='Site level error for hydrodynamics', & units='kg', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_hydro_err_si ) - + end if @@ -1118,7 +1128,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name='last 10 days of 24-hour vegetation temperature, by site x day-index', & units='m3/m3', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_vegtempmem_sitm ) - + call this%set_restart_var(vname='fates_recrate', vtype=cohort_r8, & long_name='fates diagnostics on recruitment', & units='indiv/ha/day', flushval = flushzero, & @@ -1174,7 +1184,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name='fates diag: rate of indivs moving via fusion', & units='indiv/ha/day', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_growflx_fusion_siscpf) - + call this%set_restart_var(vname='fates_demorate', vtype=cohort_r8, & long_name='fates diagnoatic rate of indivs demoted', & units='indiv/ha/day', flushval = flushzero, & @@ -1189,7 +1199,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name='biomass of indivs killed due to impact mort', & units='kgC/ha/day', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_imortcflux_si) - + call this%set_restart_var(vname='fates_fmortcflux_canopy', vtype=site_r8, & long_name='fates diagnostic biomass of canopy fire', & units='gC/m2/sec', flushval = flushzero, & @@ -1227,20 +1237,20 @@ subroutine define_restart_vars(this, initialize_variables) ir_prt_base = ivar call this%DefinePRTRestartVars(initialize_variables,ivar) - - - + + + ! Must be last thing before return this%num_restart_vars_ = ivar - + end subroutine define_restart_vars - + ! ===================================================================================== - + subroutine DefinePRTRestartVars(this,initialize_variables,ivar) ! ---------------------------------------------------------------------------------- - ! PARTEH variables are objects. These objects + ! PARTEH variables are objects. These objects ! each are registered to have things like names units and symbols ! as part of that object. Thus, when defining, reading and writing restarts, ! instead of manually typing out each variable we want, we just loop through @@ -1267,7 +1277,7 @@ subroutine DefinePRTRestartVars(this,initialize_variables,ivar) class(fates_restart_interface_type) :: this logical, intent(in) :: initialize_variables integer,intent(inout) :: ivar ! global variable counter - + integer :: dummy_out ! dummy index for variable ! position in global file integer :: i_var ! loop counter for prt variables @@ -1283,12 +1293,12 @@ subroutine DefinePRTRestartVars(this,initialize_variables,ivar) ! The base symbol name symbol_base = prt_global%state_descriptor(i_var)%symbol - + ! The long name of the variable name_base = prt_global%state_descriptor(i_var)%longname do i_pos = 1, prt_global%state_descriptor(i_var)%num_pos - + ! String describing the physical position of the variable write(pos_symbol, '(I3.3)') i_pos @@ -1306,7 +1316,7 @@ subroutine DefinePRTRestartVars(this,initialize_variables,ivar) long_name=trim(long_name), & units='kg', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, & - ivar=ivar, index = dummy_out ) + ivar=ivar, index = dummy_out ) ! Register the turnover flux variables ! ---------------------------------------------------------------------------- @@ -1316,19 +1326,19 @@ subroutine DefinePRTRestartVars(this,initialize_variables,ivar) ! The expanded long name of the variable long_name = trim(name_base)//', turnover, position:'//trim(pos_symbol) - + call this%set_restart_var(vname=trim(symbol), & vtype=cohort_r8, & long_name=trim(long_name), & units='kg', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, & - ivar=ivar, index = dummy_out ) - + ivar=ivar, index = dummy_out ) + ! Register the net allocation flux variable ! ---------------------------------------------------------------------------- - + ! The symbol that is written to file symbol = trim(symbol_base)//'_net_'//trim(pos_symbol) @@ -1340,8 +1350,8 @@ subroutine DefinePRTRestartVars(this,initialize_variables,ivar) long_name=trim(long_name), & units='kg', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, & - ivar=ivar, index = dummy_out ) - + ivar=ivar, index = dummy_out ) + ! Register the burn flux variable @@ -1357,11 +1367,11 @@ subroutine DefinePRTRestartVars(this,initialize_variables,ivar) long_name=trim(long_name), & units='kg', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, & - ivar=ivar, index = dummy_out ) + ivar=ivar, index = dummy_out ) end do end do - + return end subroutine DefinePRTRestartVars @@ -1369,20 +1379,20 @@ end subroutine DefinePRTRestartVars subroutine RegisterCohortVector(this,symbol_base, vtype, long_name_base, & units, veclength, flushval, hlms, & - initialize, ivar, index) + initialize, ivar, index) + - ! The basic idea here is that instead of saving cohorts with vector data ! as long arrays in the restart file, we give each index of the vector ! its own variable. This helps reduce the size of the restart files ! considerably. - - + + use FatesIOVariableKindMod, only : cohort_r8 - + class(fates_restart_interface_type) :: this character(*),intent(in) :: symbol_base ! Symbol name without position - character(*),intent(in) :: vtype ! String defining variable type + character(*),intent(in) :: vtype ! String defining variable type character(*),intent(in) :: long_name_base ! name without position character(*),intent(in) :: units ! units for this variable integer,intent(in) :: veclength ! length of the vector @@ -1391,58 +1401,58 @@ subroutine RegisterCohortVector(this,symbol_base, vtype, long_name_base, & logical, intent(in) :: initialize ! Is this registering or counting? integer,intent(inout) :: ivar ! global variable counter integer,intent(out) :: index ! The variable index for this variable - + ! Local Variables character(len=4) :: pos_symbol ! vectors need text strings for each position character(len=128) :: symbol ! symbol name written to file character(len=256) :: long_name ! long name written to file integer :: i_pos ! loop counter for discrete position integer :: dummy_index - + ! We give each vector its own index that points to the first position - + index = ivar + 1 - + do i_pos = 1, veclength - + ! String describing the physical position of the variable write(pos_symbol, '(I3.3)') i_pos - + ! The symbol that is written to file symbol = trim(symbol_base)//'_vec_'//trim(pos_symbol) - + ! The expanded long name of the variable long_name = trim(long_name_base)//', position:'//trim(pos_symbol) - + call this%set_restart_var(vname=trim(symbol), & vtype=vtype, & long_name=trim(long_name), & units=units, flushval = flushval, & hlms='CLM:ALM', initialize=initialize, & - ivar=ivar, index = dummy_index ) - + ivar=ivar, index = dummy_index ) + end do - + end subroutine RegisterCohortVector ! ===================================================================================== - + subroutine GetCohortRealVector(this, state_vector, len_state_vector, & variable_index_base, co_global_index) - + ! This subroutine walks through global cohort vector indices ! and pulls from the different associated restart variables - + class(fates_restart_interface_type) , intent(inout) :: this integer,intent(in) :: len_state_vector real(r8),intent(inout) :: state_vector(len_state_vector) integer,intent(in) :: variable_index_base integer,intent(in) :: co_global_index - + integer :: i_pos ! vector position loop index integer :: ir_pos_var ! global variable index - + ir_pos_var = variable_index_base do i_pos = 1, len_state_vector state_vector(i_pos) = this%rvars(ir_pos_var)%r81d(co_global_index) @@ -1450,24 +1460,24 @@ subroutine GetCohortRealVector(this, state_vector, len_state_vector, & end do return end subroutine GetCohortRealVector - - ! ===================================================================================== - + + ! ===================================================================================== + subroutine SetCohortRealVector(this, state_vector, len_state_vector, & variable_index_base, co_global_index) ! This subroutine walks through global cohort vector indices ! and pushes into the restart arrays the different associated restart variables - + class(fates_restart_interface_type) , intent(inout) :: this integer,intent(in) :: len_state_vector real(r8),intent(in) :: state_vector(len_state_vector) integer,intent(in) :: variable_index_base integer,intent(in) :: co_global_index - + integer :: i_pos ! vector position loop index integer :: ir_pos_var ! global variable index - + ir_pos_var = variable_index_base do i_pos = 1, len_state_vector this%rvars(ir_pos_var)%r81d(co_global_index) = state_vector(i_pos) @@ -1475,7 +1485,7 @@ subroutine SetCohortRealVector(this, state_vector, len_state_vector, & end do return end subroutine SetCohortRealVector - + ! ===================================================================================== @@ -1489,7 +1499,7 @@ subroutine set_restart_var(this,vname,vtype,long_name,units,flushval, & class(fates_restart_interface_type) :: this character(len=*),intent(in) :: vname character(len=*),intent(in) :: vtype - character(len=*),intent(in) :: units + character(len=*),intent(in) :: units real(r8), intent(in) :: flushval character(len=*),intent(in) :: long_name character(len=*),intent(in) :: hlms @@ -1501,32 +1511,32 @@ subroutine set_restart_var(this,vname,vtype,long_name,units,flushval, & ! A zero is passed back when the variable is ! not used - + type(fates_restart_variable_type),pointer :: rvar integer :: ub1,lb1,ub2,lb2 ! Bounds for allocating the var integer :: ityp - + logical :: use_var - + use_var = check_hlm_list(trim(hlms), trim(hlm_name)) if( use_var ) then - + ivar = ivar+1 - index = ivar - + index = ivar + if( initialize )then - + call this%rvars(ivar)%Init(vname, units, long_name, vtype, flushval, & fates_restart_num_dim_kinds, this%dim_kinds, this%dim_bounds) end if else - + index = 0 end if - + return end subroutine set_restart_var @@ -1584,7 +1594,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ! Some counters (for checking mostly) integer :: totalcohorts ! total cohort count on this thread (diagnostic) integer :: patchespersite ! number of patches per site - integer :: cohortsperpatch ! number of cohorts per patch + integer :: cohortsperpatch ! number of cohorts per patch integer :: ft ! functional type index integer :: el ! element loop index @@ -1639,14 +1649,14 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_gpp_acc_hold_co => this%rvars(ir_gpp_acc_hold_co)%r81d, & rio_resp_acc_hold_co => this%rvars(ir_resp_acc_hold_co)%r81d, & rio_npp_acc_hold_co => this%rvars(ir_npp_acc_hold_co)%r81d, & - rio_resp_m_def_co => this%rvars(ir_resp_m_def_co)%r81d, & + rio_resp_m_def_co => this%rvars(ir_resp_m_def_co)%r81d, & rio_bmort_co => this%rvars(ir_bmort_co)%r81d, & rio_hmort_co => this%rvars(ir_hmort_co)%r81d, & rio_cmort_co => this%rvars(ir_cmort_co)%r81d, & rio_daily_n_uptake_co => this%rvars(ir_daily_n_uptake_co)%r81d, & rio_daily_p_uptake_co => this%rvars(ir_daily_p_uptake_co)%r81d, & - rio_daily_c_efflux_co => this%rvars(ir_daily_c_efflux_co)%r81d, & - rio_daily_n_efflux_co => this%rvars(ir_daily_n_efflux_co)%r81d, & + rio_daily_c_efflux_co => this%rvars(ir_daily_c_efflux_co)%r81d, & + rio_daily_n_efflux_co => this%rvars(ir_daily_n_efflux_co)%r81d, & rio_daily_p_efflux_co => this%rvars(ir_daily_p_efflux_co)%r81d, & rio_daily_n_demand_co => this%rvars(ir_daily_n_demand_co)%r81d, & rio_daily_p_demand_co => this%rvars(ir_daily_p_demand_co)%r81d, & @@ -1668,8 +1678,8 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_spread_si => this%rvars(ir_spread_si)%r81d, & rio_livegrass_pa => this%rvars(ir_livegrass_pa)%r81d, & rio_age_pa => this%rvars(ir_age_pa)%r81d, & - rio_patchdistturbcat_pa => this%rvars(ir_patchdistturbcat_pa)%int1d, & - rio_agesinceanthrodist_pa => this%rvars(ir_agesinceanthrodist_pa)%r81d, & + rio_patchdistturbcat_pa => this%rvars(ir_patchdistturbcat_pa)%int1d, & + rio_agesinceanthrodist_pa => this%rvars(ir_agesinceanthrodist_pa)%r81d, & rio_nocomp_pft_label_pa => this%rvars(ir_nocomp_pft_label_pa)%int1d, & rio_area_pa => this%rvars(ir_area_pa)%r81d, & rio_watermem_siwm => this%rvars(ir_watermem_siwm)%r81d, & @@ -1698,20 +1708,20 @@ subroutine set_restart_vectors(this,nc,nsites,sites) totalCohorts = 0 - + ! --------------------------------------------------------------------------------- ! Flush arrays to values defined by %flushval (see registry entry in ! subroutine define_history_vars() ! --------------------------------------------------------------------------------- call this%flush_rvars(nc) - + do s = 1,nsites - + ! Calculate the offsets ! fcolumn is the global column index of the current site. ! For the first site, if that site aligns with the first column index ! in the clump, than the offset should be be equal to begCohort - + io_idx_si = this%restart_map(nc)%site_index(s) io_idx_co_1st = this%restart_map(nc)%cohort1_index(s) @@ -1726,32 +1736,32 @@ subroutine set_restart_vectors(this,nc,nsites,sites) io_idx_si_sc = io_idx_co_1st io_idx_si_capf = io_idx_co_1st io_idx_si_cacls= io_idx_co_1st - + ! recruitment rate do i_pft = 1,numpft rio_recrate_sift(io_idx_co_1st+i_pft-1) = sites(s)%recruitment_rate(i_pft) end do - + do i_pft = 1,numpft - rio_use_this_pft_sift(io_idx_co_1st+i_pft-1) = sites(s)%use_this_pft(i_pft) + rio_use_this_pft_sift(io_idx_co_1st+i_pft-1) = sites(s)%use_this_pft(i_pft) end do - + do i_pft = 1,numpft rio_area_pft_sift(io_idx_co_1st+i_pft-1) = sites(s)%area_pft(i_pft) end do - + do el = 1, num_elements io_idx_si_cwd = io_idx_co_1st io_idx_si_pft = io_idx_co_1st io_idx_si_scpf = io_idx_co_1st - + do i_cwd=1,ncwd this%rvars(ir_cwdagin_flxdg+el-1)%r81d(io_idx_si_cwd) = sites(s)%flux_diags(el)%cwd_ag_input(i_cwd) this%rvars(ir_cwdbgin_flxdg+el-1)%r81d(io_idx_si_cwd) = sites(s)%flux_diags(el)%cwd_bg_input(i_cwd) io_idx_si_cwd = io_idx_si_cwd + 1 end do - + do i_pft=1,numpft this%rvars(ir_leaflittin_flxdg+el-1)%r81d(io_idx_si_pft) = sites(s)%flux_diags(el)%leaf_litter_input(i_pft) this%rvars(ir_rootlittin_flxdg+el-1)%r81d(io_idx_si_pft) = sites(s)%flux_diags(el)%root_litter_input(i_pft) @@ -1767,8 +1777,8 @@ subroutine set_restart_vectors(this,nc,nsites,sites) io_idx_si_scpf = io_idx_si_scpf + 1 end do end do - - + + this%rvars(ir_oldstock_mbal+el-1)%r81d(io_idx_si) = sites(s)%mass_balance(el)%old_stock this%rvars(ir_errfates_mbal+el-1)%r81d(io_idx_si) = sites(s)%mass_balance(el)%err_fates @@ -1777,31 +1787,31 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ! canopy spread term rio_spread_si(io_idx_si) = sites(s)%spread - + cpatch => sites(s)%oldest_patch - + ! new column, reset num patches patchespersite = 0 - + do while(associated(cpatch)) - + ! found patch, increment patchespersite = patchespersite + 1 - + ccohort => cpatch%shortest - + ! new patch, reset num cohorts cohortsperpatch = 0 - + do while(associated(ccohort)) - + ! found cohort, increment cohortsperpatch = cohortsperpatch + 1 totalCohorts = totalCohorts + 1 - + if ( debug ) then write(fates_log(),*) 'CLTV io_idx_co ', io_idx_co - write(fates_log(),*) 'CLTV lowerbound ', lbound(rio_npp_acc_co,1) + write(fates_log(),*) 'CLTV lowerbound ', lbound(rio_npp_acc_co,1) write(fates_log(),*) 'CLTV upperbound ', ubound(rio_npp_acc_co,1) endif @@ -1814,7 +1824,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ir_prt_var = ir_prt_base do i_var = 1, prt_global%num_vars do i_pos = 1, prt_global%state_descriptor(i_var)%num_pos - + ir_prt_var = ir_prt_var + 1 this%rvars(ir_prt_var)%r81d(io_idx_co) = & ccohort%prt%variables(i_var)%val(i_pos) @@ -1822,7 +1832,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ir_prt_var = ir_prt_var + 1 this%rvars(ir_prt_var)%r81d(io_idx_co) = & ccohort%prt%variables(i_var)%turnover(i_pos) - + ir_prt_var = ir_prt_var + 1 this%rvars(ir_prt_var)%r81d(io_idx_co) = & ccohort%prt%variables(i_var)%net_alloc(i_pos) @@ -1830,13 +1840,13 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ir_prt_var = ir_prt_var + 1 this%rvars(ir_prt_var)%r81d(io_idx_co) = & ccohort%prt%variables(i_var)%burned(i_pos) - + end do end do - + if(hlm_use_planthydro==itrue)then - + ! Load the water contents call this%SetCohortRealVector(ccohort%co_hydr%th_ag,n_hypool_ag, & ir_hydro_th_ag_covec,io_idx_co) @@ -1849,13 +1859,13 @@ subroutine set_restart_vectors(this,nc,nsites,sites) call this%setCohortRealVector(ccohort%co_hydr%errh2o_growturn_ag, & n_hypool_ag, & ir_hydro_err_growturn_ag_covec,io_idx_co) - + this%rvars(ir_hydro_err_growturn_aroot)%r81d(io_idx_co) = & ccohort%co_hydr%errh2o_growturn_aroot - + this%rvars(ir_hydro_err_growturn_troot)%r81d(io_idx_co) = & ccohort%co_hydr%errh2o_growturn_troot - + end if @@ -1887,12 +1897,12 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_cmort_co(io_idx_co) = ccohort%cmort rio_smort_co(io_idx_co) = ccohort%smort rio_asmort_co(io_idx_co) = ccohort%asmort - rio_frmort_co(io_idx_co) = ccohort%frmort + rio_frmort_co(io_idx_co) = ccohort%frmort ! Nutrient uptake/efflux rio_daily_n_uptake_co(io_idx_co) = ccohort%daily_n_uptake rio_daily_p_uptake_co(io_idx_co) = ccohort%daily_p_uptake - + rio_daily_c_efflux_co(io_idx_co) = ccohort%daily_c_efflux rio_daily_n_efflux_co(io_idx_co) = ccohort%daily_n_efflux rio_daily_p_efflux_co(io_idx_co) = ccohort%daily_p_efflux @@ -1901,7 +1911,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_daily_p_demand_co(io_idx_co) = ccohort%daily_p_demand rio_daily_n_need_co(io_idx_co) = ccohort%daily_n_need2 rio_daily_p_need_co(io_idx_co) = ccohort%daily_p_need2 - + !Logging rio_lmort_direct_co(io_idx_co) = ccohort%lmort_direct rio_lmort_collateral_co(io_idx_co) = ccohort%lmort_collateral @@ -1916,23 +1926,25 @@ subroutine set_restart_vectors(this,nc,nsites,sites) else rio_isnew_co(io_idx_co) = old_cohort endif - + if (hlm_use_sp .eq. itrue) then !rio_c_area_co(io_idx_co) = ccohort%c_area this%rvars(ir_c_area_co)%r81d(io_idx_co) = ccohort%c_area + this%rvars(ir_gpp_tstep_co)%r81d(io_idx_co) = ccohort%gpp_tstep + this%rvars(ir_npp_tstep_co)%r81d(io_idx_co) = ccohort%npp_tstep end if - + if ( debug ) then write(fates_log(),*) 'CLTV offsetNumCohorts II ',io_idx_co, & cohortsperpatch endif - + io_idx_co = io_idx_co + 1 - + ccohort => ccohort%taller - + enddo ! ccohort do while - + ! ! deal with patch level fields here ! @@ -1942,10 +1954,10 @@ subroutine set_restart_vectors(this,nc,nsites,sites) 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 - + ! set cohorts per patch for IO rio_ncohort_pa( io_idx_co_1st ) = cohortsperpatch - + ! Set zenith angle info if ( cpatch%solar_zenith_flag ) then rio_solar_zenith_flag_pa(io_idx_co_1st) = itrue @@ -1961,18 +1973,18 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ! -------------------------------------------------------------------------- ! Send litter to the restart arrays - ! Each element has its own variable, so we have to make sure - ! we keep re-setting this + ! Each element has its own variable, so we have to make sure + ! we keep re-setting this ! -------------------------------------------------------------------------- do el = 0, num_elements-1 - + io_idx_pa_pft = io_idx_co_1st io_idx_pa_cwd = io_idx_co_1st io_idx_pa_cwsl = io_idx_co_1st io_idx_pa_dcsl = io_idx_co_1st io_idx_pa_dc = io_idx_co_1st - + litt => cpatch%litter(el+1) do i = 1,numpft @@ -1992,7 +2004,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) io_idx_pa_dcsl = io_idx_pa_dcsl + 1 end do end do - + do i = 1,ncwd this%rvars(ir_agcwd_litt+el)%r81d(io_idx_pa_cwd) = litt%ag_cwd(i) this%rvars(ir_agcwd_frag_litt+el)%r81d(io_idx_pa_cwd) = litt%ag_cwd_frag(i) @@ -2006,7 +2018,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) end do - + do i = 1,maxSWb rio_gnd_alb_dif_pasb(io_idx_pa_ib) = cpatch%gnd_alb_dif(i) rio_gnd_alb_dir_pasb(io_idx_pa_ib) = cpatch%gnd_alb_dir(i) @@ -2016,29 +2028,29 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ! Set the first cohort index to the start of the next patch, increment ! by the maximum number of cohorts per patch io_idx_co_1st = io_idx_co_1st + fates_maxElementsPerPatch - + ! reset counters so that they are all advanced evenly. io_idx_pa_pft = io_idx_co_1st io_idx_pa_cwd = io_idx_co_1st io_idx_pa_ib = io_idx_co_1st io_idx_co = io_idx_co_1st - + if ( debug ) then write(fates_log(),*) 'CLTV io_idx_co_1st ', io_idx_co_1st write(fates_log(),*) 'CLTV numCohort ', cohortsperpatch write(fates_log(),*) 'CLTV totalCohorts ', totalCohorts end if - + cpatch => cpatch%younger - + enddo ! cpatch do while - + io_idx_si_scpf = io_idx_co_1st - + ! Fill the site level diagnostics arrays do i_scls = 1, nlevsclass do i_pft = 1, numpft - + rio_fmortrate_cano_siscpf(io_idx_si_scpf) = sites(s)%fmort_rate_canopy(i_scls, i_pft) rio_fmortrate_usto_siscpf(io_idx_si_scpf) = sites(s)%fmort_rate_ustory(i_scls, i_pft) rio_imortrate_siscpf(io_idx_si_scpf) = sites(s)%imort_rate(i_scls, i_pft) @@ -2047,16 +2059,16 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_termnindiv_cano_siscpf(io_idx_si_scpf) = sites(s)%term_nindivs_canopy(i_scls,i_pft) rio_termnindiv_usto_siscpf(io_idx_si_scpf) = sites(s)%term_nindivs_ustory(i_scls,i_pft) rio_growflx_fusion_siscpf(io_idx_si_scpf) = sites(s)%growthflux_fusion(i_scls, i_pft) - + io_idx_si_scpf = io_idx_si_scpf + 1 end do rio_demorate_sisc(io_idx_si_sc) = sites(s)%demotion_rate(i_scls) rio_promrate_sisc(io_idx_si_sc) = sites(s)%promotion_rate(i_scls) - + io_idx_si_sc = io_idx_si_sc + 1 end do - + rio_termcflux_cano_si(io_idx_si) = sites(s)%term_carbonflux_canopy rio_termcflux_usto_si(io_idx_si) = sites(s)%term_carbonflux_ustory rio_democflux_si(io_idx_si) = sites(s)%demotion_carbonflux @@ -2075,14 +2087,14 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_dleafondate_si(io_idx_si) = sites(s)%dleafondate rio_dleafoffdate_si(io_idx_si) = sites(s)%dleafoffdate rio_acc_ni_si(io_idx_si) = sites(s)%acc_NI - rio_gdd_si(io_idx_si) = sites(s)%grow_deg_days - + rio_gdd_si(io_idx_si) = sites(s)%grow_deg_days + ! Accumulated trunk product rio_trunk_product_si(io_idx_si) = sites(s)%resources_management%trunk_product_site ! set numpatches for this column rio_npatch_si(io_idx_si) = patchespersite - + do i = 1,numWaterMem ! numWaterMem currently 10 rio_watermem_siwm( io_idx_si_wmem ) = sites(s)%water_memory(i) io_idx_si_wmem = io_idx_si_wmem + 1 @@ -2120,18 +2132,18 @@ subroutine set_restart_vectors(this,nc,nsites,sites) end if enddo - + if ( debug ) then write(fates_log(),*) 'CLTV total cohorts ',totalCohorts end if - + return end associate end subroutine set_restart_vectors ! ==================================================================================== - subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) + subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) ! ---------------------------------------------------------------------------------- ! This subroutine takes a peak at the restart file to determine how to allocate @@ -2145,7 +2157,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) use EDTypesMod, only : ed_patch_type use EDTypesMod, only : maxSWb use FatesInterfaceTypesMod, only : fates_maxElementsPerPatch - + use EDTypesMod, only : maxpft use EDTypesMod, only : area use EDPatchDynamicsMod, only : zero_patch @@ -2154,7 +2166,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) use EDPatchDynamicsMod, only : create_patch use EDPftvarcon, only : EDPftvarcon_inst use FatesAllometryMod, only : h2d_allom - + ! !ARGUMENTS: class(fates_restart_interface_type) , intent(inout) :: this @@ -2164,7 +2176,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) type(bc_in_type) , intent(in) :: bc_in(nsites) ! local variables - + type(ed_patch_type) , pointer :: newp type(ed_cohort_type), pointer :: new_cohort type(ed_cohort_type), pointer :: prev_cohort @@ -2184,12 +2196,12 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) ! and the number of cohorts per patch. These values tell us how much ! space to allocate. ! ---------------------------------------------------------------------------------- - + associate( rio_npatch_si => this%rvars(ir_npatch_si)%int1d , & rio_ncohort_pa => this%rvars(ir_ncohort_pa)%int1d ) - + do s = 1,nsites - + io_idx_si = this%restart_map(nc)%site_index(s) io_idx_co_1st = this%restart_map(nc)%cohort1_index(s) @@ -2201,9 +2213,9 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) write(fates_log(),*) '0 is a valid number, but this column seems uninitialized',rio_npatch_si(io_idx_si) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - + ! Initialize the site pointers to null - sites(s)%youngest_patch => null() + sites(s)%youngest_patch => null() sites(s)%oldest_patch => null() do idx_pa = 1,rio_npatch_si(io_idx_si) @@ -2212,10 +2224,10 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) write(fates_log(),*) 'create patch ',idx_pa write(fates_log(),*) 'idx_pa 1-cohortsperpatch : ', rio_ncohort_pa( io_idx_co_1st ) end if - + ! create patch - allocate(newp) - nocomp_pft = fates_unset_int + allocate(newp) + nocomp_pft = fates_unset_int ! the nocomp_pft label is set after patch creation has occured in 'get_restart_vectors' ! make new patch call create_patch(sites(s), newp, fates_unset_r8, fates_unset_r8, primaryforest, nocomp_pft ) @@ -2231,16 +2243,16 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) init_seed=fates_unset_r8, & init_seed_germ=fates_unset_r8) end do - + ! give this patch a unique patch number newp%patchno = idx_pa ! Iterate over the number of cohorts ! the file says are associated with this patch - ! we are just allocating space here, so we do + ! we are just allocating space here, so we do ! a simple list filling routine - + newp%tallest => null() newp%shortest => null() prev_cohort => null() @@ -2248,7 +2260,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) do fto = 1, rio_ncohort_pa( io_idx_co_1st ) allocate(new_cohort) - call nan_cohort(new_cohort) + call nan_cohort(new_cohort) call zero_cohort(new_cohort) new_cohort%patchptr => newp @@ -2256,7 +2268,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) if (.not.associated(newp%tallest)) then newp%tallest => new_cohort endif - + ! Every cohort's taller is the one that came before ! (unless it is first) if(associated(prev_cohort)) then @@ -2272,8 +2284,8 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) new_cohort%prt => null() call InitPRTObject(new_cohort%prt) call InitPRTBoundaryConditions(new_cohort) - - + + ! Allocate hydraulics arrays if( hlm_use_planthydro.eq.itrue ) then call InitHydrCohort(sites(s),new_cohort) @@ -2281,28 +2293,28 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) ! Update the previous prev_cohort => new_cohort - + enddo ! ends loop over fto - + ! ! insert this patch with cohorts into the site pointer. At this ! point just insert the new patch in the youngest position ! if (idx_pa == 1) then ! nothing associated yet. first patch is pointed to by youngest and oldest - + if ( debug ) write(fates_log(),*) 'idx_pa = 1 ',idx_pa - - sites(s)%youngest_patch => newp - sites(s)%oldest_patch => newp + + sites(s)%youngest_patch => newp + sites(s)%oldest_patch => newp sites(s)%youngest_patch%younger => null() sites(s)%youngest_patch%older => null() sites(s)%oldest_patch%younger => null() sites(s)%oldest_patch%older => null() - + else if (idx_pa == 2) then ! add second patch to list - + if ( debug ) write(fates_log(),*) 'idx_pa = 2 ',idx_pa - + sites(s)%youngest_patch => newp sites(s)%youngest_patch%younger => null() sites(s)%youngest_patch%older => sites(s)%oldest_patch @@ -2310,25 +2322,25 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) sites(s)%oldest_patch%older => null() else ! more than 2 patches, insert patch into youngest slot - + if ( debug ) write(fates_log(),*) 'idx_pa > 2 ',idx_pa - + newp%older => sites(s)%youngest_patch sites(s)%youngest_patch%younger => newp newp%younger => null() sites(s)%youngest_patch => newp - + endif - + io_idx_co_1st = io_idx_co_1st + fates_maxElementsPerPatch enddo ! ends loop over idx_pa enddo ! ends loop over s - + end associate end subroutine create_patchcohort_structure - + ! ==================================================================================== subroutine get_restart_vectors(this, nc, nsites, sites) @@ -2375,7 +2387,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) integer :: io_idx_pa_cwd ! each cwd class within each patch (pa_cwd) integer :: io_idx_pa_cwsl ! each cwd x soil layer integer :: io_idx_pa_dcsl ! each decomposability x soil layer - integer :: io_idx_pa_dc ! each decomposability index + integer :: io_idx_pa_dc ! each decomposability index integer :: io_idx_pa_ib ! each SW radiation band per patch (pa_ib) integer :: io_idx_si_wmem ! each water memory class within each site integer :: io_idx_si_vtmem ! counter for vegetation temp memory @@ -2390,7 +2402,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ! Some counters (for checking mostly) integer :: totalcohorts ! total cohort count on this thread (diagnostic) integer :: patchespersite ! number of patches per site - integer :: cohortsperpatch ! number of cohorts per patch + integer :: cohortsperpatch ! number of cohorts per patch integer :: el ! loop counter for elements integer :: nlevsoil ! number of soil layers integer :: ilyr ! soil layer loop counter @@ -2424,7 +2436,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) rio_seed_prod_co => this%rvars(ir_seed_prod_co)%r81d, & rio_size_class_lasttimestep => this%rvars(ir_size_class_lasttimestep_co)%int1d, & rio_dbh_co => this%rvars(ir_dbh_co)%r81d, & - rio_coage_co => this%rvars(ir_coage_co)%r81d, & + rio_coage_co => this%rvars(ir_coage_co)%r81d, & rio_g_sb_laweight_co => this%rvars(ir_g_sb_laweight_co)%r81d, & rio_height_co => this%rvars(ir_height_co)%r81d, & rio_laimemory_co => this%rvars(ir_laimemory_co)%r81d, & @@ -2437,14 +2449,14 @@ subroutine get_restart_vectors(this, nc, nsites, sites) rio_gpp_acc_hold_co => this%rvars(ir_gpp_acc_hold_co)%r81d, & rio_resp_acc_hold_co => this%rvars(ir_resp_acc_hold_co)%r81d, & rio_npp_acc_hold_co => this%rvars(ir_npp_acc_hold_co)%r81d, & - rio_resp_m_def_co => this%rvars(ir_resp_m_def_co)%r81d, & + rio_resp_m_def_co => this%rvars(ir_resp_m_def_co)%r81d, & rio_bmort_co => this%rvars(ir_bmort_co)%r81d, & rio_hmort_co => this%rvars(ir_hmort_co)%r81d, & rio_cmort_co => this%rvars(ir_cmort_co)%r81d, & - rio_daily_n_uptake_co => this%rvars(ir_daily_n_uptake_co)%r81d, & - rio_daily_p_uptake_co => this%rvars(ir_daily_p_uptake_co)%r81d, & - rio_daily_c_efflux_co => this%rvars(ir_daily_c_efflux_co)%r81d, & - rio_daily_n_efflux_co => this%rvars(ir_daily_n_efflux_co)%r81d, & + rio_daily_n_uptake_co => this%rvars(ir_daily_n_uptake_co)%r81d, & + rio_daily_p_uptake_co => this%rvars(ir_daily_p_uptake_co)%r81d, & + rio_daily_c_efflux_co => this%rvars(ir_daily_c_efflux_co)%r81d, & + rio_daily_n_efflux_co => this%rvars(ir_daily_n_efflux_co)%r81d, & rio_daily_p_efflux_co => this%rvars(ir_daily_p_efflux_co)%r81d, & rio_daily_n_demand_co => this%rvars(ir_daily_n_demand_co)%r81d, & rio_daily_p_demand_co => this%rvars(ir_daily_p_demand_co)%r81d, & @@ -2493,15 +2505,15 @@ subroutine get_restart_vectors(this, nc, nsites, sites) rio_fmortcflux_cano_si => this%rvars(ir_fmortcflux_cano_si)%r81d, & rio_fmortcflux_usto_si => this%rvars(ir_fmortcflux_usto_si)%r81d) !rio_c_area_co => this%rvars(ir_c_area_co)%r81d) - + totalcohorts = 0 - + do s = 1,nsites - + io_idx_si = this%restart_map(nc)%site_index(s) io_idx_co_1st = this%restart_map(nc)%cohort1_index(s) - + io_idx_co = io_idx_co_1st io_idx_pa_ib = io_idx_co_1st io_idx_si_wmem = io_idx_co_1st @@ -2514,13 +2526,13 @@ subroutine get_restart_vectors(this, nc, nsites, sites) io_idx_si_sc = io_idx_co_1st io_idx_si_capf = io_idx_co_1st io_idx_si_cacls= io_idx_co_1st - + ! read seed_bank info(site-level, but PFT-resolved) - do i_pft = 1,numpft + do i_pft = 1,numpft sites(s)%recruitment_rate(i_pft) = rio_recrate_sift(io_idx_co_1st+i_pft-1) enddo - - !variables for fixed biogeography mode. These are currently used in restart even when this is off. + + !variables for fixed biogeography mode. These are currently used in restart even when this is off. do i_pft = 1,numpft sites(s)%use_this_pft(i_pft) = rio_use_this_pft_sift(io_idx_co_1st+i_pft-1) sites(s)%area_pft(i_pft) = rio_area_pft_sift(io_idx_co_1st+i_pft-1) @@ -2532,13 +2544,13 @@ subroutine get_restart_vectors(this, nc, nsites, sites) io_idx_si_cwd = io_idx_co_1st io_idx_si_pft = io_idx_co_1st io_idx_si_scpf = io_idx_co_1st - + do i_cwd=1,ncwd sites(s)%flux_diags(el)%cwd_ag_input(i_cwd) = this%rvars(ir_cwdagin_flxdg+el-1)%r81d(io_idx_si_cwd) sites(s)%flux_diags(el)%cwd_bg_input(i_cwd) = this%rvars(ir_cwdbgin_flxdg+el-1)%r81d(io_idx_si_cwd) io_idx_si_cwd = io_idx_si_cwd + 1 end do - + do i_pft=1,numpft sites(s)%flux_diags(el)%leaf_litter_input(i_pft) = this%rvars(ir_leaflittin_flxdg+el-1)%r81d(io_idx_si_pft) sites(s)%flux_diags(el)%root_litter_input(i_pft) = this%rvars(ir_rootlittin_flxdg+el-1)%r81d(io_idx_si_pft) @@ -2554,34 +2566,34 @@ subroutine get_restart_vectors(this, nc, nsites, sites) io_idx_si_scpf = io_idx_si_scpf + 1 end do end do - - + + sites(s)%mass_balance(el)%old_stock = this%rvars(ir_oldstock_mbal+el-1)%r81d(io_idx_si) sites(s)%mass_balance(el)%err_fates = this%rvars(ir_errfates_mbal+el-1)%r81d(io_idx_si) end do - sites(s)%spread = rio_spread_si(io_idx_si) - + sites(s)%spread = rio_spread_si(io_idx_si) + ! Perform a check on the number of patches per site patchespersite = 0 - + cpatch => sites(s)%oldest_patch do while(associated(cpatch)) - + patchespersite = patchespersite + 1 - + ccohort => cpatch%shortest - + ! new patch, reset num cohorts cohortsperpatch = 0 - - do while(associated(ccohort)) - + + do while(associated(ccohort)) + ! found cohort, increment cohortsperpatch = cohortsperpatch + 1 totalcohorts = totalcohorts + 1 - + if ( debug ) then write(fates_log(),*) 'CVTL io_idx_co ',io_idx_co endif @@ -2593,7 +2605,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ir_prt_var = ir_prt_base do i_var = 1, prt_global%num_vars - do i_pos = 1, prt_global%state_descriptor(i_var)%num_pos + do i_pos = 1, prt_global%state_descriptor(i_var)%num_pos ir_prt_var = ir_prt_var + 1 ccohort%prt%variables(i_var)%val(i_pos) = & @@ -2609,13 +2621,13 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ir_prt_var = ir_prt_var + 1 ccohort%prt%variables(i_var)%burned(i_pos) = & - this%rvars(ir_prt_var)%r81d(io_idx_co) + this%rvars(ir_prt_var)%r81d(io_idx_co) end do end do - !ccohort%vcmax25top + !ccohort%vcmax25top !ccohort%jmax25top - !ccohort%tpu25top + !ccohort%tpu25top !ccohort%kp25top @@ -2646,15 +2658,15 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ccohort%smort = rio_smort_co(io_idx_co) ccohort%asmort = rio_asmort_co(io_idx_co) ccohort%frmort = rio_frmort_co(io_idx_co) - + ! Nutrient uptake / efflux ccohort%daily_n_uptake = rio_daily_n_uptake_co(io_idx_co) ccohort%daily_p_uptake = rio_daily_p_uptake_co(io_idx_co) ccohort%daily_c_efflux = rio_daily_c_efflux_co(io_idx_co) ccohort%daily_n_efflux = rio_daily_n_efflux_co(io_idx_co) ccohort%daily_p_efflux = rio_daily_p_efflux_co(io_idx_co) - - ccohort%daily_n_demand = rio_daily_n_demand_co(io_idx_co) + + ccohort%daily_n_demand = rio_daily_n_demand_co(io_idx_co) ccohort%daily_p_demand = rio_daily_p_demand_co(io_idx_co) ccohort%daily_n_need2 = rio_daily_n_need_co(io_idx_co) ccohort%daily_p_need2 = rio_daily_p_need_co(io_idx_co) @@ -2676,18 +2688,18 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ! Initialize Plant Hydraulics if(hlm_use_planthydro==itrue)then - + ! Load the water contents call this%GetCohortRealVector(ccohort%co_hydr%th_ag,n_hypool_ag, & ir_hydro_th_ag_covec,io_idx_co) call this%GetCohortRealVector(ccohort%co_hydr%th_aroot,sites(s)%si_hydr%nlevrhiz, & ir_hydro_th_aroot_covec,io_idx_co) - + ccohort%co_hydr%th_troot = this%rvars(ir_hydro_th_troot)%r81d(io_idx_co) - + call UpdatePlantPsiFTCFromTheta(ccohort,sites(s)%si_hydr) - + ccohort%co_hydr%errh2o_growturn_aroot = & this%rvars(ir_hydro_err_growturn_aroot)%r81d(io_idx_co) ccohort%co_hydr%errh2o_growturn_troot = & @@ -2701,12 +2713,14 @@ subroutine get_restart_vectors(this, nc, nsites, sites) if (hlm_use_sp .eq. itrue) then !ccohort%c_area = rio_c_area_co(io_idx_co) ccohort%c_area = this%rvars(ir_c_area_co)%r81d(io_idx_co) + ccohort%npp_tstep = this%rvars(ir_npp_tstep_co)%r81d(io_idx_co) + ccohort%gpp_tstep = this%rvars(ir_gpp_tstep_co)%r81d(io_idx_co) end if - + io_idx_co = io_idx_co + 1 - + ccohort => ccohort%taller - + enddo ! current cohort do while if(cohortsperpatch .ne. rio_ncohort_pa(io_idx_co_1st)) then @@ -2731,20 +2745,20 @@ subroutine get_restart_vectors(this, nc, nsites, sites) cpatch%solar_zenith_angle = rio_solar_zenith_angle_pa(io_idx_co_1st) ! set cohorts per patch for IO - + if ( debug ) then write(fates_log(),*) 'CVTL III ' & ,io_idx_co,cohortsperpatch endif - + ! -------------------------------------------------------------------------- ! Pull litter from the restart arrays - ! Each element has its own variable, so we have to make sure - ! we keep re-setting this + ! Each element has its own variable, so we have to make sure + ! we keep re-setting this ! -------------------------------------------------------------------------- do el = 0, num_elements-1 - + io_idx_pa_pft = io_idx_co_1st io_idx_pa_cwd = io_idx_co_1st io_idx_pa_cwsl = io_idx_co_1st @@ -2770,13 +2784,13 @@ subroutine get_restart_vectors(this, nc, nsites, sites) io_idx_pa_dcsl = io_idx_pa_dcsl + 1 end do end do - + do i = 1,ncwd litt%ag_cwd(i) = this%rvars(ir_agcwd_litt+el)%r81d(io_idx_pa_cwd) litt%ag_cwd_frag(i) = this%rvars(ir_agcwd_frag_litt+el)%r81d(io_idx_pa_cwd) io_idx_pa_cwd = io_idx_pa_cwd + 1 - + do ilyr=1,nlevsoil litt%bg_cwd(i,ilyr) = this%rvars(ir_bgcwd_litt+el)%r81d(io_idx_pa_cwsl) litt%bg_cwd_frag(i,ilyr) = this%rvars(ir_bgcwd_frag_litt+el)%r81d(io_idx_pa_cwsl) @@ -2794,30 +2808,30 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ! Now increment the position of the first cohort to that of the next ! patch - + io_idx_co_1st = io_idx_co_1st + fates_maxElementsPerPatch - + ! and max the number of allowed cohorts per patch io_idx_pa_pft = io_idx_co_1st io_idx_pa_cwd = io_idx_co_1st io_idx_pa_ib = io_idx_co_1st io_idx_co = io_idx_co_1st - + if ( debug ) then write(fates_log(),*) 'CVTL io_idx_co_1st ', io_idx_co_1st write(fates_log(),*) 'CVTL cohortsperpatch ', cohortsperpatch write(fates_log(),*) 'CVTL totalCohorts ', totalCohorts end if - + cpatch => cpatch%younger - + enddo ! patch do while - + if(patchespersite .ne. rio_npatch_si(io_idx_si)) then write(fates_log(),*) 'Number of patches per site during retrieval does not match allocation' call endrun(msg=errMsg(sourcefile, __LINE__)) end if - + do i = 1,numWaterMem sites(s)%water_memory(i) = rio_watermem_siwm( io_idx_si_wmem ) io_idx_si_wmem = io_idx_si_wmem + 1 @@ -2832,7 +2846,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ! Retrieve site-level hydraulics arrays ! Note that Hydraulics structures, their allocations, and the length ! declaration nlevsoi_hyd should be allocated early on when the code first - ! allocates sites (before restart info), and when the soils layer is + ! allocates sites (before restart info), and when the soils layer is ! first known. ! ----------------------------------------------------------------------------- @@ -2855,7 +2869,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) end do end if - + ! Fill the site level diagnostics arrays ! ----------------------------------------------------------------------------- @@ -2868,7 +2882,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) sites(s)%fmort_rate_ustory(i_scls, i_pft) = rio_fmortrate_usto_siscpf(io_idx_si_scpf) sites(s)%imort_rate(i_scls, i_pft) = rio_imortrate_siscpf(io_idx_si_scpf) sites(s)%fmort_rate_crown(i_scls, i_pft) = rio_fmortrate_crown_siscpf(io_idx_si_scpf) - sites(s)%fmort_rate_cambial(i_scls, i_pft) = rio_fmortrate_cambi_siscpf(io_idx_si_scpf) + sites(s)%fmort_rate_cambial(i_scls, i_pft) = rio_fmortrate_cambi_siscpf(io_idx_si_scpf) sites(s)%term_nindivs_canopy(i_scls,i_pft) = rio_termnindiv_cano_siscpf(io_idx_si_scpf) sites(s)%term_nindivs_ustory(i_scls,i_pft) = rio_termnindiv_usto_siscpf(io_idx_si_scpf) sites(s)%growthflux_fusion(i_scls, i_pft) = rio_growflx_fusion_siscpf(io_idx_si_scpf) @@ -2877,7 +2891,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) sites(s)%demotion_rate(i_scls) = rio_demorate_sisc(io_idx_si_sc) sites(s)%promotion_rate(i_scls) = rio_promrate_sisc(io_idx_si_sc) - + io_idx_si_sc = io_idx_si_sc + 1 end do @@ -2889,7 +2903,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) sites(s)%fmort_carbonflux_canopy = rio_fmortcflux_cano_si(io_idx_si) sites(s)%fmort_carbonflux_ustory = rio_fmortcflux_usto_si(io_idx_si) - + ! Site level phenology status flags sites(s)%cstatus = rio_cd_status_si(io_idx_si) @@ -2910,10 +2924,10 @@ subroutine get_restart_vectors(this, nc, nsites, sites) if ( debug ) then write(fates_log(),*) 'CVTL total cohorts ',totalCohorts end if - + end associate end subroutine get_restart_vectors - + ! ==================================================================================== subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) @@ -2942,12 +2956,12 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) integer :: ifp ! patch counter do s = 1, nsites - + ifp = 0 currentpatch => sites(s)%oldest_patch - do while (associated(currentpatch)) + do while (associated(currentpatch)) ifp = ifp+1 - + currentPatch%f_sun (:,:,:) = 0._r8 currentPatch%fabd_sun_z (:,:,:) = 0._r8 currentPatch%fabd_sha_z (:,:,:) = 0._r8 @@ -2961,7 +2975,7 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) currentPatch%nrmlzd_parprof_pft_dif_z(:,:,:,:) = 0._r8 currentPatch%nrmlzd_parprof_dir_z(:,:,:) = 0._r8 currentPatch%nrmlzd_parprof_dif_z(:,:,:) = 0._r8 - + ! ----------------------------------------------------------- ! When calling norman radiation from the short-timestep ! we are passing in boundary conditions to set the following @@ -2969,9 +2983,9 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) ! currentPatch%solar_zenith_flag (is there daylight?) ! currentPatch%solar_zenith_angle (what is the value?) ! ----------------------------------------------------------- - + if(currentPatch%solar_zenith_flag)then - + bc_out(s)%albd_parb(ifp,:) = 0._r8 ! output HLM bc_out(s)%albi_parb(ifp,:) = 0._r8 ! output HLM bc_out(s)%fabi_parb(ifp,:) = 0._r8 ! output HLM @@ -2979,10 +2993,10 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) bc_out(s)%ftdd_parb(ifp,:) = 1._r8 ! output HLM bc_out(s)%ftid_parb(ifp,:) = 1._r8 ! output HLM bc_out(s)%ftii_parb(ifp,:) = 1._r8 ! output HLM - + if (maxval(currentPatch%nrad(1,:))==0)then - !there are no leaf layers in this patch. it is effectively bare ground. - ! no radiation is absorbed + !there are no leaf layers in this patch. it is effectively bare ground. + ! no radiation is absorbed bc_out(s)%fabd_parb(ifp,:) = 0.0_r8 bc_out(s)%fabi_parb(ifp,:) = 0.0_r8 do ib = 1,hlm_numSWb @@ -2996,7 +3010,7 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) bc_out(s)%ftii_parb(ifp,ib)= 1.0_r8 enddo else - + call PatchNormanRadiation (currentPatch, & bc_out(s)%albd_parb(ifp,:), & bc_out(s)%albi_parb(ifp,:), & @@ -3005,14 +3019,14 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) bc_out(s)%ftdd_parb(ifp,:), & bc_out(s)%ftid_parb(ifp,:), & bc_out(s)%ftii_parb(ifp,:)) - - endif ! is there vegetation? - + + endif ! is there vegetation? + end if ! if the vegetation and zenith filter is active currentPatch => currentPatch%younger end do ! Loop linked-list patches enddo ! Loop Sites - + return end subroutine update_3dpatch_radiation From 64c53d380f6765f2e6a076a5c4ba57bafc485ac9 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 23 Jun 2021 23:22:14 -0600 Subject: [PATCH 171/209] Revert "adding instantaneous gpp and npp to restart" This reverts commit 7fe7af7e7298db25e55d45e5cc43157a79ea38db. --- main/FatesRestartInterfaceMod.F90 | 670 +++++++++++++++--------------- 1 file changed, 328 insertions(+), 342 deletions(-) diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 50984091ed..acdbdab904 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -15,7 +15,7 @@ module FatesRestartInterfaceMod use FatesIOVariableKindMod, only : fates_io_variable_kind_type use FatesRestartVariableMod, only : fates_restart_variable_type use FatesInterfaceTypesMod, only : nlevcoage - use FatesInterfaceTypesMod, only : bc_in_type + use FatesInterfaceTypesMod, only : bc_in_type use FatesInterfaceTypesMod, only : bc_out_type use FatesInterfaceTypesMod, only : hlm_use_planthydro use FatesInterfaceTypesMod, only : hlm_use_sp @@ -72,11 +72,11 @@ module FatesRestartInterfaceMod ! ls: layer sublayer dimension (fine discretization of upper,lower) ! wm: the number of memory slots for water (currently 10) ! ------------------------------------------------------------- - - + + ! Indices to the restart variable object - integer :: ir_npatch_si + integer :: ir_npatch_si integer :: ir_cd_status_si integer :: ir_dd_status_si integer :: ir_nchill_days_si @@ -115,8 +115,6 @@ module FatesRestartInterfaceMod integer :: ir_smort_co integer :: ir_asmort_co integer :: ir_c_area_co - integer :: ir_gpp_tstep_co - integer :: ir_npp_tstep_co integer :: ir_daily_n_uptake_co integer :: ir_daily_p_uptake_co @@ -127,7 +125,7 @@ module FatesRestartInterfaceMod integer :: ir_daily_p_demand_co integer :: ir_daily_n_need_co integer :: ir_daily_p_need_co - + !Logging integer :: ir_lmort_direct_co integer :: ir_lmort_collateral_co @@ -208,7 +206,7 @@ module FatesRestartInterfaceMod ! Hydraulic indices integer :: ir_hydro_th_ag_covec integer :: ir_hydro_th_troot - integer :: ir_hydro_th_aroot_covec + integer :: ir_hydro_th_aroot_covec integer :: ir_hydro_liqvol_shell_si integer :: ir_hydro_err_growturn_aroot integer :: ir_hydro_err_growturn_ag_covec @@ -225,12 +223,12 @@ module FatesRestartInterfaceMod ! integer constants for storing logical data integer, parameter, public :: old_cohort = 0 - integer, parameter, public :: new_cohort = 1 + integer, parameter, public :: new_cohort = 1 real(r8), parameter, public :: flushinvalid = -9999.0 real(r8), parameter, public :: flushzero = 0.0 real(r8), parameter, public :: flushone = 1.0 - + ! Local debug flag logical, parameter, public :: debug=.false. @@ -257,20 +255,20 @@ module FatesRestartInterfaceMod ! Instanteate one registry of the different dimension/kinds (dk) ! All output variables will have a pointer to one of these dk's type(fates_io_variable_kind_type) :: dim_kinds(fates_restart_num_dim_kinds) - + ! This is a structure that explains where FATES patch boundaries ! on each thread point to in the host IO array, this structure is ! allocated by number of threads. This could be dynamically ! allocated, but is unlikely to change...? ! Note: history io also instanteates fates_io_dimension_type type(fates_io_dimension_type) :: dim_bounds(fates_restart_num_dimensions) - + type(restart_map_type), pointer :: restart_map(:) integer, private :: cohort_index_, column_index_ contains - + ! public functions procedure :: Init procedure :: SetThreadBoundsEach @@ -283,7 +281,7 @@ module FatesRestartInterfaceMod procedure :: create_patchcohort_structure procedure :: get_restart_vectors procedure :: update_3dpatch_radiation - + ! private work functions procedure, private :: init_dim_kinds_maps procedure, private :: set_dim_indices @@ -299,15 +297,15 @@ module FatesRestartInterfaceMod end type fates_restart_interface_type - + contains ! ===================================================================================== - + subroutine Init(this, num_threads, fates_bounds) - + use FatesIODimensionsMod, only : fates_bounds_type, column, cohort implicit none @@ -332,13 +330,13 @@ subroutine Init(this, num_threads, fates_bounds) ! Allocate the mapping between FATES indices and the IO indices allocate(this%restart_map(num_threads)) - - end subroutine Init + + end subroutine Init ! ====================================================================== subroutine SetThreadBoundsEach(this, thread_index, thread_bounds) - + use FatesIODimensionsMod, only : fates_bounds_type implicit none @@ -349,25 +347,25 @@ subroutine SetThreadBoundsEach(this, thread_index, thread_bounds) type(fates_bounds_type), intent(in) :: thread_bounds integer :: index - + index = this%cohort_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%cohort_begin, thread_bounds%cohort_end) - + index = this%column_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%column_begin, thread_bounds%column_end) - + end subroutine SetThreadBoundsEach ! =================================================================================== subroutine assemble_restart_output_types(this) - + use FatesIOVariableKindMod, only : site_r8, site_int, cohort_r8, cohort_int implicit none - + class(fates_restart_interface_type), intent(inout) :: this call this%init_dim_kinds_maps() @@ -381,7 +379,7 @@ subroutine assemble_restart_output_types(this) end subroutine assemble_restart_output_types ! =================================================================================== - + subroutine set_dim_indices(this, dk_name, idim, dim_index) use FatesIOVariableKindMod , only : iotype_index @@ -430,13 +428,13 @@ subroutine set_cohort_index(this, index) integer, intent(in) :: index this%cohort_index_ = index end subroutine set_cohort_index - + integer function cohort_index(this) implicit none class(fates_restart_interface_type), intent(in) :: this cohort_index = this%cohort_index_ end function cohort_index - + ! ======================================================================= subroutine set_column_index(this, index) @@ -445,17 +443,17 @@ subroutine set_column_index(this, index) integer, intent(in) :: index this%column_index_ = index end subroutine set_column_index - + integer function column_index(this) implicit none class(fates_restart_interface_type), intent(in) :: this column_index = this%column_index_ end function column_index - + ! ======================================================================= subroutine init_dim_kinds_maps(this) - + ! ---------------------------------------------------------------------------------- ! This subroutine simply initializes the structures that define the different ! array and type formats for different IO variables @@ -470,9 +468,9 @@ subroutine init_dim_kinds_maps(this) ! ! ---------------------------------------------------------------------------------- use FatesIOVariableKindMod, only : site_r8, site_int, cohort_r8, cohort_int - + implicit none - + ! Arguments class(fates_restart_interface_type), intent(inout) :: this @@ -501,17 +499,17 @@ end subroutine init_dim_kinds_maps ! ==================================================================================== integer function num_restart_vars(this) - + implicit none class(fates_restart_interface_type), intent(in) :: this num_restart_vars = this%num_restart_vars_ - + end function num_restart_vars - + ! ==================================================================================== - + subroutine initialize_restart_vars(this) implicit none @@ -524,16 +522,16 @@ subroutine initialize_restart_vars(this) ! Allocate the list of restart output variable objects allocate(this%rvars(this%num_restart_vars())) - + ! construct the object that defines all of the IO variables call this%define_restart_vars(initialize_variables=.true.) - + end subroutine initialize_restart_vars ! ====================================================================================== subroutine flush_rvars(this,nc) - + class(fates_restart_interface_type) :: this integer,intent(in) :: nc @@ -546,17 +544,17 @@ subroutine flush_rvars(this,nc) call rvar%Flush(nc, this%dim_bounds, this%dim_kinds) end associate end do - + end subroutine flush_rvars - + ! ==================================================================================== - + subroutine define_restart_vars(this, initialize_variables) - + ! --------------------------------------------------------------------------------- - ! + ! ! REGISTRY OF RESTART OUTPUT VARIABLES ! ! Please add any restart variables to this registry. This registry will handle @@ -564,19 +562,19 @@ subroutine define_restart_vars(this, initialize_variables) ! variables. Note that restarts are only using 1D vectors in ALM and CLM. If you ! have a multi-dimensional variable that is below the cohort scale, then pack ! that variable into a cohort-sized output array by giving it a vtype "cohort_r8" - ! or "cohort_int". + ! or "cohort_int". ! ! Unlike history variables, restarts flush to zero. ! --------------------------------------------------------------------------------- - + use FatesIOVariableKindMod, only : site_r8, site_int, cohort_int, cohort_r8 implicit none - + class(fates_restart_interface_type), intent(inout) :: this logical, intent(in) :: initialize_variables ! are we 'count'ing or 'initializ'ing? integer :: ivar - - + + ivar=0 ! ----------------------------------------------------------------------------------- @@ -622,7 +620,7 @@ subroutine define_restart_vars(this, initialize_variables) call this%set_restart_var(vname='fates_acc_nesterov_id', vtype=site_r8, & long_name='a nesterov index accumulator', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_acc_ni_si ) - + call this%set_restart_var(vname='fates_gdd_site', vtype=site_r8, & long_name='growing degree days at each site', units='degC days', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_gdd_si ) @@ -648,7 +646,7 @@ subroutine define_restart_vars(this, initialize_variables) call this%set_restart_var(vname='fates_solar_zenith_flag_pa', vtype=cohort_int, & long_name='switch specifying if zenith is positive', units='unitless', flushval = flushinvalid, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_solar_zenith_flag_pa ) - + call this%set_restart_var(vname='fates_solar_zenith_angle_pa', vtype=cohort_r8, & long_name='the angle of the solar zenith for each patch', units='radians', flushval = flushinvalid, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_solar_zenith_angle_pa ) @@ -685,7 +683,7 @@ subroutine define_restart_vars(this, initialize_variables) call this%set_restart_var(vname='fates_coage', vtype=cohort_r8, & long_name='ed cohort - age in days', units='days', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_coage_co ) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_coage_co ) call this%set_restart_var(vname='fates_height', vtype=cohort_r8, & long_name='ed cohort - plant height', units='m', flushval = flushzero, & @@ -700,12 +698,12 @@ subroutine define_restart_vars(this, initialize_variables) long_name='ed cohort - target sapwood biomass set from prev year', & units='kgC/indiv', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_sapwmemory_co ) - + call this%set_restart_var(vname='fates_structmemory', vtype=cohort_r8, & long_name='ed cohort - target structural biomass set from prev year', & units='kgC/indiv', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_structmemory_co ) - + call this%set_restart_var(vname='fates_nplant', vtype=cohort_r8, & long_name='ed cohort - number of plants in the cohort', & units='/patch', flushval = flushzero, & @@ -745,7 +743,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name='ed cohort - maintenance respiration deficit', & units='kgC/indiv', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_resp_m_def_co ) - + call this%set_restart_var(vname='fates_bmort', vtype=cohort_r8, & long_name='ed cohort - background mortality rate', & units='/year', flushval = flushzero, & @@ -780,7 +778,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name='fates cohort- daily nitrogen efflux', & units='kg/plant/day', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_daily_n_efflux_co ) - + call this%set_restart_var(vname='fates_daily_p_efflux', vtype=cohort_r8, & long_name='fates cohort- daily phosphorus efflux', & units='kg/plant/day', flushval = flushzero, & @@ -805,7 +803,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name='fates cohort- daily nitrogen need', & units='kgN/plant/day', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_daily_n_need_co ) - + call this%set_restart_var(vname='fates_frmort', vtype=cohort_r8, & long_name='ed cohort - freezing mortality rate', & units='/year', flushval = flushzero, & @@ -818,7 +816,7 @@ subroutine define_restart_vars(this, initialize_variables) call this%set_restart_var(vname='fates_asmort', vtype=cohort_r8, & long_name='ed cohort - age senescence mortality rate', & - units = '/year', flushval = flushzero, & + units = '/year', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_asmort_co ) call this%set_restart_var(vname='fates_lmort_direct', vtype=cohort_r8, & @@ -829,12 +827,12 @@ subroutine define_restart_vars(this, initialize_variables) call this%set_restart_var(vname='fates_lmort_collateral', vtype=cohort_r8, & long_name='ed cohort - collateral mortality rate', & units='%/event', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_lmort_collateral_co ) - + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_lmort_collateral_co ) + call this%set_restart_var(vname='fates_lmort_in', vtype=cohort_r8, & long_name='ed cohort - mechanical mortality rate', & units='%/event', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_lmort_infra_co ) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_lmort_infra_co ) call this%set_restart_var(vname='fates_ddbhdt', vtype=cohort_r8, & long_name='ed cohort - differential: ddbh/dt', & @@ -918,23 +916,23 @@ subroutine define_restart_vars(this, initialize_variables) call this%RegisterCohortVector(symbol_base='fates_ag_cwd', vtype=cohort_r8, & long_name_base='above ground CWD', & units='kg/m2', veclength=num_elements, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_agcwd_litt) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_agcwd_litt) call this%RegisterCohortVector(symbol_base='fates_bg_cwd', vtype=cohort_r8, & long_name_base='below ground CWD', & units='kg/m2', veclength=num_elements, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_bgcwd_litt) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_bgcwd_litt) call this%RegisterCohortVector(symbol_base='fates_leaf_fines', vtype=cohort_r8, & long_name_base='above ground leaf litter', & units='kg/m2', veclength=num_elements, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_leaf_litt) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_leaf_litt) call this%RegisterCohortVector(symbol_base='fates_fnrt_fines', vtype=cohort_r8, & long_name_base='fine root litter', & units='kg/m2', veclength=num_elements, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fnrt_litt) - + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fnrt_litt) + call this%RegisterCohortVector(symbol_base='fates_seed', vtype=cohort_r8, & long_name_base='seed bank (non-germinated)', & units='kg/m2', veclength=num_elements, flushval = flushzero, & @@ -948,18 +946,18 @@ subroutine define_restart_vars(this, initialize_variables) call this%RegisterCohortVector(symbol_base='fates_ag_cwd_frag', vtype=cohort_r8, & long_name_base='above ground CWD frag flux', & units='kg/m2/day', veclength=num_elements, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_agcwd_frag_litt) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_agcwd_frag_litt) call this%RegisterCohortVector(symbol_base='fates_bg_cwd_frag', vtype=cohort_r8, & long_name_base='below ground CWD frag flux', & units='kg/m2/day', veclength=num_elements, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_bgcwd_frag_litt) - + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_bgcwd_frag_litt) + call this%RegisterCohortVector(symbol_base='fates_lfines_frag', vtype=cohort_r8, & long_name_base='frag flux from leaf fines', & units='kg/m2/day', veclength=num_elements, flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_lfines_frag_litt) - + call this%RegisterCohortVector(symbol_base='fates_rfines_frag', vtype=cohort_r8, & long_name_base='frag flux from froot fines', & units='kg/m2/day', veclength=num_elements, flushval = flushzero, & @@ -998,20 +996,20 @@ subroutine define_restart_vars(this, initialize_variables) units='kg/day/ha', veclength=num_elements, flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_uptake_flxdg) - + ! Site level Mass Balance State Accounting call this%RegisterCohortVector(symbol_base='fates_oldstock', vtype=site_r8, & long_name_base='Previous total mass of all fates state variables', & units='kg/ha', veclength=num_elements, flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_oldstock_mbal) - + call this%RegisterCohortVector(symbol_base='fates_errfates', vtype=site_r8, & long_name_base='Previous total mass of error fates state variables', & units='kg/ha', veclength=num_elements, flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_errfates_mbal) - - + + ! Only register satellite phenology related restart variables if it is turned on! if(hlm_use_sp .eq. itrue) then @@ -1019,19 +1017,11 @@ subroutine define_restart_vars(this, initialize_variables) 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_gpp_tstep', vtype=cohort_r8, & - long_name='instantaneous fates gross primary production', & - units='kgC/indiv/timestep', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_gpp_tstep_co ) - call this%set_restart_var(vname='fates_npp_tstep', vtype=cohort_r8, & - long_name='instantaneous fates net primary production', & - units='kgC/indiv/timestep', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_npp_tstep_co ) end if ! Only register hydraulics restart variables if it is turned on! - + if(hlm_use_planthydro==itrue) then if ( fates_maxElementsPerSite < (nshell * nlevsoi_hyd_max) ) then @@ -1049,32 +1039,32 @@ subroutine define_restart_vars(this, initialize_variables) call this%RegisterCohortVector(symbol_base='fates_hydro_th_ag', vtype=cohort_r8, & long_name_base='water in aboveground compartments', & units='kg/plant', veclength=n_hypool_ag, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_th_ag_covec) - + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_th_ag_covec) + call this%RegisterCohortVector(symbol_base='fates_hydro_th_troot', vtype=cohort_r8, & long_name_base='water in transporting roots', & units='kg/plant', veclength=n_hypool_troot, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_th_troot) - + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_th_troot) + call this%RegisterCohortVector(symbol_base='fates_hydro_th_aroot', vtype=cohort_r8, & long_name_base='water in absorbing roots', & units='kg/plant', veclength=nlevsoi_hyd_max, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_th_aroot_covec) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_th_aroot_covec) call this%RegisterCohortVector(symbol_base='fates_hydro_err_aroot', vtype=cohort_r8, & long_name_base='error in plant-hydro balance in absorbing roots', & units='kg/plant', veclength=nlevsoi_hyd_max, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_err_growturn_aroot) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_err_growturn_aroot) call this%RegisterCohortVector(symbol_base='fates_hydro_err_ag', vtype=cohort_r8, & long_name_base='error in plant-hydro balance above ground', & units='kg/plant', veclength=n_hypool_ag, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_err_growturn_ag_covec) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_err_growturn_ag_covec) call this%RegisterCohortVector(symbol_base='fates_hydro_err_troot', vtype=cohort_r8, & long_name_base='error in plant-hydro balance above ground', & units='kg/plant', veclength=n_hypool_troot, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_err_growturn_troot) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_err_growturn_troot) ! Site-level volumentric liquid water content (shell x layer) call this%set_restart_var(vname='fates_hydro_liqvol_shell', vtype=cohort_r8, & @@ -1087,13 +1077,13 @@ subroutine define_restart_vars(this, initialize_variables) long_name='Site level water mass used for new recruits', & units='kg', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_recruit_si ) - + ! Site-level water bound in dead plants call this%set_restart_var(vname='fates_hydro_dead_h2o', vtype=site_r8, & long_name='Site level water bound in dead plants', & units='kg', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_dead_si ) - + ! Site-level water balance error due to growth/turnover call this%set_restart_var(vname='fates_hydro_growturn_err', vtype=site_r8, & long_name='Site level error for hydraulics due to growth/turnover', & @@ -1111,7 +1101,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name='Site level error for hydrodynamics', & units='kg', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_hydro_err_si ) - + end if @@ -1128,7 +1118,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name='last 10 days of 24-hour vegetation temperature, by site x day-index', & units='m3/m3', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_vegtempmem_sitm ) - + call this%set_restart_var(vname='fates_recrate', vtype=cohort_r8, & long_name='fates diagnostics on recruitment', & units='indiv/ha/day', flushval = flushzero, & @@ -1184,7 +1174,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name='fates diag: rate of indivs moving via fusion', & units='indiv/ha/day', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_growflx_fusion_siscpf) - + call this%set_restart_var(vname='fates_demorate', vtype=cohort_r8, & long_name='fates diagnoatic rate of indivs demoted', & units='indiv/ha/day', flushval = flushzero, & @@ -1199,7 +1189,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name='biomass of indivs killed due to impact mort', & units='kgC/ha/day', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_imortcflux_si) - + call this%set_restart_var(vname='fates_fmortcflux_canopy', vtype=site_r8, & long_name='fates diagnostic biomass of canopy fire', & units='gC/m2/sec', flushval = flushzero, & @@ -1237,20 +1227,20 @@ subroutine define_restart_vars(this, initialize_variables) ir_prt_base = ivar call this%DefinePRTRestartVars(initialize_variables,ivar) - - - + + + ! Must be last thing before return this%num_restart_vars_ = ivar - + end subroutine define_restart_vars - + ! ===================================================================================== - + subroutine DefinePRTRestartVars(this,initialize_variables,ivar) ! ---------------------------------------------------------------------------------- - ! PARTEH variables are objects. These objects + ! PARTEH variables are objects. These objects ! each are registered to have things like names units and symbols ! as part of that object. Thus, when defining, reading and writing restarts, ! instead of manually typing out each variable we want, we just loop through @@ -1277,7 +1267,7 @@ subroutine DefinePRTRestartVars(this,initialize_variables,ivar) class(fates_restart_interface_type) :: this logical, intent(in) :: initialize_variables integer,intent(inout) :: ivar ! global variable counter - + integer :: dummy_out ! dummy index for variable ! position in global file integer :: i_var ! loop counter for prt variables @@ -1293,12 +1283,12 @@ subroutine DefinePRTRestartVars(this,initialize_variables,ivar) ! The base symbol name symbol_base = prt_global%state_descriptor(i_var)%symbol - + ! The long name of the variable name_base = prt_global%state_descriptor(i_var)%longname do i_pos = 1, prt_global%state_descriptor(i_var)%num_pos - + ! String describing the physical position of the variable write(pos_symbol, '(I3.3)') i_pos @@ -1316,7 +1306,7 @@ subroutine DefinePRTRestartVars(this,initialize_variables,ivar) long_name=trim(long_name), & units='kg', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, & - ivar=ivar, index = dummy_out ) + ivar=ivar, index = dummy_out ) ! Register the turnover flux variables ! ---------------------------------------------------------------------------- @@ -1326,19 +1316,19 @@ subroutine DefinePRTRestartVars(this,initialize_variables,ivar) ! The expanded long name of the variable long_name = trim(name_base)//', turnover, position:'//trim(pos_symbol) - + call this%set_restart_var(vname=trim(symbol), & vtype=cohort_r8, & long_name=trim(long_name), & units='kg', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, & - ivar=ivar, index = dummy_out ) - + ivar=ivar, index = dummy_out ) + ! Register the net allocation flux variable ! ---------------------------------------------------------------------------- - + ! The symbol that is written to file symbol = trim(symbol_base)//'_net_'//trim(pos_symbol) @@ -1350,8 +1340,8 @@ subroutine DefinePRTRestartVars(this,initialize_variables,ivar) long_name=trim(long_name), & units='kg', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, & - ivar=ivar, index = dummy_out ) - + ivar=ivar, index = dummy_out ) + ! Register the burn flux variable @@ -1367,11 +1357,11 @@ subroutine DefinePRTRestartVars(this,initialize_variables,ivar) long_name=trim(long_name), & units='kg', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, & - ivar=ivar, index = dummy_out ) + ivar=ivar, index = dummy_out ) end do end do - + return end subroutine DefinePRTRestartVars @@ -1379,20 +1369,20 @@ end subroutine DefinePRTRestartVars subroutine RegisterCohortVector(this,symbol_base, vtype, long_name_base, & units, veclength, flushval, hlms, & - initialize, ivar, index) - + initialize, ivar, index) + ! The basic idea here is that instead of saving cohorts with vector data ! as long arrays in the restart file, we give each index of the vector ! its own variable. This helps reduce the size of the restart files ! considerably. - - + + use FatesIOVariableKindMod, only : cohort_r8 - + class(fates_restart_interface_type) :: this character(*),intent(in) :: symbol_base ! Symbol name without position - character(*),intent(in) :: vtype ! String defining variable type + character(*),intent(in) :: vtype ! String defining variable type character(*),intent(in) :: long_name_base ! name without position character(*),intent(in) :: units ! units for this variable integer,intent(in) :: veclength ! length of the vector @@ -1401,58 +1391,58 @@ subroutine RegisterCohortVector(this,symbol_base, vtype, long_name_base, & logical, intent(in) :: initialize ! Is this registering or counting? integer,intent(inout) :: ivar ! global variable counter integer,intent(out) :: index ! The variable index for this variable - + ! Local Variables character(len=4) :: pos_symbol ! vectors need text strings for each position character(len=128) :: symbol ! symbol name written to file character(len=256) :: long_name ! long name written to file integer :: i_pos ! loop counter for discrete position integer :: dummy_index - + ! We give each vector its own index that points to the first position - + index = ivar + 1 - + do i_pos = 1, veclength - + ! String describing the physical position of the variable write(pos_symbol, '(I3.3)') i_pos - + ! The symbol that is written to file symbol = trim(symbol_base)//'_vec_'//trim(pos_symbol) - + ! The expanded long name of the variable long_name = trim(long_name_base)//', position:'//trim(pos_symbol) - + call this%set_restart_var(vname=trim(symbol), & vtype=vtype, & long_name=trim(long_name), & units=units, flushval = flushval, & hlms='CLM:ALM', initialize=initialize, & - ivar=ivar, index = dummy_index ) - + ivar=ivar, index = dummy_index ) + end do - + end subroutine RegisterCohortVector ! ===================================================================================== - + subroutine GetCohortRealVector(this, state_vector, len_state_vector, & variable_index_base, co_global_index) - + ! This subroutine walks through global cohort vector indices ! and pulls from the different associated restart variables - + class(fates_restart_interface_type) , intent(inout) :: this integer,intent(in) :: len_state_vector real(r8),intent(inout) :: state_vector(len_state_vector) integer,intent(in) :: variable_index_base integer,intent(in) :: co_global_index - + integer :: i_pos ! vector position loop index integer :: ir_pos_var ! global variable index - + ir_pos_var = variable_index_base do i_pos = 1, len_state_vector state_vector(i_pos) = this%rvars(ir_pos_var)%r81d(co_global_index) @@ -1460,24 +1450,24 @@ subroutine GetCohortRealVector(this, state_vector, len_state_vector, & end do return end subroutine GetCohortRealVector - - ! ===================================================================================== - + + ! ===================================================================================== + subroutine SetCohortRealVector(this, state_vector, len_state_vector, & variable_index_base, co_global_index) ! This subroutine walks through global cohort vector indices ! and pushes into the restart arrays the different associated restart variables - + class(fates_restart_interface_type) , intent(inout) :: this integer,intent(in) :: len_state_vector real(r8),intent(in) :: state_vector(len_state_vector) integer,intent(in) :: variable_index_base integer,intent(in) :: co_global_index - + integer :: i_pos ! vector position loop index integer :: ir_pos_var ! global variable index - + ir_pos_var = variable_index_base do i_pos = 1, len_state_vector this%rvars(ir_pos_var)%r81d(co_global_index) = state_vector(i_pos) @@ -1485,7 +1475,7 @@ subroutine SetCohortRealVector(this, state_vector, len_state_vector, & end do return end subroutine SetCohortRealVector - + ! ===================================================================================== @@ -1499,7 +1489,7 @@ subroutine set_restart_var(this,vname,vtype,long_name,units,flushval, & class(fates_restart_interface_type) :: this character(len=*),intent(in) :: vname character(len=*),intent(in) :: vtype - character(len=*),intent(in) :: units + character(len=*),intent(in) :: units real(r8), intent(in) :: flushval character(len=*),intent(in) :: long_name character(len=*),intent(in) :: hlms @@ -1511,32 +1501,32 @@ subroutine set_restart_var(this,vname,vtype,long_name,units,flushval, & ! A zero is passed back when the variable is ! not used - + type(fates_restart_variable_type),pointer :: rvar integer :: ub1,lb1,ub2,lb2 ! Bounds for allocating the var integer :: ityp - + logical :: use_var - + use_var = check_hlm_list(trim(hlms), trim(hlm_name)) if( use_var ) then - + ivar = ivar+1 - index = ivar - + index = ivar + if( initialize )then - + call this%rvars(ivar)%Init(vname, units, long_name, vtype, flushval, & fates_restart_num_dim_kinds, this%dim_kinds, this%dim_bounds) end if else - + index = 0 end if - + return end subroutine set_restart_var @@ -1594,7 +1584,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ! Some counters (for checking mostly) integer :: totalcohorts ! total cohort count on this thread (diagnostic) integer :: patchespersite ! number of patches per site - integer :: cohortsperpatch ! number of cohorts per patch + integer :: cohortsperpatch ! number of cohorts per patch integer :: ft ! functional type index integer :: el ! element loop index @@ -1649,14 +1639,14 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_gpp_acc_hold_co => this%rvars(ir_gpp_acc_hold_co)%r81d, & rio_resp_acc_hold_co => this%rvars(ir_resp_acc_hold_co)%r81d, & rio_npp_acc_hold_co => this%rvars(ir_npp_acc_hold_co)%r81d, & - rio_resp_m_def_co => this%rvars(ir_resp_m_def_co)%r81d, & + rio_resp_m_def_co => this%rvars(ir_resp_m_def_co)%r81d, & rio_bmort_co => this%rvars(ir_bmort_co)%r81d, & rio_hmort_co => this%rvars(ir_hmort_co)%r81d, & rio_cmort_co => this%rvars(ir_cmort_co)%r81d, & rio_daily_n_uptake_co => this%rvars(ir_daily_n_uptake_co)%r81d, & rio_daily_p_uptake_co => this%rvars(ir_daily_p_uptake_co)%r81d, & - rio_daily_c_efflux_co => this%rvars(ir_daily_c_efflux_co)%r81d, & - rio_daily_n_efflux_co => this%rvars(ir_daily_n_efflux_co)%r81d, & + rio_daily_c_efflux_co => this%rvars(ir_daily_c_efflux_co)%r81d, & + rio_daily_n_efflux_co => this%rvars(ir_daily_n_efflux_co)%r81d, & rio_daily_p_efflux_co => this%rvars(ir_daily_p_efflux_co)%r81d, & rio_daily_n_demand_co => this%rvars(ir_daily_n_demand_co)%r81d, & rio_daily_p_demand_co => this%rvars(ir_daily_p_demand_co)%r81d, & @@ -1678,8 +1668,8 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_spread_si => this%rvars(ir_spread_si)%r81d, & rio_livegrass_pa => this%rvars(ir_livegrass_pa)%r81d, & rio_age_pa => this%rvars(ir_age_pa)%r81d, & - rio_patchdistturbcat_pa => this%rvars(ir_patchdistturbcat_pa)%int1d, & - rio_agesinceanthrodist_pa => this%rvars(ir_agesinceanthrodist_pa)%r81d, & + rio_patchdistturbcat_pa => this%rvars(ir_patchdistturbcat_pa)%int1d, & + rio_agesinceanthrodist_pa => this%rvars(ir_agesinceanthrodist_pa)%r81d, & rio_nocomp_pft_label_pa => this%rvars(ir_nocomp_pft_label_pa)%int1d, & rio_area_pa => this%rvars(ir_area_pa)%r81d, & rio_watermem_siwm => this%rvars(ir_watermem_siwm)%r81d, & @@ -1708,20 +1698,20 @@ subroutine set_restart_vectors(this,nc,nsites,sites) totalCohorts = 0 - + ! --------------------------------------------------------------------------------- ! Flush arrays to values defined by %flushval (see registry entry in ! subroutine define_history_vars() ! --------------------------------------------------------------------------------- call this%flush_rvars(nc) - + do s = 1,nsites - + ! Calculate the offsets ! fcolumn is the global column index of the current site. ! For the first site, if that site aligns with the first column index ! in the clump, than the offset should be be equal to begCohort - + io_idx_si = this%restart_map(nc)%site_index(s) io_idx_co_1st = this%restart_map(nc)%cohort1_index(s) @@ -1736,32 +1726,32 @@ subroutine set_restart_vectors(this,nc,nsites,sites) io_idx_si_sc = io_idx_co_1st io_idx_si_capf = io_idx_co_1st io_idx_si_cacls= io_idx_co_1st - + ! recruitment rate do i_pft = 1,numpft rio_recrate_sift(io_idx_co_1st+i_pft-1) = sites(s)%recruitment_rate(i_pft) end do - + do i_pft = 1,numpft - rio_use_this_pft_sift(io_idx_co_1st+i_pft-1) = sites(s)%use_this_pft(i_pft) + rio_use_this_pft_sift(io_idx_co_1st+i_pft-1) = sites(s)%use_this_pft(i_pft) end do - + do i_pft = 1,numpft rio_area_pft_sift(io_idx_co_1st+i_pft-1) = sites(s)%area_pft(i_pft) end do - + do el = 1, num_elements io_idx_si_cwd = io_idx_co_1st io_idx_si_pft = io_idx_co_1st io_idx_si_scpf = io_idx_co_1st - + do i_cwd=1,ncwd this%rvars(ir_cwdagin_flxdg+el-1)%r81d(io_idx_si_cwd) = sites(s)%flux_diags(el)%cwd_ag_input(i_cwd) this%rvars(ir_cwdbgin_flxdg+el-1)%r81d(io_idx_si_cwd) = sites(s)%flux_diags(el)%cwd_bg_input(i_cwd) io_idx_si_cwd = io_idx_si_cwd + 1 end do - + do i_pft=1,numpft this%rvars(ir_leaflittin_flxdg+el-1)%r81d(io_idx_si_pft) = sites(s)%flux_diags(el)%leaf_litter_input(i_pft) this%rvars(ir_rootlittin_flxdg+el-1)%r81d(io_idx_si_pft) = sites(s)%flux_diags(el)%root_litter_input(i_pft) @@ -1777,8 +1767,8 @@ subroutine set_restart_vectors(this,nc,nsites,sites) io_idx_si_scpf = io_idx_si_scpf + 1 end do end do - - + + this%rvars(ir_oldstock_mbal+el-1)%r81d(io_idx_si) = sites(s)%mass_balance(el)%old_stock this%rvars(ir_errfates_mbal+el-1)%r81d(io_idx_si) = sites(s)%mass_balance(el)%err_fates @@ -1787,31 +1777,31 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ! canopy spread term rio_spread_si(io_idx_si) = sites(s)%spread - + cpatch => sites(s)%oldest_patch - + ! new column, reset num patches patchespersite = 0 - + do while(associated(cpatch)) - + ! found patch, increment patchespersite = patchespersite + 1 - + ccohort => cpatch%shortest - + ! new patch, reset num cohorts cohortsperpatch = 0 - + do while(associated(ccohort)) - + ! found cohort, increment cohortsperpatch = cohortsperpatch + 1 totalCohorts = totalCohorts + 1 - + if ( debug ) then write(fates_log(),*) 'CLTV io_idx_co ', io_idx_co - write(fates_log(),*) 'CLTV lowerbound ', lbound(rio_npp_acc_co,1) + write(fates_log(),*) 'CLTV lowerbound ', lbound(rio_npp_acc_co,1) write(fates_log(),*) 'CLTV upperbound ', ubound(rio_npp_acc_co,1) endif @@ -1824,7 +1814,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ir_prt_var = ir_prt_base do i_var = 1, prt_global%num_vars do i_pos = 1, prt_global%state_descriptor(i_var)%num_pos - + ir_prt_var = ir_prt_var + 1 this%rvars(ir_prt_var)%r81d(io_idx_co) = & ccohort%prt%variables(i_var)%val(i_pos) @@ -1832,7 +1822,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ir_prt_var = ir_prt_var + 1 this%rvars(ir_prt_var)%r81d(io_idx_co) = & ccohort%prt%variables(i_var)%turnover(i_pos) - + ir_prt_var = ir_prt_var + 1 this%rvars(ir_prt_var)%r81d(io_idx_co) = & ccohort%prt%variables(i_var)%net_alloc(i_pos) @@ -1840,13 +1830,13 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ir_prt_var = ir_prt_var + 1 this%rvars(ir_prt_var)%r81d(io_idx_co) = & ccohort%prt%variables(i_var)%burned(i_pos) - + end do end do - + if(hlm_use_planthydro==itrue)then - + ! Load the water contents call this%SetCohortRealVector(ccohort%co_hydr%th_ag,n_hypool_ag, & ir_hydro_th_ag_covec,io_idx_co) @@ -1859,13 +1849,13 @@ subroutine set_restart_vectors(this,nc,nsites,sites) call this%setCohortRealVector(ccohort%co_hydr%errh2o_growturn_ag, & n_hypool_ag, & ir_hydro_err_growturn_ag_covec,io_idx_co) - + this%rvars(ir_hydro_err_growturn_aroot)%r81d(io_idx_co) = & ccohort%co_hydr%errh2o_growturn_aroot - + this%rvars(ir_hydro_err_growturn_troot)%r81d(io_idx_co) = & ccohort%co_hydr%errh2o_growturn_troot - + end if @@ -1897,12 +1887,12 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_cmort_co(io_idx_co) = ccohort%cmort rio_smort_co(io_idx_co) = ccohort%smort rio_asmort_co(io_idx_co) = ccohort%asmort - rio_frmort_co(io_idx_co) = ccohort%frmort + rio_frmort_co(io_idx_co) = ccohort%frmort ! Nutrient uptake/efflux rio_daily_n_uptake_co(io_idx_co) = ccohort%daily_n_uptake rio_daily_p_uptake_co(io_idx_co) = ccohort%daily_p_uptake - + rio_daily_c_efflux_co(io_idx_co) = ccohort%daily_c_efflux rio_daily_n_efflux_co(io_idx_co) = ccohort%daily_n_efflux rio_daily_p_efflux_co(io_idx_co) = ccohort%daily_p_efflux @@ -1911,7 +1901,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_daily_p_demand_co(io_idx_co) = ccohort%daily_p_demand rio_daily_n_need_co(io_idx_co) = ccohort%daily_n_need2 rio_daily_p_need_co(io_idx_co) = ccohort%daily_p_need2 - + !Logging rio_lmort_direct_co(io_idx_co) = ccohort%lmort_direct rio_lmort_collateral_co(io_idx_co) = ccohort%lmort_collateral @@ -1926,25 +1916,23 @@ subroutine set_restart_vectors(this,nc,nsites,sites) else rio_isnew_co(io_idx_co) = old_cohort endif - + if (hlm_use_sp .eq. itrue) then !rio_c_area_co(io_idx_co) = ccohort%c_area this%rvars(ir_c_area_co)%r81d(io_idx_co) = ccohort%c_area - this%rvars(ir_gpp_tstep_co)%r81d(io_idx_co) = ccohort%gpp_tstep - this%rvars(ir_npp_tstep_co)%r81d(io_idx_co) = ccohort%npp_tstep end if - + if ( debug ) then write(fates_log(),*) 'CLTV offsetNumCohorts II ',io_idx_co, & cohortsperpatch endif - + io_idx_co = io_idx_co + 1 - + ccohort => ccohort%taller - + enddo ! ccohort do while - + ! ! deal with patch level fields here ! @@ -1954,10 +1942,10 @@ subroutine set_restart_vectors(this,nc,nsites,sites) 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 - + ! set cohorts per patch for IO rio_ncohort_pa( io_idx_co_1st ) = cohortsperpatch - + ! Set zenith angle info if ( cpatch%solar_zenith_flag ) then rio_solar_zenith_flag_pa(io_idx_co_1st) = itrue @@ -1973,18 +1961,18 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ! -------------------------------------------------------------------------- ! Send litter to the restart arrays - ! Each element has its own variable, so we have to make sure - ! we keep re-setting this + ! Each element has its own variable, so we have to make sure + ! we keep re-setting this ! -------------------------------------------------------------------------- do el = 0, num_elements-1 - + io_idx_pa_pft = io_idx_co_1st io_idx_pa_cwd = io_idx_co_1st io_idx_pa_cwsl = io_idx_co_1st io_idx_pa_dcsl = io_idx_co_1st io_idx_pa_dc = io_idx_co_1st - + litt => cpatch%litter(el+1) do i = 1,numpft @@ -2004,7 +1992,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) io_idx_pa_dcsl = io_idx_pa_dcsl + 1 end do end do - + do i = 1,ncwd this%rvars(ir_agcwd_litt+el)%r81d(io_idx_pa_cwd) = litt%ag_cwd(i) this%rvars(ir_agcwd_frag_litt+el)%r81d(io_idx_pa_cwd) = litt%ag_cwd_frag(i) @@ -2018,7 +2006,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) end do - + do i = 1,maxSWb rio_gnd_alb_dif_pasb(io_idx_pa_ib) = cpatch%gnd_alb_dif(i) rio_gnd_alb_dir_pasb(io_idx_pa_ib) = cpatch%gnd_alb_dir(i) @@ -2028,29 +2016,29 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ! Set the first cohort index to the start of the next patch, increment ! by the maximum number of cohorts per patch io_idx_co_1st = io_idx_co_1st + fates_maxElementsPerPatch - + ! reset counters so that they are all advanced evenly. io_idx_pa_pft = io_idx_co_1st io_idx_pa_cwd = io_idx_co_1st io_idx_pa_ib = io_idx_co_1st io_idx_co = io_idx_co_1st - + if ( debug ) then write(fates_log(),*) 'CLTV io_idx_co_1st ', io_idx_co_1st write(fates_log(),*) 'CLTV numCohort ', cohortsperpatch write(fates_log(),*) 'CLTV totalCohorts ', totalCohorts end if - + cpatch => cpatch%younger - + enddo ! cpatch do while - + io_idx_si_scpf = io_idx_co_1st - + ! Fill the site level diagnostics arrays do i_scls = 1, nlevsclass do i_pft = 1, numpft - + rio_fmortrate_cano_siscpf(io_idx_si_scpf) = sites(s)%fmort_rate_canopy(i_scls, i_pft) rio_fmortrate_usto_siscpf(io_idx_si_scpf) = sites(s)%fmort_rate_ustory(i_scls, i_pft) rio_imortrate_siscpf(io_idx_si_scpf) = sites(s)%imort_rate(i_scls, i_pft) @@ -2059,16 +2047,16 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_termnindiv_cano_siscpf(io_idx_si_scpf) = sites(s)%term_nindivs_canopy(i_scls,i_pft) rio_termnindiv_usto_siscpf(io_idx_si_scpf) = sites(s)%term_nindivs_ustory(i_scls,i_pft) rio_growflx_fusion_siscpf(io_idx_si_scpf) = sites(s)%growthflux_fusion(i_scls, i_pft) - + io_idx_si_scpf = io_idx_si_scpf + 1 end do rio_demorate_sisc(io_idx_si_sc) = sites(s)%demotion_rate(i_scls) rio_promrate_sisc(io_idx_si_sc) = sites(s)%promotion_rate(i_scls) - + io_idx_si_sc = io_idx_si_sc + 1 end do - + rio_termcflux_cano_si(io_idx_si) = sites(s)%term_carbonflux_canopy rio_termcflux_usto_si(io_idx_si) = sites(s)%term_carbonflux_ustory rio_democflux_si(io_idx_si) = sites(s)%demotion_carbonflux @@ -2087,14 +2075,14 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_dleafondate_si(io_idx_si) = sites(s)%dleafondate rio_dleafoffdate_si(io_idx_si) = sites(s)%dleafoffdate rio_acc_ni_si(io_idx_si) = sites(s)%acc_NI - rio_gdd_si(io_idx_si) = sites(s)%grow_deg_days - + rio_gdd_si(io_idx_si) = sites(s)%grow_deg_days + ! Accumulated trunk product rio_trunk_product_si(io_idx_si) = sites(s)%resources_management%trunk_product_site ! set numpatches for this column rio_npatch_si(io_idx_si) = patchespersite - + do i = 1,numWaterMem ! numWaterMem currently 10 rio_watermem_siwm( io_idx_si_wmem ) = sites(s)%water_memory(i) io_idx_si_wmem = io_idx_si_wmem + 1 @@ -2132,18 +2120,18 @@ subroutine set_restart_vectors(this,nc,nsites,sites) end if enddo - + if ( debug ) then write(fates_log(),*) 'CLTV total cohorts ',totalCohorts end if - + return end associate end subroutine set_restart_vectors ! ==================================================================================== - subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) + subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) ! ---------------------------------------------------------------------------------- ! This subroutine takes a peak at the restart file to determine how to allocate @@ -2157,7 +2145,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) use EDTypesMod, only : ed_patch_type use EDTypesMod, only : maxSWb use FatesInterfaceTypesMod, only : fates_maxElementsPerPatch - + use EDTypesMod, only : maxpft use EDTypesMod, only : area use EDPatchDynamicsMod, only : zero_patch @@ -2166,7 +2154,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) use EDPatchDynamicsMod, only : create_patch use EDPftvarcon, only : EDPftvarcon_inst use FatesAllometryMod, only : h2d_allom - + ! !ARGUMENTS: class(fates_restart_interface_type) , intent(inout) :: this @@ -2176,7 +2164,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) type(bc_in_type) , intent(in) :: bc_in(nsites) ! local variables - + type(ed_patch_type) , pointer :: newp type(ed_cohort_type), pointer :: new_cohort type(ed_cohort_type), pointer :: prev_cohort @@ -2196,12 +2184,12 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) ! and the number of cohorts per patch. These values tell us how much ! space to allocate. ! ---------------------------------------------------------------------------------- - + associate( rio_npatch_si => this%rvars(ir_npatch_si)%int1d , & rio_ncohort_pa => this%rvars(ir_ncohort_pa)%int1d ) - + do s = 1,nsites - + io_idx_si = this%restart_map(nc)%site_index(s) io_idx_co_1st = this%restart_map(nc)%cohort1_index(s) @@ -2213,9 +2201,9 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) write(fates_log(),*) '0 is a valid number, but this column seems uninitialized',rio_npatch_si(io_idx_si) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - + ! Initialize the site pointers to null - sites(s)%youngest_patch => null() + sites(s)%youngest_patch => null() sites(s)%oldest_patch => null() do idx_pa = 1,rio_npatch_si(io_idx_si) @@ -2224,10 +2212,10 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) write(fates_log(),*) 'create patch ',idx_pa write(fates_log(),*) 'idx_pa 1-cohortsperpatch : ', rio_ncohort_pa( io_idx_co_1st ) end if - + ! create patch - allocate(newp) - nocomp_pft = fates_unset_int + allocate(newp) + nocomp_pft = fates_unset_int ! the nocomp_pft label is set after patch creation has occured in 'get_restart_vectors' ! make new patch call create_patch(sites(s), newp, fates_unset_r8, fates_unset_r8, primaryforest, nocomp_pft ) @@ -2243,16 +2231,16 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) init_seed=fates_unset_r8, & init_seed_germ=fates_unset_r8) end do - + ! give this patch a unique patch number newp%patchno = idx_pa ! Iterate over the number of cohorts ! the file says are associated with this patch - ! we are just allocating space here, so we do + ! we are just allocating space here, so we do ! a simple list filling routine - + newp%tallest => null() newp%shortest => null() prev_cohort => null() @@ -2260,7 +2248,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) do fto = 1, rio_ncohort_pa( io_idx_co_1st ) allocate(new_cohort) - call nan_cohort(new_cohort) + call nan_cohort(new_cohort) call zero_cohort(new_cohort) new_cohort%patchptr => newp @@ -2268,7 +2256,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) if (.not.associated(newp%tallest)) then newp%tallest => new_cohort endif - + ! Every cohort's taller is the one that came before ! (unless it is first) if(associated(prev_cohort)) then @@ -2284,8 +2272,8 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) new_cohort%prt => null() call InitPRTObject(new_cohort%prt) call InitPRTBoundaryConditions(new_cohort) - - + + ! Allocate hydraulics arrays if( hlm_use_planthydro.eq.itrue ) then call InitHydrCohort(sites(s),new_cohort) @@ -2293,28 +2281,28 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) ! Update the previous prev_cohort => new_cohort - + enddo ! ends loop over fto - + ! ! insert this patch with cohorts into the site pointer. At this ! point just insert the new patch in the youngest position ! if (idx_pa == 1) then ! nothing associated yet. first patch is pointed to by youngest and oldest - + if ( debug ) write(fates_log(),*) 'idx_pa = 1 ',idx_pa - - sites(s)%youngest_patch => newp - sites(s)%oldest_patch => newp + + sites(s)%youngest_patch => newp + sites(s)%oldest_patch => newp sites(s)%youngest_patch%younger => null() sites(s)%youngest_patch%older => null() sites(s)%oldest_patch%younger => null() sites(s)%oldest_patch%older => null() - + else if (idx_pa == 2) then ! add second patch to list - + if ( debug ) write(fates_log(),*) 'idx_pa = 2 ',idx_pa - + sites(s)%youngest_patch => newp sites(s)%youngest_patch%younger => null() sites(s)%youngest_patch%older => sites(s)%oldest_patch @@ -2322,25 +2310,25 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) sites(s)%oldest_patch%older => null() else ! more than 2 patches, insert patch into youngest slot - + if ( debug ) write(fates_log(),*) 'idx_pa > 2 ',idx_pa - + newp%older => sites(s)%youngest_patch sites(s)%youngest_patch%younger => newp newp%younger => null() sites(s)%youngest_patch => newp - + endif - + io_idx_co_1st = io_idx_co_1st + fates_maxElementsPerPatch enddo ! ends loop over idx_pa enddo ! ends loop over s - + end associate end subroutine create_patchcohort_structure - + ! ==================================================================================== subroutine get_restart_vectors(this, nc, nsites, sites) @@ -2387,7 +2375,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) integer :: io_idx_pa_cwd ! each cwd class within each patch (pa_cwd) integer :: io_idx_pa_cwsl ! each cwd x soil layer integer :: io_idx_pa_dcsl ! each decomposability x soil layer - integer :: io_idx_pa_dc ! each decomposability index + integer :: io_idx_pa_dc ! each decomposability index integer :: io_idx_pa_ib ! each SW radiation band per patch (pa_ib) integer :: io_idx_si_wmem ! each water memory class within each site integer :: io_idx_si_vtmem ! counter for vegetation temp memory @@ -2402,7 +2390,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ! Some counters (for checking mostly) integer :: totalcohorts ! total cohort count on this thread (diagnostic) integer :: patchespersite ! number of patches per site - integer :: cohortsperpatch ! number of cohorts per patch + integer :: cohortsperpatch ! number of cohorts per patch integer :: el ! loop counter for elements integer :: nlevsoil ! number of soil layers integer :: ilyr ! soil layer loop counter @@ -2436,7 +2424,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) rio_seed_prod_co => this%rvars(ir_seed_prod_co)%r81d, & rio_size_class_lasttimestep => this%rvars(ir_size_class_lasttimestep_co)%int1d, & rio_dbh_co => this%rvars(ir_dbh_co)%r81d, & - rio_coage_co => this%rvars(ir_coage_co)%r81d, & + rio_coage_co => this%rvars(ir_coage_co)%r81d, & rio_g_sb_laweight_co => this%rvars(ir_g_sb_laweight_co)%r81d, & rio_height_co => this%rvars(ir_height_co)%r81d, & rio_laimemory_co => this%rvars(ir_laimemory_co)%r81d, & @@ -2449,14 +2437,14 @@ subroutine get_restart_vectors(this, nc, nsites, sites) rio_gpp_acc_hold_co => this%rvars(ir_gpp_acc_hold_co)%r81d, & rio_resp_acc_hold_co => this%rvars(ir_resp_acc_hold_co)%r81d, & rio_npp_acc_hold_co => this%rvars(ir_npp_acc_hold_co)%r81d, & - rio_resp_m_def_co => this%rvars(ir_resp_m_def_co)%r81d, & + rio_resp_m_def_co => this%rvars(ir_resp_m_def_co)%r81d, & rio_bmort_co => this%rvars(ir_bmort_co)%r81d, & rio_hmort_co => this%rvars(ir_hmort_co)%r81d, & rio_cmort_co => this%rvars(ir_cmort_co)%r81d, & - rio_daily_n_uptake_co => this%rvars(ir_daily_n_uptake_co)%r81d, & - rio_daily_p_uptake_co => this%rvars(ir_daily_p_uptake_co)%r81d, & - rio_daily_c_efflux_co => this%rvars(ir_daily_c_efflux_co)%r81d, & - rio_daily_n_efflux_co => this%rvars(ir_daily_n_efflux_co)%r81d, & + rio_daily_n_uptake_co => this%rvars(ir_daily_n_uptake_co)%r81d, & + rio_daily_p_uptake_co => this%rvars(ir_daily_p_uptake_co)%r81d, & + rio_daily_c_efflux_co => this%rvars(ir_daily_c_efflux_co)%r81d, & + rio_daily_n_efflux_co => this%rvars(ir_daily_n_efflux_co)%r81d, & rio_daily_p_efflux_co => this%rvars(ir_daily_p_efflux_co)%r81d, & rio_daily_n_demand_co => this%rvars(ir_daily_n_demand_co)%r81d, & rio_daily_p_demand_co => this%rvars(ir_daily_p_demand_co)%r81d, & @@ -2505,15 +2493,15 @@ subroutine get_restart_vectors(this, nc, nsites, sites) rio_fmortcflux_cano_si => this%rvars(ir_fmortcflux_cano_si)%r81d, & rio_fmortcflux_usto_si => this%rvars(ir_fmortcflux_usto_si)%r81d) !rio_c_area_co => this%rvars(ir_c_area_co)%r81d) - + totalcohorts = 0 - + do s = 1,nsites - + io_idx_si = this%restart_map(nc)%site_index(s) io_idx_co_1st = this%restart_map(nc)%cohort1_index(s) - + io_idx_co = io_idx_co_1st io_idx_pa_ib = io_idx_co_1st io_idx_si_wmem = io_idx_co_1st @@ -2526,13 +2514,13 @@ subroutine get_restart_vectors(this, nc, nsites, sites) io_idx_si_sc = io_idx_co_1st io_idx_si_capf = io_idx_co_1st io_idx_si_cacls= io_idx_co_1st - + ! read seed_bank info(site-level, but PFT-resolved) - do i_pft = 1,numpft + do i_pft = 1,numpft sites(s)%recruitment_rate(i_pft) = rio_recrate_sift(io_idx_co_1st+i_pft-1) enddo - - !variables for fixed biogeography mode. These are currently used in restart even when this is off. + + !variables for fixed biogeography mode. These are currently used in restart even when this is off. do i_pft = 1,numpft sites(s)%use_this_pft(i_pft) = rio_use_this_pft_sift(io_idx_co_1st+i_pft-1) sites(s)%area_pft(i_pft) = rio_area_pft_sift(io_idx_co_1st+i_pft-1) @@ -2544,13 +2532,13 @@ subroutine get_restart_vectors(this, nc, nsites, sites) io_idx_si_cwd = io_idx_co_1st io_idx_si_pft = io_idx_co_1st io_idx_si_scpf = io_idx_co_1st - + do i_cwd=1,ncwd sites(s)%flux_diags(el)%cwd_ag_input(i_cwd) = this%rvars(ir_cwdagin_flxdg+el-1)%r81d(io_idx_si_cwd) sites(s)%flux_diags(el)%cwd_bg_input(i_cwd) = this%rvars(ir_cwdbgin_flxdg+el-1)%r81d(io_idx_si_cwd) io_idx_si_cwd = io_idx_si_cwd + 1 end do - + do i_pft=1,numpft sites(s)%flux_diags(el)%leaf_litter_input(i_pft) = this%rvars(ir_leaflittin_flxdg+el-1)%r81d(io_idx_si_pft) sites(s)%flux_diags(el)%root_litter_input(i_pft) = this%rvars(ir_rootlittin_flxdg+el-1)%r81d(io_idx_si_pft) @@ -2566,34 +2554,34 @@ subroutine get_restart_vectors(this, nc, nsites, sites) io_idx_si_scpf = io_idx_si_scpf + 1 end do end do - - + + sites(s)%mass_balance(el)%old_stock = this%rvars(ir_oldstock_mbal+el-1)%r81d(io_idx_si) sites(s)%mass_balance(el)%err_fates = this%rvars(ir_errfates_mbal+el-1)%r81d(io_idx_si) end do - sites(s)%spread = rio_spread_si(io_idx_si) - + sites(s)%spread = rio_spread_si(io_idx_si) + ! Perform a check on the number of patches per site patchespersite = 0 - + cpatch => sites(s)%oldest_patch do while(associated(cpatch)) - + patchespersite = patchespersite + 1 - + ccohort => cpatch%shortest - + ! new patch, reset num cohorts cohortsperpatch = 0 - - do while(associated(ccohort)) - + + do while(associated(ccohort)) + ! found cohort, increment cohortsperpatch = cohortsperpatch + 1 totalcohorts = totalcohorts + 1 - + if ( debug ) then write(fates_log(),*) 'CVTL io_idx_co ',io_idx_co endif @@ -2605,7 +2593,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ir_prt_var = ir_prt_base do i_var = 1, prt_global%num_vars - do i_pos = 1, prt_global%state_descriptor(i_var)%num_pos + do i_pos = 1, prt_global%state_descriptor(i_var)%num_pos ir_prt_var = ir_prt_var + 1 ccohort%prt%variables(i_var)%val(i_pos) = & @@ -2621,13 +2609,13 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ir_prt_var = ir_prt_var + 1 ccohort%prt%variables(i_var)%burned(i_pos) = & - this%rvars(ir_prt_var)%r81d(io_idx_co) + this%rvars(ir_prt_var)%r81d(io_idx_co) end do end do - !ccohort%vcmax25top + !ccohort%vcmax25top !ccohort%jmax25top - !ccohort%tpu25top + !ccohort%tpu25top !ccohort%kp25top @@ -2658,15 +2646,15 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ccohort%smort = rio_smort_co(io_idx_co) ccohort%asmort = rio_asmort_co(io_idx_co) ccohort%frmort = rio_frmort_co(io_idx_co) - + ! Nutrient uptake / efflux ccohort%daily_n_uptake = rio_daily_n_uptake_co(io_idx_co) ccohort%daily_p_uptake = rio_daily_p_uptake_co(io_idx_co) ccohort%daily_c_efflux = rio_daily_c_efflux_co(io_idx_co) ccohort%daily_n_efflux = rio_daily_n_efflux_co(io_idx_co) ccohort%daily_p_efflux = rio_daily_p_efflux_co(io_idx_co) - - ccohort%daily_n_demand = rio_daily_n_demand_co(io_idx_co) + + ccohort%daily_n_demand = rio_daily_n_demand_co(io_idx_co) ccohort%daily_p_demand = rio_daily_p_demand_co(io_idx_co) ccohort%daily_n_need2 = rio_daily_n_need_co(io_idx_co) ccohort%daily_p_need2 = rio_daily_p_need_co(io_idx_co) @@ -2688,18 +2676,18 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ! Initialize Plant Hydraulics if(hlm_use_planthydro==itrue)then - + ! Load the water contents call this%GetCohortRealVector(ccohort%co_hydr%th_ag,n_hypool_ag, & ir_hydro_th_ag_covec,io_idx_co) call this%GetCohortRealVector(ccohort%co_hydr%th_aroot,sites(s)%si_hydr%nlevrhiz, & ir_hydro_th_aroot_covec,io_idx_co) - + ccohort%co_hydr%th_troot = this%rvars(ir_hydro_th_troot)%r81d(io_idx_co) - + call UpdatePlantPsiFTCFromTheta(ccohort,sites(s)%si_hydr) - + ccohort%co_hydr%errh2o_growturn_aroot = & this%rvars(ir_hydro_err_growturn_aroot)%r81d(io_idx_co) ccohort%co_hydr%errh2o_growturn_troot = & @@ -2713,14 +2701,12 @@ subroutine get_restart_vectors(this, nc, nsites, sites) if (hlm_use_sp .eq. itrue) then !ccohort%c_area = rio_c_area_co(io_idx_co) ccohort%c_area = this%rvars(ir_c_area_co)%r81d(io_idx_co) - ccohort%npp_tstep = this%rvars(ir_npp_tstep_co)%r81d(io_idx_co) - ccohort%gpp_tstep = this%rvars(ir_gpp_tstep_co)%r81d(io_idx_co) end if - + io_idx_co = io_idx_co + 1 - + ccohort => ccohort%taller - + enddo ! current cohort do while if(cohortsperpatch .ne. rio_ncohort_pa(io_idx_co_1st)) then @@ -2745,20 +2731,20 @@ subroutine get_restart_vectors(this, nc, nsites, sites) cpatch%solar_zenith_angle = rio_solar_zenith_angle_pa(io_idx_co_1st) ! set cohorts per patch for IO - + if ( debug ) then write(fates_log(),*) 'CVTL III ' & ,io_idx_co,cohortsperpatch endif - + ! -------------------------------------------------------------------------- ! Pull litter from the restart arrays - ! Each element has its own variable, so we have to make sure - ! we keep re-setting this + ! Each element has its own variable, so we have to make sure + ! we keep re-setting this ! -------------------------------------------------------------------------- do el = 0, num_elements-1 - + io_idx_pa_pft = io_idx_co_1st io_idx_pa_cwd = io_idx_co_1st io_idx_pa_cwsl = io_idx_co_1st @@ -2784,13 +2770,13 @@ subroutine get_restart_vectors(this, nc, nsites, sites) io_idx_pa_dcsl = io_idx_pa_dcsl + 1 end do end do - + do i = 1,ncwd litt%ag_cwd(i) = this%rvars(ir_agcwd_litt+el)%r81d(io_idx_pa_cwd) litt%ag_cwd_frag(i) = this%rvars(ir_agcwd_frag_litt+el)%r81d(io_idx_pa_cwd) io_idx_pa_cwd = io_idx_pa_cwd + 1 - + do ilyr=1,nlevsoil litt%bg_cwd(i,ilyr) = this%rvars(ir_bgcwd_litt+el)%r81d(io_idx_pa_cwsl) litt%bg_cwd_frag(i,ilyr) = this%rvars(ir_bgcwd_frag_litt+el)%r81d(io_idx_pa_cwsl) @@ -2808,30 +2794,30 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ! Now increment the position of the first cohort to that of the next ! patch - + io_idx_co_1st = io_idx_co_1st + fates_maxElementsPerPatch - + ! and max the number of allowed cohorts per patch io_idx_pa_pft = io_idx_co_1st io_idx_pa_cwd = io_idx_co_1st io_idx_pa_ib = io_idx_co_1st io_idx_co = io_idx_co_1st - + if ( debug ) then write(fates_log(),*) 'CVTL io_idx_co_1st ', io_idx_co_1st write(fates_log(),*) 'CVTL cohortsperpatch ', cohortsperpatch write(fates_log(),*) 'CVTL totalCohorts ', totalCohorts end if - + cpatch => cpatch%younger - + enddo ! patch do while - + if(patchespersite .ne. rio_npatch_si(io_idx_si)) then write(fates_log(),*) 'Number of patches per site during retrieval does not match allocation' call endrun(msg=errMsg(sourcefile, __LINE__)) end if - + do i = 1,numWaterMem sites(s)%water_memory(i) = rio_watermem_siwm( io_idx_si_wmem ) io_idx_si_wmem = io_idx_si_wmem + 1 @@ -2846,7 +2832,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ! Retrieve site-level hydraulics arrays ! Note that Hydraulics structures, their allocations, and the length ! declaration nlevsoi_hyd should be allocated early on when the code first - ! allocates sites (before restart info), and when the soils layer is + ! allocates sites (before restart info), and when the soils layer is ! first known. ! ----------------------------------------------------------------------------- @@ -2869,7 +2855,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) end do end if - + ! Fill the site level diagnostics arrays ! ----------------------------------------------------------------------------- @@ -2882,7 +2868,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) sites(s)%fmort_rate_ustory(i_scls, i_pft) = rio_fmortrate_usto_siscpf(io_idx_si_scpf) sites(s)%imort_rate(i_scls, i_pft) = rio_imortrate_siscpf(io_idx_si_scpf) sites(s)%fmort_rate_crown(i_scls, i_pft) = rio_fmortrate_crown_siscpf(io_idx_si_scpf) - sites(s)%fmort_rate_cambial(i_scls, i_pft) = rio_fmortrate_cambi_siscpf(io_idx_si_scpf) + sites(s)%fmort_rate_cambial(i_scls, i_pft) = rio_fmortrate_cambi_siscpf(io_idx_si_scpf) sites(s)%term_nindivs_canopy(i_scls,i_pft) = rio_termnindiv_cano_siscpf(io_idx_si_scpf) sites(s)%term_nindivs_ustory(i_scls,i_pft) = rio_termnindiv_usto_siscpf(io_idx_si_scpf) sites(s)%growthflux_fusion(i_scls, i_pft) = rio_growflx_fusion_siscpf(io_idx_si_scpf) @@ -2891,7 +2877,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) sites(s)%demotion_rate(i_scls) = rio_demorate_sisc(io_idx_si_sc) sites(s)%promotion_rate(i_scls) = rio_promrate_sisc(io_idx_si_sc) - + io_idx_si_sc = io_idx_si_sc + 1 end do @@ -2903,7 +2889,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) sites(s)%fmort_carbonflux_canopy = rio_fmortcflux_cano_si(io_idx_si) sites(s)%fmort_carbonflux_ustory = rio_fmortcflux_usto_si(io_idx_si) - + ! Site level phenology status flags sites(s)%cstatus = rio_cd_status_si(io_idx_si) @@ -2924,10 +2910,10 @@ subroutine get_restart_vectors(this, nc, nsites, sites) if ( debug ) then write(fates_log(),*) 'CVTL total cohorts ',totalCohorts end if - + end associate end subroutine get_restart_vectors - + ! ==================================================================================== subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) @@ -2956,12 +2942,12 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) integer :: ifp ! patch counter do s = 1, nsites - + ifp = 0 currentpatch => sites(s)%oldest_patch - do while (associated(currentpatch)) + do while (associated(currentpatch)) ifp = ifp+1 - + currentPatch%f_sun (:,:,:) = 0._r8 currentPatch%fabd_sun_z (:,:,:) = 0._r8 currentPatch%fabd_sha_z (:,:,:) = 0._r8 @@ -2975,7 +2961,7 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) currentPatch%nrmlzd_parprof_pft_dif_z(:,:,:,:) = 0._r8 currentPatch%nrmlzd_parprof_dir_z(:,:,:) = 0._r8 currentPatch%nrmlzd_parprof_dif_z(:,:,:) = 0._r8 - + ! ----------------------------------------------------------- ! When calling norman radiation from the short-timestep ! we are passing in boundary conditions to set the following @@ -2983,9 +2969,9 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) ! currentPatch%solar_zenith_flag (is there daylight?) ! currentPatch%solar_zenith_angle (what is the value?) ! ----------------------------------------------------------- - + if(currentPatch%solar_zenith_flag)then - + bc_out(s)%albd_parb(ifp,:) = 0._r8 ! output HLM bc_out(s)%albi_parb(ifp,:) = 0._r8 ! output HLM bc_out(s)%fabi_parb(ifp,:) = 0._r8 ! output HLM @@ -2993,10 +2979,10 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) bc_out(s)%ftdd_parb(ifp,:) = 1._r8 ! output HLM bc_out(s)%ftid_parb(ifp,:) = 1._r8 ! output HLM bc_out(s)%ftii_parb(ifp,:) = 1._r8 ! output HLM - + if (maxval(currentPatch%nrad(1,:))==0)then - !there are no leaf layers in this patch. it is effectively bare ground. - ! no radiation is absorbed + !there are no leaf layers in this patch. it is effectively bare ground. + ! no radiation is absorbed bc_out(s)%fabd_parb(ifp,:) = 0.0_r8 bc_out(s)%fabi_parb(ifp,:) = 0.0_r8 do ib = 1,hlm_numSWb @@ -3010,7 +2996,7 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) bc_out(s)%ftii_parb(ifp,ib)= 1.0_r8 enddo else - + call PatchNormanRadiation (currentPatch, & bc_out(s)%albd_parb(ifp,:), & bc_out(s)%albi_parb(ifp,:), & @@ -3019,14 +3005,14 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) bc_out(s)%ftdd_parb(ifp,:), & bc_out(s)%ftid_parb(ifp,:), & bc_out(s)%ftii_parb(ifp,:)) - - endif ! is there vegetation? - + + endif ! is there vegetation? + end if ! if the vegetation and zenith filter is active currentPatch => currentPatch%younger end do ! Loop linked-list patches enddo ! Loop Sites - + return end subroutine update_3dpatch_radiation From d987947f779b988f0894cfe12f2c00313568f28b Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 23 Jun 2021 23:23:29 -0600 Subject: [PATCH 172/209] cleaning up old code --- main/FatesRestartInterfaceMod.F90 | 4 ---- 1 file changed, 4 deletions(-) diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index acdbdab904..1a84aa864f 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -1694,7 +1694,6 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_imortcflux_si => this%rvars(ir_imortcflux_si)%r81d, & rio_fmortcflux_cano_si => this%rvars(ir_fmortcflux_cano_si)%r81d, & rio_fmortcflux_usto_si => this%rvars(ir_fmortcflux_usto_si)%r81d) - !rio_c_area_co => this%rvars(ir_c_area_co)%r81d) totalCohorts = 0 @@ -1918,7 +1917,6 @@ subroutine set_restart_vectors(this,nc,nsites,sites) endif if (hlm_use_sp .eq. itrue) then - !rio_c_area_co(io_idx_co) = ccohort%c_area this%rvars(ir_c_area_co)%r81d(io_idx_co) = ccohort%c_area end if @@ -2492,7 +2490,6 @@ subroutine get_restart_vectors(this, nc, nsites, sites) rio_imortcflux_si => this%rvars(ir_imortcflux_si)%r81d, & rio_fmortcflux_cano_si => this%rvars(ir_fmortcflux_cano_si)%r81d, & rio_fmortcflux_usto_si => this%rvars(ir_fmortcflux_usto_si)%r81d) - !rio_c_area_co => this%rvars(ir_c_area_co)%r81d) totalcohorts = 0 @@ -2699,7 +2696,6 @@ subroutine get_restart_vectors(this, nc, nsites, sites) end if if (hlm_use_sp .eq. itrue) then - !ccohort%c_area = rio_c_area_co(io_idx_co) ccohort%c_area = this%rvars(ir_c_area_co)%r81d(io_idx_co) end if From b87f252c4965ff2efcdea05287d7eee5be0190c2 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 23 Jun 2021 22:27:24 -0700 Subject: [PATCH 173/209] more cleanup --- main/FatesRestartInterfaceMod.F90 | 657 +++++++++++++++--------------- 1 file changed, 328 insertions(+), 329 deletions(-) diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 1a84aa864f..47737a9dd3 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -15,7 +15,7 @@ module FatesRestartInterfaceMod use FatesIOVariableKindMod, only : fates_io_variable_kind_type use FatesRestartVariableMod, only : fates_restart_variable_type use FatesInterfaceTypesMod, only : nlevcoage - use FatesInterfaceTypesMod, only : bc_in_type + use FatesInterfaceTypesMod, only : bc_in_type use FatesInterfaceTypesMod, only : bc_out_type use FatesInterfaceTypesMod, only : hlm_use_planthydro use FatesInterfaceTypesMod, only : hlm_use_sp @@ -72,11 +72,11 @@ module FatesRestartInterfaceMod ! ls: layer sublayer dimension (fine discretization of upper,lower) ! wm: the number of memory slots for water (currently 10) ! ------------------------------------------------------------- - - + + ! Indices to the restart variable object - integer :: ir_npatch_si + integer :: ir_npatch_si integer :: ir_cd_status_si integer :: ir_dd_status_si integer :: ir_nchill_days_si @@ -125,7 +125,7 @@ module FatesRestartInterfaceMod integer :: ir_daily_p_demand_co integer :: ir_daily_n_need_co integer :: ir_daily_p_need_co - + !Logging integer :: ir_lmort_direct_co integer :: ir_lmort_collateral_co @@ -206,7 +206,7 @@ module FatesRestartInterfaceMod ! Hydraulic indices integer :: ir_hydro_th_ag_covec integer :: ir_hydro_th_troot - integer :: ir_hydro_th_aroot_covec + integer :: ir_hydro_th_aroot_covec integer :: ir_hydro_liqvol_shell_si integer :: ir_hydro_err_growturn_aroot integer :: ir_hydro_err_growturn_ag_covec @@ -223,12 +223,12 @@ module FatesRestartInterfaceMod ! integer constants for storing logical data integer, parameter, public :: old_cohort = 0 - integer, parameter, public :: new_cohort = 1 + integer, parameter, public :: new_cohort = 1 real(r8), parameter, public :: flushinvalid = -9999.0 real(r8), parameter, public :: flushzero = 0.0 real(r8), parameter, public :: flushone = 1.0 - + ! Local debug flag logical, parameter, public :: debug=.false. @@ -255,20 +255,20 @@ module FatesRestartInterfaceMod ! Instanteate one registry of the different dimension/kinds (dk) ! All output variables will have a pointer to one of these dk's type(fates_io_variable_kind_type) :: dim_kinds(fates_restart_num_dim_kinds) - + ! This is a structure that explains where FATES patch boundaries ! on each thread point to in the host IO array, this structure is ! allocated by number of threads. This could be dynamically ! allocated, but is unlikely to change...? ! Note: history io also instanteates fates_io_dimension_type type(fates_io_dimension_type) :: dim_bounds(fates_restart_num_dimensions) - + type(restart_map_type), pointer :: restart_map(:) integer, private :: cohort_index_, column_index_ contains - + ! public functions procedure :: Init procedure :: SetThreadBoundsEach @@ -281,7 +281,7 @@ module FatesRestartInterfaceMod procedure :: create_patchcohort_structure procedure :: get_restart_vectors procedure :: update_3dpatch_radiation - + ! private work functions procedure, private :: init_dim_kinds_maps procedure, private :: set_dim_indices @@ -297,15 +297,15 @@ module FatesRestartInterfaceMod end type fates_restart_interface_type - + contains ! ===================================================================================== - + subroutine Init(this, num_threads, fates_bounds) - + use FatesIODimensionsMod, only : fates_bounds_type, column, cohort implicit none @@ -330,13 +330,13 @@ subroutine Init(this, num_threads, fates_bounds) ! Allocate the mapping between FATES indices and the IO indices allocate(this%restart_map(num_threads)) - - end subroutine Init + + end subroutine Init ! ====================================================================== subroutine SetThreadBoundsEach(this, thread_index, thread_bounds) - + use FatesIODimensionsMod, only : fates_bounds_type implicit none @@ -347,25 +347,25 @@ subroutine SetThreadBoundsEach(this, thread_index, thread_bounds) type(fates_bounds_type), intent(in) :: thread_bounds integer :: index - + index = this%cohort_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%cohort_begin, thread_bounds%cohort_end) - + index = this%column_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%column_begin, thread_bounds%column_end) - + end subroutine SetThreadBoundsEach ! =================================================================================== subroutine assemble_restart_output_types(this) - + use FatesIOVariableKindMod, only : site_r8, site_int, cohort_r8, cohort_int implicit none - + class(fates_restart_interface_type), intent(inout) :: this call this%init_dim_kinds_maps() @@ -379,7 +379,7 @@ subroutine assemble_restart_output_types(this) end subroutine assemble_restart_output_types ! =================================================================================== - + subroutine set_dim_indices(this, dk_name, idim, dim_index) use FatesIOVariableKindMod , only : iotype_index @@ -428,13 +428,13 @@ subroutine set_cohort_index(this, index) integer, intent(in) :: index this%cohort_index_ = index end subroutine set_cohort_index - + integer function cohort_index(this) implicit none class(fates_restart_interface_type), intent(in) :: this cohort_index = this%cohort_index_ end function cohort_index - + ! ======================================================================= subroutine set_column_index(this, index) @@ -443,17 +443,17 @@ subroutine set_column_index(this, index) integer, intent(in) :: index this%column_index_ = index end subroutine set_column_index - + integer function column_index(this) implicit none class(fates_restart_interface_type), intent(in) :: this column_index = this%column_index_ end function column_index - + ! ======================================================================= subroutine init_dim_kinds_maps(this) - + ! ---------------------------------------------------------------------------------- ! This subroutine simply initializes the structures that define the different ! array and type formats for different IO variables @@ -468,9 +468,9 @@ subroutine init_dim_kinds_maps(this) ! ! ---------------------------------------------------------------------------------- use FatesIOVariableKindMod, only : site_r8, site_int, cohort_r8, cohort_int - + implicit none - + ! Arguments class(fates_restart_interface_type), intent(inout) :: this @@ -499,17 +499,17 @@ end subroutine init_dim_kinds_maps ! ==================================================================================== integer function num_restart_vars(this) - + implicit none class(fates_restart_interface_type), intent(in) :: this num_restart_vars = this%num_restart_vars_ - + end function num_restart_vars - + ! ==================================================================================== - + subroutine initialize_restart_vars(this) implicit none @@ -522,16 +522,16 @@ subroutine initialize_restart_vars(this) ! Allocate the list of restart output variable objects allocate(this%rvars(this%num_restart_vars())) - + ! construct the object that defines all of the IO variables call this%define_restart_vars(initialize_variables=.true.) - + end subroutine initialize_restart_vars ! ====================================================================================== subroutine flush_rvars(this,nc) - + class(fates_restart_interface_type) :: this integer,intent(in) :: nc @@ -544,17 +544,17 @@ subroutine flush_rvars(this,nc) call rvar%Flush(nc, this%dim_bounds, this%dim_kinds) end associate end do - + end subroutine flush_rvars - + ! ==================================================================================== - + subroutine define_restart_vars(this, initialize_variables) - + ! --------------------------------------------------------------------------------- - ! + ! ! REGISTRY OF RESTART OUTPUT VARIABLES ! ! Please add any restart variables to this registry. This registry will handle @@ -562,19 +562,19 @@ subroutine define_restart_vars(this, initialize_variables) ! variables. Note that restarts are only using 1D vectors in ALM and CLM. If you ! have a multi-dimensional variable that is below the cohort scale, then pack ! that variable into a cohort-sized output array by giving it a vtype "cohort_r8" - ! or "cohort_int". + ! or "cohort_int". ! ! Unlike history variables, restarts flush to zero. ! --------------------------------------------------------------------------------- - + use FatesIOVariableKindMod, only : site_r8, site_int, cohort_int, cohort_r8 implicit none - + class(fates_restart_interface_type), intent(inout) :: this logical, intent(in) :: initialize_variables ! are we 'count'ing or 'initializ'ing? integer :: ivar - - + + ivar=0 ! ----------------------------------------------------------------------------------- @@ -620,7 +620,7 @@ subroutine define_restart_vars(this, initialize_variables) call this%set_restart_var(vname='fates_acc_nesterov_id', vtype=site_r8, & long_name='a nesterov index accumulator', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_acc_ni_si ) - + call this%set_restart_var(vname='fates_gdd_site', vtype=site_r8, & long_name='growing degree days at each site', units='degC days', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_gdd_si ) @@ -646,7 +646,7 @@ subroutine define_restart_vars(this, initialize_variables) call this%set_restart_var(vname='fates_solar_zenith_flag_pa', vtype=cohort_int, & long_name='switch specifying if zenith is positive', units='unitless', flushval = flushinvalid, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_solar_zenith_flag_pa ) - + call this%set_restart_var(vname='fates_solar_zenith_angle_pa', vtype=cohort_r8, & long_name='the angle of the solar zenith for each patch', units='radians', flushval = flushinvalid, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_solar_zenith_angle_pa ) @@ -683,7 +683,7 @@ subroutine define_restart_vars(this, initialize_variables) call this%set_restart_var(vname='fates_coage', vtype=cohort_r8, & long_name='ed cohort - age in days', units='days', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_coage_co ) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_coage_co ) call this%set_restart_var(vname='fates_height', vtype=cohort_r8, & long_name='ed cohort - plant height', units='m', flushval = flushzero, & @@ -698,12 +698,12 @@ subroutine define_restart_vars(this, initialize_variables) long_name='ed cohort - target sapwood biomass set from prev year', & units='kgC/indiv', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_sapwmemory_co ) - + call this%set_restart_var(vname='fates_structmemory', vtype=cohort_r8, & long_name='ed cohort - target structural biomass set from prev year', & units='kgC/indiv', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_structmemory_co ) - + call this%set_restart_var(vname='fates_nplant', vtype=cohort_r8, & long_name='ed cohort - number of plants in the cohort', & units='/patch', flushval = flushzero, & @@ -743,7 +743,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name='ed cohort - maintenance respiration deficit', & units='kgC/indiv', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_resp_m_def_co ) - + call this%set_restart_var(vname='fates_bmort', vtype=cohort_r8, & long_name='ed cohort - background mortality rate', & units='/year', flushval = flushzero, & @@ -778,7 +778,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name='fates cohort- daily nitrogen efflux', & units='kg/plant/day', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_daily_n_efflux_co ) - + call this%set_restart_var(vname='fates_daily_p_efflux', vtype=cohort_r8, & long_name='fates cohort- daily phosphorus efflux', & units='kg/plant/day', flushval = flushzero, & @@ -803,7 +803,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name='fates cohort- daily nitrogen need', & units='kgN/plant/day', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_daily_n_need_co ) - + call this%set_restart_var(vname='fates_frmort', vtype=cohort_r8, & long_name='ed cohort - freezing mortality rate', & units='/year', flushval = flushzero, & @@ -816,7 +816,7 @@ subroutine define_restart_vars(this, initialize_variables) call this%set_restart_var(vname='fates_asmort', vtype=cohort_r8, & long_name='ed cohort - age senescence mortality rate', & - units = '/year', flushval = flushzero, & + units = '/year', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_asmort_co ) call this%set_restart_var(vname='fates_lmort_direct', vtype=cohort_r8, & @@ -827,12 +827,12 @@ subroutine define_restart_vars(this, initialize_variables) call this%set_restart_var(vname='fates_lmort_collateral', vtype=cohort_r8, & long_name='ed cohort - collateral mortality rate', & units='%/event', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_lmort_collateral_co ) - + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_lmort_collateral_co ) + call this%set_restart_var(vname='fates_lmort_in', vtype=cohort_r8, & long_name='ed cohort - mechanical mortality rate', & units='%/event', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_lmort_infra_co ) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_lmort_infra_co ) call this%set_restart_var(vname='fates_ddbhdt', vtype=cohort_r8, & long_name='ed cohort - differential: ddbh/dt', & @@ -916,23 +916,23 @@ subroutine define_restart_vars(this, initialize_variables) call this%RegisterCohortVector(symbol_base='fates_ag_cwd', vtype=cohort_r8, & long_name_base='above ground CWD', & units='kg/m2', veclength=num_elements, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_agcwd_litt) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_agcwd_litt) call this%RegisterCohortVector(symbol_base='fates_bg_cwd', vtype=cohort_r8, & long_name_base='below ground CWD', & units='kg/m2', veclength=num_elements, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_bgcwd_litt) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_bgcwd_litt) call this%RegisterCohortVector(symbol_base='fates_leaf_fines', vtype=cohort_r8, & long_name_base='above ground leaf litter', & units='kg/m2', veclength=num_elements, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_leaf_litt) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_leaf_litt) call this%RegisterCohortVector(symbol_base='fates_fnrt_fines', vtype=cohort_r8, & long_name_base='fine root litter', & units='kg/m2', veclength=num_elements, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fnrt_litt) - + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fnrt_litt) + call this%RegisterCohortVector(symbol_base='fates_seed', vtype=cohort_r8, & long_name_base='seed bank (non-germinated)', & units='kg/m2', veclength=num_elements, flushval = flushzero, & @@ -946,18 +946,18 @@ subroutine define_restart_vars(this, initialize_variables) call this%RegisterCohortVector(symbol_base='fates_ag_cwd_frag', vtype=cohort_r8, & long_name_base='above ground CWD frag flux', & units='kg/m2/day', veclength=num_elements, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_agcwd_frag_litt) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_agcwd_frag_litt) call this%RegisterCohortVector(symbol_base='fates_bg_cwd_frag', vtype=cohort_r8, & long_name_base='below ground CWD frag flux', & units='kg/m2/day', veclength=num_elements, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_bgcwd_frag_litt) - + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_bgcwd_frag_litt) + call this%RegisterCohortVector(symbol_base='fates_lfines_frag', vtype=cohort_r8, & long_name_base='frag flux from leaf fines', & units='kg/m2/day', veclength=num_elements, flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_lfines_frag_litt) - + call this%RegisterCohortVector(symbol_base='fates_rfines_frag', vtype=cohort_r8, & long_name_base='frag flux from froot fines', & units='kg/m2/day', veclength=num_elements, flushval = flushzero, & @@ -996,20 +996,20 @@ subroutine define_restart_vars(this, initialize_variables) units='kg/day/ha', veclength=num_elements, flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_uptake_flxdg) - + ! Site level Mass Balance State Accounting call this%RegisterCohortVector(symbol_base='fates_oldstock', vtype=site_r8, & long_name_base='Previous total mass of all fates state variables', & units='kg/ha', veclength=num_elements, flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_oldstock_mbal) - + call this%RegisterCohortVector(symbol_base='fates_errfates', vtype=site_r8, & long_name_base='Previous total mass of error fates state variables', & units='kg/ha', veclength=num_elements, flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_errfates_mbal) - - + + ! Only register satellite phenology related restart variables if it is turned on! if(hlm_use_sp .eq. itrue) then @@ -1021,7 +1021,7 @@ subroutine define_restart_vars(this, initialize_variables) ! Only register hydraulics restart variables if it is turned on! - + if(hlm_use_planthydro==itrue) then if ( fates_maxElementsPerSite < (nshell * nlevsoi_hyd_max) ) then @@ -1039,32 +1039,32 @@ subroutine define_restart_vars(this, initialize_variables) call this%RegisterCohortVector(symbol_base='fates_hydro_th_ag', vtype=cohort_r8, & long_name_base='water in aboveground compartments', & units='kg/plant', veclength=n_hypool_ag, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_th_ag_covec) - + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_th_ag_covec) + call this%RegisterCohortVector(symbol_base='fates_hydro_th_troot', vtype=cohort_r8, & long_name_base='water in transporting roots', & units='kg/plant', veclength=n_hypool_troot, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_th_troot) - + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_th_troot) + call this%RegisterCohortVector(symbol_base='fates_hydro_th_aroot', vtype=cohort_r8, & long_name_base='water in absorbing roots', & units='kg/plant', veclength=nlevsoi_hyd_max, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_th_aroot_covec) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_th_aroot_covec) call this%RegisterCohortVector(symbol_base='fates_hydro_err_aroot', vtype=cohort_r8, & long_name_base='error in plant-hydro balance in absorbing roots', & units='kg/plant', veclength=nlevsoi_hyd_max, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_err_growturn_aroot) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_err_growturn_aroot) call this%RegisterCohortVector(symbol_base='fates_hydro_err_ag', vtype=cohort_r8, & long_name_base='error in plant-hydro balance above ground', & units='kg/plant', veclength=n_hypool_ag, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_err_growturn_ag_covec) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_err_growturn_ag_covec) call this%RegisterCohortVector(symbol_base='fates_hydro_err_troot', vtype=cohort_r8, & long_name_base='error in plant-hydro balance above ground', & units='kg/plant', veclength=n_hypool_troot, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_err_growturn_troot) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_err_growturn_troot) ! Site-level volumentric liquid water content (shell x layer) call this%set_restart_var(vname='fates_hydro_liqvol_shell', vtype=cohort_r8, & @@ -1077,13 +1077,13 @@ subroutine define_restart_vars(this, initialize_variables) long_name='Site level water mass used for new recruits', & units='kg', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_recruit_si ) - + ! Site-level water bound in dead plants call this%set_restart_var(vname='fates_hydro_dead_h2o', vtype=site_r8, & long_name='Site level water bound in dead plants', & units='kg', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_dead_si ) - + ! Site-level water balance error due to growth/turnover call this%set_restart_var(vname='fates_hydro_growturn_err', vtype=site_r8, & long_name='Site level error for hydraulics due to growth/turnover', & @@ -1101,7 +1101,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name='Site level error for hydrodynamics', & units='kg', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_hydro_err_si ) - + end if @@ -1118,7 +1118,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name='last 10 days of 24-hour vegetation temperature, by site x day-index', & units='m3/m3', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_vegtempmem_sitm ) - + call this%set_restart_var(vname='fates_recrate', vtype=cohort_r8, & long_name='fates diagnostics on recruitment', & units='indiv/ha/day', flushval = flushzero, & @@ -1174,7 +1174,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name='fates diag: rate of indivs moving via fusion', & units='indiv/ha/day', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_growflx_fusion_siscpf) - + call this%set_restart_var(vname='fates_demorate', vtype=cohort_r8, & long_name='fates diagnoatic rate of indivs demoted', & units='indiv/ha/day', flushval = flushzero, & @@ -1189,7 +1189,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name='biomass of indivs killed due to impact mort', & units='kgC/ha/day', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_imortcflux_si) - + call this%set_restart_var(vname='fates_fmortcflux_canopy', vtype=site_r8, & long_name='fates diagnostic biomass of canopy fire', & units='gC/m2/sec', flushval = flushzero, & @@ -1227,20 +1227,20 @@ subroutine define_restart_vars(this, initialize_variables) ir_prt_base = ivar call this%DefinePRTRestartVars(initialize_variables,ivar) - - - + + + ! Must be last thing before return this%num_restart_vars_ = ivar - + end subroutine define_restart_vars - + ! ===================================================================================== - + subroutine DefinePRTRestartVars(this,initialize_variables,ivar) ! ---------------------------------------------------------------------------------- - ! PARTEH variables are objects. These objects + ! PARTEH variables are objects. These objects ! each are registered to have things like names units and symbols ! as part of that object. Thus, when defining, reading and writing restarts, ! instead of manually typing out each variable we want, we just loop through @@ -1267,7 +1267,7 @@ subroutine DefinePRTRestartVars(this,initialize_variables,ivar) class(fates_restart_interface_type) :: this logical, intent(in) :: initialize_variables integer,intent(inout) :: ivar ! global variable counter - + integer :: dummy_out ! dummy index for variable ! position in global file integer :: i_var ! loop counter for prt variables @@ -1283,12 +1283,12 @@ subroutine DefinePRTRestartVars(this,initialize_variables,ivar) ! The base symbol name symbol_base = prt_global%state_descriptor(i_var)%symbol - + ! The long name of the variable name_base = prt_global%state_descriptor(i_var)%longname do i_pos = 1, prt_global%state_descriptor(i_var)%num_pos - + ! String describing the physical position of the variable write(pos_symbol, '(I3.3)') i_pos @@ -1306,7 +1306,7 @@ subroutine DefinePRTRestartVars(this,initialize_variables,ivar) long_name=trim(long_name), & units='kg', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, & - ivar=ivar, index = dummy_out ) + ivar=ivar, index = dummy_out ) ! Register the turnover flux variables ! ---------------------------------------------------------------------------- @@ -1316,19 +1316,19 @@ subroutine DefinePRTRestartVars(this,initialize_variables,ivar) ! The expanded long name of the variable long_name = trim(name_base)//', turnover, position:'//trim(pos_symbol) - + call this%set_restart_var(vname=trim(symbol), & vtype=cohort_r8, & long_name=trim(long_name), & units='kg', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, & - ivar=ivar, index = dummy_out ) - + ivar=ivar, index = dummy_out ) + ! Register the net allocation flux variable ! ---------------------------------------------------------------------------- - + ! The symbol that is written to file symbol = trim(symbol_base)//'_net_'//trim(pos_symbol) @@ -1340,8 +1340,8 @@ subroutine DefinePRTRestartVars(this,initialize_variables,ivar) long_name=trim(long_name), & units='kg', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, & - ivar=ivar, index = dummy_out ) - + ivar=ivar, index = dummy_out ) + ! Register the burn flux variable @@ -1357,11 +1357,11 @@ subroutine DefinePRTRestartVars(this,initialize_variables,ivar) long_name=trim(long_name), & units='kg', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, & - ivar=ivar, index = dummy_out ) + ivar=ivar, index = dummy_out ) end do end do - + return end subroutine DefinePRTRestartVars @@ -1369,20 +1369,20 @@ end subroutine DefinePRTRestartVars subroutine RegisterCohortVector(this,symbol_base, vtype, long_name_base, & units, veclength, flushval, hlms, & - initialize, ivar, index) + initialize, ivar, index) + - ! The basic idea here is that instead of saving cohorts with vector data ! as long arrays in the restart file, we give each index of the vector ! its own variable. This helps reduce the size of the restart files ! considerably. - - + + use FatesIOVariableKindMod, only : cohort_r8 - + class(fates_restart_interface_type) :: this character(*),intent(in) :: symbol_base ! Symbol name without position - character(*),intent(in) :: vtype ! String defining variable type + character(*),intent(in) :: vtype ! String defining variable type character(*),intent(in) :: long_name_base ! name without position character(*),intent(in) :: units ! units for this variable integer,intent(in) :: veclength ! length of the vector @@ -1391,58 +1391,58 @@ subroutine RegisterCohortVector(this,symbol_base, vtype, long_name_base, & logical, intent(in) :: initialize ! Is this registering or counting? integer,intent(inout) :: ivar ! global variable counter integer,intent(out) :: index ! The variable index for this variable - + ! Local Variables character(len=4) :: pos_symbol ! vectors need text strings for each position character(len=128) :: symbol ! symbol name written to file character(len=256) :: long_name ! long name written to file integer :: i_pos ! loop counter for discrete position integer :: dummy_index - + ! We give each vector its own index that points to the first position - + index = ivar + 1 - + do i_pos = 1, veclength - + ! String describing the physical position of the variable write(pos_symbol, '(I3.3)') i_pos - + ! The symbol that is written to file symbol = trim(symbol_base)//'_vec_'//trim(pos_symbol) - + ! The expanded long name of the variable long_name = trim(long_name_base)//', position:'//trim(pos_symbol) - + call this%set_restart_var(vname=trim(symbol), & vtype=vtype, & long_name=trim(long_name), & units=units, flushval = flushval, & hlms='CLM:ALM', initialize=initialize, & - ivar=ivar, index = dummy_index ) - + ivar=ivar, index = dummy_index ) + end do - + end subroutine RegisterCohortVector ! ===================================================================================== - + subroutine GetCohortRealVector(this, state_vector, len_state_vector, & variable_index_base, co_global_index) - + ! This subroutine walks through global cohort vector indices ! and pulls from the different associated restart variables - + class(fates_restart_interface_type) , intent(inout) :: this integer,intent(in) :: len_state_vector real(r8),intent(inout) :: state_vector(len_state_vector) integer,intent(in) :: variable_index_base integer,intent(in) :: co_global_index - + integer :: i_pos ! vector position loop index integer :: ir_pos_var ! global variable index - + ir_pos_var = variable_index_base do i_pos = 1, len_state_vector state_vector(i_pos) = this%rvars(ir_pos_var)%r81d(co_global_index) @@ -1450,24 +1450,24 @@ subroutine GetCohortRealVector(this, state_vector, len_state_vector, & end do return end subroutine GetCohortRealVector - - ! ===================================================================================== - + + ! ===================================================================================== + subroutine SetCohortRealVector(this, state_vector, len_state_vector, & variable_index_base, co_global_index) ! This subroutine walks through global cohort vector indices ! and pushes into the restart arrays the different associated restart variables - + class(fates_restart_interface_type) , intent(inout) :: this integer,intent(in) :: len_state_vector real(r8),intent(in) :: state_vector(len_state_vector) integer,intent(in) :: variable_index_base integer,intent(in) :: co_global_index - + integer :: i_pos ! vector position loop index integer :: ir_pos_var ! global variable index - + ir_pos_var = variable_index_base do i_pos = 1, len_state_vector this%rvars(ir_pos_var)%r81d(co_global_index) = state_vector(i_pos) @@ -1475,7 +1475,7 @@ subroutine SetCohortRealVector(this, state_vector, len_state_vector, & end do return end subroutine SetCohortRealVector - + ! ===================================================================================== @@ -1489,7 +1489,7 @@ subroutine set_restart_var(this,vname,vtype,long_name,units,flushval, & class(fates_restart_interface_type) :: this character(len=*),intent(in) :: vname character(len=*),intent(in) :: vtype - character(len=*),intent(in) :: units + character(len=*),intent(in) :: units real(r8), intent(in) :: flushval character(len=*),intent(in) :: long_name character(len=*),intent(in) :: hlms @@ -1501,32 +1501,32 @@ subroutine set_restart_var(this,vname,vtype,long_name,units,flushval, & ! A zero is passed back when the variable is ! not used - + type(fates_restart_variable_type),pointer :: rvar integer :: ub1,lb1,ub2,lb2 ! Bounds for allocating the var integer :: ityp - + logical :: use_var - + use_var = check_hlm_list(trim(hlms), trim(hlm_name)) if( use_var ) then - + ivar = ivar+1 - index = ivar - + index = ivar + if( initialize )then - + call this%rvars(ivar)%Init(vname, units, long_name, vtype, flushval, & fates_restart_num_dim_kinds, this%dim_kinds, this%dim_bounds) end if else - + index = 0 end if - + return end subroutine set_restart_var @@ -1584,7 +1584,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ! Some counters (for checking mostly) integer :: totalcohorts ! total cohort count on this thread (diagnostic) integer :: patchespersite ! number of patches per site - integer :: cohortsperpatch ! number of cohorts per patch + integer :: cohortsperpatch ! number of cohorts per patch integer :: ft ! functional type index integer :: el ! element loop index @@ -1639,14 +1639,14 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_gpp_acc_hold_co => this%rvars(ir_gpp_acc_hold_co)%r81d, & rio_resp_acc_hold_co => this%rvars(ir_resp_acc_hold_co)%r81d, & rio_npp_acc_hold_co => this%rvars(ir_npp_acc_hold_co)%r81d, & - rio_resp_m_def_co => this%rvars(ir_resp_m_def_co)%r81d, & + rio_resp_m_def_co => this%rvars(ir_resp_m_def_co)%r81d, & rio_bmort_co => this%rvars(ir_bmort_co)%r81d, & rio_hmort_co => this%rvars(ir_hmort_co)%r81d, & rio_cmort_co => this%rvars(ir_cmort_co)%r81d, & rio_daily_n_uptake_co => this%rvars(ir_daily_n_uptake_co)%r81d, & rio_daily_p_uptake_co => this%rvars(ir_daily_p_uptake_co)%r81d, & - rio_daily_c_efflux_co => this%rvars(ir_daily_c_efflux_co)%r81d, & - rio_daily_n_efflux_co => this%rvars(ir_daily_n_efflux_co)%r81d, & + rio_daily_c_efflux_co => this%rvars(ir_daily_c_efflux_co)%r81d, & + rio_daily_n_efflux_co => this%rvars(ir_daily_n_efflux_co)%r81d, & rio_daily_p_efflux_co => this%rvars(ir_daily_p_efflux_co)%r81d, & rio_daily_n_demand_co => this%rvars(ir_daily_n_demand_co)%r81d, & rio_daily_p_demand_co => this%rvars(ir_daily_p_demand_co)%r81d, & @@ -1668,8 +1668,8 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_spread_si => this%rvars(ir_spread_si)%r81d, & rio_livegrass_pa => this%rvars(ir_livegrass_pa)%r81d, & rio_age_pa => this%rvars(ir_age_pa)%r81d, & - rio_patchdistturbcat_pa => this%rvars(ir_patchdistturbcat_pa)%int1d, & - rio_agesinceanthrodist_pa => this%rvars(ir_agesinceanthrodist_pa)%r81d, & + rio_patchdistturbcat_pa => this%rvars(ir_patchdistturbcat_pa)%int1d, & + rio_agesinceanthrodist_pa => this%rvars(ir_agesinceanthrodist_pa)%r81d, & rio_nocomp_pft_label_pa => this%rvars(ir_nocomp_pft_label_pa)%int1d, & rio_area_pa => this%rvars(ir_area_pa)%r81d, & rio_watermem_siwm => this%rvars(ir_watermem_siwm)%r81d, & @@ -1697,20 +1697,20 @@ subroutine set_restart_vectors(this,nc,nsites,sites) totalCohorts = 0 - + ! --------------------------------------------------------------------------------- ! Flush arrays to values defined by %flushval (see registry entry in ! subroutine define_history_vars() ! --------------------------------------------------------------------------------- call this%flush_rvars(nc) - + do s = 1,nsites - + ! Calculate the offsets ! fcolumn is the global column index of the current site. ! For the first site, if that site aligns with the first column index ! in the clump, than the offset should be be equal to begCohort - + io_idx_si = this%restart_map(nc)%site_index(s) io_idx_co_1st = this%restart_map(nc)%cohort1_index(s) @@ -1725,32 +1725,32 @@ subroutine set_restart_vectors(this,nc,nsites,sites) io_idx_si_sc = io_idx_co_1st io_idx_si_capf = io_idx_co_1st io_idx_si_cacls= io_idx_co_1st - + ! recruitment rate do i_pft = 1,numpft rio_recrate_sift(io_idx_co_1st+i_pft-1) = sites(s)%recruitment_rate(i_pft) end do - + do i_pft = 1,numpft - rio_use_this_pft_sift(io_idx_co_1st+i_pft-1) = sites(s)%use_this_pft(i_pft) + rio_use_this_pft_sift(io_idx_co_1st+i_pft-1) = sites(s)%use_this_pft(i_pft) end do - + do i_pft = 1,numpft rio_area_pft_sift(io_idx_co_1st+i_pft-1) = sites(s)%area_pft(i_pft) end do - + do el = 1, num_elements io_idx_si_cwd = io_idx_co_1st io_idx_si_pft = io_idx_co_1st io_idx_si_scpf = io_idx_co_1st - + do i_cwd=1,ncwd this%rvars(ir_cwdagin_flxdg+el-1)%r81d(io_idx_si_cwd) = sites(s)%flux_diags(el)%cwd_ag_input(i_cwd) this%rvars(ir_cwdbgin_flxdg+el-1)%r81d(io_idx_si_cwd) = sites(s)%flux_diags(el)%cwd_bg_input(i_cwd) io_idx_si_cwd = io_idx_si_cwd + 1 end do - + do i_pft=1,numpft this%rvars(ir_leaflittin_flxdg+el-1)%r81d(io_idx_si_pft) = sites(s)%flux_diags(el)%leaf_litter_input(i_pft) this%rvars(ir_rootlittin_flxdg+el-1)%r81d(io_idx_si_pft) = sites(s)%flux_diags(el)%root_litter_input(i_pft) @@ -1766,8 +1766,8 @@ subroutine set_restart_vectors(this,nc,nsites,sites) io_idx_si_scpf = io_idx_si_scpf + 1 end do end do - - + + this%rvars(ir_oldstock_mbal+el-1)%r81d(io_idx_si) = sites(s)%mass_balance(el)%old_stock this%rvars(ir_errfates_mbal+el-1)%r81d(io_idx_si) = sites(s)%mass_balance(el)%err_fates @@ -1776,31 +1776,31 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ! canopy spread term rio_spread_si(io_idx_si) = sites(s)%spread - + cpatch => sites(s)%oldest_patch - + ! new column, reset num patches patchespersite = 0 - + do while(associated(cpatch)) - + ! found patch, increment patchespersite = patchespersite + 1 - + ccohort => cpatch%shortest - + ! new patch, reset num cohorts cohortsperpatch = 0 - + do while(associated(ccohort)) - + ! found cohort, increment cohortsperpatch = cohortsperpatch + 1 totalCohorts = totalCohorts + 1 - + if ( debug ) then write(fates_log(),*) 'CLTV io_idx_co ', io_idx_co - write(fates_log(),*) 'CLTV lowerbound ', lbound(rio_npp_acc_co,1) + write(fates_log(),*) 'CLTV lowerbound ', lbound(rio_npp_acc_co,1) write(fates_log(),*) 'CLTV upperbound ', ubound(rio_npp_acc_co,1) endif @@ -1813,7 +1813,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ir_prt_var = ir_prt_base do i_var = 1, prt_global%num_vars do i_pos = 1, prt_global%state_descriptor(i_var)%num_pos - + ir_prt_var = ir_prt_var + 1 this%rvars(ir_prt_var)%r81d(io_idx_co) = & ccohort%prt%variables(i_var)%val(i_pos) @@ -1821,7 +1821,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ir_prt_var = ir_prt_var + 1 this%rvars(ir_prt_var)%r81d(io_idx_co) = & ccohort%prt%variables(i_var)%turnover(i_pos) - + ir_prt_var = ir_prt_var + 1 this%rvars(ir_prt_var)%r81d(io_idx_co) = & ccohort%prt%variables(i_var)%net_alloc(i_pos) @@ -1829,13 +1829,13 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ir_prt_var = ir_prt_var + 1 this%rvars(ir_prt_var)%r81d(io_idx_co) = & ccohort%prt%variables(i_var)%burned(i_pos) - + end do end do - + if(hlm_use_planthydro==itrue)then - + ! Load the water contents call this%SetCohortRealVector(ccohort%co_hydr%th_ag,n_hypool_ag, & ir_hydro_th_ag_covec,io_idx_co) @@ -1848,13 +1848,13 @@ subroutine set_restart_vectors(this,nc,nsites,sites) call this%setCohortRealVector(ccohort%co_hydr%errh2o_growturn_ag, & n_hypool_ag, & ir_hydro_err_growturn_ag_covec,io_idx_co) - + this%rvars(ir_hydro_err_growturn_aroot)%r81d(io_idx_co) = & ccohort%co_hydr%errh2o_growturn_aroot - + this%rvars(ir_hydro_err_growturn_troot)%r81d(io_idx_co) = & ccohort%co_hydr%errh2o_growturn_troot - + end if @@ -1886,12 +1886,12 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_cmort_co(io_idx_co) = ccohort%cmort rio_smort_co(io_idx_co) = ccohort%smort rio_asmort_co(io_idx_co) = ccohort%asmort - rio_frmort_co(io_idx_co) = ccohort%frmort + rio_frmort_co(io_idx_co) = ccohort%frmort ! Nutrient uptake/efflux rio_daily_n_uptake_co(io_idx_co) = ccohort%daily_n_uptake rio_daily_p_uptake_co(io_idx_co) = ccohort%daily_p_uptake - + rio_daily_c_efflux_co(io_idx_co) = ccohort%daily_c_efflux rio_daily_n_efflux_co(io_idx_co) = ccohort%daily_n_efflux rio_daily_p_efflux_co(io_idx_co) = ccohort%daily_p_efflux @@ -1900,7 +1900,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_daily_p_demand_co(io_idx_co) = ccohort%daily_p_demand rio_daily_n_need_co(io_idx_co) = ccohort%daily_n_need2 rio_daily_p_need_co(io_idx_co) = ccohort%daily_p_need2 - + !Logging rio_lmort_direct_co(io_idx_co) = ccohort%lmort_direct rio_lmort_collateral_co(io_idx_co) = ccohort%lmort_collateral @@ -1915,22 +1915,22 @@ subroutine set_restart_vectors(this,nc,nsites,sites) else rio_isnew_co(io_idx_co) = old_cohort endif - + if (hlm_use_sp .eq. itrue) then this%rvars(ir_c_area_co)%r81d(io_idx_co) = ccohort%c_area end if - + if ( debug ) then write(fates_log(),*) 'CLTV offsetNumCohorts II ',io_idx_co, & cohortsperpatch endif - + io_idx_co = io_idx_co + 1 - + ccohort => ccohort%taller - + enddo ! ccohort do while - + ! ! deal with patch level fields here ! @@ -1940,10 +1940,10 @@ subroutine set_restart_vectors(this,nc,nsites,sites) 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 - + ! set cohorts per patch for IO rio_ncohort_pa( io_idx_co_1st ) = cohortsperpatch - + ! Set zenith angle info if ( cpatch%solar_zenith_flag ) then rio_solar_zenith_flag_pa(io_idx_co_1st) = itrue @@ -1959,18 +1959,18 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ! -------------------------------------------------------------------------- ! Send litter to the restart arrays - ! Each element has its own variable, so we have to make sure - ! we keep re-setting this + ! Each element has its own variable, so we have to make sure + ! we keep re-setting this ! -------------------------------------------------------------------------- do el = 0, num_elements-1 - + io_idx_pa_pft = io_idx_co_1st io_idx_pa_cwd = io_idx_co_1st io_idx_pa_cwsl = io_idx_co_1st io_idx_pa_dcsl = io_idx_co_1st io_idx_pa_dc = io_idx_co_1st - + litt => cpatch%litter(el+1) do i = 1,numpft @@ -1990,7 +1990,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) io_idx_pa_dcsl = io_idx_pa_dcsl + 1 end do end do - + do i = 1,ncwd this%rvars(ir_agcwd_litt+el)%r81d(io_idx_pa_cwd) = litt%ag_cwd(i) this%rvars(ir_agcwd_frag_litt+el)%r81d(io_idx_pa_cwd) = litt%ag_cwd_frag(i) @@ -2004,7 +2004,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) end do - + do i = 1,maxSWb rio_gnd_alb_dif_pasb(io_idx_pa_ib) = cpatch%gnd_alb_dif(i) rio_gnd_alb_dir_pasb(io_idx_pa_ib) = cpatch%gnd_alb_dir(i) @@ -2014,29 +2014,29 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ! Set the first cohort index to the start of the next patch, increment ! by the maximum number of cohorts per patch io_idx_co_1st = io_idx_co_1st + fates_maxElementsPerPatch - + ! reset counters so that they are all advanced evenly. io_idx_pa_pft = io_idx_co_1st io_idx_pa_cwd = io_idx_co_1st io_idx_pa_ib = io_idx_co_1st io_idx_co = io_idx_co_1st - + if ( debug ) then write(fates_log(),*) 'CLTV io_idx_co_1st ', io_idx_co_1st write(fates_log(),*) 'CLTV numCohort ', cohortsperpatch write(fates_log(),*) 'CLTV totalCohorts ', totalCohorts end if - + cpatch => cpatch%younger - + enddo ! cpatch do while - + io_idx_si_scpf = io_idx_co_1st - + ! Fill the site level diagnostics arrays do i_scls = 1, nlevsclass do i_pft = 1, numpft - + rio_fmortrate_cano_siscpf(io_idx_si_scpf) = sites(s)%fmort_rate_canopy(i_scls, i_pft) rio_fmortrate_usto_siscpf(io_idx_si_scpf) = sites(s)%fmort_rate_ustory(i_scls, i_pft) rio_imortrate_siscpf(io_idx_si_scpf) = sites(s)%imort_rate(i_scls, i_pft) @@ -2045,16 +2045,16 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_termnindiv_cano_siscpf(io_idx_si_scpf) = sites(s)%term_nindivs_canopy(i_scls,i_pft) rio_termnindiv_usto_siscpf(io_idx_si_scpf) = sites(s)%term_nindivs_ustory(i_scls,i_pft) rio_growflx_fusion_siscpf(io_idx_si_scpf) = sites(s)%growthflux_fusion(i_scls, i_pft) - + io_idx_si_scpf = io_idx_si_scpf + 1 end do rio_demorate_sisc(io_idx_si_sc) = sites(s)%demotion_rate(i_scls) rio_promrate_sisc(io_idx_si_sc) = sites(s)%promotion_rate(i_scls) - + io_idx_si_sc = io_idx_si_sc + 1 end do - + rio_termcflux_cano_si(io_idx_si) = sites(s)%term_carbonflux_canopy rio_termcflux_usto_si(io_idx_si) = sites(s)%term_carbonflux_ustory rio_democflux_si(io_idx_si) = sites(s)%demotion_carbonflux @@ -2073,14 +2073,14 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_dleafondate_si(io_idx_si) = sites(s)%dleafondate rio_dleafoffdate_si(io_idx_si) = sites(s)%dleafoffdate rio_acc_ni_si(io_idx_si) = sites(s)%acc_NI - rio_gdd_si(io_idx_si) = sites(s)%grow_deg_days - + rio_gdd_si(io_idx_si) = sites(s)%grow_deg_days + ! Accumulated trunk product rio_trunk_product_si(io_idx_si) = sites(s)%resources_management%trunk_product_site ! set numpatches for this column rio_npatch_si(io_idx_si) = patchespersite - + do i = 1,numWaterMem ! numWaterMem currently 10 rio_watermem_siwm( io_idx_si_wmem ) = sites(s)%water_memory(i) io_idx_si_wmem = io_idx_si_wmem + 1 @@ -2118,18 +2118,18 @@ subroutine set_restart_vectors(this,nc,nsites,sites) end if enddo - + if ( debug ) then write(fates_log(),*) 'CLTV total cohorts ',totalCohorts end if - + return end associate end subroutine set_restart_vectors ! ==================================================================================== - subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) + subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) ! ---------------------------------------------------------------------------------- ! This subroutine takes a peak at the restart file to determine how to allocate @@ -2143,7 +2143,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) use EDTypesMod, only : ed_patch_type use EDTypesMod, only : maxSWb use FatesInterfaceTypesMod, only : fates_maxElementsPerPatch - + use EDTypesMod, only : maxpft use EDTypesMod, only : area use EDPatchDynamicsMod, only : zero_patch @@ -2152,7 +2152,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) use EDPatchDynamicsMod, only : create_patch use EDPftvarcon, only : EDPftvarcon_inst use FatesAllometryMod, only : h2d_allom - + ! !ARGUMENTS: class(fates_restart_interface_type) , intent(inout) :: this @@ -2162,7 +2162,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) type(bc_in_type) , intent(in) :: bc_in(nsites) ! local variables - + type(ed_patch_type) , pointer :: newp type(ed_cohort_type), pointer :: new_cohort type(ed_cohort_type), pointer :: prev_cohort @@ -2182,12 +2182,12 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) ! and the number of cohorts per patch. These values tell us how much ! space to allocate. ! ---------------------------------------------------------------------------------- - + associate( rio_npatch_si => this%rvars(ir_npatch_si)%int1d , & rio_ncohort_pa => this%rvars(ir_ncohort_pa)%int1d ) - + do s = 1,nsites - + io_idx_si = this%restart_map(nc)%site_index(s) io_idx_co_1st = this%restart_map(nc)%cohort1_index(s) @@ -2199,9 +2199,9 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) write(fates_log(),*) '0 is a valid number, but this column seems uninitialized',rio_npatch_si(io_idx_si) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - + ! Initialize the site pointers to null - sites(s)%youngest_patch => null() + sites(s)%youngest_patch => null() sites(s)%oldest_patch => null() do idx_pa = 1,rio_npatch_si(io_idx_si) @@ -2210,10 +2210,10 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) write(fates_log(),*) 'create patch ',idx_pa write(fates_log(),*) 'idx_pa 1-cohortsperpatch : ', rio_ncohort_pa( io_idx_co_1st ) end if - + ! create patch - allocate(newp) - nocomp_pft = fates_unset_int + allocate(newp) + nocomp_pft = fates_unset_int ! the nocomp_pft label is set after patch creation has occured in 'get_restart_vectors' ! make new patch call create_patch(sites(s), newp, fates_unset_r8, fates_unset_r8, primaryforest, nocomp_pft ) @@ -2229,16 +2229,16 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) init_seed=fates_unset_r8, & init_seed_germ=fates_unset_r8) end do - + ! give this patch a unique patch number newp%patchno = idx_pa ! Iterate over the number of cohorts ! the file says are associated with this patch - ! we are just allocating space here, so we do + ! we are just allocating space here, so we do ! a simple list filling routine - + newp%tallest => null() newp%shortest => null() prev_cohort => null() @@ -2246,7 +2246,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) do fto = 1, rio_ncohort_pa( io_idx_co_1st ) allocate(new_cohort) - call nan_cohort(new_cohort) + call nan_cohort(new_cohort) call zero_cohort(new_cohort) new_cohort%patchptr => newp @@ -2254,7 +2254,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) if (.not.associated(newp%tallest)) then newp%tallest => new_cohort endif - + ! Every cohort's taller is the one that came before ! (unless it is first) if(associated(prev_cohort)) then @@ -2270,8 +2270,8 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) new_cohort%prt => null() call InitPRTObject(new_cohort%prt) call InitPRTBoundaryConditions(new_cohort) - - + + ! Allocate hydraulics arrays if( hlm_use_planthydro.eq.itrue ) then call InitHydrCohort(sites(s),new_cohort) @@ -2279,28 +2279,28 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) ! Update the previous prev_cohort => new_cohort - + enddo ! ends loop over fto - + ! ! insert this patch with cohorts into the site pointer. At this ! point just insert the new patch in the youngest position ! if (idx_pa == 1) then ! nothing associated yet. first patch is pointed to by youngest and oldest - + if ( debug ) write(fates_log(),*) 'idx_pa = 1 ',idx_pa - - sites(s)%youngest_patch => newp - sites(s)%oldest_patch => newp + + sites(s)%youngest_patch => newp + sites(s)%oldest_patch => newp sites(s)%youngest_patch%younger => null() sites(s)%youngest_patch%older => null() sites(s)%oldest_patch%younger => null() sites(s)%oldest_patch%older => null() - + else if (idx_pa == 2) then ! add second patch to list - + if ( debug ) write(fates_log(),*) 'idx_pa = 2 ',idx_pa - + sites(s)%youngest_patch => newp sites(s)%youngest_patch%younger => null() sites(s)%youngest_patch%older => sites(s)%oldest_patch @@ -2308,25 +2308,25 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) sites(s)%oldest_patch%older => null() else ! more than 2 patches, insert patch into youngest slot - + if ( debug ) write(fates_log(),*) 'idx_pa > 2 ',idx_pa - + newp%older => sites(s)%youngest_patch sites(s)%youngest_patch%younger => newp newp%younger => null() sites(s)%youngest_patch => newp - + endif - + io_idx_co_1st = io_idx_co_1st + fates_maxElementsPerPatch enddo ! ends loop over idx_pa enddo ! ends loop over s - + end associate end subroutine create_patchcohort_structure - + ! ==================================================================================== subroutine get_restart_vectors(this, nc, nsites, sites) @@ -2337,7 +2337,6 @@ subroutine get_restart_vectors(this, nc, nsites, sites) use EDTypesMod, only : maxSWb use FatesInterfaceTypesMod, only : numpft use FatesInterfaceTypesMod, only : fates_maxElementsPerPatch - use EDPhysiologyMod, only : assign_cohort_sp_properties use EDTypesMod, only : numWaterMem use EDTypesMod, only : num_vegtemp_mem use FatesSizeAgeTypeIndicesMod, only : get_age_class_index @@ -2373,7 +2372,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) integer :: io_idx_pa_cwd ! each cwd class within each patch (pa_cwd) integer :: io_idx_pa_cwsl ! each cwd x soil layer integer :: io_idx_pa_dcsl ! each decomposability x soil layer - integer :: io_idx_pa_dc ! each decomposability index + integer :: io_idx_pa_dc ! each decomposability index integer :: io_idx_pa_ib ! each SW radiation band per patch (pa_ib) integer :: io_idx_si_wmem ! each water memory class within each site integer :: io_idx_si_vtmem ! counter for vegetation temp memory @@ -2388,7 +2387,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ! Some counters (for checking mostly) integer :: totalcohorts ! total cohort count on this thread (diagnostic) integer :: patchespersite ! number of patches per site - integer :: cohortsperpatch ! number of cohorts per patch + integer :: cohortsperpatch ! number of cohorts per patch integer :: el ! loop counter for elements integer :: nlevsoil ! number of soil layers integer :: ilyr ! soil layer loop counter @@ -2422,7 +2421,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) rio_seed_prod_co => this%rvars(ir_seed_prod_co)%r81d, & rio_size_class_lasttimestep => this%rvars(ir_size_class_lasttimestep_co)%int1d, & rio_dbh_co => this%rvars(ir_dbh_co)%r81d, & - rio_coage_co => this%rvars(ir_coage_co)%r81d, & + rio_coage_co => this%rvars(ir_coage_co)%r81d, & rio_g_sb_laweight_co => this%rvars(ir_g_sb_laweight_co)%r81d, & rio_height_co => this%rvars(ir_height_co)%r81d, & rio_laimemory_co => this%rvars(ir_laimemory_co)%r81d, & @@ -2435,14 +2434,14 @@ subroutine get_restart_vectors(this, nc, nsites, sites) rio_gpp_acc_hold_co => this%rvars(ir_gpp_acc_hold_co)%r81d, & rio_resp_acc_hold_co => this%rvars(ir_resp_acc_hold_co)%r81d, & rio_npp_acc_hold_co => this%rvars(ir_npp_acc_hold_co)%r81d, & - rio_resp_m_def_co => this%rvars(ir_resp_m_def_co)%r81d, & + rio_resp_m_def_co => this%rvars(ir_resp_m_def_co)%r81d, & rio_bmort_co => this%rvars(ir_bmort_co)%r81d, & rio_hmort_co => this%rvars(ir_hmort_co)%r81d, & rio_cmort_co => this%rvars(ir_cmort_co)%r81d, & - rio_daily_n_uptake_co => this%rvars(ir_daily_n_uptake_co)%r81d, & - rio_daily_p_uptake_co => this%rvars(ir_daily_p_uptake_co)%r81d, & - rio_daily_c_efflux_co => this%rvars(ir_daily_c_efflux_co)%r81d, & - rio_daily_n_efflux_co => this%rvars(ir_daily_n_efflux_co)%r81d, & + rio_daily_n_uptake_co => this%rvars(ir_daily_n_uptake_co)%r81d, & + rio_daily_p_uptake_co => this%rvars(ir_daily_p_uptake_co)%r81d, & + rio_daily_c_efflux_co => this%rvars(ir_daily_c_efflux_co)%r81d, & + rio_daily_n_efflux_co => this%rvars(ir_daily_n_efflux_co)%r81d, & rio_daily_p_efflux_co => this%rvars(ir_daily_p_efflux_co)%r81d, & rio_daily_n_demand_co => this%rvars(ir_daily_n_demand_co)%r81d, & rio_daily_p_demand_co => this%rvars(ir_daily_p_demand_co)%r81d, & @@ -2490,15 +2489,15 @@ subroutine get_restart_vectors(this, nc, nsites, sites) rio_imortcflux_si => this%rvars(ir_imortcflux_si)%r81d, & rio_fmortcflux_cano_si => this%rvars(ir_fmortcflux_cano_si)%r81d, & rio_fmortcflux_usto_si => this%rvars(ir_fmortcflux_usto_si)%r81d) - + totalcohorts = 0 - + do s = 1,nsites - + io_idx_si = this%restart_map(nc)%site_index(s) io_idx_co_1st = this%restart_map(nc)%cohort1_index(s) - + io_idx_co = io_idx_co_1st io_idx_pa_ib = io_idx_co_1st io_idx_si_wmem = io_idx_co_1st @@ -2511,13 +2510,13 @@ subroutine get_restart_vectors(this, nc, nsites, sites) io_idx_si_sc = io_idx_co_1st io_idx_si_capf = io_idx_co_1st io_idx_si_cacls= io_idx_co_1st - + ! read seed_bank info(site-level, but PFT-resolved) - do i_pft = 1,numpft + do i_pft = 1,numpft sites(s)%recruitment_rate(i_pft) = rio_recrate_sift(io_idx_co_1st+i_pft-1) enddo - - !variables for fixed biogeography mode. These are currently used in restart even when this is off. + + !variables for fixed biogeography mode. These are currently used in restart even when this is off. do i_pft = 1,numpft sites(s)%use_this_pft(i_pft) = rio_use_this_pft_sift(io_idx_co_1st+i_pft-1) sites(s)%area_pft(i_pft) = rio_area_pft_sift(io_idx_co_1st+i_pft-1) @@ -2529,13 +2528,13 @@ subroutine get_restart_vectors(this, nc, nsites, sites) io_idx_si_cwd = io_idx_co_1st io_idx_si_pft = io_idx_co_1st io_idx_si_scpf = io_idx_co_1st - + do i_cwd=1,ncwd sites(s)%flux_diags(el)%cwd_ag_input(i_cwd) = this%rvars(ir_cwdagin_flxdg+el-1)%r81d(io_idx_si_cwd) sites(s)%flux_diags(el)%cwd_bg_input(i_cwd) = this%rvars(ir_cwdbgin_flxdg+el-1)%r81d(io_idx_si_cwd) io_idx_si_cwd = io_idx_si_cwd + 1 end do - + do i_pft=1,numpft sites(s)%flux_diags(el)%leaf_litter_input(i_pft) = this%rvars(ir_leaflittin_flxdg+el-1)%r81d(io_idx_si_pft) sites(s)%flux_diags(el)%root_litter_input(i_pft) = this%rvars(ir_rootlittin_flxdg+el-1)%r81d(io_idx_si_pft) @@ -2551,34 +2550,34 @@ subroutine get_restart_vectors(this, nc, nsites, sites) io_idx_si_scpf = io_idx_si_scpf + 1 end do end do - - + + sites(s)%mass_balance(el)%old_stock = this%rvars(ir_oldstock_mbal+el-1)%r81d(io_idx_si) sites(s)%mass_balance(el)%err_fates = this%rvars(ir_errfates_mbal+el-1)%r81d(io_idx_si) end do - sites(s)%spread = rio_spread_si(io_idx_si) - + sites(s)%spread = rio_spread_si(io_idx_si) + ! Perform a check on the number of patches per site patchespersite = 0 - + cpatch => sites(s)%oldest_patch do while(associated(cpatch)) - + patchespersite = patchespersite + 1 - + ccohort => cpatch%shortest - + ! new patch, reset num cohorts cohortsperpatch = 0 - - do while(associated(ccohort)) - + + do while(associated(ccohort)) + ! found cohort, increment cohortsperpatch = cohortsperpatch + 1 totalcohorts = totalcohorts + 1 - + if ( debug ) then write(fates_log(),*) 'CVTL io_idx_co ',io_idx_co endif @@ -2590,7 +2589,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ir_prt_var = ir_prt_base do i_var = 1, prt_global%num_vars - do i_pos = 1, prt_global%state_descriptor(i_var)%num_pos + do i_pos = 1, prt_global%state_descriptor(i_var)%num_pos ir_prt_var = ir_prt_var + 1 ccohort%prt%variables(i_var)%val(i_pos) = & @@ -2606,13 +2605,13 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ir_prt_var = ir_prt_var + 1 ccohort%prt%variables(i_var)%burned(i_pos) = & - this%rvars(ir_prt_var)%r81d(io_idx_co) + this%rvars(ir_prt_var)%r81d(io_idx_co) end do end do - !ccohort%vcmax25top + !ccohort%vcmax25top !ccohort%jmax25top - !ccohort%tpu25top + !ccohort%tpu25top !ccohort%kp25top @@ -2643,15 +2642,15 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ccohort%smort = rio_smort_co(io_idx_co) ccohort%asmort = rio_asmort_co(io_idx_co) ccohort%frmort = rio_frmort_co(io_idx_co) - + ! Nutrient uptake / efflux ccohort%daily_n_uptake = rio_daily_n_uptake_co(io_idx_co) ccohort%daily_p_uptake = rio_daily_p_uptake_co(io_idx_co) ccohort%daily_c_efflux = rio_daily_c_efflux_co(io_idx_co) ccohort%daily_n_efflux = rio_daily_n_efflux_co(io_idx_co) ccohort%daily_p_efflux = rio_daily_p_efflux_co(io_idx_co) - - ccohort%daily_n_demand = rio_daily_n_demand_co(io_idx_co) + + ccohort%daily_n_demand = rio_daily_n_demand_co(io_idx_co) ccohort%daily_p_demand = rio_daily_p_demand_co(io_idx_co) ccohort%daily_n_need2 = rio_daily_n_need_co(io_idx_co) ccohort%daily_p_need2 = rio_daily_p_need_co(io_idx_co) @@ -2673,18 +2672,18 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ! Initialize Plant Hydraulics if(hlm_use_planthydro==itrue)then - + ! Load the water contents call this%GetCohortRealVector(ccohort%co_hydr%th_ag,n_hypool_ag, & ir_hydro_th_ag_covec,io_idx_co) call this%GetCohortRealVector(ccohort%co_hydr%th_aroot,sites(s)%si_hydr%nlevrhiz, & ir_hydro_th_aroot_covec,io_idx_co) - + ccohort%co_hydr%th_troot = this%rvars(ir_hydro_th_troot)%r81d(io_idx_co) - + call UpdatePlantPsiFTCFromTheta(ccohort,sites(s)%si_hydr) - + ccohort%co_hydr%errh2o_growturn_aroot = & this%rvars(ir_hydro_err_growturn_aroot)%r81d(io_idx_co) ccohort%co_hydr%errh2o_growturn_troot = & @@ -2698,11 +2697,11 @@ subroutine get_restart_vectors(this, nc, nsites, sites) if (hlm_use_sp .eq. itrue) then ccohort%c_area = this%rvars(ir_c_area_co)%r81d(io_idx_co) end if - + io_idx_co = io_idx_co + 1 - + ccohort => ccohort%taller - + enddo ! current cohort do while if(cohortsperpatch .ne. rio_ncohort_pa(io_idx_co_1st)) then @@ -2727,20 +2726,20 @@ subroutine get_restart_vectors(this, nc, nsites, sites) cpatch%solar_zenith_angle = rio_solar_zenith_angle_pa(io_idx_co_1st) ! set cohorts per patch for IO - + if ( debug ) then write(fates_log(),*) 'CVTL III ' & ,io_idx_co,cohortsperpatch endif - + ! -------------------------------------------------------------------------- ! Pull litter from the restart arrays - ! Each element has its own variable, so we have to make sure - ! we keep re-setting this + ! Each element has its own variable, so we have to make sure + ! we keep re-setting this ! -------------------------------------------------------------------------- do el = 0, num_elements-1 - + io_idx_pa_pft = io_idx_co_1st io_idx_pa_cwd = io_idx_co_1st io_idx_pa_cwsl = io_idx_co_1st @@ -2766,13 +2765,13 @@ subroutine get_restart_vectors(this, nc, nsites, sites) io_idx_pa_dcsl = io_idx_pa_dcsl + 1 end do end do - + do i = 1,ncwd litt%ag_cwd(i) = this%rvars(ir_agcwd_litt+el)%r81d(io_idx_pa_cwd) litt%ag_cwd_frag(i) = this%rvars(ir_agcwd_frag_litt+el)%r81d(io_idx_pa_cwd) io_idx_pa_cwd = io_idx_pa_cwd + 1 - + do ilyr=1,nlevsoil litt%bg_cwd(i,ilyr) = this%rvars(ir_bgcwd_litt+el)%r81d(io_idx_pa_cwsl) litt%bg_cwd_frag(i,ilyr) = this%rvars(ir_bgcwd_frag_litt+el)%r81d(io_idx_pa_cwsl) @@ -2790,30 +2789,30 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ! Now increment the position of the first cohort to that of the next ! patch - + io_idx_co_1st = io_idx_co_1st + fates_maxElementsPerPatch - + ! and max the number of allowed cohorts per patch io_idx_pa_pft = io_idx_co_1st io_idx_pa_cwd = io_idx_co_1st io_idx_pa_ib = io_idx_co_1st io_idx_co = io_idx_co_1st - + if ( debug ) then write(fates_log(),*) 'CVTL io_idx_co_1st ', io_idx_co_1st write(fates_log(),*) 'CVTL cohortsperpatch ', cohortsperpatch write(fates_log(),*) 'CVTL totalCohorts ', totalCohorts end if - + cpatch => cpatch%younger - + enddo ! patch do while - + if(patchespersite .ne. rio_npatch_si(io_idx_si)) then write(fates_log(),*) 'Number of patches per site during retrieval does not match allocation' call endrun(msg=errMsg(sourcefile, __LINE__)) end if - + do i = 1,numWaterMem sites(s)%water_memory(i) = rio_watermem_siwm( io_idx_si_wmem ) io_idx_si_wmem = io_idx_si_wmem + 1 @@ -2828,7 +2827,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ! Retrieve site-level hydraulics arrays ! Note that Hydraulics structures, their allocations, and the length ! declaration nlevsoi_hyd should be allocated early on when the code first - ! allocates sites (before restart info), and when the soils layer is + ! allocates sites (before restart info), and when the soils layer is ! first known. ! ----------------------------------------------------------------------------- @@ -2851,7 +2850,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) end do end if - + ! Fill the site level diagnostics arrays ! ----------------------------------------------------------------------------- @@ -2864,7 +2863,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) sites(s)%fmort_rate_ustory(i_scls, i_pft) = rio_fmortrate_usto_siscpf(io_idx_si_scpf) sites(s)%imort_rate(i_scls, i_pft) = rio_imortrate_siscpf(io_idx_si_scpf) sites(s)%fmort_rate_crown(i_scls, i_pft) = rio_fmortrate_crown_siscpf(io_idx_si_scpf) - sites(s)%fmort_rate_cambial(i_scls, i_pft) = rio_fmortrate_cambi_siscpf(io_idx_si_scpf) + sites(s)%fmort_rate_cambial(i_scls, i_pft) = rio_fmortrate_cambi_siscpf(io_idx_si_scpf) sites(s)%term_nindivs_canopy(i_scls,i_pft) = rio_termnindiv_cano_siscpf(io_idx_si_scpf) sites(s)%term_nindivs_ustory(i_scls,i_pft) = rio_termnindiv_usto_siscpf(io_idx_si_scpf) sites(s)%growthflux_fusion(i_scls, i_pft) = rio_growflx_fusion_siscpf(io_idx_si_scpf) @@ -2873,7 +2872,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) sites(s)%demotion_rate(i_scls) = rio_demorate_sisc(io_idx_si_sc) sites(s)%promotion_rate(i_scls) = rio_promrate_sisc(io_idx_si_sc) - + io_idx_si_sc = io_idx_si_sc + 1 end do @@ -2885,7 +2884,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) sites(s)%fmort_carbonflux_canopy = rio_fmortcflux_cano_si(io_idx_si) sites(s)%fmort_carbonflux_ustory = rio_fmortcflux_usto_si(io_idx_si) - + ! Site level phenology status flags sites(s)%cstatus = rio_cd_status_si(io_idx_si) @@ -2906,10 +2905,10 @@ subroutine get_restart_vectors(this, nc, nsites, sites) if ( debug ) then write(fates_log(),*) 'CVTL total cohorts ',totalCohorts end if - + end associate end subroutine get_restart_vectors - + ! ==================================================================================== subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) @@ -2938,12 +2937,12 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) integer :: ifp ! patch counter do s = 1, nsites - + ifp = 0 currentpatch => sites(s)%oldest_patch - do while (associated(currentpatch)) + do while (associated(currentpatch)) ifp = ifp+1 - + currentPatch%f_sun (:,:,:) = 0._r8 currentPatch%fabd_sun_z (:,:,:) = 0._r8 currentPatch%fabd_sha_z (:,:,:) = 0._r8 @@ -2957,7 +2956,7 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) currentPatch%nrmlzd_parprof_pft_dif_z(:,:,:,:) = 0._r8 currentPatch%nrmlzd_parprof_dir_z(:,:,:) = 0._r8 currentPatch%nrmlzd_parprof_dif_z(:,:,:) = 0._r8 - + ! ----------------------------------------------------------- ! When calling norman radiation from the short-timestep ! we are passing in boundary conditions to set the following @@ -2965,9 +2964,9 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) ! currentPatch%solar_zenith_flag (is there daylight?) ! currentPatch%solar_zenith_angle (what is the value?) ! ----------------------------------------------------------- - + if(currentPatch%solar_zenith_flag)then - + bc_out(s)%albd_parb(ifp,:) = 0._r8 ! output HLM bc_out(s)%albi_parb(ifp,:) = 0._r8 ! output HLM bc_out(s)%fabi_parb(ifp,:) = 0._r8 ! output HLM @@ -2975,10 +2974,10 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) bc_out(s)%ftdd_parb(ifp,:) = 1._r8 ! output HLM bc_out(s)%ftid_parb(ifp,:) = 1._r8 ! output HLM bc_out(s)%ftii_parb(ifp,:) = 1._r8 ! output HLM - + if (maxval(currentPatch%nrad(1,:))==0)then - !there are no leaf layers in this patch. it is effectively bare ground. - ! no radiation is absorbed + !there are no leaf layers in this patch. it is effectively bare ground. + ! no radiation is absorbed bc_out(s)%fabd_parb(ifp,:) = 0.0_r8 bc_out(s)%fabi_parb(ifp,:) = 0.0_r8 do ib = 1,hlm_numSWb @@ -2992,7 +2991,7 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) bc_out(s)%ftii_parb(ifp,ib)= 1.0_r8 enddo else - + call PatchNormanRadiation (currentPatch, & bc_out(s)%albd_parb(ifp,:), & bc_out(s)%albi_parb(ifp,:), & @@ -3001,14 +3000,14 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) bc_out(s)%ftdd_parb(ifp,:), & bc_out(s)%ftid_parb(ifp,:), & bc_out(s)%ftii_parb(ifp,:)) - - endif ! is there vegetation? - + + endif ! is there vegetation? + end if ! if the vegetation and zenith filter is active currentPatch => currentPatch%younger end do ! Loop linked-list patches enddo ! Loop Sites - + return end subroutine update_3dpatch_radiation From 3150bdc4944134b105cd1f0a9c37d1318d47e5d0 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 5 Jul 2021 18:03:29 -0400 Subject: [PATCH 174/209] Initialized a script that will take an existing cdl file and create a new one based off of a diff xml file. --- parameter_files/patch_default_e3smtest.xml | 10 ++ tools/BatchPatchParams.py | 119 +++++++++++++++++++++ tools/FatesPFTIndexSwapper.py | 37 +++++-- 3 files changed, 160 insertions(+), 6 deletions(-) create mode 100644 parameter_files/patch_default_e3smtest.xml create mode 100755 tools/BatchPatchParams.py diff --git a/parameter_files/patch_default_e3smtest.xml b/parameter_files/patch_default_e3smtest.xml new file mode 100644 index 0000000000..01111c2200 --- /dev/null +++ b/parameter_files/patch_default_e3smtest.xml @@ -0,0 +1,10 @@ + + + fates_params_default.cdl + fates_params_e3smtest.cdl + 1,2,3,4,5,6,7,8,9,10,11,12 + + 0,0,0,0,0,0,0,0,0,0,0,0 + 0,0,0,0,0,0,0,0,0,0,0,0 + + diff --git a/tools/BatchPatchParams.py b/tools/BatchPatchParams.py new file mode 100755 index 0000000000..127b7d21bc --- /dev/null +++ b/tools/BatchPatchParams.py @@ -0,0 +1,119 @@ +#!/usr/bin/env python + +#### this script modifies the default FATES parameter file to generate +# a file used in testing E3SM +# Parser code was based off of modify_fates_paramfile.py + +import os +import argparse +import code # For development: code.interact(local=dict(globals(), **locals())) + +# This is the list of fields that should be changed +# (no spaces on comma parsed parameter values): +# --------------------------------------------------------------------------------------- + + + +override_list = [["fates_prescribed_nuptake","pft","0,0,0,0,0,0,0,0,0,0,0,0"], \ + ["fates_prescribed_puptake","pft","0,0,0,0,0,0,0,0,0,0,0,0"],] + + +# --------------------------------------------------------------------------------------- + +class param_type: + def __init__(self,name,values_text): + self.name = name + self.values = values_text.replace(" ","") #[float(x) for x in values_text.split(',')] + + + + +def load_xml(xmlfile): + + import xml.etree.ElementTree as et + + xmlroot = et.parse(xmlfile).getroot() + print("\nOpenend: "+xmlfile) + + base_cdl = xmlroot.find('base_file').text + new_cdl = xmlroot.find('new_file').text + + pftparams = xmlroot.find('pft_list').text.replace(" ","") + + paramroot = xmlroot.find('parameters') + paramlist = [] + for param in paramroot: + print("parsing "+param.tag) + paramlist.append(param_type(param.tag,param.text)) + + + + return(base_cdl,new_cdl,pftparams,paramlist) + + + +# Little function for assembling the call to the system to make the modification +# ---------------------------------------------------------------------------------------- + +def parse_syscall_str(fnamein,fnameout,param_name,dimtype,param_val): + + if(dimtype=="pft"): + pft_str = " --allpfts" + else: + pft_str = "" + + sys_call_str = "../tools/modify_fates_paramfile.py"+" --fin " + fnamein + \ + " --fout " + fnameout + " --var " + param_name + pft_str + \ + " --val " + param_val + " --overwrite" + + return(sys_call_str) + + + +def main(): + + # Parse arguments + parser = argparse.ArgumentParser(description='Parse command line arguments to this script.') + parser.add_argument('--f', dest='xmlfile', type=str, help="XML control file Required.", required=True) + args = parser.parse_args() + + + # Load the xml file, which contains the base cdl, the output cdl, + # and the parameters to be modified + [base_cdl,new_cdl,pftlist,paramlist] = load_xml(args.xmlfile) + + + # Convert the base cdl file into a temp nc binary + base_nc = os.popen('mktemp').read().rstrip('\n') + gencmd = "ncgen -o "+base_nc+" "+base_cdl + print(gencmd) + os.system(gencmd) + + # Generate a temp output file name + new_nc = os.popen('mktemp').read().rstrip('\n') + + + # Use FatesPFTIndexSwapper.py to prune out unwanted PFTs + swapcmd="../tools/FatesPFTIndexSwapper.py --pft-indices="+pftlist+" --fin="+base_nc+" --fout="+new_nc #+" 1>/dev/null" + os.system(swapcmd) + + # code.interact(local=dict(globals(), **locals())) + + # On subsequent parameters, overwrite the file + for param in paramlist: + + if(len(param.values.split(',')) != len(pftlist.split(',')) ): + print('The number of parameters for pfts does not match the pft list') + exit(2) + + change_str = parse_syscall_str(new_nc,new_nc,param.name,"pft",param.values) + os.system(change_str) + + # Dump the new file to the cdl + os.system("ncdump "+new_nc+" > "+new_cdl) + + +# This is the actual call to main + +if __name__ == "__main__": + main() diff --git a/tools/FatesPFTIndexSwapper.py b/tools/FatesPFTIndexSwapper.py index 9e0830d626..7e39056fa8 100755 --- a/tools/FatesPFTIndexSwapper.py +++ b/tools/FatesPFTIndexSwapper.py @@ -25,7 +25,9 @@ pft_dim_name = 'fates_pft' prt_dim_name = 'fates_prt_organs' - +hydro_dim_name = 'fates_hydr_organs' +litt_dim_name = 'fates_litterclass' +string_dim_name = 'fates_string_length' class timetype: @@ -165,22 +167,31 @@ def main(argv): # Idenfity if this variable has pft dimension pft_dim_found = -1 prt_dim_found = -1 + hydro_dim_found = -1 + litt_dim_found = -1 + string_dim_found = -1 pft_dim_len = len(fp_in.variables.get(key).dimensions) for idim, name in enumerate(fp_in.variables.get(key).dimensions): + # Manipulate data if(name==pft_dim_name): pft_dim_found = idim if(name==prt_dim_name): prt_dim_found = idim - + if(name==litt_dim_name): + litt_dim_found = idim + if(name==hydro_dim_name): + hydro_dim_found = idim + if(name==string_dim_name): + string_dim_found = idim # Copy over the input data # Tedious, but I have to permute through all combinations of dimension position if( pft_dim_len == 0 ): out_var = fp_out.createVariable(key,'d',(fp_in.variables.get(key).dimensions)) out_var.assignValue(float(fp_in.variables.get(key).data)) - elif( (pft_dim_found==-1) & (prt_dim_found==-1) ): + elif( (pft_dim_found==-1) & (prt_dim_found==-1) & (litt_dim_found==-1) & (hydro_dim_found==-1) ): out_var = fp_out.createVariable(key,'d',(fp_in.variables.get(key).dimensions)) out_var[:] = in_var[:] elif( (pft_dim_found==0) & (pft_dim_len==1) ): # 1D fates_pft @@ -208,14 +219,28 @@ def main(argv): for id,ipft in enumerate(donor_pft_indices): out_var[id] = fp_in.variables.get(key).data[ipft-1] - elif( (prt_dim_found==0) & (pft_dim_len==2) ): # fates_prt_organs - string_length + elif( (prt_dim_found==0) & (pft_dim_len==2) ): + out_var = fp_out.createVariable(key,'c',(fp_in.variables.get(key).dimensions)) + out_var[:] = in_var[:] + + elif( (hydro_dim_found==0) & (string_dim_found>=0) ): out_var = fp_out.createVariable(key,'c',(fp_in.variables.get(key).dimensions)) out_var[:] = in_var[:] + + elif( (litt_dim_found==0) & (string_dim_found>=0) ): + out_var = fp_out.createVariable(key,'c',(fp_in.variables.get(key).dimensions)) + out_var[:] = in_var[:] + + elif( prt_dim_found==0 ): # fates_prt_organs - indices + out_var = fp_out.createVariable(key,'d',(fp_in.variables.get(key).dimensions)) + out_var[:] = in_var[:] - elif( prt_dim_found==0 ): + elif( litt_dim_found==0 ): + out_var = fp_out.createVariable(key,'d',(fp_in.variables.get(key).dimensions)) + out_var[:] = in_var[:] + elif( hydro_dim_found==0): out_var = fp_out.createVariable(key,'d',(fp_in.variables.get(key).dimensions)) out_var[:] = in_var[:] - else: print('This variable has a dimensioning that we have not considered yet.') print('Please add this condition to the logic above this statement.') From a7a884414e1ae2c2a7fba595ee565b98425de14a Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 5 Jul 2021 18:16:29 -0400 Subject: [PATCH 175/209] removed temporary text overrides for batch cdl converter --- tools/BatchPatchParams.py | 10 +--------- 1 file changed, 1 insertion(+), 9 deletions(-) diff --git a/tools/BatchPatchParams.py b/tools/BatchPatchParams.py index 127b7d21bc..f4738d397b 100755 --- a/tools/BatchPatchParams.py +++ b/tools/BatchPatchParams.py @@ -8,14 +8,6 @@ import argparse import code # For development: code.interact(local=dict(globals(), **locals())) -# This is the list of fields that should be changed -# (no spaces on comma parsed parameter values): -# --------------------------------------------------------------------------------------- - - - -override_list = [["fates_prescribed_nuptake","pft","0,0,0,0,0,0,0,0,0,0,0,0"], \ - ["fates_prescribed_puptake","pft","0,0,0,0,0,0,0,0,0,0,0,0"],] # --------------------------------------------------------------------------------------- @@ -25,7 +17,7 @@ def __init__(self,name,values_text): self.name = name self.values = values_text.replace(" ","") #[float(x) for x in values_text.split(',')] - +# --------------------------------------------------------------------------------------- def load_xml(xmlfile): From 2704375f39483e90acdba36c410266edd0f3ac1f Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 6 Jul 2021 10:16:56 -0400 Subject: [PATCH 176/209] Added sorting to the batch parameter script --- tools/BatchPatchParams.py | 23 +++++++++++++++++------ 1 file changed, 17 insertions(+), 6 deletions(-) diff --git a/tools/BatchPatchParams.py b/tools/BatchPatchParams.py index f4738d397b..4f13ad798e 100755 --- a/tools/BatchPatchParams.py +++ b/tools/BatchPatchParams.py @@ -7,7 +7,7 @@ import os import argparse import code # For development: code.interact(local=dict(globals(), **locals())) - +from scipy.io import netcdf # --------------------------------------------------------------------------------------- @@ -88,22 +88,33 @@ def main(): # Use FatesPFTIndexSwapper.py to prune out unwanted PFTs swapcmd="../tools/FatesPFTIndexSwapper.py --pft-indices="+pftlist+" --fin="+base_nc+" --fout="+new_nc #+" 1>/dev/null" os.system(swapcmd) - - # code.interact(local=dict(globals(), **locals())) + + # We open the new parameter file. We only use this + # to do some dimension checking. + fp_nc = netcdf.netcdf_file(base_nc, 'r') # On subsequent parameters, overwrite the file for param in paramlist: - if(len(param.values.split(',')) != len(pftlist.split(',')) ): - print('The number of parameters for pfts does not match the pft list') + dset_len = len(fp_nc.variables.get(param.name).data[:]) + if(len(param.values.split(',')) != dset_len ): + print('The number of parameters values specified does not match the dataset') exit(2) change_str = parse_syscall_str(new_nc,new_nc,param.name,"pft",param.values) os.system(change_str) + # Sort the new file + newer_nc = os.popen('mktemp').read().rstrip('\n') + os.system("../tools/ncvarsort.py --fin "+new_nc+" --fout "+newer_nc+" --overwrite") + # Dump the new file to the cdl - os.system("ncdump "+new_nc+" > "+new_cdl) + os.system("ncdump "+newer_nc+" > "+new_cdl) + + fp_nc.close() + print("\nBatch parameter transfer complete\n") + # This is the actual call to main From 5730cedef519a0821e77d24284be55a7d95d097e Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 9 Jul 2021 16:48:57 -0700 Subject: [PATCH 177/209] adding restart variables for calculating area index profiles --- main/FatesRestartInterfaceMod.F90 | 42 ++++++++++++++++++++++++++++++- 1 file changed, 41 insertions(+), 1 deletion(-) diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 47737a9dd3..f1c528ae9e 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -115,6 +115,9 @@ module FatesRestartInterfaceMod integer :: ir_smort_co integer :: ir_asmort_co integer :: ir_c_area_co + integer :: ir_treelai_co + integer :: ir_treesai_co + integer :: ir_canopy_layer_tlai_pa integer :: ir_daily_n_uptake_co integer :: ir_daily_p_uptake_co @@ -1017,6 +1020,18 @@ subroutine define_restart_vars(this, initialize_variables) long_name='area of the fates cohort', & units='m2', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_c_area_co ) + call this%set_restart_var(vname='fates_cohort_treelai', vtype=cohort_r8, & + long_name='leaf area index of fates cohort', & + units='m2/m2', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_treelai_co ) + call this%set_restart_var(vname='fates_cohort_treesai', vtype=cohort_r8, & + long_name='stem area index of fates cohort', & + units='m2/m2', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_treesai_co ) + call this%set_restart_var(vname='fates_canopy_layer_tlai_pa', vtype=cohort_r8, & + long_name='total patch level leaf area index of each fates canopy layer', & + units='m2/m2', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_canopy_layer_tlai_pa ) end if @@ -1540,6 +1555,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) use EDTypesMod, only : ed_cohort_type use EDTypesMod, only : ed_patch_type use EDTypesMod, only : maxSWb + use EDTypesMod, only : nclmax use EDTypesMod, only : numWaterMem use EDTypesMod, only : num_vegtemp_mem @@ -1579,7 +1595,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) integer :: io_idx_si_cwd ! each site-cwd index integer :: io_idx_si_pft ! each site-pft index integer :: io_idx_si_vtmem ! indices for veg-temp memory at site - + integer :: io_idx_pa_ncl ! each canopy layer within each patch ! Some counters (for checking mostly) integer :: totalcohorts ! total cohort count on this thread (diagnostic) @@ -1918,6 +1934,8 @@ subroutine set_restart_vectors(this,nc,nsites,sites) if (hlm_use_sp .eq. itrue) then this%rvars(ir_c_area_co)%r81d(io_idx_co) = ccohort%c_area + this%rvars(ir_treelai_co)%r81d(io_idx_co) = ccohort%treelai + this%rvars(ir_treesai_co)%r81d(io_idx_co) = ccohort%treesai end if if ( debug ) then @@ -1970,6 +1988,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) io_idx_pa_cwsl = io_idx_co_1st io_idx_pa_dcsl = io_idx_co_1st io_idx_pa_dc = io_idx_co_1st + io_idx_pa_ncl = io_idx_co_1st litt => cpatch%litter(el+1) @@ -2011,6 +2030,13 @@ subroutine set_restart_vectors(this,nc,nsites,sites) io_idx_pa_ib = io_idx_pa_ib + 1 end do + if (hlm_use_sp .eq. itrue) then + do i = 1,nclmax + this%rvars(ir_canopy_layer_tlai_pa)%r81d(io_idx_pa_ncl) = cpatch%canopy_layer_tlai(i) + io_idx_pa_ncl = io_idx_pa_ncl + 1 + end do + end if + ! Set the first cohort index to the start of the next patch, increment ! by the maximum number of cohorts per patch io_idx_co_1st = io_idx_co_1st + fates_maxElementsPerPatch @@ -2020,6 +2046,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) io_idx_pa_cwd = io_idx_co_1st io_idx_pa_ib = io_idx_co_1st io_idx_co = io_idx_co_1st + io_idx_pa_ncl = io_idx_co_1st if ( debug ) then write(fates_log(),*) 'CLTV io_idx_co_1st ', io_idx_co_1st @@ -2335,6 +2362,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) use EDTypesMod, only : ed_cohort_type use EDTypesMod, only : ed_patch_type use EDTypesMod, only : maxSWb + use EDTypesMod, only : nclmax use FatesInterfaceTypesMod, only : numpft use FatesInterfaceTypesMod, only : fates_maxElementsPerPatch use EDTypesMod, only : numWaterMem @@ -2383,6 +2411,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) integer :: io_idx_si_capf ! each cohort age class x pft index within site integer :: io_idx_si_cwd integer :: io_idx_si_pft + integer :: io_idx_pa_ncl ! each canopy layer within each patch ! Some counters (for checking mostly) integer :: totalcohorts ! total cohort count on this thread (diagnostic) @@ -2502,6 +2531,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) io_idx_pa_ib = io_idx_co_1st io_idx_si_wmem = io_idx_co_1st io_idx_si_vtmem = io_idx_co_1st + io_idx_pa_ncl = io_idx_co_1st ! Hydraulics counters lyr = hydraulic layer, shell = rhizosphere shell io_idx_si_lyr_shell = io_idx_co_1st @@ -2696,6 +2726,8 @@ subroutine get_restart_vectors(this, nc, nsites, sites) if (hlm_use_sp .eq. itrue) then ccohort%c_area = this%rvars(ir_c_area_co)%r81d(io_idx_co) + ccohort%treelai = this%rvars(ir_treelai_co)%r81d(io_idx_co) + ccohort%treesai = this%rvars(ir_treesai_co)%r81d(io_idx_co) end if io_idx_co = io_idx_co + 1 @@ -2787,6 +2819,13 @@ subroutine get_restart_vectors(this, nc, nsites, sites) io_idx_pa_ib = io_idx_pa_ib + 1 end do + if (hlm_use_sp .eq. itrue) then + do i = 1,nclmax + cpatch%canopy_layer_tlai(i) = this%rvars(ir_canopy_layer_tlai_pa)%r81d(io_idx_pa_ncl) + io_idx_pa_ncl = io_idx_pa_ncl + 1 + end do + end if + ! Now increment the position of the first cohort to that of the next ! patch @@ -2797,6 +2836,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) io_idx_pa_cwd = io_idx_co_1st io_idx_pa_ib = io_idx_co_1st io_idx_co = io_idx_co_1st + io_idx_pa_ncl = io_idx_co_1st if ( debug ) then write(fates_log(),*) 'CVTL io_idx_co_1st ', io_idx_co_1st From 2c892f7b84a7a56322e568dfa57ebb0c4e8225d1 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 21 Jul 2021 10:03:12 -0400 Subject: [PATCH 178/209] Updated the batchPatch and modify_fates_paramfile scripts to allow parameters to be defined as the full vector --- tools/BatchPatchParams.py | 18 +- tools/modify_fates_paramfile.py | 385 ++++++++++++++++++-------------- 2 files changed, 225 insertions(+), 178 deletions(-) diff --git a/tools/BatchPatchParams.py b/tools/BatchPatchParams.py index 4f13ad798e..19587b426a 100755 --- a/tools/BatchPatchParams.py +++ b/tools/BatchPatchParams.py @@ -47,16 +47,11 @@ def load_xml(xmlfile): # Little function for assembling the call to the system to make the modification # ---------------------------------------------------------------------------------------- -def parse_syscall_str(fnamein,fnameout,param_name,dimtype,param_val): - - if(dimtype=="pft"): - pft_str = " --allpfts" - else: - pft_str = "" +def parse_syscall_str(fnamein,fnameout,param_name,param_val): sys_call_str = "../tools/modify_fates_paramfile.py"+" --fin " + fnamein + \ - " --fout " + fnameout + " --var " + param_name + pft_str + \ - " --val " + param_val + " --overwrite" + " --fout " + fnameout + " --var " + param_name + \ + " --val " + param_val + " --overwrite --all" return(sys_call_str) @@ -96,12 +91,7 @@ def main(): # On subsequent parameters, overwrite the file for param in paramlist: - dset_len = len(fp_nc.variables.get(param.name).data[:]) - if(len(param.values.split(',')) != dset_len ): - print('The number of parameters values specified does not match the dataset') - exit(2) - - change_str = parse_syscall_str(new_nc,new_nc,param.name,"pft",param.values) + change_str = parse_syscall_str(new_nc,new_nc,param.name,param.values) os.system(change_str) # Sort the new file diff --git a/tools/modify_fates_paramfile.py b/tools/modify_fates_paramfile.py index 12fb552cdc..670ad96d8a 100755 --- a/tools/modify_fates_paramfile.py +++ b/tools/modify_fates_paramfile.py @@ -25,6 +25,7 @@ import datetime import time import numpy as np +import code # For development: code.interact(local=dict(globals(), **locals())) # ======================================================================================== # ======================================================================================== @@ -46,30 +47,39 @@ def main(): parser.add_argument('--silent', '--s', dest='silent', help="prevent writing of output.", action="store_true") parser.add_argument('--nohist', dest='nohist', help="prevent recording of the edit in the history attribute of the output file", action="store_true") parser.add_argument('--changeshape', dest='changeshape', help="allow script to change shape of specified variable, and all other variables with the relevant dimension, if necessary", action="store_true") + parser.add_argument('--all',dest='varall',help="replace all values for the specified parameter, supercedes other flags",action="store_true") # args = parser.parse_args() # - # work with the file in some random temporary place so that if something goes wrong, then nothing happens to original file and it doesn't make a persistent output file + # work with the file in some random temporary place so that if something goes wrong, + # then nothing happens to original file and it doesn't make a persistent output file tempdir = tempfile.mkdtemp() tempfilename = os.path.join(tempdir, 'temp_fates_param_file.nc') ncfile_old = None rename_pft = False - # - try: - outputval = float(args.val) - if args.changeshape: - raise Exception - except: + + if args.varall: + # val_list = args.val.split(',') + # output_vec = [float(valstr) for valstr in val_list] + outputval = np.fromstring(args.val, sep=',', dtype=np.float64) + + else: + try: - #print('output variable not interpretable as real. trying array') - outputval = np.fromstring(args.val, sep=',', dtype=np.float32) - if len(outputval) == 0: - raise RuntimeError('output variable needs to have size greater than zero') + outputval = float(args.val) + if args.changeshape: + raise Exception except: - if args.varname != 'fates_pftname': - raise RuntimeError('output variable not interpretable as real or array') - else: - rename_pft = True + try: + #print('output variable not interpretable as real. trying array') + outputval = np.fromstring(args.val, sep=',', dtype=np.float32) + if len(outputval) == 0: + raise RuntimeError('output variable needs to have size greater than zero') + except: + if args.varname != 'fates_pftname': + raise RuntimeError('output variable not interpretable as real or array') + else: + rename_pft = True # # try: @@ -78,169 +88,213 @@ def main(): ncfile = nc.netcdf_file(tempfilename, 'a') # var = ncfile.variables[args.varname] + # - ### check to make sure that, if a PFT is specified, the variable has a PFT dimension, and if not, then it doesn't. and also that shape is reasonable. + ### check to make sure that, if a PFT is specified, the variable has a PFT dimension, + ### and if not, then it doesn't. and also that shape is reasonable. ndim_file = len(var.dimensions) - ispftvar = False - # for purposes of current state of this script, assume 1D - if ndim_file > 2: - raise ValueError('variable dimensionality is too high for this script') - for i in range(ndim_file): - if var.dimensions[i] == 'fates_pft': - ispftvar = True - npft_file = var.shape[i] - pftdim = i - otherdimpresent = False - elif var.dimensions[i] in ['fates_history_age_bins','fates_history_size_bins','fates_history_coage_bins','fates_history_height_bins','fates_NCWD','fates_litterclass','fates_leafage_class','fates_prt_organs','fates_hydr_organs','fates_variants']: - otherdimpresent = True - otherdimname = var.dimensions[i] - otherdimlength = var.shape[i] - elif var.dimensions[i] == 'fates_string_length' and rename_pft: - otherdimpresent = True - otherdimname = var.dimensions[i] - otherdimlength = var.shape[i] - else: - raise ValueError('variable is not on either the PFT or scalar dimension') - # - if args.changeshape: - ### if we are allowing the script to change the shape of the variable, then we need to figure out if that's really a thing that needs to happen. - ### first identify what dimension we would change the shape of if we had to. - length_specified = len(outputval) - if length_specified != otherdimlength: - ### ok, we find ourselves in the situation where we need to rewrite the netcdf from scratch with its revised shape. - # - # first lets chech to make sure the dimension we are changing can be changed without breaking things. - plastic_dimensions_list = ['fates_history_age_bins','fates_history_size_bins','fates_history_coage_bins','fates_history_height_bins','fates_leafage_class'] - if otherdimname not in plastic_dimensions_list: - raise ValueError('asking to change the shape of a dimension, '+otherdimname+', that will probably break things') + + + if args.varall: + + # Calculate total number of values expected + nvals = 1 + #code.interact(local=dict(globals(), **locals())) + for i in range(ndim_file): + nvals = nvals*np.prod(var.shape[i]) + if(len(outputval) != nvals): + print('Input vector is not the same size as the in-file array for {}'.format(args.varname)) + print('total size = {}, you specified = {} values'.format(nvals,len(outputval))) + exit(2) + + if(ndim_file==2): + ii = 0 + for i in range(var.shape[0]): + for j in range(var.shape[1]): + var[i,j] = outputval[ii] + ii=ii+1 + + elif(ndim_file==1): + for i in range(var.shape[0]): + var[i] = outputval[i] + + else: + + ispftvar = False + # for purposes of current state of this script, assume 1D + if ndim_file > 2: + raise ValueError('variable dimensionality is too high for this script') + for i in range(ndim_file): + if var.dimensions[i] == 'fates_pft': + ispftvar = True + npft_file = var.shape[i] + pftdim = i + otherdimpresent = False + elif var.dimensions[i] in ['fates_history_age_bins','fates_history_size_bins', \ + 'fates_history_coage_bins','fates_history_height_bins', \ + 'fates_NCWD','fates_litterclass','fates_leafage_class', \ + 'fates_prt_organs','fates_hydr_organs','fates_variants']: + otherdimpresent = True + otherdimname = var.dimensions[i] + otherdimlength = var.shape[i] + elif var.dimensions[i] == 'fates_string_length' and rename_pft: + otherdimpresent = True + otherdimname = var.dimensions[i] + otherdimlength = var.shape[i] else: - print('WARNING: we need to change the dimension of '+otherdimname) - ### close the file that's open and start over. - ncfile.close() - os.remove(tempfilename) - ncfile = nc.netcdf_file(tempfilename, 'w') - ncfile_old = nc.netcdf_file(args.inputfname, 'r') - # - try: - ncfile.history = ncfile_old.history - except: - print('no history') - # - ### copy over and, when needed, modify the dimensions - for name, dimlength in ncfile_old.dimensions.items(): - #print(name, dimlength) - if name != otherdimname: - ncfile.createDimension(name, dimlength) + raise ValueError('variable is not on either the PFT or scalar dimension') + + # + if args.changeshape: + ### if we are allowing the script to change the shape of the variable, + ### then we need to figure out if that's really a thing that needs to happen. + ### first identify what dimension we would change the shape of if we had to. + length_specified = len(outputval) + if length_specified != otherdimlength: + ### ok, we find ourselves in the situation where we need to rewrite the netcdf + ### from scratch with its revised shape. + # + # first lets chech to make sure the dimension we are changing can be changed without breaking things. + plastic_dimensions_list = ['fates_history_age_bins','fates_history_size_bins', \ + 'fates_history_coage_bins','fates_history_height_bins', \ + 'fates_leafage_class'] + if otherdimname not in plastic_dimensions_list: + raise ValueError('asking to change the shape of a dimension, '+\ + otherdimname+', that will probably break things') else: - ncfile.createDimension(name, length_specified) - #print(name, length_specified) - # - ### copy over and, when needed, modify the variables - for name, variable in ncfile_old.variables.items(): - variabledims = variable.dimensions - #print(name, variabledims) - x = ncfile.createVariable(name, variable.data.dtype, variable.dimensions) - try: - x.units = variable.units - except: - print('no units') + print('WARNING: we need to change the dimension of '+otherdimname) + ### close the file that's open and start over. + ncfile.close() + os.remove(tempfilename) + ncfile = nc.netcdf_file(tempfilename, 'w') + ncfile_old = nc.netcdf_file(args.inputfname, 'r') + # try: - x.long_name = variable.long_name + ncfile.history = ncfile_old.history except: - print('no long name') + print('no history') # - if len(variable.dimensions) > 0: - if not otherdimname in variable.dimensions: - x[:] = variable[:] + ### copy over and, when needed, modify the dimensions + for name, dimlength in ncfile_old.dimensions.items(): + #print(name, dimlength) + if name != otherdimname: + ncfile.createDimension(name, dimlength) else: - if len(variable.dimensions) == 1: - if length_specified > otherdimlength: - print('WARNING: Variable '+name+' has a dimension that has been reshaped. New length is longer than old, so its been filled in with zeros.') - x[0:otherdimlength] = variable[0:otherdimlength] - x[otherdimlength:length_specified] = 0 - else: - print('WARNING: Variable '+name+' has a dimension that has been reshaped. New length is shorter than old, so its been truncated.') - x[0:length_specified] = variable[0:length_specified] - elif len(variable.dimensions) == 2: - if length_specified > otherdimlength: - print('WARNING: Variable '+name+' has a dimension that has been reshaped. New length is longer than old, so its been filled in with zeros.') - x[0:otherdimlength,:] = variable[0:otherdimlength,:] - x[otherdimlength:length_specified,:] = 0 - else: - print('WARNING: Variable '+name+' has a dimension that has been reshaped. New length is shorter than old, so its been truncated.') - x[0:length_specified,:] = variable[0:length_specified,:] - else: - x.assignValue(float(variable.data)) - # - var = ncfile.variables[args.varname] - else: - # declare as none for now - ncfile_old = None - # - if (args.pftnum == None and args.pftname == None and ispftvar) and not args.allpfts: - raise ValueError('pft value is missing but variable has pft dimension.') - if (args.pftnum != None or args.pftname != None) and args.allpfts: - raise ValueError("can't specify both a PFT number and the argument allPFTs.") - if (args.pftnum != None or args.pftname != None) and not ispftvar: - raise ValueError('pft value is present but variable does not have pft dimension.') - if (args.pftnum != None and args.pftname != None): - raise ValueError('can only specify pft number or name, not both.') - if (args.pftnum == None or args.pftname != None) and not args.allpfts and ispftvar: - ## now we need to figure out what the number of the pft that has been given a name argument - pftnamelist = [] - npftnames = ncfile.variables['fates_pftname'].shape[0] - for i in range(npftnames): - pftname_bytelist = list(ncfile.variables['fates_pftname'][i,:]) - pftname_stringlist = [i.decode('utf-8') for i in pftname_bytelist] - pftnamelist.append(''.join(pftname_stringlist).strip()) - n_times_pft_listed = pftnamelist.count(args.pftname.strip()) - if n_times_pft_listed != 1: - raise ValueError('can only index by PFT name if the chosen PFT name occurs once and only once.') - pftnum = pftnamelist.index(args.pftname.strip()) - args.pftnum=pftnum +1 - if args.pftnum != None and ispftvar: - if not rename_pft: - if args.pftnum > npft_file: - raise ValueError('PFT specified ('+str(args.pftnum)+') is larger than the number of PFTs in the file ('+str(npft_file)+').') + ncfile.createDimension(name, length_specified) + #print(name, length_specified) + # + ### copy over and, when needed, modify the variables + for name, variable in ncfile_old.variables.items(): + variabledims = variable.dimensions + #print(name, variabledims) + x = ncfile.createVariable(name, variable.data.dtype, variable.dimensions) + try: + x.units = variable.units + except: + print('no units') + try: + x.long_name = variable.long_name + except: + print('no long name') + # + if len(variable.dimensions) > 0: + if not otherdimname in variable.dimensions: + x[:] = variable[:] + else: + if len(variable.dimensions) == 1: + if length_specified > otherdimlength: + print('WARNING: Variable '+name+ \ + ' has a dimension that has been reshaped.'+\ + ' New length is longer than old, so its been filled in with zeros.') + x[0:otherdimlength] = variable[0:otherdimlength] + x[otherdimlength:length_specified] = 0 + else: + print('WARNING: Variable '+name+' has a dimension that has been reshaped.'+\ + ' New length is shorter than old, so its been truncated.') + x[0:length_specified] = variable[0:length_specified] + elif len(variable.dimensions) == 2: + if length_specified > otherdimlength: + print('WARNING: Variable '+name+' has a dimension that has been reshaped.'+\ + ' New length is longer than old, so its been filled in with zeros.') + x[0:otherdimlength,:] = variable[0:otherdimlength,:] + x[otherdimlength:length_specified,:] = 0 + else: + print('WARNING: Variable '+name+' has a dimension that has been reshaped.'+\ + ' New length is shorter than old, so its been truncated.') + x[0:length_specified,:] = variable[0:length_specified,:] + else: + x.assignValue(float(variable.data)) + # + var = ncfile.variables[args.varname] + else: + # declare as none for now + ncfile_old = None + # + if (args.pftnum == None and args.pftname == None and ispftvar) and not args.allpfts: + raise ValueError('pft value is missing but variable has pft dimension.') + if (args.pftnum != None or args.pftname != None) and args.allpfts: + raise ValueError("can't specify both a PFT number and the argument allPFTs.") + if (args.pftnum != None or args.pftname != None) and not ispftvar: + raise ValueError('pft value is present but variable does not have pft dimension.') + if (args.pftnum != None and args.pftname != None): + raise ValueError('can only specify pft number or name, not both.') + if (args.pftnum == None or args.pftname != None) and not args.allpfts and ispftvar: + ## now we need to figure out what the number of the pft that has been given a name argument + pftnamelist = [] + npftnames = ncfile.variables['fates_pftname'].shape[0] + for i in range(npftnames): + pftname_bytelist = list(ncfile.variables['fates_pftname'][i,:]) + pftname_stringlist = [i.decode('utf-8') for i in pftname_bytelist] + pftnamelist.append(''.join(pftname_stringlist).strip()) + n_times_pft_listed = pftnamelist.count(args.pftname.strip()) + if n_times_pft_listed != 1: + raise ValueError('can only index by PFT name if the chosen PFT name occurs once and only once.') + pftnum = pftnamelist.index(args.pftname.strip()) + args.pftnum=pftnum +1 + if args.pftnum != None and ispftvar: + if not rename_pft: + if args.pftnum > npft_file: + raise ValueError('PFT specified ('+str(args.pftnum)+') is larger than the number of PFTs in the file ('+str(npft_file)+').') + if pftdim == 0: + if not args.silent: + print('replacing prior value of variable '+args.varname+', for PFT '+str(args.pftnum)+', which was '+str(var[args.pftnum-1])+', with new value of '+str(outputval)) + var[args.pftnum-1] = outputval + if pftdim == 1: + if not args.silent: + print('replacing prior value of variable '+args.varname+', for PFT '+str(args.pftnum)+', which was '+str(var[:,args.pftnum-1])+', with new value of '+str(outputval)) + var[:,args.pftnum-1] = outputval + else: + pftname_in_bytelist = list(ncfile.variables['fates_pftname'][args.pftnum-1,:]) + pftname_in_stringlist = [i.decode('utf-8') for i in pftname_in_bytelist] + print('replacing prior value of pft name for PFT '+str(args.pftnum)+', which was "'+''.join(pftname_in_stringlist).strip()+'", with new value of "'+args.val+'"') + var[args.pftnum-1] = args.val.ljust(otherdimlength) + elif args.allpfts and ispftvar: if pftdim == 0: if not args.silent: - print('replacing prior value of variable '+args.varname+', for PFT '+str(args.pftnum)+', which was '+str(var[args.pftnum-1])+', with new value of '+str(outputval)) - var[args.pftnum-1] = outputval + print('replacing prior values of variable '+args.varname+', for all PFTs, which were '+str(var[:])+', with new value of '+str(outputval)) + var[:] = outputval if pftdim == 1: if not args.silent: - print('replacing prior value of variable '+args.varname+', for PFT '+str(args.pftnum)+', which was '+str(var[:,args.pftnum-1])+', with new value of '+str(outputval)) - var[:,args.pftnum-1] = outputval - else: - pftname_in_bytelist = list(ncfile.variables['fates_pftname'][args.pftnum-1,:]) - pftname_in_stringlist = [i.decode('utf-8') for i in pftname_in_bytelist] - print('replacing prior value of pft name for PFT '+str(args.pftnum)+', which was "'+''.join(pftname_in_stringlist).strip()+'", with new value of "'+args.val+'"') - var[args.pftnum-1] = args.val.ljust(otherdimlength) - elif args.allpfts and ispftvar: - if pftdim == 0: - if not args.silent: - print('replacing prior values of variable '+args.varname+', for all PFTs, which were '+str(var[:])+', with new value of '+str(outputval)) - var[:] = outputval - if pftdim == 1: - if not args.silent: - print('replacing prior values of variable '+args.varname+', for all PFTs, which were '+str(var[:])+', with new value of '+str(outputval)) - var[:] = outputval - elif args.pftnum == None and not ispftvar and ndim_file > 0: - if not otherdimpresent: + print('replacing prior values of variable '+args.varname+', for all PFTs, which were '+str(var[:])+', with new value of '+str(outputval)) + var[:] = outputval + elif args.pftnum == None and not ispftvar and ndim_file > 0: + if not otherdimpresent: + if not args.silent: + print('replacing prior value of variable '+args.varname+', which was '+str(var[:])+', with new value of '+str(outputval)) + var[:] = outputval + else: + #print(var.shape) + #print(outputval.shape) + if not args.silent: + print('replacing prior value of variable '+args.varname+', which was '+str(var[:])+', with new value of '+str(outputval)) + var[:] = outputval + elif ndim_file < 1: if not args.silent: - print('replacing prior value of variable '+args.varname+', which was '+str(var[:])+', with new value of '+str(outputval)) - var[:] = outputval + print('replacing prior value of scalar variable '+args.varname+', which was '+str(var.data)+', with new value of '+str(outputval)) + var.assignValue(outputval) else: - #print(var.shape) - #print(outputval.shape) - if not args.silent: - print('replacing prior value of variable '+args.varname+', which was '+str(var[:])+', with new value of '+str(outputval)) - var[:] = outputval - elif ndim_file < 1: - if not args.silent: - print('replacing prior value of scalar variable '+args.varname+', which was '+str(var.data)+', with new value of '+str(outputval)) - var.assignValue(outputval) - else: - raise ValueError('Nothing happened somehow.') + raise ValueError('Nothing happened somehow.') + # if not args.nohist: # write to the netcdf file history attribute what you just did. @@ -250,6 +304,9 @@ def main(): oldhiststr = ncfile.history.decode('utf-8') newhiststr = oldhiststr + "\n "+timestampstring + ': ' + actionstring ncfile.history = newhiststr + + + # ncfile.close() if type(ncfile_old) != type(None): From 5b25b2bb9d276e8eee19a46d30995d096dbadf3b Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 22 Jul 2021 15:21:53 -0700 Subject: [PATCH 179/209] fixing missing season_decid check in EDInitMod due to bad merge --- main/EDInitMod.F90 | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 6edce0b9be..a4c39ecdcb 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -783,8 +783,19 @@ subroutine init_cohorts( site_in, patch_in, bc_in) stem_drop_fraction = EDPftvarcon_inst%phen_stem_drop_fraction(temp_cohort%pft) - if(hlm_use_sp.eq.ifalse)then ! do not override SP vales with phenology + + if( prt_params%season_decid(pft) == itrue .and. & + any(site_in%cstatus == [phen_cstat_nevercold,phen_cstat_iscold])) then + temp_cohort%laimemory = c_leaf + temp_cohort%sapwmemory = c_sapw * stem_drop_fraction + temp_cohort%structmemory = c_struct * stem_drop_fraction + c_leaf = 0._r8 + c_sapw = (1.0_r8-stem_drop_fraction) * c_sapw + c_struct = (1.0_r8-stem_drop_fraction) * c_struct + cstatus = leaves_off + endif + if ( prt_params%stress_decid(pft) == itrue .and. & any(site_in%dstatus == [phen_dstat_timeoff,phen_dstat_moistoff])) then temp_cohort%laimemory = c_leaf @@ -795,6 +806,7 @@ subroutine init_cohorts( site_in, patch_in, bc_in) c_struct = (1.0_r8-stem_drop_fraction) * c_struct cstatus = leaves_off endif + end if ! SP mode if ( debug ) write(fates_log(),*) 'EDInitMod.F90 call create_cohort ' From bd585257864eca3ecbb34dd70681c7bc0112b46a Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 3 Aug 2021 08:49:29 -0600 Subject: [PATCH 180/209] adding diagnostics --- biogeochem/EDCanopyStructureMod.F90 | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 6ee77f646f..aec5f8aaca 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -2012,11 +2012,16 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) ! It is assumed that cpatch%canopy_area_profile and cpat%xai_profiles ! have been updated (ie ed_leaf_area_profile has been called since dynamics has been called) + write(fates_log(),*) 's, ifp: ', s, ifp + write(fates_log(),*) 'EDCanopyStructure pre: bc_out(s)%tlai_pa(ifp): ', bc_out(s)%tlai_pa(ifp) + bc_out(s)%elai_pa(ifp) = calc_areaindex(currentPatch,'elai') bc_out(s)%tlai_pa(ifp) = calc_areaindex(currentPatch,'tlai') bc_out(s)%esai_pa(ifp) = calc_areaindex(currentPatch,'esai') bc_out(s)%tsai_pa(ifp) = calc_areaindex(currentPatch,'tsai') + write(fates_log(),*) 'EDCanopyStructure post: bc_out(s)%tlai_pa(ifp): ', bc_out(s)%tlai_pa(ifp) + !if(debug) then ! write(fates_log(),*) 'ifp: ', ifp ! write(fates_log(),*) 'bc_out(s)%elai_pa(ifp): ', bc_out(s)%elai_pa(ifp) From 55e17e1f91a09017a7b30637a04ac11b3a2b8674 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 3 Aug 2021 11:33:55 -0600 Subject: [PATCH 181/209] adding tlai_profile output to diagnostics --- biogeochem/EDCanopyStructureMod.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index aec5f8aaca..b951990fa1 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1861,6 +1861,8 @@ subroutine leaf_area_profile( currentSite ) currentPatch%tlai_profile(cl,ft,iv) = currentPatch%tlai_profile(cl,ft,iv) / & currentPatch%canopy_area_profile(cl,ft,iv) + write(fates_log(), *) 'currentPatch%tlai_profile(cl,ft,iv): ', currentPatch%tlai_profile(cl,ft,iv) + write(fates_log(), *) 'currentPatch%canopy_area_profile(cl,ft,iv): ', currentPatch%canopy_area_profile(cl,ft,iv) currentPatch%tsai_profile(cl,ft,iv) = currentPatch%tsai_profile(cl,ft,iv) / & currentPatch%canopy_area_profile(cl,ft,iv) From eb9b850a7fff854ec14baf996ebb4a99db992d31 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 5 Aug 2021 10:29:34 -0600 Subject: [PATCH 182/209] fixing duplicates from poor merge --- biogeochem/EDPhysiologyMod.F90 | 26 -------------------------- 1 file changed, 26 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 6c088ef12a..888e490b4d 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1239,9 +1239,6 @@ subroutine phenology_leafonoff(currentSite) if(store_c>nearzero) then - store_c_transfer_frac = & - min(EDPftvarcon_inst%phenflush_fraction(ipft)*currentCohort%laimemory, store_c)/store_c - store_c_transfer_frac = & min((EDPftvarcon_inst%phenflush_fraction(ipft)*currentCohort%laimemory)/store_c, & (1.0_r8-carbon_store_buffer)) @@ -2479,29 +2476,6 @@ subroutine fragmentation_scaler( currentPatch, bc_in) ifp = currentPatch%patchno if(currentPatch%nocomp_pft_label.gt.0)then - if ( .not. use_century_tfunc ) then - !calculate rate constant scalar for soil temperature,assuming that the base rate constants - !are assigned for non-moisture limiting conditions at 25C. - if (bc_in%t_veg24_pa(ifp) >= tfrz) then - t_scalar = q10_mr**((bc_in%t_veg24_pa(ifp)-(tfrz+25._r8))/10._r8) - ! Q10**((t_soisno(c,j)-(tfrz+25._r8))/10._r8) - else - t_scalar = (q10_mr**(-25._r8/10._r8))*(q10_froz**((bc_in%t_veg24_pa(ifp)-tfrz)/10._r8)) - !Q10**(-25._r8/10._r8))*(froz_q10**((t_soisno(c,j)-tfrz)/10._r8) - endif - else - ! original century uses an arctangent function to calculate the - ! temperature dependence of decomposition - t_scalar = max(catanf(bc_in%t_veg24_pa(ifp)-tfrz)/catanf_30,0.01_r8) - endif - - !Moisture Limitations - !BTRAN APPROACH - is quite simple, but max's out decomp at all unstressed - !soil moisture values, which is not realistic. - !litter decomp is proportional to water limitation on average... - w_scalar = sum(currentPatch%btran_ft(1:numpft))/real(numpft,r8) - - currentPatch%fragmentation_scaler = min(1.0_r8,max(0.0_r8,t_scalar * w_scalar)) ! Use the hlm temp and moisture decomp fractions by default if ( use_hlm_soil_scalar ) then From f2c3156b7c7ccd1a80d8de95f93ccf816e41d4b8 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 5 Aug 2021 10:38:53 -0600 Subject: [PATCH 183/209] adding frag scaler diag --- biogeochem/EDPhysiologyMod.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 888e490b4d..a56d5a60ae 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -224,6 +224,7 @@ subroutine PreDisturbanceLitterFluxes( currentSite, currentPatch, bc_in ) ! Calculate the fragmentation rates call fragmentation_scaler(currentPatch, bc_in) + write(fates_log(),*) 'PreDistLittFlux: frag_scaler: ', currentPatch%fragmentation_scaler do el = 1, num_elements @@ -249,6 +250,7 @@ subroutine PreDisturbanceLitterFluxes( currentSite, currentPatch, bc_in ) nlev_eff_decomp = max(bc_in%max_rooting_depth_index_col, 1) call CWDOut(litt,currentPatch%fragmentation_scaler,nlev_eff_decomp) + write(fates_log(),*) 'PreDistLittFlux: sum ag_cwd_frag: ', sum(litt%ag_cwd_frag) site_mass => currentSite%mass_balance(el) From a0f66242d604b03909a7739118bb9ee07489e5b2 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 5 Aug 2021 11:56:05 -0600 Subject: [PATCH 184/209] Fixing no comp label check This needs to be not equal since when in any mode other than no comp or its derivatives, the label will be -999 --- biogeochem/EDPhysiologyMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index a56d5a60ae..924c4fbd55 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -2477,7 +2477,7 @@ subroutine fragmentation_scaler( currentPatch, bc_in) catanf_30 = catanf(30._r8) ifp = currentPatch%patchno - if(currentPatch%nocomp_pft_label.gt.0)then + if(currentPatch%nocomp_pft_label.ne.0)then ! Use the hlm temp and moisture decomp fractions by default if ( use_hlm_soil_scalar ) then From 9cc3e7c36af64ca10d5b0be85c199bf5b070951a Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 6 Aug 2021 10:30:05 -0600 Subject: [PATCH 185/209] fixedbiogeog passes bfb now --- main/EDInitMod.F90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index a4c39ecdcb..991281ec48 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -327,11 +327,11 @@ subroutine set_site_properties( nsites, sites,bc_in ) end do !hlm_pft do ft = 1,numpft - if(sites(s)%area_pft(ft).lt.0.01_r8.and.sites(s)%area_pft(ft).gt.0.0_r8)then - write(fates_log(),*) 'removing small pft patches',s,ft,sites(s)%area_pft(ft) - sites(s)%area_pft(ft)=0.0_r8 - ! remove tiny patches to prevent numerical errors in terminate patches - endif + ! if(sites(s)%area_pft(ft).lt.0.01_r8.and.sites(s)%area_pft(ft).gt.0.0_r8)then + ! write(fates_log(),*) 'removing small pft patches',s,ft,sites(s)%area_pft(ft) + ! sites(s)%area_pft(ft)=0.0_r8 + ! ! remove tiny patches to prevent numerical errors in terminate patches + ! endif if(sites(s)%area_pft(ft).lt.0._r8)then write(fates_log(),*) 'negative area',s,ft,sites(s)%area_pft(ft) call endrun(msg=errMsg(sourcefile, __LINE__)) From 58a427e704bcdd2ecaae890178c2eee0e6485339 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 9 Aug 2021 16:48:28 -0400 Subject: [PATCH 186/209] Updates to enable scalars in the BatchPatch script, also some tweaks to print statements and new file for parameters at barro colorado island panama. --- parameter_files/patch_default_bciopt224.xml | 52 +++++++++++++++++++++ tools/BatchPatchParams.py | 3 +- tools/modify_fates_paramfile.py | 8 +++- tools/ncvarsort.py | 6 ++- 4 files changed, 64 insertions(+), 5 deletions(-) create mode 100644 parameter_files/patch_default_bciopt224.xml diff --git a/parameter_files/patch_default_bciopt224.xml b/parameter_files/patch_default_bciopt224.xml new file mode 100644 index 0000000000..d8e3fe9631 --- /dev/null +++ b/parameter_files/patch_default_bciopt224.xml @@ -0,0 +1,52 @@ + + + This parameter dataset was created by Ryan Knox rgknox@lbl.gov. Please contact if using in published work. The calibration uses the following datasets: [1] Ely et al. 2019. Leaf mass area, Panama. NGEE-Tropics data collection.http://dx.doi.org/10.15486/ngt/1411973 and [2] Condit et al. 2019. Complete data from the Barro Colorado 50-ha plot. https://doi.org/10.15146/5xcp-0d46. 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. + fates_params_default.cdl + fates_params_opt224_vmn6phi_080621.cdl + 1 + + 0 + 0 + 1,1,3,4 + 0.03347526,0.024,1e-08,0.0047 + 0.03347526,0.024,1e-08,0.0047 + 0.025,0,0,0 + 0.45,0.25,0,0 + 0.8012471 + 30.94711 + 0.0673 + 0.976 + -9 + -9 + 3 + 0.1266844 + 1.281329 + -9 + 0.768654 + 0.768654 + 57.6 + 0.74 + 21.6 + 200 + 2 + 5 + 0.4863088 + 3 + 3e-06 + 3e-06 + 3e-07 + 3e-08 + 0.03991654 + 0.01995827 + 0.01303514 + 0.02955703 + 3 + 3 + 0.04680188 + 0.001 + 0.8374751 + -1 + 0.5 + 1 + + diff --git a/tools/BatchPatchParams.py b/tools/BatchPatchParams.py index 19587b426a..57edb7dfcb 100755 --- a/tools/BatchPatchParams.py +++ b/tools/BatchPatchParams.py @@ -50,7 +50,7 @@ def load_xml(xmlfile): def parse_syscall_str(fnamein,fnameout,param_name,param_val): sys_call_str = "../tools/modify_fates_paramfile.py"+" --fin " + fnamein + \ - " --fout " + fnameout + " --var " + param_name + \ + " --fout " + fnameout + " --var " + param_name + " --silent " +\ " --val " + param_val + " --overwrite --all" return(sys_call_str) @@ -73,7 +73,6 @@ def main(): # Convert the base cdl file into a temp nc binary base_nc = os.popen('mktemp').read().rstrip('\n') gencmd = "ncgen -o "+base_nc+" "+base_cdl - print(gencmd) os.system(gencmd) # Generate a temp output file name diff --git a/tools/modify_fates_paramfile.py b/tools/modify_fates_paramfile.py index 670ad96d8a..44565e48b3 100755 --- a/tools/modify_fates_paramfile.py +++ b/tools/modify_fates_paramfile.py @@ -62,7 +62,7 @@ def main(): # val_list = args.val.split(',') # output_vec = [float(valstr) for valstr in val_list] outputval = np.fromstring(args.val, sep=',', dtype=np.float64) - + else: try: @@ -117,6 +117,12 @@ def main(): elif(ndim_file==1): for i in range(var.shape[0]): var[i] = outputval[i] + elif(ndim_file==0): + var.assignValue(outputval[0]) + else: + print("Unhandled dimension size in modify_fates_paramfile.py") + print("using --all flag") + exit(2) else: diff --git a/tools/ncvarsort.py b/tools/ncvarsort.py index 75d80c3799..e9cdc422b4 100755 --- a/tools/ncvarsort.py +++ b/tools/ncvarsort.py @@ -83,7 +83,8 @@ def main(): # #Copy dimensions for dname, the_dim in dsin.dimensions.items(): - print(dname, the_dim.size) + if args.debug: + print(dname, the_dim.size) dsout.createDimension(dname, the_dim.size ) # print() @@ -100,7 +101,8 @@ def main(): v_name = varnames_list_sorted[i] varin = dsin.variables[v_name] outVar = dsout.createVariable(v_name, varin.datatype, varin.dimensions) - print(v_name) + if args.debug: + print(v_name) # outVar.setncatts({k: varin.getncattr(k) for k in varin.ncattrs()}) outVar[:] = varin[:] From a5c2d9d4e61d8470f3136d6b6be653c84f7d43a2 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 9 Aug 2021 16:49:34 -0400 Subject: [PATCH 187/209] Update to the bci parameter patch file. --- parameter_files/patch_default_bciopt224.xml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/parameter_files/patch_default_bciopt224.xml b/parameter_files/patch_default_bciopt224.xml index d8e3fe9631..b5e886c188 100644 --- a/parameter_files/patch_default_bciopt224.xml +++ b/parameter_files/patch_default_bciopt224.xml @@ -1,6 +1,6 @@ - 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. 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. + 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. The ECA nutrient aquisition parmeters are unconstrained, the file output naming convention vmn6phi is shorthand for vmax for nitrogen uptake is order e-6 and for phosphorus is excessively high. These parameters were calibrated with the special fates modification in main/EDTypesMod.F90: nclmax = 3 fates_params_default.cdl fates_params_opt224_vmn6phi_080621.cdl 1 From e065f7f8716a0a01dfcd3923fdd1d1c0059f80aa Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 9 Aug 2021 17:36:08 -0400 Subject: [PATCH 188/209] Updated notes on the bci patch xml file to include Koven et al. 2019 --- parameter_files/patch_default_bciopt224.xml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/parameter_files/patch_default_bciopt224.xml b/parameter_files/patch_default_bciopt224.xml index b5e886c188..bfcc288efa 100644 --- a/parameter_files/patch_default_bciopt224.xml +++ b/parameter_files/patch_default_bciopt224.xml @@ -1,6 +1,6 @@ - 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. 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 + This parameter dataset was created by Ryan Knox rgknox@lbl.gov. Please contact if using in published work. The calibration uses the following datasets: [1] Ely et al. 2019. Leaf mass area, Panama. NGEE-Tropics data collection.http://dx.doi.org/10.15486/ngt/1411973 and [2] Condit et al. 2019. Complete data from the Barro Colorado 50-ha plot. https://doi.org/10.15146/5xcp-0d46. [3] Koven et al. 2019. Benchmarking and parameter sensitivity of physiological and vegetation dynamics using the functionally assembled terrestrial ecosystem simulator. Biogeosciences. The ECA nutrient aquisition parmeters are unconstrained, the file output naming convention vmn6phi is shorthand for vmax for nitrogen uptake is order e-6 and for phosphorus is excessively high. These parameters were calibrated with the special fates modification in main/EDTypesMod.F90: nclmax = 3 fates_params_default.cdl fates_params_opt224_vmn6phi_080621.cdl 1 From 9e646dcbad9d82c499a59b1160972e96d750c43a Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 12 Aug 2021 14:47:40 -0700 Subject: [PATCH 189/209] manually reverting diagnostic writes --- biogeochem/EDCanopyStructureMod.F90 | 417 +++++++++++------------ biogeochem/EDPhysiologyMod.F90 | 508 ++++++++++++++-------------- 2 files changed, 447 insertions(+), 478 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index b951990fa1..6d3b6f723b 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1,8 +1,8 @@ module EDCanopyStructureMod ! ===================================================================================== - ! Code to determine whether the canopy is closed, and which plants are either in the - ! understorey or overstorey. This is obviosuly far too complicated for it's own good + ! Code to determine whether the canopy is closed, and which plants are either in the + ! understorey or overstorey. This is obviosuly far too complicated for it's own good ! ===================================================================================== use FatesConstantsMod , only : r8 => fates_r8 @@ -57,7 +57,7 @@ module EDCanopyStructureMod public :: update_hlm_dynamics public :: UpdateFatesAvgSnowDepth - logical, parameter :: debug=.true. + logical, parameter :: debug=.false. character(len=*), parameter, private :: sourcefile = & __FILE__ @@ -66,7 +66,7 @@ module EDCanopyStructureMod ! will attempt to reduce errors ! below this level - real(r8), parameter :: area_check_precision = 1.0E-7_r8 ! Area conservation checks must + real(r8), parameter :: area_check_precision = 1.0E-7_r8 ! Area conservation checks must ! be within this absolute tolerance real(r8), parameter :: area_check_rel_precision = 1.0E-4_r8 ! Area conservation checks must ! be within this relative tolerance @@ -91,42 +91,42 @@ subroutine canopy_structure( currentSite , bc_in ) ! All top leaves in the same canopy layer get the same light resources. ! The first canopy layer is the 'canopy' or 'overstorey'. The second is the 'understorey'. ! More than two layers is not permitted at the moment - ! Seeds germinating into the 3rd or higher layers are automatically removed. + ! Seeds germinating into the 3rd or higher layers are automatically removed. ! ! ------Perfect Plasticity----- ! The idea of these canopy layers derives originally from Purves et al. 2009 ! Their concept is that, given enoughplasticity in canopy position, size, shape and depth ! all of the gound area will be filled perfectly by leaves, and additional leaves will have - ! to exist in the understorey. + ! to exist in the understorey. ! Purves et al. use the concept of 'Z*' to assume that the height required to attain a place in the ! canopy is spatially uniform. In this implementation, described in Fisher et al. (2010, New Phyt) we ! extent that concept to assume that position in the canopy has some random element, and that BOTH height - ! and chance combine to determine whether trees get into the canopy. + ! and chance combine to determine whether trees get into the canopy. ! Thus, when the canopy is closed and there is excess area, some of it must be demoted - ! If we demote -all- the trees less than a given height, there is a massive advantage in being the cohort that is - ! the biggest when the canopy is closed. + ! If we demote -all- the trees less than a given height, there is a massive advantage in being the cohort that is + ! the biggest when the canopy is closed. ! In this implementation, the amount demoted, ('weight') is a function of the height weighted by the competitive exclusion - ! parameter (ED_val_comp_excln). + ! parameter (ED_val_comp_excln). - ! Complexity in this routine results from a few things. + ! Complexity in this routine results from a few things. ! Firstly, the complication of the demotion amount sometimes being larger than the cohort area (for a very small, short cohort) - ! Second, occasionaly, disturbance (specifically fire) can cause the canopy layer to become less than closed, - ! without changing the area of the patch. If this happens, then some of the plants in the lower layer need to be 'promoted' so - ! all of the routine has to happen in both the downwards and upwards directions. + ! Second, occasionaly, disturbance (specifically fire) can cause the canopy layer to become less than closed, + ! without changing the area of the patch. If this happens, then some of the plants in the lower layer need to be 'promoted' so + ! all of the routine has to happen in both the downwards and upwards directions. ! ! The order of events here is therefore: - ! (The entire subroutine has a single outer 'patch' loop. - ! Section 1: figure out the total area, and whether there are >1 canopy layers at all. + ! (The entire subroutine has a single outer 'patch' loop. + ! Section 1: figure out the total area, and whether there are >1 canopy layers at all. ! - ! Sorts out cohorts into canopy and understorey layers... + ! Sorts out cohorts into canopy and understorey layers... ! ! !USES: use EDParamsMod, only : ED_val_comp_excln use EDTypesMod , only : min_patch_area - + ! - ! !ARGUMENTS + ! !ARGUMENTS type(ed_site_type) , intent(inout), target :: currentSite type(bc_in_type), intent(in) :: bc_in @@ -135,7 +135,7 @@ subroutine canopy_structure( currentSite , bc_in ) type(ed_patch_type) , pointer :: currentPatch type(ed_cohort_type), pointer :: currentCohort integer :: i_lyr ! current layer index - integer :: z ! Current number of canopy layers. (1= canopy, 2 = understorey) + integer :: z ! Current number of canopy layers. (1= canopy, 2 = understorey) integer :: ipft real(r8) :: arealayer(nclmax+2) ! Amount of plant area currently in each canopy layer integer :: patch_area_counter ! count iterations used to solve canopy areas @@ -152,8 +152,8 @@ subroutine canopy_structure( currentSite , bc_in ) !---------------------------------------------------------------------- - currentPatch => currentSite%oldest_patch - ! + currentPatch => currentSite%oldest_patch + ! ! zero site-level demotion / promotion tracking info currentSite%demotion_rate(:) = 0._r8 currentSite%promotion_rate(:) = 0._r8 @@ -162,9 +162,9 @@ subroutine canopy_structure( currentSite , bc_in ) ! - ! Section 1: Check total canopy area. + ! Section 1: Check total canopy area. ! - do while (associated(currentPatch)) ! Patch loop + do while (associated(currentPatch)) ! Patch loop ! ------------------------------------------------------------------------------ ! Perform numerical checks on some cohort and patch structures @@ -173,7 +173,7 @@ subroutine canopy_structure( currentSite , bc_in ) ! canopy layer has a special bounds check currentCohort => currentPatch%tallest do while (associated(currentCohort)) - if( currentCohort%canopy_layer < 1 .or. currentCohort%canopy_layer > nclmax+1 ) then + if( currentCohort%canopy_layer < 1 .or. currentCohort%canopy_layer > nclmax+1 ) then write(fates_log(),*) 'lat:',currentSite%lat write(fates_log(),*) 'lon:',currentSite%lon write(fates_log(),*) 'BOGUS CANOPY LAYER: ',currentCohort%canopy_layer @@ -199,11 +199,11 @@ subroutine canopy_structure( currentSite , bc_in ) call terminate_cohorts(currentSite, currentPatch, 1, 12, bc_in) ! Calculate how many layers we have in this canopy - ! This also checks the understory to see if its crown + ! This also checks the understory to see if its crown ! area is large enough to warrant a temporary sub-understory layer z = NumPotentialCanopyLayers(currentPatch,currentSite%spread,include_substory=.false.) - do i_lyr = 1,z ! Loop around the currently occupied canopy layers. + do i_lyr = 1,z ! Loop around the currently occupied canopy layers. call DemoteFromLayer(currentSite, currentPatch, i_lyr, bc_in) end do @@ -228,7 +228,7 @@ subroutine canopy_structure( currentSite , bc_in ) ! We only promote if we have at least two layers if (z>1) then - do i_lyr=1,z-1 + do i_lyr=1,z-1 call PromoteIntoLayer(currentSite, currentPatch, i_lyr) end do @@ -275,7 +275,7 @@ subroutine canopy_structure( currentSite , bc_in ) write(fates_log(),*) 'lon:',currentSite%lon write(fates_log(),*) 'spread:',currentSite%spread currentCohort => currentPatch%tallest - do while (associated(currentCohort)) + do while (associated(currentCohort)) write(fates_log(),*) 'coh ilayer:',currentCohort%canopy_layer write(fates_log(),*) 'coh dbh:',currentCohort%dbh write(fates_log(),*) 'coh pft:',currentCohort%pft @@ -296,13 +296,13 @@ subroutine canopy_structure( currentSite , bc_in ) enddo ! do while(area_not_balanced) - ! Set current canopy layer occupancy indicator. - currentPatch%NCL_p = min(nclmax,z) + ! Set current canopy layer occupancy indicator. + currentPatch%NCL_p = min(nclmax,z) ! ------------------------------------------------------------------------------------------- - ! if we are using "strict PPA", then calculate a z_star value as - ! the height of the smallest tree in the canopy - ! loop from top to bottom and locate the shortest cohort in level 1 whose shorter + ! if we are using "strict PPA", then calculate a z_star value as + ! the height of the smallest tree in the canopy + ! loop from top to bottom and locate the shortest cohort in level 1 whose shorter ! neighbor is in level 2 set zstar as the ehight of that shortest level 1 cohort ! ------------------------------------------------------------------------------------------- @@ -373,8 +373,8 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) if ( demote_area > area_target_precision ) then - ! Is this layer currently over-occupied? - ! In that case, we need to work out which cohorts to demote. + ! Is this layer currently over-occupied? + ! In that case, we need to work out which cohorts to demote. ! We go in order from shortest to tallest for ranked demotion sumweights = 0.0_r8 @@ -412,7 +412,7 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) ! Rank ordered deterministic method ! ----------------------------------------------------------- ! If there are cohorts that have the exact same height (which is possible, really) - ! we don't want to unilaterally promote/demote one before the others. + ! we don't want to unilaterally promote/demote one before the others. ! So we <>mote them as a unit ! now we need to go through and figure out how many equal-size cohorts there are. ! then we need to go through, add up the collective crown areas of all equal-sized @@ -449,7 +449,7 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) do while (associated(nextc)) if ( abs(nextc%hite - currentCohort%hite) < similar_height_tol ) then if (nextc%canopy_layer .eq. currentCohort%canopy_layer ) then - ! now we know the total crown area of all equal-sized, + ! now we know the total crown area of all equal-sized, ! equal-canopy-layer cohorts nextc%excl_weight = & max(0.0_r8,min(nextc%c_area, & @@ -475,7 +475,7 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) else currentCohort%excl_weight = & max(min(currentCohort%c_area, demote_area - sumweights ), 0._r8) - sumweights = sumweights + currentCohort%excl_weight + sumweights = sumweights + currentCohort%excl_weight end if endif @@ -496,7 +496,7 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) currentCohort => currentPatch%tallest do while (associated(currentCohort)) - if(currentCohort%canopy_layer == i_lyr) then + if(currentCohort%canopy_layer == i_lyr) then currentCohort%excl_weight = currentCohort%excl_weight/sumweights if( 1._r8/currentCohort%excl_weight < scale_factor_min ) & @@ -505,7 +505,7 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) scale_factor = scale_factor + currentCohort%excl_weight * currentCohort%c_area endif - currentCohort => currentCohort%shorter + currentCohort => currentCohort%shorter enddo ! This is the factor by which we need to multiply @@ -520,7 +520,7 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) currentCohort => currentPatch%tallest do while (associated(currentCohort)) - if(currentCohort%canopy_layer == i_lyr) then + if(currentCohort%canopy_layer == i_lyr) then currentCohort%excl_weight = currentCohort%c_area * currentCohort%excl_weight * scale_factor if(debug) then @@ -539,7 +539,7 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) end if endif - currentCohort => currentCohort%shorter + currentCohort => currentCohort%shorter enddo else @@ -551,8 +551,8 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) area_res = 0._r8 scale_factor_res = 0._r8 currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if(currentCohort%canopy_layer == i_lyr) then + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == i_lyr) then area_res = area_res + & currentCohort%c_area * currentCohort%excl_weight * & scale_factor_min @@ -560,7 +560,7 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) currentCohort%c_area * & (1._r8 - (currentCohort%excl_weight * scale_factor_min)) endif - currentCohort => currentCohort%shorter + currentCohort => currentCohort%shorter enddo area_res = demote_area - area_res @@ -568,8 +568,8 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) scale_factor_res = area_res / scale_factor_res currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if(currentCohort%canopy_layer == i_lyr) then + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == i_lyr) then currentCohort%excl_weight = currentCohort%c_area * & (currentCohort%excl_weight * scale_factor_min + & @@ -590,7 +590,7 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) end if endif - currentCohort => currentCohort%shorter + currentCohort => currentCohort%shorter enddo end if @@ -601,7 +601,7 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) ! perform a check and see if the demotions meet the demand sumweights = 0._r8 currentCohort => currentPatch%tallest - do while (associated(currentCohort)) + do while (associated(currentCohort)) if(currentCohort%canopy_layer == i_lyr) then sumweights = sumweights + currentCohort%excl_weight end if @@ -672,13 +672,13 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) call copy_cohort(currentCohort, copyc) newarea = currentCohort%c_area - cc_loss - copyc%n = currentCohort%n*newarea/currentCohort%c_area + copyc%n = currentCohort%n*newarea/currentCohort%c_area currentCohort%n = currentCohort%n - copyc%n copyc%canopy_layer = i_lyr !the taller cohort is the copy ! Demote the current cohort to the understory. - currentCohort%canopy_layer = i_lyr + 1 + currentCohort%canopy_layer = i_lyr + 1 ! keep track of number and biomass of demoted cohort currentSite%demotion_rate(currentCohort%size_class) = & @@ -690,7 +690,7 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & currentCohort%pft,currentCohort%c_area) - !----------- Insert copy into linked list ------------------------! + !----------- Insert copy into linked list ------------------------! copyc%shorter => currentCohort if(associated(currentCohort%taller))then copyc%taller => currentCohort%taller @@ -713,9 +713,9 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) ! kill the ones which go into canopy layers that are not allowed - if(currentCohort%canopy_layer>nclmax )then + if(currentCohort%canopy_layer>nclmax )then - ! put the litter from the terminated cohorts + ! put the litter from the terminated cohorts ! straight into the fragmenting pools call SendCohortToLitter(currentSite,currentPatch, & currentCohort,currentCohort%n,bc_in) @@ -732,7 +732,7 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) endif !canopy layer = i_ly currentCohort => currentCohort%shorter - enddo !currentCohort + enddo !currentCohort ! Update the area calculations of the current layer @@ -766,7 +766,7 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) ! ------------------------------------------------------------------------------------------- ! Check whether the intended 'full' layers are actually filling all the space. ! If not, promote some fraction of cohorts upwards. - ! THIS SECTION MIGHT BE TRIGGERED BY A FIRE OR MORTALITY EVENT, FOLLOWED BY A PATCH FUSION, + ! THIS SECTION MIGHT BE TRIGGERED BY A FIRE OR MORTALITY EVENT, FOLLOWED BY A PATCH FUSION, ! SO THE TOP LAYER IS NO LONGER FULL. ! ------------------------------------------------------------------------------------------- @@ -809,7 +809,7 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) ! how much do we need to gain? - promote_area = currentPatch%area - arealayer_current + promote_area = currentPatch%area - arealayer_current if( promote_area > area_target_precision ) then @@ -820,10 +820,10 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) ! than the tolerance on the gains needed into current layer ! --------------------------------------------------------------------------- - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - !look at the cohorts in the canopy layer below... - if(currentCohort%canopy_layer == i_lyr+1)then + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + !look at the cohorts in the canopy layer below... + if(currentCohort%canopy_layer == i_lyr+1)then leaf_c = currentCohort%prt%GetState(leaf_organ,all_carbon_elements) store_c = currentCohort%prt%GetState(store_organ,all_carbon_elements) @@ -831,7 +831,7 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) sapw_c = currentCohort%prt%GetState(sapw_organ,all_carbon_elements) struct_c = currentCohort%prt%GetState(struct_organ,all_carbon_elements) - currentCohort%canopy_layer = i_lyr + currentCohort%canopy_layer = i_lyr call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & currentCohort%pft,currentCohort%c_area) ! keep track of number and biomass of promoted cohort @@ -841,7 +841,7 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) (leaf_c + fnrt_c + store_c + sapw_c + struct_c) * currentCohort%n endif - currentCohort => currentCohort%shorter + currentCohort => currentCohort%shorter enddo else @@ -853,14 +853,14 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) ! figure out with what weighting we need to promote cohorts. - ! This is the opposite of the demotion weighting... + ! This is the opposite of the demotion weighting... sumweights = 0.0_r8 - currentCohort => currentPatch%tallest + currentCohort => currentPatch%tallest do while (associated(currentCohort)) call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & currentCohort%pft,currentCohort%c_area) - if(currentCohort%canopy_layer == i_lyr+1)then !look at the cohorts in the canopy layer below... + if(currentCohort%canopy_layer == i_lyr+1)then !look at the cohorts in the canopy layer below... if (ED_val_comp_excln .ge. 0.0_r8 ) then @@ -875,7 +875,7 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) ! ------------------------------------------------------------------ ! Rank ordered deterministic method ! If there are cohorts that have the exact same height (which is possible, really) - ! we don't want to unilaterally promote/demote one before the others. + ! we don't want to unilaterally promote/demote one before the others. ! So we <>mote them as a unit ! now we need to go through and figure out how many equal-size cohorts there are. ! then we need to go through, add up the collective crown areas of all equal-sized @@ -911,7 +911,7 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) do while (associated(nextc)) if ( abs(nextc%hite - currentCohort%hite) < similar_height_tol ) then if (nextc%canopy_layer .eq. currentCohort%canopy_layer ) then - ! now we know the total crown area of all equal-sized, + ! now we know the total crown area of all equal-sized, ! equal-canopy-layer cohorts nextc%prom_weight = & max(0.0_r8,min(nextc%c_area, & @@ -937,13 +937,13 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) else currentCohort%prom_weight = & max(min(currentCohort%c_area, promote_area - sumweights ), 0._r8) - sumweights = sumweights + currentCohort%prom_weight + sumweights = sumweights + currentCohort%prom_weight end if endif endif - currentCohort => currentCohort%shorter + currentCohort => currentCohort%shorter enddo !currentCohort @@ -959,7 +959,7 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) currentCohort => currentPatch%tallest do while (associated(currentCohort)) - if(currentCohort%canopy_layer == (i_lyr+1) ) then + if(currentCohort%canopy_layer == (i_lyr+1) ) then currentCohort%prom_weight = currentCohort%prom_weight/sumweights if( 1._r8/currentCohort%prom_weight < scale_factor_min ) & @@ -968,7 +968,7 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) scale_factor = scale_factor + currentCohort%prom_weight * currentCohort%c_area endif - currentCohort => currentCohort%shorter + currentCohort => currentCohort%shorter enddo ! This is the factor by which we need to multiply @@ -984,7 +984,7 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) currentCohort => currentPatch%tallest do while (associated(currentCohort)) - if(currentCohort%canopy_layer == (i_lyr+1) ) then + if(currentCohort%canopy_layer == (i_lyr+1) ) then currentCohort%prom_weight = currentCohort%c_area * & currentCohort%prom_weight * scale_factor @@ -1003,7 +1003,7 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) end if endif - currentCohort => currentCohort%shorter + currentCohort => currentCohort%shorter enddo else @@ -1014,15 +1014,15 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) area_res = 0._r8 scale_factor_res = 0._r8 currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if(currentCohort%canopy_layer == (i_lyr+1) ) then + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == (i_lyr+1) ) then area_res = area_res + & currentCohort%c_area*currentCohort%prom_weight*scale_factor_min scale_factor_res = scale_factor_res + & currentCohort%c_area * & (1._r8 - (currentCohort%prom_weight * scale_factor_min)) endif - currentCohort => currentCohort%shorter + currentCohort => currentCohort%shorter enddo area_res = promote_area - area_res @@ -1030,8 +1030,8 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) scale_factor_res = area_res / scale_factor_res currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if(currentCohort%canopy_layer == (i_lyr+1)) then + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == (i_lyr+1)) then currentCohort%prom_weight = currentCohort%c_area * & (currentCohort%prom_weight * scale_factor_min + & @@ -1053,7 +1053,7 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) end if endif - currentCohort => currentCohort%shorter + currentCohort => currentCohort%shorter enddo end if @@ -1064,7 +1064,7 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) ! lets perform a check and see if the promotions meet the demand sumweights = 0._r8 currentCohort => currentPatch%tallest - do while (associated(currentCohort)) + do while (associated(currentCohort)) if(currentCohort%canopy_layer == (i_lyr+1)) then sumweights = sumweights + currentCohort%prom_weight end if @@ -1082,10 +1082,10 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) end if currentCohort => currentPatch%tallest - do while (associated(currentCohort)) + do while (associated(currentCohort)) - !All the trees in this layer need to promote some area upwards... + !All the trees in this layer need to promote some area upwards... if( (currentCohort%canopy_layer == i_lyr+1) ) then cc_gain = currentCohort%prom_weight @@ -1128,14 +1128,14 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & currentCohort%pft,currentCohort%c_area) - ! number of individuals in promoted cohort. - copyc%n = currentCohort%n*cc_gain/currentCohort%c_area + ! number of individuals in promoted cohort. + copyc%n = currentCohort%n*cc_gain/currentCohort%c_area - ! number of individuals in cohort remaining in understorey + ! number of individuals in cohort remaining in understorey currentCohort%n = currentCohort%n - copyc%n - currentCohort%canopy_layer = i_lyr + 1 ! keep current cohort in the understory. - copyc%canopy_layer = i_lyr ! promote copy to the higher canopy layer. + currentCohort%canopy_layer = i_lyr + 1 ! keep current cohort in the understory. + copyc%canopy_layer = i_lyr ! promote copy to the higher canopy layer. ! keep track of number and biomass of promoted cohort currentSite%promotion_rate(copyc%size_class) = & @@ -1148,7 +1148,7 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) currentCohort%pft,currentCohort%c_area) call carea_allom(copyc%dbh,copyc%n,currentSite%spread,copyc%pft,copyc%c_area) - !----------- Insert copy into linked list ------------------------! + !----------- Insert copy into linked list ------------------------! copyc%shorter => currentCohort if(associated(currentCohort%taller))then copyc%taller => currentCohort%taller @@ -1157,7 +1157,7 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) currentPatch%tallest => copyc copyc%taller => null() endif - currentCohort%taller => copyc + currentCohort%taller => copyc elseif(cc_gain > currentCohort%c_area)then @@ -1170,7 +1170,7 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) endif ! if(currentCohort%canopy_layer == i_lyr+1) then currentCohort => currentCohort%shorter - enddo !currentCohort + enddo !currentCohort call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr,arealayer_current) @@ -1195,20 +1195,20 @@ end subroutine PromoteIntoLayer subroutine canopy_spread( currentSite ) ! ! !DESCRIPTION: - ! Calculates the spatial spread of tree canopies based on canopy closure. + ! Calculates the spatial spread of tree canopies based on canopy closure. ! ! !USES: use EDTypesMod , only : AREA - use EDParamsMod, only : ED_val_canopy_closure_thresh + use EDParamsMod, only : ED_val_canopy_closure_thresh ! - ! !ARGUMENTS + ! !ARGUMENTS type (ed_site_type), intent(inout), target :: currentSite ! ! !LOCAL VARIABLES: type (ed_cohort_type), pointer :: currentCohort type (ed_patch_type) , pointer :: currentPatch real(r8) :: sitelevel_canopyarea ! Amount of canopy in top layer at the site level - real(r8) :: inc ! Arbitrary daily incremental change in canopy area + real(r8) :: inc ! Arbitrary daily incremental change in canopy area integer :: z !---------------------------------------------------------------------- @@ -1216,7 +1216,7 @@ subroutine canopy_spread( currentSite ) currentPatch => currentSite%oldest_patch - sitelevel_canopyarea = 0.0_r8 + sitelevel_canopyarea = 0.0_r8 do while (associated(currentPatch)) !calculate canopy area in each patch... @@ -1239,8 +1239,8 @@ subroutine canopy_spread( currentSite ) ! squash the tree canopies and make them taller and thinner if( sitelevel_canopyarea/AREA .gt. ED_val_canopy_closure_thresh ) then currentSite%spread = currentSite%spread - inc - else - currentSite%spread = currentSite%spread + inc + else + currentSite%spread = currentSite%spread + inc endif ! put within bounds to make sure it stays between 0 and 1 @@ -1264,7 +1264,7 @@ subroutine canopy_summarization( nsites, sites, bc_in ) use EDtypesMod , only : area use FatesConstantsMod , only : itrue - ! !ARGUMENTS + ! !ARGUMENTS integer , intent(in) :: nsites type(ed_site_type) , intent(inout), target :: sites(nsites) type(bc_in_type) , intent(in) :: bc_in(nsites) @@ -1275,8 +1275,8 @@ subroutine canopy_summarization( nsites, sites, bc_in ) integer :: s integer :: ft ! plant functional type integer :: ifp ! the number of the vegetated patch (1,2,3). In SP mode bareground patch is 0 - integer :: patchn ! identification number for each patch. - real(r8) :: canopy_leaf_area ! total amount of leaf area in the vegetated area. m2. + integer :: patchn ! identification number for each patch. + real(r8) :: canopy_leaf_area ! total amount of leaf area in the vegetated area. m2. real(r8) :: leaf_c ! leaf carbon [kg] real(r8) :: fnrt_c ! fineroot carbon [kg] real(r8) :: sapw_c ! sapwood carbon [kg] @@ -1292,8 +1292,8 @@ subroutine canopy_summarization( nsites, sites, bc_in ) do s = 1,nsites ! -------------------------------------------------------------------------------- - ! Set the patch indices (this is usefull mostly for communicating with a host or - ! driving model. Loops through all patches and sets cpatch%patchno to the integer + ! Set the patch indices (this is usefull mostly for communicating with a host or + ! driving model. Loops through all patches and sets cpatch%patchno to the integer ! order of oldest to youngest where the oldest is 1. ! -------------------------------------------------------------------------------- call set_patchno( sites(s) ) @@ -1302,12 +1302,12 @@ subroutine canopy_summarization( nsites, sites, bc_in ) do while(associated(currentPatch)) - !zero cohort-summed variables. + !zero cohort-summed variables. currentPatch%total_canopy_area = 0.0_r8 currentPatch%total_tree_area = 0.0_r8 canopy_leaf_area = 0.0_r8 - !update cohort quantitie s + !update cohort quantitie s currentCohort => currentPatch%shortest do while(associated(currentCohort)) @@ -1347,7 +1347,7 @@ subroutine canopy_summarization( nsites, sites, bc_in ) endif endif - ! adding checks for SP and NOCOMP modes. + ! adding checks for SP and NOCOMP modes. if(currentPatch%nocomp_pft_label.eq.0)then write(fates_log(),*) 'cohorts in barepatch',currentPatch%total_canopy_area,currentPatch%nocomp_pft_label call endrun(msg=errMsg(sourcefile, __LINE__)) @@ -1367,7 +1367,7 @@ subroutine canopy_summarization( nsites, sites, bc_in ) end if end if !sp mode - ! Check for erroneous zero values. + ! Check for erroneous zero values. if(currentCohort%dbh <= 0._r8 .or. currentCohort%n == 0._r8)then write(fates_log(),*) 'FATES: dbh or n is zero in canopy_summarization', & currentCohort%dbh,currentCohort%n @@ -1403,7 +1403,7 @@ subroutine canopy_summarization( nsites, sites, bc_in ) currentPatch => currentPatch%younger end do !patch loop - call leaf_area_profile(sites(s)) + call leaf_area_profile(sites(s)) end do ! site loop @@ -1413,34 +1413,34 @@ end subroutine canopy_summarization ! ==================================================================================== subroutine UpdateFatesAvgSnowDepth(sites,bc_in) - + ! This routine updates the snow depth used in FATES to occlude vegetation ! Currently this average takes into account the depth of snow and the ! areal coverage fraction - + type(ed_site_type) , intent(inout), target :: sites(:) type(bc_in_type) , intent(in) :: bc_in(:) - + integer :: s - + do s = 1, size(sites,dim=1) sites(s)%snow_depth = bc_in(s)%snow_depth_si * bc_in(s)%frac_sno_eff_si end do - + return end subroutine UpdateFatesAvgSnowDepth - - + + ! ===================================================================================== subroutine leaf_area_profile( currentSite ) ! ----------------------------------------------------------------------------------- - ! This subroutine calculates how leaf and stem areas are distributed + ! This subroutine calculates how leaf and stem areas are distributed ! in vertical and horizontal space. ! ! The following cohort level diagnostics are updated here: - ! + ! ! currentCohort%treelai ! LAI per unit crown area (m2/m2) ! currentCohort%treesai ! SAI per unit crown area (m2/m2) ! currentCohort%lai ! LAI per unit canopy area (m2/m2) @@ -1449,10 +1449,10 @@ subroutine leaf_area_profile( currentSite ) ! ! layers needed to describe this crown ! ! The following patch level diagnostics are updated here: - ! + ! ! currentPatch%canopy_layer_tlai(cl) ! total leaf area index of canopy layer ! currentPatch%ncan(cl,ft) ! number of vegetation layers needed - ! ! in this patch's pft/canopy-layer + ! ! in this patch's pft/canopy-layer ! currentPatch%nrad(cl,ft) ! same as ncan, but does not include ! ! layers occluded by snow ! ! CURRENTLY SAME AS NCAN @@ -1462,7 +1462,7 @@ subroutine leaf_area_profile( currentSite ) ! currentPatch%elai_profile(cl,ft,iv) ! non-snow covered m2 of leaves per m2 of PFT footprint ! currentPatch%tsai_profile(cl,ft,iv) ! m2 of stems per m2 of PFT footprint ! currentPatch%esai_profile(cl,ft,iv) ! non-snow covered m2 of stems per m2 of PFT footprint - ! currentPatch%canopy_area_profile(cl,ft,iv) ! Fractional area of leaf layer + ! currentPatch%canopy_area_profile(cl,ft,iv) ! Fractional area of leaf layer ! ! relative to vegetated area ! currentPatch%layer_height_profile(cl,ft,iv) ! Elevation of layer in m ! @@ -1473,7 +1473,7 @@ subroutine leaf_area_profile( currentSite ) use EDtypesMod , only : area, dinc_ed, hitemax, n_hite_bins ! - ! !ARGUMENTS + ! !ARGUMENTS type(ed_site_type) , intent(inout) :: currentSite @@ -1481,10 +1481,10 @@ subroutine leaf_area_profile( currentSite ) ! !LOCAL VARIABLES: type (ed_patch_type) , pointer :: currentPatch type (ed_cohort_type) , pointer :: currentCohort - real(r8) :: remainder !Thickness of layer at bottom of canopy. - real(r8) :: fleaf ! fraction of cohort incepting area that is leaves. - integer :: ft ! Plant functional type index. - integer :: iv ! Vertical leaf layer index + real(r8) :: remainder !Thickness of layer at bottom of canopy. + real(r8) :: fleaf ! fraction of cohort incepting area that is leaves. + integer :: ft ! Plant functional type index. + integer :: iv ! Vertical leaf layer index integer :: cl ! Canopy layer index real(r8) :: fraction_exposed ! how much of this layer is not covered by snow? real(r8) :: layer_top_hite ! notional top height of this canopy layer (m) @@ -1499,7 +1499,6 @@ subroutine leaf_area_profile( currentSite ) real(r8) :: max_chite ! top of cohort canopy (m) real(r8) :: lai ! summed lai for checking m2 m-2 real(r8) :: leaf_c ! leaf carbon [kg] - real(r8) :: saicheck ! diagnostic check for Satellite phenology mode !---------------------------------------------------------------------- @@ -1509,27 +1508,27 @@ subroutine leaf_area_profile( currentSite ) ! Here we are trying to generate a profile of leaf area, indexed by 'z' and by pft ! We assume that each point in the canopy recieved the light attenuated by the average - ! leaf area index above it, irrespective of PFT identity... + ! leaf area index above it, irrespective of PFT identity... ! Each leaf is defined by how deep in the canopy it is, in terms of LAI units. (FIX(RF,032414), GB) - currentPatch => currentSite%oldest_patch + currentPatch => currentSite%oldest_patch do while(associated(currentPatch)) ! -------------------------------------------------------------------------------- - ! Calculate tree and canopy areas. + ! Calculate tree and canopy areas. ! calculate tree lai and sai. ! -------------------------------------------------------------------------------- currentPatch%canopy_layer_tlai(:) = 0._r8 - currentPatch%ncan(:,:) = 0 - currentPatch%nrad(:,:) = 0 + currentPatch%ncan(:,:) = 0 + currentPatch%nrad(:,:) = 0 patch_lai = 0._r8 currentPatch%tlai_profile(:,:,:) = 0._r8 - currentPatch%tsai_profile(:,:,:) = 0._r8 + currentPatch%tsai_profile(:,:,:) = 0._r8 currentPatch%elai_profile(:,:,:) = 0._r8 - currentPatch%esai_profile(:,:,:) = 0._r8 + currentPatch%esai_profile(:,:,:) = 0._r8 currentPatch%layer_height_profile(:,:,:) = 0._r8 - currentPatch%canopy_area_profile(:,:,:) = 0._r8 + currentPatch%canopy_area_profile(:,:,:) = 0._r8 currentPatch%canopy_mask(:,:) = 0 ! ------------------------------------------------------------------------------ @@ -1541,7 +1540,7 @@ subroutine leaf_area_profile( currentSite ) currentCohort => currentPatch%tallest - do while(associated(currentCohort)) + do while(associated(currentCohort)) ft = currentCohort%pft cl = currentCohort%canopy_layer @@ -1554,34 +1553,20 @@ subroutine leaf_area_profile( currentSite ) currentCohort%treelai = tree_lai(leaf_c, currentCohort%pft, currentCohort%c_area, & currentCohort%n, currentCohort%canopy_layer, & - currentPatch%canopy_layer_tlai,currentCohort%vcmax25top ) + currentPatch%canopy_layer_tlai,currentCohort%vcmax25top ) if (hlm_use_sp .eq. ifalse) then currentCohort%treesai = tree_sai(currentCohort%pft, currentCohort%dbh, currentCohort%canopy_trim, & currentCohort%c_area, currentCohort%n, currentCohort%canopy_layer, & currentPatch%canopy_layer_tlai, currentCohort%treelai , & - currentCohort%vcmax25top,4) - else - ! If we are using satellite phenology, conduct a check against the calculated sai - saicheck = tree_sai(currentCohort%pft, currentCohort%dbh, currentCohort%canopy_trim, & - currentCohort%c_area, currentCohort%n, currentCohort%canopy_layer, & - currentPatch%canopy_layer_tlai, currentCohort%treelai , & - currentCohort%vcmax25top,4) - - if ( debug ) write(fates_log(), *) 'SP mode: sai check: ', saicheck - + currentCohort%vcmax25top,4) end if - if ( debug ) write(fates_log(), *) 'currentCohort%canopy_layer: ', cl - if ( debug ) write(fates_log(), *) 'currentCohort%pft: ', ft - if ( debug ) write(fates_log(), *) 'currentCohort%treesai: ', currentCohort%treesai - if ( debug ) write(fates_log(), *) 'currentCohort%treelai: ', currentCohort%treelai - - currentCohort%lai = currentCohort%treelai *currentCohort%c_area/currentPatch%total_canopy_area - currentCohort%sai = currentCohort%treesai *currentCohort%c_area/currentPatch%total_canopy_area + currentCohort%lai = currentCohort%treelai *currentCohort%c_area/currentPatch%total_canopy_area + currentCohort%sai = currentCohort%treesai *currentCohort%c_area/currentPatch%total_canopy_area ! Number of actual vegetation layers in this cohort's crown - currentCohort%nv = ceiling((currentCohort%treelai+currentCohort%treesai)/dinc_ed) + currentCohort%nv = ceiling((currentCohort%treelai+currentCohort%treesai)/dinc_ed) currentPatch%ncan(cl,ft) = max(currentPatch%ncan(cl,ft),currentCohort%NV) @@ -1589,47 +1574,47 @@ subroutine leaf_area_profile( currentSite ) currentPatch%canopy_layer_tlai(cl) = currentPatch%canopy_layer_tlai(cl) + currentCohort%lai - currentCohort => currentCohort%shorter + currentCohort => currentCohort%shorter enddo !currentCohort if(smooth_leaf_distribution == 1)then ! ----------------------------------------------------------------------------- - ! we are going to ignore the concept of canopy layers, and put all of the leaf - ! area into height banded bins. using the same domains as we had before, except + ! we are going to ignore the concept of canopy layers, and put all of the leaf + ! area into height banded bins. using the same domains as we had before, except ! that CL always = 1 ! ----------------------------------------------------------------------------- - ! this is a crude way of dividing up the bins. Should it be a function of actual maximum height? - dh = 1.0_r8*(HITEMAX/N_HITE_BINS) - do iv = 1,N_HITE_BINS + ! this is a crude way of dividing up the bins. Should it be a function of actual maximum height? + dh = 1.0_r8*(HITEMAX/N_HITE_BINS) + do iv = 1,N_HITE_BINS if (iv == 1) then minh(iv) = 0.0_r8 maxh(iv) = dh - else + else minh(iv) = (iv-1)*dh maxh(iv) = (iv)*dh endif enddo currentCohort => currentPatch%shortest - do while(associated(currentCohort)) + do while(associated(currentCohort)) ft = currentCohort%pft min_chite = currentCohort%hite - currentCohort%hite * EDPftvarcon_inst%crown(ft) - max_chite = currentCohort%hite - do iv = 1,N_HITE_BINS + 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 + if(max_chite > maxh(iv).and.min_chite < minh(iv))then frac_canopy(iv)= min(1.0_r8,dh / (currentCohort%hite*EDPftvarcon_inst%crown(ft))) - ! this is the layer with the bottom of the canopy in it. - elseif(min_chite < maxh(iv).and.min_chite > minh(iv).and.max_chite > maxh(iv))then + ! this is the layer with the bottom of the canopy in it. + elseif(min_chite < maxh(iv).and.min_chite > minh(iv).and.max_chite > maxh(iv))then frac_canopy(iv) = (maxh(iv) -min_chite ) / (currentCohort%hite*EDPftvarcon_inst%crown(ft)) - ! this is the layer with the top of the canopy in it. - elseif(max_chite > minh(iv).and.max_chite < maxh(iv).and.min_chite < minh(iv))then + ! this is the layer with the top of the canopy in it. + elseif(max_chite > minh(iv).and.max_chite < maxh(iv).and.min_chite < minh(iv))then frac_canopy(iv) = (max_chite - minh(iv)) / (currentCohort%hite*EDPftvarcon_inst%crown(ft)) - elseif(max_chite < maxh(iv).and.min_chite > minh(iv))then !the whole cohort is within this layer. + 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 @@ -1638,33 +1623,26 @@ subroutine leaf_area_profile( currentSite ) currentCohort%lai currentPatch%tsai_profile(1,ft,iv) = currentPatch%tsai_profile(1,ft,iv) + frac_canopy(iv) * & currentCohort%sai - if ( debug ) write(fates_log(), *) 'currentCohort%pft,iv: ', ft,iv - if ( debug ) write(fates_log(), *) 'currentPatch%tlai_profile(1,ft,iv): ', currentPatch%tlai_profile(1,ft,iv) - if ( debug ) write(fates_log(), *) 'currentPatch%tsai_profile(1,ft,iv): ', currentPatch%tsai_profile(1,ft,iv) !snow burial - if(currentSite%snow_depth > maxh(iv))then + if(currentSite%snow_depth > maxh(iv))then fraction_exposed = 0._r8 endif - if(currentSite%snow_depth < minh(iv))then + if(currentSite%snow_depth < minh(iv))then fraction_exposed = 1._r8 endif - if(currentSite%snow_depth >= minh(iv) .and. currentSite%snow_depth <= maxh(iv)) then !only partly hidden... + if(currentSite%snow_depth >= minh(iv) .and. currentSite%snow_depth <= maxh(iv)) then !only partly hidden... fraction_exposed = 1._r8 - max(0._r8,(min(1.0_r8,(currentSite%snow_depth-minh(iv))/dh))) endif - if ( debug ) write(fates_log(), *) 'leaf_area_profile()', currentPatch%elai_profile(1,ft,iv) - currentPatch%elai_profile(1,ft,iv) = currentPatch%tlai_profile(1,ft,iv) * fraction_exposed currentPatch%esai_profile(1,ft,iv) = currentPatch%tsai_profile(1,ft,iv) * fraction_exposed - if ( debug ) write(fates_log(), *) 'leaf_area_profile()', currentPatch%elai_profile(1,ft,iv) - enddo ! (iv) hite bins currentCohort => currentCohort%taller - enddo !currentCohort + enddo !currentCohort ! ----------------------------------------------------------------------------- ! Perform a leaf area conservation check on the LAI profile @@ -1679,32 +1657,32 @@ subroutine leaf_area_profile( currentSite ) endif - else ! smooth leaf distribution + else ! smooth leaf distribution ! ----------------------------------------------------------------------------- ! Standard canopy layering model. - ! Go through all cohorts and add their leaf area - ! and canopy area to the accumulators. + ! Go through all cohorts and add their leaf area + ! and canopy area to the accumulators. ! ----------------------------------------------------------------------------- currentCohort => currentPatch%shortest - do while(associated(currentCohort)) - ft = currentCohort%pft + do while(associated(currentCohort)) + ft = currentCohort%pft cl = currentCohort%canopy_layer ! ---------------------------------------------------------------- - ! How much of each tree is stem area index? Assuming that there is + ! How much of each tree is stem area index? Assuming that there is ! This may indeed be zero if there is a sensecent grass ! ---------------------------------------------------------------- - if( (currentCohort%treelai+currentCohort%treesai) > 0._r8)then - fleaf = currentCohort%lai / (currentCohort%lai + currentCohort%sai) + if( (currentCohort%treelai+currentCohort%treesai) > 0._r8)then + fleaf = currentCohort%lai / (currentCohort%lai + currentCohort%sai) else fleaf = 0._r8 endif - currentPatch%nrad(cl,ft) = currentPatch%ncan(cl,ft) + currentPatch%nrad(cl,ft) = currentPatch%ncan(cl,ft) if (currentPatch%nrad(cl,ft) > nlevleaf ) then write(fates_log(), *) 'Number of radiative leaf layers is larger' @@ -1718,8 +1696,8 @@ subroutine leaf_area_profile( currentSite ) ! -------------------------------------------------------------------------- - ! Whole layers. Make a weighted average of the leaf area in each layer - ! before dividing it by the total area. Fill up layer for whole layers. + ! Whole layers. Make a weighted average of the leaf area in each layer + ! before dividing it by the total area. Fill up layer for whole layers. ! -------------------------------------------------------------------------- do iv = 1,currentCohort%NV @@ -1755,7 +1733,7 @@ subroutine leaf_area_profile( currentSite ) (dinc_ed*real(currentCohort%nv-1,r8)) if(remainder > dinc_ed )then write(fates_log(), *)'ED: issue with remainder', & - currentCohort%treelai,currentCohort%treesai,dinc_ed, & + currentCohort%treelai,currentCohort%treesai,dinc_ed, & currentCohort%NV,remainder call endrun(msg=errMsg(sourcefile, __LINE__)) endif @@ -1782,7 +1760,7 @@ subroutine leaf_area_profile( currentSite ) currentPatch%layer_height_profile(cl,ft,iv) = currentPatch%layer_height_profile(cl,ft,iv) + & (remainder * fleaf * currentCohort%c_area/currentPatch%total_canopy_area * & - (layer_top_hite+layer_bottom_hite)/2.0_r8) !average height of layer. + (layer_top_hite+layer_bottom_hite)/2.0_r8) !average height of layer. end do @@ -1811,7 +1789,7 @@ subroutine leaf_area_profile( currentSite ) write(fates_log(), *) 'ED: fracarea', currentCohort%pft, & currentCohort%c_area/currentPatch%total_canopy_area endif - currentCohort => currentCohort%taller + currentCohort => currentCohort%taller enddo !currentCohort call endrun(msg=errMsg(sourcefile, __LINE__)) @@ -1848,7 +1826,7 @@ subroutine leaf_area_profile( currentSite ) write(fates_log(), *) 'ED: fracarea', currentCohort%pft, & currentCohort%c_area/currentPatch%total_canopy_area endif - currentCohort => currentCohort%taller + currentCohort => currentCohort%taller enddo !currentCohort call endrun(msg=errMsg(sourcefile, __LINE__)) end if @@ -1861,8 +1839,6 @@ subroutine leaf_area_profile( currentSite ) currentPatch%tlai_profile(cl,ft,iv) = currentPatch%tlai_profile(cl,ft,iv) / & currentPatch%canopy_area_profile(cl,ft,iv) - write(fates_log(), *) 'currentPatch%tlai_profile(cl,ft,iv): ', currentPatch%tlai_profile(cl,ft,iv) - write(fates_log(), *) 'currentPatch%canopy_area_profile(cl,ft,iv): ', currentPatch%canopy_area_profile(cl,ft,iv) currentPatch%tsai_profile(cl,ft,iv) = currentPatch%tsai_profile(cl,ft,iv) / & currentPatch%canopy_area_profile(cl,ft,iv) @@ -1893,7 +1869,7 @@ subroutine leaf_area_profile( currentSite ) do ft = 1,numpft do iv = 1, currentPatch%nrad(cl,ft) if(currentPatch%canopy_area_profile(cl,ft,iv) > 0._r8)then - currentPatch%canopy_mask(cl,ft) = 1 + currentPatch%canopy_mask(cl,ft) = 1 endif end do !iv enddo !ft @@ -1903,9 +1879,9 @@ subroutine leaf_area_profile( currentSite ) end if - currentPatch => currentPatch%younger + currentPatch => currentPatch%younger - enddo !patch + enddo !patch return end subroutine leaf_area_profile @@ -1924,7 +1900,7 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) use FatesInterfaceTypesMod , only : bc_out_type ! - ! !ARGUMENTS + ! !ARGUMENTS integer, intent(in) :: nsites type(ed_site_type), intent(inout), target :: sites(nsites) integer, intent(in) :: fcolumn(nsites) @@ -1942,16 +1918,16 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) do s = 1,nsites ifp = 0 - total_patch_area = 0._r8 + total_patch_area = 0._r8 total_canopy_area = 0._r8 bc_out(s)%canopy_fraction_pa(:) = 0._r8 currentPatch => sites(s)%oldest_patch c = fcolumn(s) do while(associated(currentPatch)) - !if(currentPatch%nocomp_pft_label.ne.0)then + !if(currentPatch%nocomp_pft_label.ne.0)then ! only increase ifp for veg patches, not bareground (in SP mode) ifp = ifp+1 - !endif ! stay with ifp=0 for bareground patch. + !endif ! stay with ifp=0 for bareground patch. if ( currentPatch%total_canopy_area-currentPatch%area > 0.000001_r8 ) then write(fates_log(),*) 'ED: canopy area bigger than area',currentPatch%total_canopy_area ,currentPatch%area currentPatch%total_canopy_area = currentPatch%area @@ -1976,7 +1952,7 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) ! weight = min(1.0_r8,currentCohort%lai/currentPatch%lai) ! bc_out(s)%dleaf_pa(ifp) = bc_out(s)%dleaf_pa(ifp) + & ! EDPftvarcon_inst%dleaf(currentCohort%pft)*weight - ! currentCohort => currentCohort%taller + ! currentCohort => currentCohort%taller ! enddo ! end if @@ -1989,11 +1965,11 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) bc_out(s)%displa_pa(ifp) = EDPftvarcon_inst%displar(1) * bc_out(s)%htop_pa(ifp) bc_out(s)%dleaf_pa(ifp) = EDPftvarcon_inst%dleaf(1) - ! We are assuming here that grass is all located underneath tree canopies. + ! We are assuming here that grass is all located underneath tree canopies. ! The alternative is to assume it is all spatial distinct from tree canopies. ! In which case, the bare area would have to be reduced by the grass area... - ! currentPatch%total_canopy_area/currentPatch%area is fraction of this patch cover by plants - ! currentPatch%area/AREA is the fraction of the soil covered by this patch. + ! currentPatch%total_canopy_area/currentPatch%area is fraction of this patch cover by plants + ! currentPatch%area/AREA is the fraction of the soil covered by this patch. if(currentPatch%area.gt.0.0_r8)then bc_out(s)%canopy_fraction_pa(ifp) = & min(1.0_r8,currentPatch%total_canopy_area/currentPatch%area)*(currentPatch%area/AREA) @@ -2014,16 +1990,11 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) ! It is assumed that cpatch%canopy_area_profile and cpat%xai_profiles ! have been updated (ie ed_leaf_area_profile has been called since dynamics has been called) - write(fates_log(),*) 's, ifp: ', s, ifp - write(fates_log(),*) 'EDCanopyStructure pre: bc_out(s)%tlai_pa(ifp): ', bc_out(s)%tlai_pa(ifp) - bc_out(s)%elai_pa(ifp) = calc_areaindex(currentPatch,'elai') bc_out(s)%tlai_pa(ifp) = calc_areaindex(currentPatch,'tlai') bc_out(s)%esai_pa(ifp) = calc_areaindex(currentPatch,'esai') bc_out(s)%tsai_pa(ifp) = calc_areaindex(currentPatch,'tsai') - write(fates_log(),*) 'EDCanopyStructure post: bc_out(s)%tlai_pa(ifp): ', bc_out(s)%tlai_pa(ifp) - !if(debug) then ! write(fates_log(),*) 'ifp: ', ifp ! write(fates_log(),*) 'bc_out(s)%elai_pa(ifp): ', bc_out(s)%elai_pa(ifp) @@ -2036,7 +2007,7 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) ! patches which shall under-go photosynthesis ! INTERF-TODO: we may want to stop using frac_veg_nosno_alb and let ! FATES internal variables decide if photosynthesis is possible - ! we are essentially calculating it inside FATES to tell the + ! we are essentially calculating it inside FATES to tell the ! host to tell itself when to do things (circuitous). Just have ! to determine where else it is used @@ -2069,7 +2040,7 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) if(currentPatch%nocomp_pft_label.ne.0)then ! for vegetated patches only ifp = ifp+1 bc_out(s)%canopy_fraction_pa(ifp) = bc_out(s)%canopy_fraction_pa(ifp)/total_patch_area - else ! for the bareground patch (in SP mode). + else ! for the bareground patch (in SP mode). bc_out(s)%canopy_fraction_pa(ifp) =0.0_r8 endif ! veg patch @@ -2086,11 +2057,11 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) ! For recruitment, we initialized their water, but flagged them ! to not be included in the site level balance yet, for they ! will demand the water for their initialization on the first hydraulics time-step - + if (hlm_use_planthydro.eq.itrue) then call UpdateH2OVeg(sites(s),bc_out(s),bc_out(s)%plant_stored_h2o_si,1) end if - + end do ! This call to RecruitWaterStorage() makes an accounting of @@ -2099,7 +2070,7 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) ! a flux, it is just accounting for diagnostics purposes. The water ! will not actually be moved until the beginning of the first hydraulics ! call during the fast timestep sequence - + if (hlm_use_planthydro.eq.itrue) then call RecruitWaterStorage(nsites,sites,bc_out) end if @@ -2230,7 +2201,7 @@ function NumPotentialCanopyLayers(currentPatch,site_spread,include_substory) res z = 1 currentCohort => currentPatch%tallest - do while (associated(currentCohort)) + do while (associated(currentCohort)) z = max(z,currentCohort%canopy_layer) currentCohort => currentCohort%shorter enddo @@ -2238,7 +2209,7 @@ function NumPotentialCanopyLayers(currentPatch,site_spread,include_substory) res if(include_substory)then arealayer = 0.0 currentCohort => currentPatch%tallest - do while (associated(currentCohort)) + do while (associated(currentCohort)) if(currentCohort%canopy_layer == z) then call carea_allom(currentCohort%dbh,currentCohort%n,site_spread,currentCohort%pft,c_area) arealayer = arealayer + c_area @@ -2246,7 +2217,7 @@ function NumPotentialCanopyLayers(currentPatch,site_spread,include_substory) res currentCohort => currentCohort%shorter enddo - ! Does the bottom layer have more than a full canopy? + ! Does the bottom layer have more than a full canopy? ! If so we need to make another layer. if(arealayer > currentPatch%area)then z = z + 1 diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 924c4fbd55..68763c5a97 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -3,7 +3,7 @@ module EDPhysiologyMod #include "shr_assert.h" ! ============================================================================ - ! Miscellaneous physiology routines from ED. + ! Miscellaneous physiology routines from ED. ! ============================================================================ use FatesGlobals, only : fates_log @@ -119,14 +119,14 @@ module EDPhysiologyMod public :: ZeroAllocationRates public :: PreDisturbanceLitterFluxes - public :: PreDisturbanceIntegrateLitter + public :: PreDisturbanceIntegrateLitter public :: SeedIn logical, parameter :: debug = .false. ! local debug flag character(len=*), parameter, private :: sourcefile = & __FILE__ - integer, parameter :: dleafon_drycheck = 100 ! Drought deciduous leaves max days on check parameter + integer, parameter :: dleafon_drycheck = 100 ! Drought deciduous leaves max days on check parameter ! ============================================================================ @@ -141,7 +141,7 @@ subroutine ZeroLitterFluxes( currentSite ) ! call sequence. - ! !ARGUMENTS + ! !ARGUMENTS type(ed_site_type), intent(inout), target :: currentSite type(ed_patch_type), pointer :: currentPatch @@ -163,7 +163,7 @@ end subroutine ZeroLitterFluxes subroutine ZeroAllocationRates( currentSite ) - ! !ARGUMENTS + ! !ARGUMENTS type(ed_site_type), intent(inout), target :: currentSite type(ed_patch_type), pointer :: currentPatch type(ed_cohort_type), pointer :: currentCohort @@ -172,7 +172,7 @@ subroutine ZeroAllocationRates( currentSite ) do while(associated(currentPatch)) currentCohort => currentPatch%tallest - do while (associated(currentCohort)) + do while (associated(currentCohort)) ! This sets turnover and growth rates to zero call currentCohort%prt%ZeroRates() @@ -191,7 +191,7 @@ end subroutine ZeroAllocationRates subroutine PreDisturbanceLitterFluxes( currentSite, currentPatch, bc_in ) ! ----------------------------------------------------------------------------------- - ! + ! ! This subroutine calculates all of the different litter input and output fluxes ! associated with seed turnover, seed influx, litterfall from live and ! dead plants, germination, and fragmentation. @@ -203,29 +203,27 @@ subroutine PreDisturbanceLitterFluxes( currentSite, currentPatch, bc_in ) ! with disturbance. Those fluxes are handled elsewhere (EDPatchDynamcisMod) ! because the fluxes are potentially cross patch, and also dealing ! patch areas that are changing. - ! + ! ! ----------------------------------------------------------------------------------- - ! !ARGUMENTS + ! !ARGUMENTS type(ed_site_type), intent(inout) :: currentSite type(ed_patch_type), intent(inout) :: currentPatch type(bc_in_type), intent(in) :: bc_in ! ! !LOCAL VARIABLES: - type(site_massbal_type), pointer :: site_mass - type(litter_type), pointer :: litt ! Points to the litter object for + type(site_massbal_type), pointer :: site_mass + type(litter_type), pointer :: litt ! Points to the litter object for ! the different element types integer :: el ! Litter element loop index integer :: nlev_eff_decomp ! Number of active layers over which ! fragmentation fluxes are transfered !------------------------------------------------------------------------------------ - ! Calculate the fragmentation rates + ! Calculate the fragmentation rates call fragmentation_scaler(currentPatch, bc_in) - write(fates_log(),*) 'PreDistLittFlux: frag_scaler: ', currentPatch%fragmentation_scaler - do el = 1, num_elements @@ -233,9 +231,9 @@ subroutine PreDisturbanceLitterFluxes( currentSite, currentPatch, bc_in ) ! Calculate loss rate of viable seeds to litter call SeedDecay(litt) - + ! Calculate seed germination rate, the status flags prevent - ! germination from occuring when the site is in a drought + ! germination from occuring when the site is in a drought ! (for drought deciduous) or too cold (for cold deciduous) call SeedGermination(litt, currentSite%cstatus, currentSite%dstatus) @@ -260,7 +258,7 @@ subroutine PreDisturbanceLitterFluxes( currentSite, currentPatch, bc_in ) ( sum(litt%ag_cwd_frag) + sum(litt%bg_cwd_frag) + & sum(litt%leaf_fines_frag) + sum(litt%root_fines_frag) + & sum(litt%seed_decay) + sum(litt%seed_germ_decay)) - + end do @@ -273,14 +271,14 @@ subroutine PreDisturbanceIntegrateLitter(currentPatch) ! ----------------------------------------------------------------------------------- ! - ! This step applies the litter fluxes to the prognostic state variables. + ! This step applies the litter fluxes to the prognostic state variables. ! This procedure is called in response to fluxes generated from: - ! 1) seed rain, + ! 1) seed rain, ! 2) non-disturbance generating turnover ! 3) litter fall from living plants ! 4) fragmentation ! - ! This routine does NOT accomodate the litter fluxes associated with + ! This routine does NOT accomodate the litter fluxes associated with ! disturbance generation. That will happen after this call. ! Fluxes associated with FIRE also happen after this step. ! @@ -295,7 +293,7 @@ subroutine PreDisturbanceIntegrateLitter(currentPatch) ! Locals - type(litter_type), pointer :: litt + type(litter_type), pointer :: litt integer :: el ! Loop counter for litter element type integer :: pft ! pft loop counter integer :: c ! CWD loop counter @@ -320,7 +318,7 @@ subroutine PreDisturbanceIntegrateLitter(currentPatch) ! Note that the recruitment scheme will use seed_germ ! for its construction costs. litt%seed_germ(pft) = litt%seed_germ(pft) + & - litt%seed_germ_in(pft) - & + litt%seed_germ_in(pft) - & litt%seed_germ_decay(pft) @@ -366,11 +364,11 @@ end subroutine PreDisturbanceIntegrateLitter subroutine trim_canopy( currentSite ) ! ! !DESCRIPTION: - ! Canopy trimming / leaf optimisation. Removes leaves in negative annual carbon balance. + ! Canopy trimming / leaf optimisation. Removes leaves in negative annual carbon balance. ! ! !USES: - ! !ARGUMENTS + ! !ARGUMENTS type (ed_site_type),intent(inout), target :: currentSite ! ! !LOCAL VARIABLES: @@ -379,7 +377,7 @@ subroutine trim_canopy( currentSite ) integer :: z ! leaf layer integer :: ipft ! pft index - logical :: trimmed ! was this layer trimmed in this year? If not expand the canopy. + logical :: trimmed ! was this layer trimmed in this year? If not expand the canopy. real(r8) :: tar_bl ! target leaf biomass (leaves flushed, trimmed) real(r8) :: tar_bfr ! target fine-root biomass (leaves flushed, trimmed) real(r8) :: bfr_per_bleaf ! ratio of fine root per leaf biomass @@ -394,7 +392,7 @@ subroutine trim_canopy( currentSite ) real(r8) :: struct_c ! structure carbon [kg] real(r8) :: leaf_inc ! LAI-only portion of the vegetation increment of dinc_ed real(r8) :: lai_canopy_above ! the LAI in the canopy layers above the layer of interest - real(r8) :: lai_layers_above ! the LAI in the leaf layers, within the current canopy, + real(r8) :: lai_layers_above ! the LAI in the leaf layers, within the current canopy, ! above the leaf layer of interest real(r8) :: lai_current ! the LAI in the current leaf layer real(r8) :: cumulative_lai ! whole canopy cumulative LAI, top down, to the leaf layer of interest @@ -406,8 +404,8 @@ subroutine trim_canopy( currentSite ) ! LAPACK linear least squares fit variables ! The standard equation for a linear fit, y = mx + b, is converted to a linear system, AX=B and has - ! the form: [n sum(x); sum(x) sum(x^2)] * [b; m] = [sum(y); sum(x*y)] where - ! n is the number of leaf layers + ! the form: [n sum(x); sum(x) sum(x^2)] * [b; m] = [sum(y); sum(x*y)] where + ! n is the number of leaf layers ! x is yearly_net_uptake minus the leaf cost aka the net-net uptake ! y is the cumulative lai for the current cohort ! b is the y-intercept i.e. the cumulative lai that has zero net-net uptake @@ -428,7 +426,7 @@ subroutine trim_canopy( currentSite ) real(r8) :: work(workmax) ! work array real(r8) :: initial_trim ! Initial trim - real(r8) :: optimum_trim ! Optimum trim value + real(r8) :: optimum_trim ! Optimum trim value real(r8) :: initial_laimem ! Initial laimemory real(r8) :: optimum_laimem ! Optimum laimemory @@ -448,7 +446,7 @@ subroutine trim_canopy( currentSite ) icohort = 1 currentCohort => currentPatch%tallest - do while (associated(currentCohort)) + do while (associated(currentCohort)) ! Save off the incoming trim and laimemory initial_trim = currentCohort%canopy_trim @@ -469,12 +467,12 @@ subroutine trim_canopy( currentSite ) currentCohort%treelai = tree_lai(leaf_c, currentCohort%pft, currentCohort%c_area, & currentCohort%n, currentCohort%canopy_layer, & - currentPatch%canopy_layer_tlai,currentCohort%vcmax25top ) + currentPatch%canopy_layer_tlai,currentCohort%vcmax25top ) currentCohort%treesai = tree_sai(currentCohort%pft, currentCohort%dbh, currentCohort%canopy_trim, & currentCohort%c_area, currentCohort%n, currentCohort%canopy_layer, & currentPatch%canopy_layer_tlai, currentCohort%treelai, & - currentCohort%vcmax25top,0 ) + currentCohort%vcmax25top,0 ) currentCohort%nv = ceiling((currentCohort%treelai+currentCohort%treesai)/dinc_ed) @@ -503,7 +501,7 @@ subroutine trim_canopy( currentSite ) nnu_clai_a(:,:) = 0._r8 nnu_clai_b(:,:) = 0._r8 - !Leaf cost vs netuptake for each leaf layer. + !Leaf cost vs netuptake for each leaf layer. do z = 1, currentCohort%nv ! Calculate the cumulative total vegetation area index (no snow occlusion, stems and leaves) @@ -517,11 +515,11 @@ subroutine trim_canopy( currentSite ) cumulative_lai_cohort = lai_layers_above + 0.5*lai_current ! Now add in the lai above the current cohort for calculating the sla leaf level - lai_canopy_above = sum(currentPatch%canopy_layer_tlai(1:cl-1)) + lai_canopy_above = sum(currentPatch%canopy_layer_tlai(1:cl-1)) cumulative_lai = lai_canopy_above + cumulative_lai_cohort ! There was activity this year in this leaf layer. This should only occur for bottom most leaf layer - if (currentCohort%year_net_uptake(z) /= 999._r8)then + if (currentCohort%year_net_uptake(z) /= 999._r8)then ! Calculate sla_levleaf following the sla profile with overlying leaf area ! Scale for leaf nitrogen profile @@ -536,9 +534,9 @@ subroutine trim_canopy( currentSite ) end if !Leaf Cost kgC/m2/year-1 - !decidous costs. + !decidous costs. if (prt_params%season_decid(ipft) == itrue .or. & - prt_params%stress_decid(ipft) == itrue )then + prt_params%stress_decid(ipft) == itrue )then ! Leaf cost at leaf level z accounting for sla profile (kgC/m2) currentCohort%leaf_cost = 1._r8/(sla_levleaf*1000.0_r8) @@ -572,9 +570,9 @@ subroutine trim_canopy( currentSite ) endif ! Construct the arrays for a least square fit of the net_net_uptake versus the cumulative lai - ! if at least nll leaf layers are present in the current cohort and only for the bottom nll + ! if at least nll leaf layers are present in the current cohort and only for the bottom nll ! leaf layers. - if (currentCohort%nv > nll .and. currentCohort%nv - z < nll) then + if (currentCohort%nv > nll .and. currentCohort%nv - z < nll) then ! Build the A matrix for the LHS of the linear system. A = [n sum(x); sum(x) sum(x^2)] ! where n = nll and x = yearly_net_uptake-leafcost @@ -586,7 +584,7 @@ subroutine trim_canopy( currentSite ) ! Build the B matrix for the RHS of the linear system. B = [sum(y); sum(x*y)] ! where x = yearly_net_uptake-leafcost and y = cumulative_lai_cohort nnu_clai_b(1,1) = nnu_clai_b(1,1) + cumulative_lai_cohort - nnu_clai_b(2,1) = nnu_clai_b(2,1) + (cumulative_lai_cohort * & + nnu_clai_b(2,1) = nnu_clai_b(2,1) + (cumulative_lai_cohort * & (currentCohort%year_net_uptake(z) - currentCohort%leaf_cost)) end if @@ -600,13 +598,13 @@ subroutine trim_canopy( currentSite ) ! currentCohort%canopy_trim,currentCohort%leaf_cost ! endif - ! keep trimming until none of the canopy is in negative carbon balance. + ! keep trimming until none of the canopy is in negative carbon balance. if (currentCohort%hite > EDPftvarcon_inst%hgt_min(ipft)) then currentCohort%canopy_trim = currentCohort%canopy_trim - & EDPftvarcon_inst%trim_inc(ipft) if (prt_params%evergreen(ipft) /= 1)then currentCohort%laimemory = currentCohort%laimemory * & - (1.0_r8 - EDPftvarcon_inst%trim_inc(ipft)) + (1.0_r8 - EDPftvarcon_inst%trim_inc(ipft)) endif trimmed = .true. @@ -614,7 +612,7 @@ subroutine trim_canopy( currentSite ) endif ! hite check endif ! trim limit check endif ! net uptake check - endif ! leaf activity check + endif ! leaf activity check enddo ! z, leaf layer loop ! Compute the optimal cumulative lai based on the cohort net-net uptake profile if at least 2 leaf layers @@ -630,7 +628,7 @@ subroutine trim_canopy( currentSite ) ! endif ! Compute the minimum of 2-norm of of the least squares fit to solve for X - ! Note that dgels returns the solution by overwriting the nnu_clai_b array. + ! Note that dgels returns the solution by overwriting the nnu_clai_b array. ! The result has the form: X = [b; m] ! where b = y-intercept (i.e. the cohort lai that has zero yearly net-net uptake) ! and m is the slope of the linear fit @@ -651,7 +649,7 @@ subroutine trim_canopy( currentSite ) ! Calculate the optimum trim based on the initial canopy trim value if (cumulative_lai_cohort > 0._r8) then ! Sometime cumulative_lai comes in at 0.0? - ! + ! optimum_trim = (nnu_clai_b(1,1) / cumulative_lai_cohort) * initial_trim optimum_laimem = (nnu_clai_b(1,1) / cumulative_lai_cohort) * initial_laimem @@ -673,7 +671,7 @@ subroutine trim_canopy( currentSite ) ! Reset activity for the cohort for the start of the next year currentCohort%year_net_uptake(:) = 999.0_r8 - ! Add to trim fraction if cohort not trimmed at all + ! Add to trim fraction if cohort not trimmed at all if ( (.not.trimmed) .and.currentCohort%canopy_trim < 1.0_r8)then currentCohort%canopy_trim = currentCohort%canopy_trim + EDPftvarcon_inst%trim_inc(ipft) endif @@ -682,7 +680,7 @@ subroutine trim_canopy( currentSite ) write(fates_log(),*) 'trimming:',currentCohort%canopy_trim endif - ! currentCohort%canopy_trim = 1.0_r8 !FIX(RF,032414) this turns off ctrim for now. + ! currentCohort%canopy_trim = 1.0_r8 !FIX(RF,032414) this turns off ctrim for now. currentCohort => currentCohort%shorter icohort = icohort + 1 enddo @@ -696,7 +694,7 @@ end subroutine trim_canopy subroutine phenology( currentSite, bc_in ) ! ! !DESCRIPTION: - ! Phenology. + ! Phenology. ! ! !USES: use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm @@ -757,26 +755,26 @@ subroutine phenology( currentSite, bc_in ) ilayer_swater = minloc(abs(bc_in%z_sisl(:)-dphen_soil_depth),dim=1) - ! Parameter of drought decid leaf loss in mm in top layer...FIX(RF,032414) + ! Parameter of drought decid leaf loss in mm in top layer...FIX(RF,032414) ! - this is arbitrary and poorly understood. Needs work. ED_ - !Parameters: defaults from Botta et al. 2000 GCB,6 709-725 + !Parameters: defaults from Botta et al. 2000 GCB,6 709-725 !Parameters, default from from SDGVM model of senesence temp_in_C = 0._r8 - cpatch => CurrentSite%oldest_patch - do while(associated(cpatch)) + cpatch => CurrentSite%oldest_patch + do while(associated(cpatch)) temp_in_C = temp_in_C + bc_in%t_veg24_pa(cpatch%patchno)*cpatch%area cpatch => cpatch%younger end do temp_in_C = temp_in_C * area_inv - tfrz - !-----------------Cold Phenology--------------------! + !-----------------Cold Phenology--------------------! !Zero growing degree and chilling day counters if (currentSite%lat > 0)then ncdstart = 270 !Northern Hemisphere begining November - gddstart = 1 !Northern Hemisphere begining January + gddstart = 1 !Northern Hemisphere begining January else ncdstart = 120 !Southern Hemisphere beginning May gddstart = 181 !Northern Hemisphere begining July @@ -796,7 +794,7 @@ subroutine phenology( currentSite, bc_in ) endif !GDD accumulation function, which also depends on chilling days. - ! -68 + 638 * (-0.001 * ncd) + ! -68 + 638 * (-0.001 * ncd) gdd_threshold = ED_val_phen_a + ED_val_phen_b*exp(ED_val_phen_c*real(currentSite%nchilldays,r8)) !Accumulate temperature of last 10 days. @@ -824,27 +822,27 @@ subroutine phenology( currentSite, bc_in ) currentSite%grow_deg_days = currentSite%grow_deg_days + temp_in_C endif - !this logic is to prevent GDD accumulating after the leaves have fallen and before the - ! beginnning of the accumulation period, to prevend erroneous autumn leaf flushing. + !this logic is to prevent GDD accumulating after the leaves have fallen and before the + ! beginnning of the accumulation period, to prevend erroneous autumn leaf flushing. if(model_day_int>365)then !only do this after the first year to prevent odd behaviour - if(currentSite%lat .gt. 0.0_r8)then !Northern Hemisphere + if(currentSite%lat .gt. 0.0_r8)then !Northern Hemisphere ! In the north, don't accumulate when we are past the leaf fall date. - ! Accumulation starts on day 1 of year in NH. + ! Accumulation starts on day 1 of year in NH. ! The 180 is to prevent going into an 'always off' state after initialization if( model_day_int .gt. currentSite%cleafoffdate.and.hlm_day_of_year.gt.180)then ! currentSite%grow_deg_days = 0._r8 endif - else !Southern Hemisphere + else !Southern Hemisphere ! In the South, don't accumulate after the leaf off date, and before the start of - ! the accumulation phase (day 181). - if(model_day_int .gt. currentSite%cleafoffdate.and.hlm_day_of_year.lt.gddstart) then! + ! the accumulation phase (day 181). + if(model_day_int .gt. currentSite%cleafoffdate.and.hlm_day_of_year.lt.gddstart) then! currentSite%grow_deg_days = 0._r8 endif endif - endif !year1 + endif !year1 - ! Calculate the number of days since the leaves last came on + ! Calculate the number of days since the leaves last came on ! and off. If this is the beginning of the simulation, that day might ! not had occured yet, so set it to last year to get things rolling @@ -863,9 +861,9 @@ subroutine phenology( currentSite, bc_in ) !LEAF ON: COLD DECIDUOUS. Needs to - !1) have exceeded the growing degree day threshold + !1) have exceeded the growing degree day threshold !2) The leaves should not be on already - !3) There should have been at least one chilling day in the counting period. + !3) There should have been at least one chilling day in the counting period. ! this prevents tropical or warm climate plants that are "cold-deciduous" ! from ever re-flushing after they have reached their maximum age (thus ! preventing them from competing @@ -876,9 +874,9 @@ subroutine phenology( currentSite, bc_in ) (dayssincecleafoff > ED_val_phen_mindayson) .and. & (currentSite%nchilldays >= 1)) then currentSite%cstatus = phen_cstat_notcold ! Set to not-cold status (leaves can come on) - currentSite%cleafondate = model_day_int - dayssincecleafon = 0 - currentSite%grow_deg_days = 0._r8 ! zero GDD for the rest of the year until counting season begins. + currentSite%cleafondate = model_day_int + dayssincecleafon = 0 + currentSite%grow_deg_days = 0._r8 ! zero GDD for the rest of the year until counting season begins. if ( debug ) write(fates_log(),*) 'leaves on' endif !GDD @@ -890,7 +888,7 @@ subroutine phenology( currentSite, bc_in ) !1) have exceeded the number of cold days threshold !2) have exceeded the minimum leafon time. !3) The leaves should not be off already - !4) The day of simulation should be larger than the counting period. + !4) The day of simulation should be larger than the counting period. if ( (currentSite%cstatus == phen_cstat_notcold) .and. & @@ -899,12 +897,12 @@ subroutine phenology( currentSite, bc_in ) (dayssincecleafon > ED_val_phen_mindayson) )then currentSite%grow_deg_days = 0._r8 ! The equations for Botta et al - ! are for calculations of + ! are for calculations of ! first flush, but if we dont ! clear this value, it will cause ! leaves to flush later in the year currentSite%cstatus = phen_cstat_iscold ! alter status of site to 'leaves off' - currentSite%cleafoffdate = model_day_int ! record leaf off date + currentSite%cleafoffdate = model_day_int ! record leaf off date if ( debug ) write(fates_log(),*) 'leaves off' endif @@ -916,59 +914,59 @@ subroutine phenology( currentSite, bc_in ) ! plants from re-emerging in areas without at least some cold days if( (currentSite%cstatus == phen_cstat_notcold) .and. & - (dayssincecleafoff > 400)) then ! remove leaves after a whole year - ! when there is no 'off' period. + (dayssincecleafoff > 400)) then ! remove leaves after a whole year + ! when there is no 'off' period. currentSite%grow_deg_days = 0._r8 currentSite%cstatus = phen_cstat_nevercold ! alter status of site to imply that this ! site is never really cold enough ! for cold deciduous - currentSite%cleafoffdate = model_day_int ! record leaf off date + currentSite%cleafoffdate = model_day_int ! record leaf off date if ( debug ) write(fates_log(),*) 'leaves off' endif !-----------------Drought Phenology--------------------! ! Principles of drought-deciduos phenology model... - ! The 'is_drought' flag is false when leaves are on, and true when leaves area off. - ! The following sets those site-level flags, which are acted on in phenology_deciduos. - ! A* The leaves live for either the length of time the soil moisture is over the threshold - ! or the lifetime of the leaves, whichever is shorter. + ! The 'is_drought' flag is false when leaves are on, and true when leaves area off. + ! The following sets those site-level flags, which are acted on in phenology_deciduos. + ! A* The leaves live for either the length of time the soil moisture is over the threshold + ! or the lifetime of the leaves, whichever is shorter. ! B*: If the soil is only wet for a very short time, then the leaves stay on for 100 days - ! C*: The leaves are only permitted to come ON for a 60 day window around when they last came on, + ! C*: The leaves are only permitted to come ON for a 60 day window around when they last came on, ! to prevent 'flickering' on in response to wet season storms - ! D*: We don't allow anything to happen in the first ten days to allow the water memory window - ! to come into equlibirium. - ! E*: If the soil is always wet, the leaves come on at the beginning of the window, and then - ! last for their lifespan. + ! D*: We don't allow anything to happen in the first ten days to allow the water memory window + ! to come into equlibirium. + ! E*: If the soil is always wet, the leaves come on at the beginning of the window, and then + ! last for their lifespan. ! ISSUES - ! 1. It's not clear what water content we should track. Here we are tracking the top layer, - ! but we probably should track something like BTRAN, but BTRAN is defined for each PFT, + ! 1. It's not clear what water content we should track. Here we are tracking the top layer, + ! but we probably should track something like BTRAN, but BTRAN is defined for each PFT, ! and there could potentially be more than one stress-dec PFT.... ? - ! 2. In the beginning, the window is set at an arbitrary time of the year, so the leaves + ! 2. In the beginning, the window is set at an arbitrary time of the year, so the leaves ! might come on in the dry season, using up stored reserves - ! for the stress-dec plants, and potentially killing them. To get around this, + ! for the stress-dec plants, and potentially killing them. To get around this, ! we need to read in the 'leaf on' date from some kind of start-up file - ! but we would need that to happen for every resolution, etc. + ! but we would need that to happen for every resolution, etc. ! 3. Will this methodology properly kill off the stress-dec trees where there is no - ! water stress? What about where the wet period coincides with the warm period? + ! water stress? What about where the wet period coincides with the warm period? ! We would just get them overlapping with the cold-dec trees, even though that isn't appropriate - ! Why don't the drought deciduous trees grow in the North? - ! Is cold decidousness maybe even the same as drought deciduosness there (and so does this - ! distinction actually matter??).... + ! Why don't the drought deciduous trees grow in the North? + ! Is cold decidousness maybe even the same as drought deciduosness there (and so does this + ! distinction actually matter??).... ! Accumulate surface water memory of last 10 days. ! Liquid volume in ground layer (m3/m3) do i_wmem = 1,numWaterMem-1 !shift memory along one currentSite%water_memory(numWaterMem+1-i_wmem) = currentSite%water_memory(numWaterMem-i_wmem) enddo - currentSite%water_memory(1) = bc_in%h2o_liqvol_sl(ilayer_swater) + currentSite%water_memory(1) = bc_in%h2o_liqvol_sl(ilayer_swater) ! Calculate the mean water content over the last 10 days (m3/m3) mean_10day_liqvol = sum(currentSite%water_memory(1:numWaterMem))/real(numWaterMem,r8) - ! In drought phenology, we often need to force the leaves to stay - ! on or off as moisture fluctuates... + ! In drought phenology, we often need to force the leaves to stay + ! on or off as moisture fluctuates... ! Calculate days since leaves have come off, but make a provision ! for the first year of simulation, we have to assume a leaf drop @@ -980,19 +978,19 @@ subroutine phenology( currentSite, bc_in ) dayssincedleafoff = model_day_int - currentSite%dleafoffdate endif - ! the leaves are on. How long have they been on? + ! the leaves are on. How long have they been on? if (model_day_int < currentSite%dleafondate) then dayssincedleafon = model_day_int - (currentSite%dleafondate-365) else - dayssincedleafon = model_day_int - currentSite%dleafondate + dayssincedleafon = model_day_int - currentSite%dleafondate endif ! LEAF ON: DROUGHT DECIDUOUS WETNESS - ! Here, we used a window of oppurtunity to determine if we are + ! Here, we used a window of oppurtunity to determine if we are ! close to the time when then leaves came on last year ! Has it been ... - ! a) a year, plus or minus 1 month since we last had leaf-on? + ! a) a year, plus or minus 1 month since we last had leaf-on? ! b) Has there also been at least a nominaly short amount of "leaf-off" ! c) is the model day at least > 10 (let soil water spin-up) ! Note that cold-starts begin in the "leaf-on" @@ -1017,9 +1015,9 @@ subroutine phenology( currentSite, bc_in ) ! LEAF ON: DROUGHT DECIDUOUS TIME EXCEEDANCE ! If we still haven't done budburst by end of window, then force it - ! If the status is "phen_dstat_moistoff", it means this site currently has - ! leaves off due to actual moisture limitations. - ! So we trigger bud-burst at the end of the month since + ! If the status is "phen_dstat_moistoff", it means this site currently has + ! leaves off due to actual moisture limitations. + ! So we trigger bud-burst at the end of the month since ! last year's bud-burst. If this is imposed, then we set the new ! status to indicate bud-burst was forced by timing @@ -1042,27 +1040,27 @@ subroutine phenology( currentSite, bc_in ) end if end if - ! LEAF OFF: DROUGHT DECIDUOUS LIFESPAN - if the leaf gets to - ! the end of its useful life. A*, E* - ! i.e. Are the leaves rouhgly at the end of their lives? + ! LEAF OFF: DROUGHT DECIDUOUS LIFESPAN - if the leaf gets to + ! the end of its useful life. A*, E* + ! i.e. Are the leaves rouhgly at the end of their lives? if ( (currentSite%dstatus == phen_dstat_moiston .or. & - currentSite%dstatus == phen_dstat_timeon ) .and. & - (dayssincedleafon > canopy_leaf_lifespan) )then + currentSite%dstatus == phen_dstat_timeon ) .and. & + (dayssincedleafon > canopy_leaf_lifespan) )then currentSite%dstatus = phen_dstat_timeoff !alter status of site to 'leaves off' - currentSite%dleafoffdate = model_day_int !record leaf on date + currentSite%dleafoffdate = model_day_int !record leaf on date endif - ! LEAF OFF: DROUGHT DECIDUOUS DRYNESS - if the soil gets too dry, - ! and the leaves have already been on a while... + ! LEAF OFF: DROUGHT DECIDUOUS DRYNESS - if the soil gets too dry, + ! and the leaves have already been on a while... if ( (currentSite%dstatus == phen_dstat_moiston .or. & currentSite%dstatus == phen_dstat_timeon ) .and. & (model_day_int > numWaterMem) .and. & (mean_10day_liqvol <= ED_val_phen_drought_threshold) .and. & - (dayssincedleafon > dleafon_drycheck ) ) then + (dayssincedleafon > dleafon_drycheck ) ) then currentSite%dstatus = phen_dstat_moistoff ! alter status of site to 'leaves off' - currentSite%dleafoffdate = model_day_int ! record leaf on date + currentSite%dleafoffdate = model_day_int ! record leaf on date endif call phenology_leafonoff(currentSite) @@ -1082,8 +1080,8 @@ subroutine phenology_leafonoff(currentSite) type(ed_site_type), intent(inout), target :: currentSite ! ! !LOCAL VARIABLES: - type(ed_patch_type) , pointer :: currentPatch - type(ed_cohort_type), pointer :: currentCohort + type(ed_patch_type) , pointer :: currentPatch + type(ed_cohort_type), pointer :: currentCohort real(r8) :: leaf_c ! leaf carbon [kg] real(r8) :: sapw_c ! sapwood carbon [kg] @@ -1097,11 +1095,11 @@ subroutine phenology_leafonoff(currentSite) real(r8) :: stem_drop_fraction !------------------------------------------------------------------------ - currentPatch => CurrentSite%oldest_patch + currentPatch => CurrentSite%oldest_patch - do while(associated(currentPatch)) + do while(associated(currentPatch)) currentCohort => currentPatch%tallest - do while(associated(currentCohort)) + do while(associated(currentCohort)) ipft = currentCohort%pft @@ -1121,15 +1119,15 @@ subroutine phenology_leafonoff(currentSite) ! for leaves. Time to signal flushing if (prt_params%season_decid(ipft) == itrue)then - if ( currentSite%cstatus == phen_cstat_notcold )then ! we have just moved to leaves being on . - if (currentCohort%status_coh == leaves_off)then ! Are the leaves currently off? - currentCohort%status_coh = leaves_on ! Leaves are on, so change status to - ! stop flow of carbon out of bstore. + if ( currentSite%cstatus == phen_cstat_notcold )then ! we have just moved to leaves being on . + if (currentCohort%status_coh == leaves_off)then ! Are the leaves currently off? + currentCohort%status_coh = leaves_on ! Leaves are on, so change status to + ! stop flow of carbon out of bstore. if(store_c>nearzero) then ! flush either the amount required from the laimemory, or -most- of the storage pool ! RF: added a criterion to stop the entire store pool emptying and triggering termination mortality - ! n.b. this might not be necessary if we adopted a more gradual approach to leaf flushing... + ! n.b. this might not be necessary if we adopted a more gradual approach to leaf flushing... store_c_transfer_frac = min((EDPftvarcon_inst%phenflush_fraction(ipft)* & currentCohort%laimemory)/store_c,(1.0_r8-carbon_store_buffer)) @@ -1143,12 +1141,12 @@ subroutine phenology_leafonoff(currentSite) store_c_transfer_frac = 0.0_r8 end if - ! This call will request that storage carbon will be transferred to + ! This call will request that storage carbon will be transferred to ! leaf tissues. It is specified as a fraction of the available storage if(prt_params%woody(ipft) == itrue) then call PRTPhenologyFlush(currentCohort%prt, ipft, leaf_organ, store_c_transfer_frac) - currentCohort%laimemory = 0.0_r8 + currentCohort%laimemory = 0.0_r8 else @@ -1156,18 +1154,18 @@ subroutine phenology_leafonoff(currentSite) if (stem_drop_fraction .gt. 0.0_r8) then call PRTPhenologyFlush(currentCohort%prt, ipft, leaf_organ, & - store_c_transfer_frac*currentCohort%laimemory/totalmemory) + store_c_transfer_frac*currentCohort%laimemory/totalmemory) call PRTPhenologyFlush(currentCohort%prt, ipft, sapw_organ, & store_c_transfer_frac*currentCohort%sapwmemory/totalmemory) - call PRTPhenologyFlush(currentCohort%prt, ipft, struct_organ, & + call PRTPhenologyFlush(currentCohort%prt, ipft, struct_organ, & store_c_transfer_frac*currentCohort%structmemory/totalmemory) - else + else call PRTPhenologyFlush(currentCohort%prt, ipft, leaf_organ, & - store_c_transfer_frac) + store_c_transfer_frac) end if @@ -1177,17 +1175,17 @@ subroutine phenology_leafonoff(currentSite) endif endif !pft phenology - endif ! growing season + endif ! growing season !COLD LEAF OFF if (currentSite%cstatus == phen_cstat_nevercold .or. & - currentSite%cstatus == phen_cstat_iscold) then ! past leaf drop day? Leaves still on tree? + currentSite%cstatus == phen_cstat_iscold) then ! past leaf drop day? Leaves still on tree? if (currentCohort%status_coh == leaves_on) then ! leaves have not dropped ! leaf off occur on individuals bigger than specific size for grass if (currentCohort%dbh > EDPftvarcon_inst%phen_cold_size_threshold(ipft) & - .or. prt_params%woody(ipft)==itrue) then + .or. prt_params%woody(ipft)==itrue) then ! This sets the cohort to the "leaves off" flag currentCohort%status_coh = leaves_off @@ -1208,7 +1206,7 @@ subroutine phenology_leafonoff(currentSite) currentCohort%sapwmemory = sapw_c * stem_drop_fraction - currentCohort%structmemory = struct_c * stem_drop_fraction + currentCohort%structmemory = struct_c * stem_drop_fraction call PRTDeciduousTurnover(currentCohort%prt,ipft, & sapw_organ, stem_drop_fraction) @@ -1229,24 +1227,24 @@ subroutine phenology_leafonoff(currentSite) if (prt_params%stress_decid(ipft) == itrue )then if (currentSite%dstatus == phen_dstat_moiston .or. & - currentSite%dstatus == phen_dstat_timeon )then + currentSite%dstatus == phen_dstat_timeon )then - ! we have just moved to leaves being on . - if (currentCohort%status_coh == leaves_off)then + ! we have just moved to leaves being on . + if (currentCohort%status_coh == leaves_off)then - !is it the leaf-on day? Are the leaves currently off? + !is it the leaf-on day? Are the leaves currently off? - currentCohort%status_coh = leaves_on ! Leaves are on, so change status to - ! stop flow of carbon out of bstore. + currentCohort%status_coh = leaves_on ! Leaves are on, so change status to + ! stop flow of carbon out of bstore. if(store_c>nearzero) then - store_c_transfer_frac = & + store_c_transfer_frac = & min((EDPftvarcon_inst%phenflush_fraction(ipft)*currentCohort%laimemory)/store_c, & (1.0_r8-carbon_store_buffer)) if(prt_params%woody(ipft).ne.itrue)then - + totalmemory=currentCohort%laimemory+currentCohort%sapwmemory+currentCohort%structmemory store_c_transfer_frac = min(EDPftvarcon_inst%phenflush_fraction(ipft)*totalmemory/store_c, & (1.0_r8-carbon_store_buffer)) @@ -1257,7 +1255,7 @@ subroutine phenology_leafonoff(currentSite) store_c_transfer_frac = 0.0_r8 endif - ! This call will request that storage carbon will be transferred to + ! This call will request that storage carbon will be transferred to ! leaf tissues. It is specified as a fraction of the available storage if(prt_params%woody(ipft) == itrue) then @@ -1272,18 +1270,18 @@ subroutine phenology_leafonoff(currentSite) if (stem_drop_fraction .gt. 0.0_r8) then call PRTPhenologyFlush(currentCohort%prt, ipft, leaf_organ, & - store_c_transfer_frac*currentCohort%laimemory/totalmemory) + store_c_transfer_frac*currentCohort%laimemory/totalmemory) call PRTPhenologyFlush(currentCohort%prt, ipft, sapw_organ, & store_c_transfer_frac*currentCohort%sapwmemory/totalmemory) - call PRTPhenologyFlush(currentCohort%prt, ipft, struct_organ, & + call PRTPhenologyFlush(currentCohort%prt, ipft, struct_organ, & store_c_transfer_frac*currentCohort%structmemory/totalmemory) else call PRTPhenologyFlush(currentCohort%prt, ipft, leaf_organ, & - store_c_transfer_frac) + store_c_transfer_frac) end if @@ -1297,7 +1295,7 @@ subroutine phenology_leafonoff(currentSite) !DROUGHT LEAF OFF if (currentSite%dstatus == phen_dstat_moistoff .or. & - currentSite%dstatus == phen_dstat_timeoff) then + currentSite%dstatus == phen_dstat_timeoff) then if (currentCohort%status_coh == leaves_on) then ! leaves have not dropped @@ -1313,7 +1311,7 @@ subroutine phenology_leafonoff(currentSite) if(prt_params%woody(ipft).ne.itrue)then currentCohort%sapwmemory = sapw_c * stem_drop_fraction - currentCohort%structmemory = struct_c * stem_drop_fraction + currentCohort%structmemory = struct_c * stem_drop_fraction call PRTDeciduousTurnover(currentCohort%prt,ipft, & sapw_organ, stem_drop_fraction) @@ -1342,21 +1340,21 @@ end subroutine phenology_leafonoff subroutine satellite_phenology(currentSite, bc_in) ! ----------------------------------------------------------------------------------- - ! Takes the daily inputs of leaf area index, stem area index and canopy height and + ! Takes the daily inputs of leaf area index, stem area index and canopy height and ! translates them into a FATES structure with one patch and one cohort per PFT - ! The leaf area of the cohort is modified each day to match that asserted by the HLM + ! The leaf area of the cohort is modified each day to match that asserted by the HLM ! ----------------------------------------------------------------------------------- - ! !USES: - ! - ! !ARGUMENTS: + ! !USES: + ! + ! !ARGUMENTS: type(ed_site_type), intent(inout), target :: currentSite type(bc_in_type), intent(in) :: bc_in class(prt_vartypes), pointer :: prt - ! !LOCAL VARIABLES: - type(ed_patch_type) , pointer :: currentPatch + ! !LOCAL VARIABLES: + type(ed_patch_type) , pointer :: currentPatch type(ed_cohort_type), pointer :: currentCohort real(r8) :: spread ! dummy value of canopy spread to estimate c_area @@ -1368,9 +1366,9 @@ subroutine satellite_phenology(currentSite, bc_in) ! To Do in this routine. - ! Get access to HLM input varialbes. + ! Get access to HLM input varialbes. ! Weight them by PFT - ! Loop around patches, and for each single cohort in each patch + ! Loop around patches, and for each single cohort in each patch ! call assign_cohort_SP_properties to determine cohort height, dbh, 'n', area, leafc from drivers. currentSite%sp_tlai(:) = 0._r8 @@ -1378,18 +1376,18 @@ subroutine satellite_phenology(currentSite, bc_in) currentSite%sp_htop(:) = 0._r8 ! WEIGHTING OF FATES PFTs on to HLM_PFTs - ! 1. Add up the area associated with each FATES PFT + ! 1. Add up the area associated with each FATES PFT ! where pft_areafrac is the area of land in each HLM PFT and (from surface dataset) ! hlm_pft_map is the area of that land in each FATES PFT (from param file) - ! 2. weight each fates PFT target for lai, sai and htop by the area of the + ! 2. weight each fates PFT target for lai, sai and htop by the area of the ! contrbuting HLM PFTs. currentPatch => currentSite%oldest_patch do while (associated(currentPatch)) fates_pft = currentPatch%nocomp_pft_label - if(fates_pft.ne.0)then + if(fates_pft.ne.0)then do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) @@ -1397,10 +1395,10 @@ subroutine satellite_phenology(currentSite, bc_in) !leaf area index currentSite%sp_tlai(fates_pft) = currentSite%sp_tlai(fates_pft) + & bc_in%hlm_sp_tlai(hlm_pft) * bc_in%pft_areafrac(hlm_pft) & - * EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft) + * EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft) !stem area index currentSite%sp_tsai(fates_pft) = currentSite%sp_tsai(fates_pft) + & - bc_in%hlm_sp_tsai(hlm_pft) * bc_in%pft_areafrac(hlm_pft) & + bc_in%hlm_sp_tsai(hlm_pft) * bc_in%pft_areafrac(hlm_pft) & * EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft) ! canopy height currentSite%sp_htop(fates_pft) = currentSite%sp_htop(fates_pft) + & @@ -1411,7 +1409,7 @@ subroutine satellite_phenology(currentSite, bc_in) ! weight for total area in each patch/fates_pft ! this is needed because the area of pft_areafrac does not need to sum to 1.0 - if(currentPatch%area.gt.0.0_r8)then + if(currentPatch%area.gt.0.0_r8)then currentSite%sp_tlai(fates_pft) = currentSite%sp_tlai(fates_pft) & /(currentPatch%area/area) currentSite%sp_tsai(fates_pft) = currentSite%sp_tsai(fates_pft) & @@ -1422,16 +1420,16 @@ subroutine satellite_phenology(currentSite, bc_in) end if ! not bare patch currentPatch => currentPatch%younger - end do ! patch loop + end do ! patch loop ! ------------------------------------------------------------ ! now we have the target lai, sai and htop for each PFT/patch ! find properties of the cohort that go along with that ! 1. Find canopy area from HTOP (height) ! 2. Find 'n' associated with canopy area, given a closed canopy - ! 3. Find 'bleaf' associated with TLAI and canopy area. + ! 3. Find 'bleaf' associated with TLAI and canopy area. ! These things happen in the catchily titled "assign_cohort_SP_properties" routine. - ! ------------------------------------------------------------ + ! ------------------------------------------------------------ currentPatch => currentSite%oldest_patch do while (associated(currentPatch)) @@ -1439,7 +1437,7 @@ subroutine satellite_phenology(currentSite, bc_in) currentCohort => currentPatch%tallest do while (associated(currentCohort)) - ! FIRST SOME CHECKS. + ! FIRST SOME CHECKS. fates_pft =currentCohort%pft if(fates_pft.ne.currentPatch%nocomp_pft_label)then ! does this cohort belong in this PFT patch? write(fates_log(),*) 'wrong PFT label in cohort in SP mode',fates_pft,currentPatch%nocomp_pft_label @@ -1451,7 +1449,7 @@ subroutine satellite_phenology(currentSite, bc_in) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - ! Call routine to invert SP drivers into cohort properites. + ! Call routine to invert SP drivers into cohort properites. call assign_cohort_SP_properties(currentCohort, currentSite%sp_htop(fates_pft), currentSite%sp_tlai(fates_pft) , currentSite%sp_tsai(fates_pft),currentPatch%area,ifalse,leaf_c) currentCohort => currentCohort%shorter @@ -1481,15 +1479,15 @@ subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,l integer, intent(in) :: init ! are we in the initialization routine? if so do not set leaf_c real(r8), intent(out) :: leaf_c ! leaf carbon estimated to generate target tlai - real(r8) :: dummy_n ! set cohort n to a dummy value of 1.0 + real(r8) :: dummy_n ! set cohort n to a dummy value of 1.0 integer :: fates_pft ! fates pft numer for weighting loop real(r8) :: spread ! dummy value of canopy spread to estimate c_area real(r8) :: check_treelai real(r8) :: canopylai(1:nclmax) real(r8) :: fracerr - real(r8) :: oldcarea + real(r8) :: oldcarea - ! Do some checks + ! Do some checks if(associated(currentCohort%shorter))then write(fates_log(),*) 'SP mode has >1 cohort' write(fates_log(),*) "SP mode >1 cohort: PFT",currentCohort%pft, currentCohort%shorter%pft @@ -1507,8 +1505,8 @@ subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,l dummy_n = 1.0_r8 ! make n=1 to get area of one tree. spread = 1.0_r8 ! fix this to 0 to remove dynamics of canopy closure, assuming a closed canopy. - ! n.b. the value of this will only affect 'n', which isn't/shouldn't be a diagnostic in - ! SP mode. + ! n.b. the value of this will only affect 'n', which isn't/shouldn't be a diagnostic in + ! SP mode. call carea_allom(currentCohort%dbh,dummy_n,spread,currentCohort%pft,currentCohort%c_area) !------------------------------------------ @@ -1527,7 +1525,7 @@ subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,l leaf_c = leafc_from_treelai( currentCohort%treelai, currentCohort%pft, currentCohort%c_area,& currentCohort%n, currentCohort%canopy_layer, currentCohort%vcmax25top) - !check that the inverse calculation of leafc from treelai is the same as the + !check that the inverse calculation of leafc from treelai is the same as the ! standard calculation of treelai from leafc. Maybe can delete eventually? check_treelai = tree_lai(leaf_c, currentCohort%pft, currentCohort%c_area, & @@ -1539,10 +1537,10 @@ subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,l call endrun(msg=errMsg(sourcefile, __LINE__)) end if - ! the carea_allom routine sometimes generates precision-tolerance level errors in the canopy area - ! these mean that the canopy area does not exactly add up to the patch area, which causes chaos in - ! the radiation routines. Correct both the area and the 'n' to remove error, and don't use - !! carea_allom in SP mode after this point. + ! the carea_allom routine sometimes generates precision-tolerance level errors in the canopy area + ! these mean that the canopy area does not exactly add up to the patch area, which causes chaos in + ! the radiation routines. Correct both the area and the 'n' to remove error, and don't use + !! carea_allom in SP mode after this point. if(abs(currentCohort%c_area-parea).gt.nearzero)then ! there is an error if(abs(currentCohort%c_area-parea).lt.10.e-9)then !correct this if it's a very small error @@ -1554,13 +1552,13 @@ subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,l write(fates_log(),*) 'SPassign, c_area still broken',currentCohort%c_area-parea,currentCohort%c_area-oldcarea call endrun(msg=errMsg(sourcefile, __LINE__)) end if - else + else write(fates_log(),*) 'SPassign, big error in c_area',currentCohort%c_area-parea,currentCohort%pft end if ! still broken end if !small error if(init.eq.ifalse)then - call SetState(currentCohort%prt,leaf_organ,1,leaf_c,1) + call SetState(currentCohort%prt,leaf_organ,1,leaf_c,1) endif ! assert sai @@ -1573,13 +1571,13 @@ end subroutine assign_cohort_SP_properties subroutine SeedIn( currentSite, bc_in ) ! ----------------------------------------------------------------------------------- - ! Flux from plants into the seed pool. + ! Flux from plants into the seed pool. ! It is assumed that allocation to seed on living pools has already been calculated ! at the daily time step. ! Note: Some seed generation can occur during disturbance. It is assumed that ! some plants use their storage upon death to create seeds, but this in only - ! triggered during non-fire and non-logging events. See - ! subroutine mortality_litter_fluxes() and DistributeSeeds(), look for + ! triggered during non-fire and non-logging events. See + ! subroutine mortality_litter_fluxes() and DistributeSeeds(), look for ! parameter allom_frbstor_repro ! ----------------------------------------------------------------------------------- @@ -1589,7 +1587,7 @@ subroutine SeedIn( currentSite, bc_in ) use EDTypesMod, only : homogenize_seed_pfts !use FatesInterfaceTypesMod, only : hlm_use_fixed_biogeog ! For future reduced complexity? ! - ! !ARGUMENTS + ! !ARGUMENTS type(ed_site_type), intent(inout), target :: currentSite type(bc_in_type), intent(in) :: bc_in @@ -1666,7 +1664,7 @@ subroutine SeedIn( currentSite, bc_in ) ! Loop over all patches again and disperse the mixed seeds into the input flux - ! arrays + ! arrays ! Loop over all patches and sum up the seed input for each PFT currentPatch => currentSite%oldest_patch @@ -1686,9 +1684,9 @@ subroutine SeedIn( currentSite, bc_in ) case(carbon12_element) seed_stoich = 1._r8 case(nitrogen_element) - seed_stoich = prt_params%nitr_recr_stoich(pft) + seed_stoich = prt_params%nitr_recr_stoich(pft) case(phosphorus_element) - seed_stoich = prt_params%phos_recr_stoich(pft) + seed_stoich = prt_params%phos_recr_stoich(pft) case default write(fates_log(), *) 'undefined element specified' write(fates_log(), *) 'while defining forced external seed mass flux' @@ -1701,7 +1699,7 @@ subroutine SeedIn( currentSite, bc_in ) ! Seeds entering externally [kg/site/day] site_mass%seed_in = site_mass%seed_in + seed_in_external*currentPatch%area - end if !use this pft + end if !use this pft enddo @@ -1718,9 +1716,9 @@ end subroutine SeedIn subroutine SeedDecay( litt ) ! ! !DESCRIPTION: - ! Flux from seed pool into leaf litter pool + ! Flux from seed pool into leaf litter pool ! - ! !ARGUMENTS + ! !ARGUMENTS type(litter_type) :: litt ! ! !LOCAL VARIABLES: @@ -1733,7 +1731,7 @@ subroutine SeedDecay( litt ) ! seed_decay is kg/day ! Assume that decay rates are same for all chemical species - do pft = 1,numpft + do pft = 1,numpft litt%seed_decay(pft) = litt%seed(pft) * & EDPftvarcon_inst%seed_decay_rate(pft)*years_per_day @@ -1749,13 +1747,13 @@ end subroutine SeedDecay subroutine SeedGermination( litt, cold_stat, drought_stat ) ! ! !DESCRIPTION: - ! Flux from seed pool into sapling pool + ! Flux from seed pool into sapling pool ! ! !USES: ! ! !ARGUMENTS - type(litter_type) :: litt + type(litter_type) :: litt integer, intent(in) :: cold_stat ! Is the site in cold leaf-off status? integer, intent(in) :: drought_stat ! Is the site in drought leaf-off status? ! @@ -1763,7 +1761,7 @@ subroutine SeedGermination( litt, cold_stat, drought_stat ) integer :: pft - real(r8), parameter :: max_germination = 1.0_r8 ! Cap on germination rates. + real(r8), parameter :: max_germination = 1.0_r8 ! Cap on germination rates. ! KgC/m2/yr Lishcke et al. 2009 ! Turning of this cap? because the cap will impose changes on proportionality @@ -1773,9 +1771,9 @@ subroutine SeedGermination( litt, cold_stat, drought_stat ) !---------------------------------------------------------------------- ! germination_rate is being pulled to PFT parameter; units are 1/yr - ! thus the mortality rate of seed -> recruit (in units of carbon) + ! thus the mortality rate of seed -> recruit (in units of carbon) ! is seed_decay_rate(p)/germination_rate(p) - ! and thus the mortality rate (in units of individuals) is the product of + ! and thus the mortality rate (in units of individuals) is the product of ! that times the ratio of (hypothetical) seed mass to recruit biomass do pft = 1,numpft @@ -1809,12 +1807,12 @@ end subroutine SeedGermination subroutine recruitment( currentSite, currentPatch, bc_in ) ! ! !DESCRIPTION: - ! spawn new cohorts of juveniles of each PFT + ! spawn new cohorts of juveniles of each PFT ! ! !USES: use FatesInterfaceTypesMod, only : hlm_use_ed_prescribed_phys ! - ! !ARGUMENTS + ! !ARGUMENTS type(ed_site_type), intent(inout), target :: currentSite type(ed_patch_type), intent(inout), pointer :: currentPatch type(bc_in_type), intent(in) :: bc_in @@ -1849,7 +1847,7 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) real(r8) :: mass_avail ! The mass of each nutrient/carbon available in the seed_germination pool [kg] real(r8) :: mass_demand ! Total mass demanded by the plant to achieve the stoichiometric targets ! of all the organs in the recruits. Used for both [kg per plant] and [kg per cohort] - real(r8) :: stem_drop_fraction + real(r8) :: stem_drop_fraction !---------------------------------------------------------------------- @@ -1878,9 +1876,9 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) ! Default assumption is that leaves are on cohortstatus = leaves_on - temp_cohort%laimemory = 0.0_r8 - temp_cohort%sapwmemory = 0.0_r8 - temp_cohort%structmemory = 0.0_r8 + temp_cohort%laimemory = 0.0_r8 + temp_cohort%sapwmemory = 0.0_r8 + temp_cohort%structmemory = 0.0_r8 ! But if the plant is seasonally (cold) deciduous, and the site status is flagged @@ -1894,13 +1892,13 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) if (prt_params%woody(ft).ne.itrue) then temp_cohort%sapwmemory = c_sapw * stem_drop_fraction temp_cohort%structmemory = c_struct * stem_drop_fraction - c_sapw = (1.0_r8 - stem_drop_fraction) * c_sapw + c_sapw = (1.0_r8 - stem_drop_fraction) * c_sapw c_struct = (1.0_r8 - stem_drop_fraction) * c_struct endif cohortstatus = leaves_off endif - ! Or.. if the plant is drought deciduous, and the site status is flagged as + ! Or.. if the plant is drought deciduous, and the site status is flagged as ! "in a drought", then likewise, set the cohort's status to leaves_off, and remember leaf ! biomass if ((prt_params%stress_decid(ft) == itrue) .and. & @@ -1912,7 +1910,7 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) if(prt_params%woody(ft).ne.itrue)then temp_cohort%sapwmemory = c_sapw * stem_drop_fraction temp_cohort%structmemory = c_struct * stem_drop_fraction - c_sapw = (1.0_r8 - stem_drop_fraction) * c_sapw + c_sapw = (1.0_r8 - stem_drop_fraction) * c_sapw c_struct = (1.0_r8 - stem_drop_fraction) * c_struct endif cohortstatus = leaves_off @@ -1940,7 +1938,7 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) mass_demand = & c_struct*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(struct_organ)) + & c_leaf*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(leaf_organ)) + & - c_fnrt*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(fnrt_organ)) + & + c_fnrt*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(fnrt_organ)) + & c_sapw*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(sapw_organ)) + & StorageNutrientTarget(ft, element_id, & c_leaf*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(leaf_organ)), & @@ -1953,7 +1951,7 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) mass_demand = & c_struct*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(struct_organ)) + & c_leaf*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(leaf_organ)) + & - c_fnrt*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(fnrt_organ)) + & + c_fnrt*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(fnrt_organ)) + & c_sapw*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(sapw_organ)) + & StorageNutrientTarget(ft, element_id, & c_leaf*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(leaf_organ)), & @@ -1972,7 +1970,7 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) ! Update number density if this is the limiting mass ! ------------------------------------------------------------------------ - temp_cohort%n = min(temp_cohort%n, mass_avail/mass_demand) + temp_cohort%n = min(temp_cohort%n, mass_avail/mass_demand) end do @@ -2054,7 +2052,7 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) site_mass => currentSite%mass_balance(el) ! Remove mass from the germination pool. However, if we are use prescribed physiology, - ! AND the forced recruitment model, then we are not realling using the prognostic + ! AND the forced recruitment model, then we are not realling using the prognostic ! seed_germination model, so we have to short circuit things. We send all of the ! seed germination mass to an outflux pool, and use an arbitrary generic input flux ! to balance out the new recruits. @@ -2073,8 +2071,8 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) else - currentPatch%litter(el)%seed_germ(ft) = currentPatch%litter(el)%seed_germ(ft) - & - temp_cohort%n / currentPatch%area * & + currentPatch%litter(el)%seed_germ(ft) = currentPatch%litter(el)%seed_germ(ft) - & + temp_cohort%n / currentPatch%area * & (m_struct + m_leaf + m_fnrt + m_sapw + m_store + m_repro) end if @@ -2089,8 +2087,8 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) call prt%CheckInitialConditions() ! This initializes the cohort - call create_cohort(currentSite,currentPatch, temp_cohort%pft, temp_cohort%n, & - temp_cohort%hite, temp_cohort%coage, temp_cohort%dbh, prt, & + call create_cohort(currentSite,currentPatch, temp_cohort%pft, temp_cohort%n, & + temp_cohort%hite, temp_cohort%coage, temp_cohort%dbh, prt, & temp_cohort%laimemory, temp_cohort%sapwmemory, temp_cohort%structmemory, & cohortstatus, recruitstatus, & temp_cohort%canopy_trim,temp_cohort%c_area, & @@ -2128,7 +2126,7 @@ subroutine CWDInput( currentSite, currentPatch, litt, bc_in) use SFParamsMod , only : SF_val_CWD_frac ! - ! !ARGUMENTS + ! !ARGUMENTS type(ed_site_type), intent(inout), target :: currentSite type(ed_patch_type),intent(inout), target :: currentPatch type(litter_type),intent(inout),target :: litt @@ -2145,7 +2143,7 @@ subroutine CWDInput( currentSite, currentPatch, litt, bc_in) real(r8) :: dead_n_ilogging ! indirect understory dead-tree density (logging) real(r8) :: dead_n_natural ! understory dead density not associated ! with direct logging - real(r8) :: leaf_m ! mass of the element of interest in the + real(r8) :: leaf_m ! mass of the element of interest in the ! leaf [kg] real(r8) :: fnrt_m ! fine-root [kg] real(r8) :: sapw_m ! sapwood [kg] @@ -2174,7 +2172,7 @@ subroutine CWDInput( currentSite, currentPatch, litt, bc_in) !---------------------------------------------------------------------- ! ----------------------------------------------------------------------------------- - ! Other direct litter fluxes happen in phenology and in spawn_patches. + ! Other direct litter fluxes happen in phenology and in spawn_patches. ! ----------------------------------------------------------------------------------- numlevsoil = currentSite%nlevsoil @@ -2189,7 +2187,7 @@ subroutine CWDInput( currentSite, currentPatch, litt, bc_in) currentCohort => currentPatch%shortest do while(associated(currentCohort)) - pft = currentCohort%pft + pft = currentCohort%pft call set_root_fraction(currentSite%rootfrac_scr, pft, currentSite%zi_soil, & bc_in%max_rooting_depth_index_col) @@ -2214,7 +2212,7 @@ subroutine CWDInput( currentSite, currentPatch, litt, bc_in) ! PART 1 Litter fluxes from non-mortal tissue turnovers Kg/m2/day ! Important note: Turnover has already been removed from the cohorts. ! So, in the next part of this algorithm, when we send the biomass - ! from dying trees to the litter pools, we don't have to worry + ! from dying trees to the litter pools, we don't have to worry ! about double counting. ! --------------------------------------------------------------------------------- @@ -2255,7 +2253,7 @@ subroutine CWDInput( currentSite, currentPatch, litt, bc_in) prt_params%allom_agb_frac(pft) * currentCohort%n bg_cwd_tot = (sapw_m_turnover + struct_m_turnover) * & - SF_val_CWD_frac(c) * plant_dens * & + SF_val_CWD_frac(c) * plant_dens * & (1.0_r8-prt_params%allom_agb_frac(pft)) do ilyr = 1, numlevsoil @@ -2276,7 +2274,7 @@ subroutine CWDInput( currentSite, currentPatch, litt, bc_in) ! Total number of dead (n/m2/day) dead_n = -1.0_r8 * currentCohort%dndt/currentPatch%area*years_per_day - if(currentCohort%canopy_layer > 1)then + if(currentCohort%canopy_layer > 1)then ! Total number of dead understory from direct logging ! (it is possible that large harvestable trees are in the understory) @@ -2333,9 +2331,9 @@ subroutine CWDInput( currentSite, currentPatch, litt, bc_in) do c = 1,ncwd - ! Below-ground + ! Below-ground - bg_cwd_tot = (struct_m + sapw_m) * & + bg_cwd_tot = (struct_m + sapw_m) * & SF_val_CWD_frac(c) * dead_n * & (1.0_r8-prt_params%allom_agb_frac(pft)) @@ -2356,12 +2354,12 @@ subroutine CWDInput( currentSite, currentPatch, litt, bc_in) trunk_wood = (struct_m + sapw_m) * & SF_val_CWD_frac(c) * dead_n_dlogging * & - prt_params%allom_agb_frac(pft) + prt_params%allom_agb_frac(pft) site_mass%wood_product = site_mass%wood_product + & trunk_wood * currentPatch%area * logging_export_frac - ! Add AG wood to litter from the non-exported fraction of wood + ! Add AG wood to litter from the non-exported fraction of wood ! from direct anthro sources litt%ag_cwd_in(c) = litt%ag_cwd_in(c) + & @@ -2372,7 +2370,7 @@ subroutine CWDInput( currentSite, currentPatch, litt, bc_in) ! Add AG wood to litter from indirect anthro sources - litt%ag_cwd_in(c) = litt%ag_cwd_in(c) + (struct_m + sapw_m) * & + litt%ag_cwd_in(c) = litt%ag_cwd_in(c) + (struct_m + sapw_m) * & SF_val_CWD_frac(c) * (dead_n_natural+dead_n_ilogging) * & prt_params%allom_agb_frac(pft) @@ -2382,7 +2380,7 @@ subroutine CWDInput( currentSite, currentPatch, litt, bc_in) else - litt%ag_cwd_in(c) = litt%ag_cwd_in(c) + (struct_m + sapw_m) * & + litt%ag_cwd_in(c) = litt%ag_cwd_in(c) + (struct_m + sapw_m) * & SF_val_CWD_frac(c) * dead_n * & prt_params%allom_agb_frac(pft) @@ -2406,7 +2404,7 @@ subroutine CWDInput( currentSite, currentPatch, litt, bc_in) currentSite%resources_management%delta_biomass_stock = & currentSite%resources_management%delta_biomass_stock + & - (leaf_m + fnrt_m + store_m ) * & + (leaf_m + fnrt_m + store_m ) * & (dead_n_ilogging+dead_n_dlogging) *currentPatch%area currentSite%resources_management%trunk_product_site = & @@ -2417,7 +2415,7 @@ subroutine CWDInput( currentSite, currentPatch, litt, bc_in) currentSite%resources_management%delta_litter_stock = & currentSite%resources_management%delta_litter_stock + & (struct_m + sapw_m) * & - SF_val_CWD_frac(c) * (dead_n_natural+dead_n_ilogging) * & + SF_val_CWD_frac(c) * (dead_n_natural+dead_n_ilogging) * & currentPatch%area currentSite%resources_management%delta_biomass_stock = & @@ -2434,7 +2432,7 @@ subroutine CWDInput( currentSite, currentPatch, litt, bc_in) currentCohort => currentCohort%taller - enddo ! end loop over cohorts + enddo ! end loop over cohorts return @@ -2443,11 +2441,11 @@ end subroutine CWDInput ! ===================================================================================== - subroutine fragmentation_scaler( currentPatch, bc_in) + subroutine fragmentation_scaler( currentPatch, bc_in) ! ! !DESCRIPTION: ! Simple CWD fragmentation Model - ! FIX(SPM, 091914) this should be a function as it returns a value in + ! FIX(SPM, 091914) this should be a function as it returns a value in ! currentPatch%fragmentation_scaler ! ! !USES: @@ -2456,7 +2454,7 @@ subroutine fragmentation_scaler( currentPatch, bc_in) use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm use FatesConstantsMod, only : pi => pi_const ! - ! !ARGUMENTS + ! !ARGUMENTS type(ed_patch_type), intent(inout) :: currentPatch type(bc_in_type), intent(in) :: bc_in @@ -2476,19 +2474,19 @@ subroutine fragmentation_scaler( currentPatch, bc_in) catanf(t1) = 11.75_r8 +(29.7_r8 / pi) * atan( pi * 0.031_r8 * ( t1 - 15.4_r8 )) catanf_30 = catanf(30._r8) - ifp = currentPatch%patchno + ifp = currentPatch%patchno if(currentPatch%nocomp_pft_label.ne.0)then ! Use the hlm temp and moisture decomp fractions by default if ( use_hlm_soil_scalar ) then - + ! Calculate the fragmentation_scaler currentPatch%fragmentation_scaler = min(1.0_r8,max(0.0_r8,bc_in%t_scalar_sisl * bc_in%w_scalar_sisl)) else - + if ( .not. use_century_tfunc ) then - !calculate rate constant scalar for soil temperature,assuming that the base rate constants + !calculate rate constant scalar for soil temperature,assuming that the base rate constants !are assigned for non-moisture limiting conditions at 25C. if (bc_in%t_veg24_pa(ifp) >= tfrz) then t_scalar = q10_mr**((bc_in%t_veg24_pa(ifp)-(tfrz+25._r8))/10._r8) @@ -2498,23 +2496,23 @@ subroutine fragmentation_scaler( currentPatch, bc_in) !Q10**(-25._r8/10._r8))*(froz_q10**((t_soisno(c,j)-tfrz)/10._r8) endif else - ! original century uses an arctangent function to calculate the - ! temperature dependence of decomposition + ! original century uses an arctangent function to calculate the + ! temperature dependence of decomposition t_scalar = max(catanf(bc_in%t_veg24_pa(ifp)-tfrz)/catanf_30,0.01_r8) - endif - - !Moisture Limitations - !BTRAN APPROACH - is quite simple, but max's out decomp at all unstressed - !soil moisture values, which is not realistic. - !litter decomp is proportional to water limitation on average... + endif + + !Moisture Limitations + !BTRAN APPROACH - is quite simple, but max's out decomp at all unstressed + !soil moisture values, which is not realistic. + !litter decomp is proportional to water limitation on average... w_scalar = sum(currentPatch%btran_ft(1:numpft))/real(numpft,r8) ! Calculate the fragmentation_scaler currentPatch%fragmentation_scaler(:) = min(1.0_r8,max(0.0_r8,t_scalar * w_scalar)) endif ! scalar - - endif ! not bare ground + + endif ! not bare ground end subroutine fragmentation_scaler @@ -2524,20 +2522,20 @@ subroutine CWDOut( litt, fragmentation_scaler, nlev_eff_decomp ) ! ! !DESCRIPTION: ! Simple CWD fragmentation Model - ! spawn new cohorts of juveniles of each PFT + ! spawn new cohorts of juveniles of each PFT ! ! !USES: use SFParamsMod, only : SF_val_max_decomp ! - ! !ARGUMENTS + ! !ARGUMENTS type(litter_type),intent(inout),target :: litt real(r8),intent(in) :: fragmentation_scaler(:) ! This is not necessarily every soil layer, this is the number ! of effective layers that are active and can be sent ! to the soil decomposition model - integer,intent(in) :: nlev_eff_decomp + integer,intent(in) :: nlev_eff_decomp ! ! !LOCAL VARIABLES: @@ -2552,27 +2550,27 @@ subroutine CWDOut( litt, fragmentation_scaler, nlev_eff_decomp ) ! moisture scalars and fragmentation scalar associated with specified index value ! is used for ag_cwd_frag and root_fines_frag calculations. - do c = 1,ncwd + do c = 1,ncwd litt%ag_cwd_frag(c) = litt%ag_cwd(c) * SF_val_max_decomp(c) * & years_per_day * fragmentation_scaler(soil_layer_index) - + do ilyr = 1,nlev_eff_decomp litt%bg_cwd_frag(c,ilyr) = litt%bg_cwd(c,ilyr) * SF_val_max_decomp(c) * & years_per_day * fragmentation_scaler(ilyr) enddo end do - ! this is the rate at which dropped leaves stop being part of the burnable pool - ! and begin to be part of the decomposing pool. This should probably be highly - ! sensitive to moisture, but also to the type of leaf thick leaves can dry out - ! before they are decomposed, for example. This section needs further scientific input. + ! this is the rate at which dropped leaves stop being part of the burnable pool + ! and begin to be part of the decomposing pool. This should probably be highly + ! sensitive to moisture, but also to the type of leaf thick leaves can dry out + ! before they are decomposed, for example. This section needs further scientific input. do dcmpy = 1,ndcmpy litt%leaf_fines_frag(dcmpy) = litt%leaf_fines(dcmpy) * & years_per_day * SF_val_max_decomp(dl_sf) * fragmentation_scaler(soil_layer_index) - + do ilyr = 1,nlev_eff_decomp litt%root_fines_frag(dcmpy,ilyr) = litt%root_fines(dcmpy,ilyr) * & years_per_day * SF_val_max_decomp(dl_sf) * fragmentation_scaler(ilyr) From d94ca1a3670ca65b0b689f4dda192c381be515e4 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 12 Aug 2021 15:11:11 -0700 Subject: [PATCH 190/209] removing more diagnostics --- biogeochem/EDCohortDynamicsMod.F90 | 633 ++++++++++++++--------------- biogeochem/EDPhysiologyMod.F90 | 3 - 2 files changed, 315 insertions(+), 321 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 474e7573e8..2fa98aa59f 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -1,9 +1,9 @@ module EDCohortDynamicsMod ! ! !DESCRIPTION: - ! Cohort stuctures in ED. + ! Cohort stuctures in ED. ! - ! !USES: + ! !USES: use FatesGlobals , only : endrun => fates_endrun use FatesGlobals , only : fates_log use FatesInterfaceTypesMod , only : hlm_freq_day @@ -67,7 +67,7 @@ module EDCohortDynamicsMod use FatesAllometryMod , only : ForceDBH use FatesAllometryMod , only : tree_lai, tree_sai use FatesAllometryMod , only : set_root_fraction - use PRTGenericMod, only : prt_carbon_allom_hyp + use PRTGenericMod, only : prt_carbon_allom_hyp use PRTGenericMod, only : prt_cnp_flex_allom_hyp use PRTGenericMod, only : prt_vartypes use PRTGenericMod, only : all_carbon_elements @@ -97,9 +97,9 @@ module EDCohortDynamicsMod use PRTAllometricCNPMod, only : acnp_bc_out_id_pefflux use PRTAllometricCNPMod, only : acnp_bc_out_id_nneed use PRTAllometricCNPMod, only : acnp_bc_out_id_pneed - - - use shr_infnan_mod, only : nan => shr_infnan_nan, assignment(=) + + + use shr_infnan_mod, only : nan => shr_infnan_nan, assignment(=) ! CIME globals use shr_log_mod , only : errMsg => shr_log_errMsg @@ -133,7 +133,7 @@ module EDCohortDynamicsMod integer, parameter, private :: conserve_dbh_and_number_not_crownarea = 2 integer, parameter, private :: cohort_fusion_conservation_method = conserve_crownarea_and_number_not_dbh - + ! 10/30/09: Created by Rosie Fisher !-------------------------------------------------------------------------------------! @@ -142,7 +142,7 @@ module EDCohortDynamicsMod !-------------------------------------------------------------------------------------! - + subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & prt, laimemory, sapwmemory, structmemory, & status, recruitstatus,ctrim, carea, clayer, spread, bc_in) @@ -159,58 +159,58 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & ! ! !USES: ! - ! !ARGUMENTS + ! !ARGUMENTS type(ed_site_type), intent(inout), target :: currentSite type(ed_patch_type), intent(inout), pointer :: patchptr integer, intent(in) :: pft ! Cohort Plant Functional Type - integer, intent(in) :: clayer ! canopy status of cohort + integer, intent(in) :: clayer ! canopy status of cohort ! (1 = canopy, 2 = understorey, etc.) - integer, intent(in) :: status ! growth status of plant + integer, intent(in) :: status ! growth status of plant ! (2 = leaves on , 1 = leaves off) - integer, intent(in) :: recruitstatus ! recruit status of plant + integer, intent(in) :: recruitstatus ! recruit status of plant ! (1 = recruitment , 0 = other) - real(r8), intent(in) :: nn ! number of individuals in cohort + real(r8), intent(in) :: nn ! number of individuals in cohort ! per 'area' (10000m2 default) real(r8), intent(in) :: hite ! height: meters real(r8), intent(in) :: coage ! cohort age in years real(r8), intent(in) :: dbh ! dbh: cm class(prt_vartypes),target :: prt ! The allocated PARTEH ! object - real(r8), intent(in) :: laimemory ! target leaf biomass- set from + real(r8), intent(in) :: laimemory ! target leaf biomass- set from ! previous year: kGC per indiv - real(r8), intent(in) :: sapwmemory ! target sapwood biomass- set from - ! previous year: kGC per indiv - real(r8), intent(in) :: structmemory ! target structural biomass- set from - ! previous year: kGC per indiv - real(r8), intent(in) :: ctrim ! What is the fraction of the maximum + real(r8), intent(in) :: sapwmemory ! target sapwood biomass- set from + ! previous year: kGC per indiv + real(r8), intent(in) :: structmemory ! target structural biomass- set from + ! previous year: kGC per indiv + real(r8), intent(in) :: ctrim ! What is the fraction of the maximum ! leaf biomass that we are targeting? - real(r8), intent(in) :: spread ! The community assembly effects how + real(r8), intent(in) :: spread ! The community assembly effects how ! spread crowns are in horizontal space real(r8), intent(in) :: carea ! area of cohort ONLY USED IN SP MODE. type(bc_in_type), intent(in) :: bc_in ! External boundary conditions - + ! !LOCAL VARIABLES: type(ed_cohort_type), pointer :: new_cohort ! Pointer to New Cohort structure. - type(ed_cohort_type), pointer :: storesmallcohort - type(ed_cohort_type), pointer :: storebigcohort - integer :: iage ! loop counter for leaf age classes + type(ed_cohort_type), pointer :: storesmallcohort + type(ed_cohort_type), pointer :: storebigcohort + integer :: iage ! loop counter for leaf age classes real(r8) :: leaf_c ! total leaf carbon integer :: tnull,snull ! are the tallest and shortest cohorts allocate integer :: nlevrhiz ! number of rhizosphere layers !---------------------------------------------------------------------- - + allocate(new_cohort) call nan_cohort(new_cohort) ! Make everything in the cohort not-a-number - call zero_cohort(new_cohort) ! Zero things that need to be zeroed. + call zero_cohort(new_cohort) ! Zero things that need to be zeroed. ! Point to the PARTEH object new_cohort%prt => prt - + ! The PARTEH cohort object should be allocated and already ! initialized in this routine. call new_cohort%prt%CheckInitialConditions() @@ -225,7 +225,7 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & new_cohort%patchptr => patchptr - new_cohort%pft = pft + new_cohort%pft = pft new_cohort%status_coh = status new_cohort%n = nn new_cohort%hite = hite @@ -251,12 +251,12 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & ! we don't need to update this ever if cohort age tracking is off call coagetype_class_index(new_cohort%coage, new_cohort%pft, & new_cohort%coage_class,new_cohort%coage_by_pft_class) - + ! This routine may be called during restarts, and at this point in the call sequence ! the actual cohort data is unknown, as this is really only used for allocation ! In these cases, testing if things like biomass are reasonable is pre-mature ! However, in this part of the code, we will pass in nominal values for size, number and type - + if (new_cohort%dbh <= 0._r8 .or. new_cohort%n == 0._r8 .or. new_cohort%pft == 0 ) then write(fates_log(),*) 'ED: something is zero in create_cohort', & new_cohort%dbh,new_cohort%n, & @@ -276,14 +276,12 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & new_cohort%treelai = tree_lai(leaf_c, new_cohort%pft, new_cohort%c_area, & new_cohort%n, new_cohort%canopy_layer, & - patchptr%canopy_layer_tlai,new_cohort%vcmax25top ) - - write(fates_log(),*) 'create_cohort: calling tree_sai' + patchptr%canopy_layer_tlai,new_cohort%vcmax25top ) if(hlm_use_sp.eq.ifalse)then new_cohort%treesai = tree_sai(new_cohort%pft, new_cohort%dbh, new_cohort%canopy_trim, & new_cohort%c_area, new_cohort%n, new_cohort%canopy_layer, & - patchptr%canopy_layer_tlai, new_cohort%treelai,new_cohort%vcmax25top,2 ) + patchptr%canopy_layer_tlai, new_cohort%treelai,new_cohort%vcmax25top,2 ) end if new_cohort%lai = new_cohort%treelai * new_cohort%c_area/patchptr%area @@ -291,7 +289,7 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & ! Put cohort at the right place in the linked list storebigcohort => patchptr%tallest - storesmallcohort => patchptr%shortest + storesmallcohort => patchptr%shortest if (associated(patchptr%tallest)) then tnull = 0 @@ -304,17 +302,17 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & snull = 0 else snull = 1 - patchptr%shortest => new_cohort + patchptr%shortest => new_cohort endif call InitPRTBoundaryConditions(new_cohort) - + ! Recuits do not have mortality rates, nor have they moved any ! carbon when they are created. They will bias our statistics ! until they have experienced a full day. We need a newly recruited flag. - ! This flag will be set to false after it has experienced + ! This flag will be set to false after it has experienced ! growth, disturbance and mortality. new_cohort%isnew = .true. @@ -331,14 +329,14 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & ! This calculates volumes and lengths call UpdatePlantHydrLenVol(new_cohort,currentSite%si_hydr) - + ! This updates the Kmax's of the plant's compartments call UpdatePlantKmax(new_cohort%co_hydr,new_cohort,currentSite%si_hydr) ! Since this is a newly initialized plant, we set the previous compartment-size ! equal to the ones we just calculated. call SavePreviousCompartmentVolumes(new_cohort%co_hydr) - + ! This comes up with starter suctions and then water contents ! based on the soil values call InitPlantHydStates(currentSite,new_cohort) @@ -358,11 +356,11 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & endif endif - + call insert_cohort(new_cohort, patchptr%tallest, patchptr%shortest, tnull, snull, & storebigcohort, storesmallcohort) - patchptr%tallest => storebigcohort + patchptr%tallest => storebigcohort patchptr%shortest => storesmallcohort end subroutine create_cohort @@ -370,7 +368,7 @@ end subroutine create_cohort ! ------------------------------------------------------------------------------------- subroutine InitPRTBoundaryConditions(new_cohort) - + ! Set the boundary conditions that flow in an out of the PARTEH ! allocation hypotheses. Each of these calls to "RegsterBC" are simply ! setting pointers. @@ -394,9 +392,9 @@ subroutine InitPRTBoundaryConditions(new_cohort) select case(hlm_parteh_mode) case (prt_carbon_allom_hyp) - + ! Register boundary conditions for the Carbon Only Allometric Hypothesis - + call new_cohort%prt%RegisterBCInOut(ac_bc_inout_id_dbh,bc_rval = new_cohort%dbh) call new_cohort%prt%RegisterBCInOut(ac_bc_inout_id_netdc,bc_rval = new_cohort%npp_acc) call new_cohort%prt%RegisterBCIn(ac_bc_in_id_pft,bc_ival = new_cohort%pft) @@ -412,7 +410,7 @@ subroutine InitPRTBoundaryConditions(new_cohort) call new_cohort%prt%RegisterBCIn(acnp_bc_in_id_netdnh4, bc_rval = new_cohort%daily_nh4_uptake) call new_cohort%prt%RegisterBCIn(acnp_bc_in_id_netdno3, bc_rval = new_cohort%daily_no3_uptake) call new_cohort%prt%RegisterBCIn(acnp_bc_in_id_netdp, bc_rval = new_cohort%daily_p_uptake) - + call new_cohort%prt%RegisterBCInOut(acnp_bc_inout_id_dbh,bc_rval = new_cohort%dbh) call new_cohort%prt%RegisterBCInOut(acnp_bc_inout_id_rmaint_def,bc_rval = new_cohort%resp_m_def) @@ -421,21 +419,21 @@ subroutine InitPRTBoundaryConditions(new_cohort) call new_cohort%prt%RegisterBCOut(acnp_bc_out_id_pefflux, bc_rval = new_cohort%daily_p_efflux) call new_cohort%prt%RegisterBCOut(acnp_bc_out_id_nneed, bc_rval = new_cohort%daily_n_need) call new_cohort%prt%RegisterBCOut(acnp_bc_out_id_pneed, bc_rval = new_cohort%daily_p_need) - - + + case DEFAULT - + write(fates_log(),*) 'You specified an unknown PRT module' write(fates_log(),*) 'Aborting' call endrun(msg=errMsg(sourcefile, __LINE__)) - + end select - + end subroutine InitPRTBoundaryConditions ! ------------------------------------------------------------------------------------! - + subroutine InitPRTObject(prt) ! ----------------------------------------------------------------------------------- @@ -444,7 +442,7 @@ subroutine InitPRTObject(prt) ! The argument that is passed in is a pointer that is then associated with this ! newly allocated object. ! The object that is allocated is the specific extended class for the hypothesis - ! of choice. + ! of choice. ! Following this, the object and its internal mappings are initialized. ! This routine does NOT set any of the initial conditions, or boundary conditions ! such as the organ/element masses. Those are handled after this call. @@ -453,36 +451,36 @@ subroutine InitPRTObject(prt) ! Argument class(prt_vartypes), pointer :: prt - + ! Potential Extended types class(callom_prt_vartypes), pointer :: c_allom_prt class(cnp_allom_prt_vartypes), pointer :: cnp_allom_prt - + select case(hlm_parteh_mode) case (prt_carbon_allom_hyp) - + allocate(c_allom_prt) prt => c_allom_prt - + case (prt_cnp_flex_allom_hyp) - + allocate(cnp_allom_prt) prt => cnp_allom_prt case DEFAULT - + write(fates_log(),*) 'You specified an unknown PRT module' write(fates_log(),*) 'Aborting' call endrun(msg=errMsg(sourcefile, __LINE__)) - + end select - + ! This is the call to allocate the data structures in the PRT object ! This call will be extended to each specific class. call prt%InitPRTVartype() - + return end subroutine InitPRTObject @@ -493,14 +491,14 @@ end subroutine InitPRTObject subroutine nan_cohort(cc_p) ! ! !DESCRIPTION: - ! Make all the cohort variables NaN so they aren't used before defined. + ! Make all the cohort variables NaN so they aren't used before defined. ! ! !USES: use FatesConstantsMod, only : fates_unset_int ! - ! !ARGUMENTS + ! !ARGUMENTS type (ed_cohort_type), intent(inout), target :: cc_p ! ! !LOCAL VARIABLES: @@ -509,35 +507,35 @@ subroutine nan_cohort(cc_p) currentCohort => cc_p - currentCohort%taller => null() ! pointer to next tallest cohort - currentCohort%shorter => null() ! pointer to next shorter cohort + currentCohort%taller => null() ! pointer to next tallest cohort + currentCohort%shorter => null() ! pointer to next shorter cohort currentCohort%patchptr => null() ! pointer to patch that cohort is in - nullify(currentCohort%taller) - nullify(currentCohort%shorter) - nullify(currentCohort%patchptr) + nullify(currentCohort%taller) + nullify(currentCohort%shorter) + nullify(currentCohort%patchptr) ! VEGETATION STRUCTURE - currentCohort%pft = fates_unset_int ! pft number + currentCohort%pft = fates_unset_int ! pft number currentCohort%indexnumber = fates_unset_int ! unique number for each cohort. (within clump?) - currentCohort%canopy_layer = fates_unset_int ! canopy status of cohort (1 = canopy, 2 = understorey, etc.) - currentCohort%canopy_layer_yesterday = nan ! recent canopy status of cohort (1 = canopy, 2 = understorey, etc.) + currentCohort%canopy_layer = fates_unset_int ! canopy status of cohort (1 = canopy, 2 = understorey, etc.) + currentCohort%canopy_layer_yesterday = nan ! recent canopy status of cohort (1 = canopy, 2 = understorey, etc.) currentCohort%NV = fates_unset_int ! Number of leaf layers: - currentCohort%status_coh = fates_unset_int ! growth status of plant (2 = leaves on , 1 = leaves off) currentCohort%size_class = fates_unset_int ! size class index currentCohort%size_class_lasttimestep = fates_unset_int ! size class index currentCohort%size_by_pft_class = fates_unset_int ! size by pft classification index currentCohort%coage_class = fates_unset_int ! cohort age class index - currentCohort%coage_by_pft_class = fates_unset_int ! cohort age by pft class index + currentCohort%coage_by_pft_class = fates_unset_int ! cohort age by pft class index - currentCohort%n = nan ! number of individuals in cohort per 'area' (10000m2 default) + currentCohort%n = nan ! number of individuals in cohort per 'area' (10000m2 default) currentCohort%dbh = nan ! 'diameter at breast height' in cm currentCohort%coage = nan ! age of the cohort in years - currentCohort%hite = nan ! height: meters + currentCohort%hite = nan ! height: meters currentCohort%laimemory = nan ! target leaf biomass- set from previous year: kGC per indiv currentCohort%sapwmemory = nan ! target sapwood biomass- set from previous year: kGC per indiv currentCohort%structmemory = nan ! target structural biomass- set from previous year: kGC per indiv - currentCohort%lai = nan ! leaf area index of cohort m2/m2 + currentCohort%lai = nan ! leaf area index of cohort m2/m2 currentCohort%sai = nan ! stem area index of cohort m2/m2 currentCohort%g_sb_laweight = nan ! Total leaf conductance of cohort (stomata+blayer) weighted by leaf-area [m/s]*[m2] currentCohort%canopy_trim = nan ! What is the fraction of the maximum leaf biomass that we are targeting? :- @@ -548,18 +546,18 @@ subroutine nan_cohort(cc_p) currentCohort%treelai = nan ! lai of tree (total leaf area (m2) / canopy area (m2) currentCohort%treesai = nan ! stem area index of tree (total stem area (m2) / canopy area (m2) currentCohort%seed_prod = nan - currentCohort%vcmax25top = nan - currentCohort%jmax25top = nan - currentCohort%tpu25top = nan - currentCohort%kp25top = nan + currentCohort%vcmax25top = nan + currentCohort%jmax25top = nan + currentCohort%tpu25top = nan + currentCohort%kp25top = nan - ! CARBON FLUXES + ! CARBON FLUXES currentCohort%gpp_acc_hold = nan ! GPP: kgC/indiv/year currentCohort%gpp_tstep = nan ! GPP: kgC/indiv/timestep - currentCohort%gpp_acc = nan ! GPP: kgC/indiv/day + currentCohort%gpp_acc = nan ! GPP: kgC/indiv/day currentCohort%npp_acc_hold = nan ! NPP: kgC/indiv/year currentCohort%npp_tstep = nan ! NPP: kGC/indiv/timestep - currentCohort%npp_acc = nan ! NPP: kgC/indiv/day + currentCohort%npp_acc = nan ! NPP: kgC/indiv/day currentCohort%year_net_uptake(:) = nan ! Net uptake of individual leaf layers kgC/m2/year currentCohort%ts_net_uptake(:) = nan ! Net uptake of individual leaf layers kgC/m2/s currentCohort%resp_acc_hold = nan ! RESP: kgC/indiv/year @@ -577,8 +575,8 @@ subroutine nan_cohort(cc_p) currentCohort%daily_p_need = nan currentCohort%daily_n_demand = nan currentCohort%daily_p_demand = nan - - + + currentCohort%c13disc_clm = nan ! C13 discrimination, per mil at indiv/timestep currentCohort%c13disc_acc = nan ! C13 discrimination, per mil at indiv/timestep at indiv/daily at the end of a day @@ -586,9 +584,9 @@ subroutine nan_cohort(cc_p) currentCohort%rdark = nan currentCohort%resp_m = nan ! Maintenance respiration. kGC/cohort/year currentCohort%resp_m_def = nan ! Maintenance respiration deficit kgC/plant - currentCohort%livestem_mr = nan ! Live stem maintenance respiration. kgC/indiv/s-1 - currentCohort%livecroot_mr = nan ! Coarse root maintenance respiration. kgC/indiv/s-1 - currentCohort%froot_mr = nan ! Fine root maintenance respiration. kgC/indiv/s-1 + currentCohort%livestem_mr = nan ! Live stem maintenance respiration. kgC/indiv/s-1 + currentCohort%livecroot_mr = nan ! Coarse root maintenance respiration. kgC/indiv/s-1 + currentCohort%froot_mr = nan ! Fine root maintenance respiration. kgC/indiv/s-1 currentCohort%resp_g_tstep = nan ! Growth respiration. kGC/indiv/timestep @@ -606,10 +604,10 @@ subroutine nan_cohort(cc_p) currentCohort%treesai = nan ! stem area index of tree (total stem area (m2) / canopy area (m2) - ! VARIABLES NEEDED FOR INTEGRATION - currentCohort%dndt = nan ! time derivative of cohort size - currentCohort%dhdt = nan ! time derivative of height - currentCohort%ddbhdt = nan ! time derivative of dbh + ! VARIABLES NEEDED FOR INTEGRATION + currentCohort%dndt = nan ! time derivative of cohort size + currentCohort%dhdt = nan ! time derivative of height + currentCohort%ddbhdt = nan ! time derivative of dbh ! FIRE currentCohort%fraction_crown_burned = nan ! proportion of crown affected by fire @@ -624,12 +622,12 @@ end subroutine nan_cohort subroutine zero_cohort(cc_p) ! ! !DESCRIPTION: - ! Zero variables that need to be accounted for if - ! this cohort is altered before they are defined. + ! Zero variables that need to be accounted for if + ! this cohort is altered before they are defined. ! ! !USES: ! - ! !ARGUMENTS + ! !ARGUMENTS type (ed_cohort_type), intent(inout), target :: cc_p ! ! !LOCAL VARIABLES: @@ -638,8 +636,8 @@ subroutine zero_cohort(cc_p) currentCohort => cc_p - currentCohort%NV = 0 - currentCohort%status_coh = 0 + currentCohort%NV = 0 + currentCohort%status_coh = 0 currentCohort%rdark = 0._r8 currentCohort%resp_m = 0._r8 currentCohort%resp_m_def = 0._r8 @@ -647,7 +645,7 @@ subroutine zero_cohort(cc_p) currentCohort%livestem_mr = 0._r8 currentCohort%livecroot_mr = 0._r8 currentCohort%froot_mr = 0._r8 - currentCohort%fire_mort = 0._r8 + currentCohort%fire_mort = 0._r8 currentcohort%npp_acc = 0._r8 currentcohort%gpp_acc = 0._r8 currentcohort%resp_acc = 0._r8 @@ -656,28 +654,28 @@ subroutine zero_cohort(cc_p) currentcohort%resp_tstep = 0._r8 currentcohort%resp_acc_hold = 0._r8 - currentcohort%year_net_uptake(:) = 999._r8 ! this needs to be 999, or trimming of new cohorts will break. + currentcohort%year_net_uptake(:) = 999._r8 ! this needs to be 999, or trimming of new cohorts will break. currentcohort%ts_net_uptake(:) = 0._r8 - currentcohort%fraction_crown_burned = 0._r8 + currentcohort%fraction_crown_burned = 0._r8 currentCohort%size_class = 1 currentCohort%coage_class = 1 currentCohort%seed_prod = 0._r8 currentCohort%size_class_lasttimestep = 0 - currentcohort%npp_acc_hold = 0._r8 - currentcohort%gpp_acc_hold = 0._r8 - currentcohort%dmort = 0._r8 - currentcohort%g_sb_laweight = 0._r8 - currentcohort%treesai = 0._r8 + currentcohort%npp_acc_hold = 0._r8 + currentcohort%gpp_acc_hold = 0._r8 + currentcohort%dmort = 0._r8 + currentcohort%g_sb_laweight = 0._r8 + currentcohort%treesai = 0._r8 currentCohort%lmort_direct = 0._r8 currentCohort%lmort_infra = 0._r8 currentCohort%lmort_collateral = 0._r8 - currentCohort%l_degrad = 0._r8 + currentCohort%l_degrad = 0._r8 currentCohort%leaf_cost = 0._r8 currentcohort%excl_weight = 0._r8 currentcohort%prom_weight = 0._r8 currentcohort%crownfire_mort = 0._r8 currentcohort%cambial_mort = 0._r8 - currentCohort%c13disc_clm = 0._r8 + currentCohort%c13disc_clm = 0._r8 currentCohort%c13disc_acc = 0._r8 ! Daily nutrient fluxes are INTEGRATED over the course of the @@ -688,31 +686,31 @@ subroutine zero_cohort(cc_p) currentCohort%daily_nh4_uptake = 0._r8 currentCohort%daily_no3_uptake = 0._r8 currentCohort%daily_p_uptake = 0._r8 - + currentCohort%daily_c_efflux = 0._r8 currentCohort%daily_n_efflux = 0._r8 currentCohort%daily_p_efflux = 0._r8 - + currentCohort%daily_n_need = 0._r8 currentCohort%daily_p_need = 0._r8 ! Initialize these as negative currentCohort%daily_p_demand = -9._r8 currentCohort%daily_n_demand = -9._r8 - - + + end subroutine zero_cohort !-------------------------------------------------------------------------------------! subroutine terminate_cohorts( currentSite, currentPatch, level , call_index, bc_in) ! ! !DESCRIPTION: - ! terminates cohorts when they get too small + ! terminates cohorts when they get too small ! ! !USES: - + ! - ! !ARGUMENTS + ! !ARGUMENTS type (ed_site_type) , intent(inout), target :: currentSite type (ed_patch_type), intent(inout), target :: currentPatch integer , intent(in) :: level @@ -722,7 +720,7 @@ subroutine terminate_cohorts( currentSite, currentPatch, level , call_index, bc_ ! Important point regarding termination levels. Termination is typically ! called after fusion. We do this so that we can re-capture the biomass that would ! otherwise be lost from termination. The biomass of a fused plant remains in the - ! live pool. However, some plant number densities can be so low that they + ! live pool. However, some plant number densities can be so low that they ! can cause numerical instabilities. Thus, we call terminate_cohorts at level=1 ! before fusion to get rid of these cohorts that are so incredibly sparse, and then ! terminate the remainder at level 2 for various other reasons. @@ -740,7 +738,7 @@ subroutine terminate_cohorts( currentSite, currentPatch, level , call_index, bc_ real(r8) :: repro_c ! reproductive carbon [kg] real(r8) :: struct_c ! structural carbon [kg] integer :: terminate ! do we terminate (itrue) or not (ifalse) - integer :: c ! counter for litter size class. + integer :: c ! counter for litter size class. integer :: levcan ! canopy level !---------------------------------------------------------------------- @@ -764,14 +762,14 @@ subroutine terminate_cohorts( currentSite, currentPatch, level , call_index, bc_ write(fates_log(),*) 'terminating cohorts 0',currentCohort%n/currentPatch%area,currentCohort%dbh,call_index endif endif - + ! The rest of these are only allowed if we are not dealing with a recruit (level 2) if (.not.currentCohort%isnew .and. level == 2) then ! Not enough n or dbh if (currentCohort%n/currentPatch%area <= min_npm2 .or. & ! currentCohort%n <= min_nppatch .or. & - (currentCohort%dbh < 0.00001_r8 .and. store_c < 0._r8) ) then + (currentCohort%dbh < 0.00001_r8 .and. store_c < 0._r8) ) then terminate = itrue if ( debug ) then write(fates_log(),*) 'terminating cohorts 1',currentCohort%n/currentPatch%area,currentCohort%dbh,call_index @@ -779,7 +777,7 @@ subroutine terminate_cohorts( currentSite, currentPatch, level , call_index, bc_ endif ! Outside the maximum canopy layer - if (currentCohort%canopy_layer > nclmax ) then + if (currentCohort%canopy_layer > nclmax ) then terminate = itrue if ( debug ) then write(fates_log(),*) 'terminating cohorts 2', currentCohort%canopy_layer,call_index @@ -800,14 +798,14 @@ subroutine terminate_cohorts( currentSite, currentPatch, level , call_index, bc_ if ( ( struct_c+sapw_c+leaf_c+fnrt_c+store_c ) < 0._r8) then terminate = itrue if ( debug ) then - write(fates_log(),*) 'terminating cohorts 4', & + write(fates_log(),*) 'terminating cohorts 4', & struct_c,sapw_c,leaf_c,fnrt_c,store_c,call_index endif - + endif endif ! if (.not.currentCohort%isnew .and. level == 2) then - if (terminate == itrue) then + if (terminate == itrue) then ! preserve a record of the to-be-terminated cohort for mortality accounting levcan = currentCohort%canopy_layer @@ -818,48 +816,48 @@ subroutine terminate_cohorts( currentSite, currentPatch, level , call_index, bc_ if(levcan==ican_upper) then currentSite%term_nindivs_canopy(currentCohort%size_class,currentCohort%pft) = & currentSite%term_nindivs_canopy(currentCohort%size_class,currentCohort%pft) + currentCohort%n - + currentSite%term_carbonflux_canopy = currentSite%term_carbonflux_canopy + & currentCohort%n * (struct_c+sapw_c+leaf_c+fnrt_c+store_c+repro_c) else currentSite%term_nindivs_ustory(currentCohort%size_class,currentCohort%pft) = & currentSite%term_nindivs_ustory(currentCohort%size_class,currentCohort%pft) + currentCohort%n - + currentSite%term_carbonflux_ustory = currentSite%term_carbonflux_ustory + & currentCohort%n * (struct_c+sapw_c+leaf_c+fnrt_c+store_c+repro_c) end if - ! put the litter from the terminated cohorts + ! put the litter from the terminated cohorts ! straight into the fragmenting pools if (currentCohort%n.gt.0.0_r8) then call SendCohortToLitter(currentSite,currentPatch, & currentCohort,currentCohort%n,bc_in) end if - + ! Set pointers and remove the current cohort from the list shorterCohort => currentCohort%shorter - + if (.not. associated(tallerCohort)) then currentPatch%tallest => shorterCohort if(associated(shorterCohort)) shorterCohort%taller => null() - else + else tallerCohort%shorter => shorterCohort endif - + if (.not. associated(shorterCohort)) then currentPatch%shortest => tallerCohort if(associated(tallerCohort)) tallerCohort%shorter => null() - else + else shorterCohort%taller => tallerCohort endif - + call DeallocateCohort(currentCohort) deallocate(currentCohort) nullify(currentCohort) - + endif currentCohort => tallerCohort enddo @@ -869,15 +867,15 @@ end subroutine terminate_cohorts ! ===================================================================================== subroutine SendCohortToLitter(csite,cpatch,ccohort,nplant,bc_in) - + ! ----------------------------------------------------------------------------------- ! This routine transfers the existing mass in all pools and all elements ! on a vegetation cohort, into the litter pool. - ! + ! ! Important: (1) This IS NOT turnover, this is not a partial transfer. ! (2) This is from a select number of plants in the cohort. ie this is ! not a "whole-sale" sending of all plants to litter. - ! (3) This does not affect the PER PLANT mass pools, so + ! (3) This does not affect the PER PLANT mass pools, so ! do not update any PARTEH structures. ! (4) The change in plant number density (due to death or termination) ! IS NOT handled here. @@ -893,7 +891,7 @@ subroutine SendCohortToLitter(csite,cpatch,ccohort,nplant,bc_in) real(r8) :: nplant ! Number (absolute) ! of plants to transfer type(bc_in_type), intent(in) :: bc_in - + type(litter_type), pointer :: litt ! Litter object for each element type(site_fluxdiags_type),pointer :: flux_diags @@ -910,7 +908,7 @@ subroutine SendCohortToLitter(csite,cpatch,ccohort,nplant,bc_in) integer :: pft ! pft index of the cohort integer :: sl ! loop index for soil layers integer :: dcmpy ! loop index for decomposability - + !---------------------------------------------------------------------- pft = ccohort%pft @@ -921,14 +919,14 @@ subroutine SendCohortToLitter(csite,cpatch,ccohort,nplant,bc_in) bc_in%max_rooting_depth_index_col) do el=1,num_elements - + leaf_m = ccohort%prt%GetState(leaf_organ, element_list(el)) store_m = ccohort%prt%GetState(store_organ, element_list(el)) sapw_m = ccohort%prt%GetState(sapw_organ, element_list(el)) fnrt_m = ccohort%prt%GetState(fnrt_organ, element_list(el)) struct_m = ccohort%prt%GetState(struct_organ, element_list(el)) repro_m = ccohort%prt%GetState(repro_organ, element_list(el)) - + litt => cpatch%litter(el) flux_diags => csite%flux_diags(el) @@ -958,13 +956,13 @@ subroutine SendCohortToLitter(csite,cpatch,ccohort,nplant,bc_in) (1.0_r8 - prt_params%allom_agb_frac(pft)) * nplant enddo - + do dcmpy=1,ndcmpy dcmpy_frac = GetDecompyFrac(pft,leaf_organ,dcmpy) - + litt%leaf_fines(dcmpy) = litt%leaf_fines(dcmpy) + & plant_dens * (leaf_m+repro_m) * dcmpy_frac - + dcmpy_frac = GetDecompyFrac(pft,fnrt_organ,dcmpy) do sl=1,csite%nlevsoil litt%root_fines(dcmpy,sl) = litt%root_fines(dcmpy,sl) + & @@ -979,10 +977,10 @@ subroutine SendCohortToLitter(csite,cpatch,ccohort,nplant,bc_in) flux_diags%root_litter_input(pft) = & flux_diags%root_litter_input(pft) + & (fnrt_m+store_m) * nplant - - + + end do - + return end subroutine SendCohortToLitter @@ -998,27 +996,27 @@ subroutine DeallocateCohort(currentCohort) ! inside the cohort structure. This DOES NOT deallocate ! the cohort structure itself. ! ---------------------------------------------------------------------------------- - + type(ed_cohort_type),intent(inout) :: currentCohort - + ! At this point, nothing should be pointing to current Cohort if (hlm_use_planthydro.eq.itrue) call DeallocateHydrCohort(currentCohort) - + ! Deallocate the cohort's PRT structures call currentCohort%prt%DeallocatePRTVartypes() - + ! Deallocate the PRT object deallocate(currentCohort%prt) - + return end subroutine DeallocateCohort - - subroutine fuse_cohorts(currentSite, currentPatch, bc_in) + + subroutine fuse_cohorts(currentSite, currentPatch, bc_in) ! ! !DESCRIPTION: - ! Join similar cohorts to reduce total number + ! Join similar cohorts to reduce total number ! ! !USES: use EDParamsMod , only : ED_val_cohort_size_fusion_tol @@ -1027,10 +1025,10 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) use FatesConstantsMod , only : itrue use FatesConstantsMod, only : days_per_year use EDTypesMod , only : maxCohortsPerPatch - + ! - ! !ARGUMENTS - type (ed_site_type), intent(inout), target :: currentSite + ! !ARGUMENTS + type (ed_site_type), intent(inout), target :: currentSite type (ed_patch_type), intent(inout), target :: currentPatch type (bc_in_type), intent(in) :: bc_in ! @@ -1043,7 +1041,7 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) type (ed_cohort_type) , pointer :: shorterCohort type (ed_cohort_type) , pointer :: tallerCohort - integer :: i + integer :: i integer :: fusion_took_place integer :: iterate ! do we need to keep fusing to get below maxcohorts? integer :: nocohorts @@ -1052,7 +1050,7 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) real(r8) :: coage_diff real(r8) :: leaf_c_next ! Leaf carbon * plant density of current (for weighting) real(r8) :: leaf_c_curr ! Leaf carbon * plant density of next (for weighting) - real(r8) :: leaf_c_target + real(r8) :: leaf_c_target real(r8) :: dynamic_size_fusion_tolerance real(r8) :: dynamic_age_fusion_tolerance real(r8) :: dbh @@ -1073,47 +1071,47 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) ! set the cohort age fusion tolerance (in fraction of years) dynamic_age_fusion_tolerance = ED_val_cohort_age_fusion_tol - + !This needs to be a function of the canopy layer, because otherwise, at canopy closure !the number of cohorts doubles and very dissimilar cohorts are fused together !because c_area and biomass are non-linear with dbh, this causes several mass inconsistancies - !in theory, all of this routine therefore causes minor losses of C and area, but these are below - !detection limit normally. + !in theory, all of this routine therefore causes minor losses of C and area, but these are below + !detection limit normally. iterate = 1 - fusion_took_place = 0 + fusion_took_place = 0 + - !---------------------------------------------------------------------! ! Keep doing this until nocohorts <= maxcohorts ! !---------------------------------------------------------------------! - - if (associated(currentPatch%shortest)) then + + if (associated(currentPatch%shortest)) then do while(iterate == 1) - + currentCohort => currentPatch%tallest - + ! The following logic continues the loop while the current cohort is not the shortest cohort ! if they point to the same target (ie equivalence), then the loop ends. ! This loop is different than the simple "continue while associated" loop in that ! it omits the last cohort (because it has already been compared by that point) - + do while ( .not.associated(currentCohort,currentPatch%shortest) ) nextc => currentPatch%tallest do while (associated(nextc)) nextnextc => nextc%shorter - diff = abs((currentCohort%dbh - nextc%dbh)/(0.5_r8*(currentCohort%dbh + nextc%dbh))) + diff = abs((currentCohort%dbh - nextc%dbh)/(0.5_r8*(currentCohort%dbh + nextc%dbh))) !Criteria used to divide up the height continuum into different cohorts. if (diff < dynamic_size_fusion_tolerance) then - ! Only fuse if the cohorts are within x years of each other + ! Only fuse if the cohorts are within x years of each other ! if they are the same age we make diff 0- to avoid errors divding by zero !NB if cohort age tracking is off then the age of both should be 0 - ! and hence the age fusion criterion is met + ! and hence the age fusion criterion is met if (abs(currentCohort%coage - nextc%coage) shorterCohort if(associated(shorterCohort)) shorterCohort%taller => null() - else + else tallerCohort%shorter => shorterCohort endif if (.not. associated(shorterCohort)) then currentPatch%shortest => tallerCohort if(associated(tallerCohort)) tallerCohort%shorter => null() - else + else shorterCohort%taller => tallerCohort endif ! At this point, nothing should be pointing to current Cohort ! update hydraulics quantities that are functions of hite & biomasses ! deallocate the hydro structure of nextc - if (hlm_use_planthydro.eq.itrue) then + if (hlm_use_planthydro.eq.itrue) then call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & currentCohort%pft,currentCohort%c_area) leaf_c = currentCohort%prt%GetState(leaf_organ, carbon12_element) currentCohort%treelai = tree_lai(leaf_c, & currentCohort%pft, currentCohort%c_area, currentCohort%n, & currentCohort%canopy_layer, currentPatch%canopy_layer_tlai, & - currentCohort%vcmax25top ) - call UpdateSizeDepPlantHydProps(currentSite,currentCohort, bc_in) + currentCohort%vcmax25top ) + call UpdateSizeDepPlantHydProps(currentSite,currentCohort, bc_in) endif - + call DeallocateCohort(nextc) deallocate(nextc) nullify(nextc) - + endif ! if( currentCohort%isnew.eqv.nextc%isnew ) then endif !canopy layer endif !pft - endif !index no. - endif ! cohort age diff - endif !diff + endif !index no. + endif ! cohort age diff + endif !diff nextc => nextnextc @@ -1518,12 +1515,12 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) if (associated (currentCohort%shorter)) then currentCohort => currentCohort%shorter endif - + enddo !end currentCohort cohort loop !---------------------------------------------------------------------! ! Is the number of cohorts larger than the maximum? ! - !---------------------------------------------------------------------! + !---------------------------------------------------------------------! nocohorts = 0 currentCohort => currentPatch%tallest do while(associated(currentCohort)) @@ -1537,7 +1534,7 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) iterate = 1 !---------------------------------------------------------------------! ! Making profile tolerance larger means that more fusion will happen ! - !---------------------------------------------------------------------! + !---------------------------------------------------------------------! dynamic_size_fusion_tolerance = dynamic_size_fusion_tolerance * 1.1_r8 dynamic_age_fusion_tolerance = dynamic_age_fusion_tolerance * 1.1_r8 !write(fates_log(),*) 'maxcohorts exceeded',dynamic_fusion_tolerance @@ -1547,13 +1544,13 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) iterate = 0 endif - else + else if (nocohorts > maxCohortsPerPatch) then iterate = 1 !---------------------------------------------------------------------! ! Making profile tolerance larger means that more fusion will happen ! - !---------------------------------------------------------------------! + !---------------------------------------------------------------------! dynamic_size_fusion_tolerance = dynamic_size_fusion_tolerance * 1.1_r8 !write(fates_log(),*) 'maxcohorts exceeded',dynamic_fusion_tolerance @@ -1563,7 +1560,7 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) endif end if - + if ( dynamic_size_fusion_tolerance .gt. 100._r8) then ! something has gone terribly wrong and we need to report what write(fates_log(),*) 'exceeded reasonable expectation of cohort fusion.' @@ -1580,9 +1577,9 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) enddo !do while nocohorts>maxcohorts - endif ! patch. + endif ! patch. - if (fusion_took_place == 1) then ! if fusion(s) occured sort cohorts + if (fusion_took_place == 1) then ! if fusion(s) occured sort cohorts call sort_cohorts(currentPatch) endif @@ -1590,7 +1587,7 @@ end subroutine fuse_cohorts !-------------------------------------------------------------------------------------! - subroutine sort_cohorts(patchptr) + subroutine sort_cohorts(patchptr) ! ============================================================================ ! sort cohorts into the correct order DO NOT CHANGE THIS IT WILL BREAK ! ============================================================================ @@ -1599,9 +1596,9 @@ subroutine sort_cohorts(patchptr) type(ed_patch_type) , pointer :: current_patch type(ed_cohort_type), pointer :: current_c, next_c - type(ed_cohort_type), pointer :: shortestc, tallestc - type(ed_cohort_type), pointer :: storesmallcohort - type(ed_cohort_type), pointer :: storebigcohort + type(ed_cohort_type), pointer :: shortestc, tallestc + type(ed_cohort_type), pointer :: storesmallcohort + type(ed_cohort_type), pointer :: storebigcohort integer :: snull,tnull current_patch => patchptr @@ -1609,12 +1606,12 @@ subroutine sort_cohorts(patchptr) shortestc => NULL() storebigcohort => null() storesmallcohort => null() - current_c => current_patch%tallest + current_c => current_patch%tallest - do while (associated(current_c)) + do while (associated(current_c)) next_c => current_c%shorter - tallestc => storebigcohort - shortestc => storesmallcohort + tallestc => storebigcohort + shortestc => storesmallcohort if (associated(tallestc)) then tnull = 0 else @@ -1631,7 +1628,7 @@ subroutine sort_cohorts(patchptr) call insert_cohort(current_c, tallestc, shortestc, tnull, snull, storebigcohort, storesmallcohort) - current_patch%tallest => storebigcohort + current_patch%tallest => storebigcohort current_patch%shortest => storesmallcohort current_c => next_c @@ -1643,24 +1640,24 @@ end subroutine sort_cohorts subroutine insert_cohort(pcc, ptall, pshort, tnull, snull, storebigcohort, storesmallcohort) ! ! !DESCRIPTION: - ! Insert cohort into linked list + ! Insert cohort into linked list ! ! !USES: ! - ! !ARGUMENTS + ! !ARGUMENTS type(ed_cohort_type) , intent(inout), target :: pcc type(ed_cohort_type) , intent(inout), target :: ptall type(ed_cohort_type) , intent(inout), target :: pshort integer , intent(in) :: tnull integer , intent(in) :: snull type(ed_cohort_type) , intent(inout),pointer,optional :: storesmallcohort ! storage of the smallest cohort for insertion routine - type(ed_cohort_type) , intent(inout),pointer,optional :: storebigcohort ! storage of the largest cohort for insertion routine + type(ed_cohort_type) , intent(inout),pointer,optional :: storebigcohort ! storage of the largest cohort for insertion routine ! ! !LOCAL VARIABLES: type(ed_patch_type), pointer :: currentPatch type(ed_cohort_type), pointer :: current type(ed_cohort_type), pointer :: tallptr, shortptr, icohort - type(ed_cohort_type), pointer :: ptallest, pshortest + type(ed_cohort_type), pointer :: ptallest, pshortest real(r8) :: tsp integer :: tallptrnull,exitloop !---------------------------------------------------------------------- @@ -1676,21 +1673,21 @@ subroutine insert_cohort(pcc, ptall, pshort, tnull, snull, storebigcohort, store pshortest => null() endif - icohort => pcc ! assign address to icohort local name - !place in the correct place in the linked list of heights - !begin by finding cohort that is just taller than the new cohort + icohort => pcc ! assign address to icohort local name + !place in the correct place in the linked list of heights + !begin by finding cohort that is just taller than the new cohort tsp = icohort%hite current => pshortest exitloop = 0 - !starting with shortest tree on the grid, find tree just - !taller than tree being considered and return its pointer + !starting with shortest tree on the grid, find tree just + !taller than tree being considered and return its pointer if (associated(current)) then do while (associated(current).and.exitloop == 0) if (current%hite < tsp) then - current => current%taller + current => current%taller else - exitloop = 1 + exitloop = 1 endif enddo endif @@ -1703,48 +1700,48 @@ subroutine insert_cohort(pcc, ptall, pshort, tnull, snull, storebigcohort, store tallptrnull = 1 endif - !new cohort is tallest - if (.not.associated(tallptr)) then - !new shorter cohort to the new cohort is the old tallest cohort + !new cohort is tallest + if (.not.associated(tallptr)) then + !new shorter cohort to the new cohort is the old tallest cohort shortptr => ptallest - !new cohort is tallest cohort and next taller remains null + !new cohort is tallest cohort and next taller remains null ptallest => icohort if (present(storebigcohort)) then storebigcohort => icohort end if - currentPatch%tallest => icohort - icohort%patchptr%tallest => icohort - !new cohort is not tallest + currentPatch%tallest => icohort + icohort%patchptr%tallest => icohort + !new cohort is not tallest else - !next shorter cohort to new cohort is the next shorter cohort - !to the cohort just taller than the new cohort + !next shorter cohort to new cohort is the next shorter cohort + !to the cohort just taller than the new cohort shortptr => tallptr%shorter - !new cohort becomes the next shorter cohort to the cohort - !just taller than the new cohort + !new cohort becomes the next shorter cohort to the cohort + !just taller than the new cohort tallptr%shorter => icohort endif - !new cohort is shortest + !new cohort is shortest if (.not.associated(shortptr)) then - !next shorter reamins null - !cohort is placed at the bottom of the list + !next shorter reamins null + !cohort is placed at the bottom of the list pshortest => icohort if (present(storesmallcohort)) then - storesmallcohort => icohort + storesmallcohort => icohort end if - currentPatch%shortest => icohort - icohort%patchptr%shortest => icohort + currentPatch%shortest => icohort + icohort%patchptr%shortest => icohort else - !new cohort is not shortest and becomes next taller cohort - !to the cohort just below it as defined in the previous block + !new cohort is not shortest and becomes next taller cohort + !to the cohort just below it as defined in the previous block shortptr%taller => icohort endif - ! assign taller and shorter links for the new cohort + ! assign taller and shorter links for the new cohort icohort%taller => tallptr - if (tallptrnull == 1) then + if (tallptrnull == 1) then icohort%taller=> null() endif icohort%shorter => shortptr @@ -1755,11 +1752,11 @@ end subroutine insert_cohort subroutine copy_cohort( currentCohort,copyc ) ! ! !DESCRIPTION: - ! Copies all the variables in one cohort into another empty cohort + ! Copies all the variables in one cohort into another empty cohort ! ! !USES: ! - ! !ARGUMENTS + ! !ARGUMENTS type(ed_cohort_type), intent(inout) , target :: copyc ! New cohort argument. type(ed_cohort_type), intent(in) , target :: currentCohort ! Old cohort argument. ! @@ -1771,18 +1768,18 @@ subroutine copy_cohort( currentCohort,copyc ) n => copyc n%indexnumber = fates_unset_int - + ! VEGETATION STRUCTURE n%pft = o%pft - n%n = o%n + n%n = o%n n%dbh = o%dbh - n%coage = o%coage + n%coage = o%coage n%hite = o%hite n%laimemory = o%laimemory n%sapwmemory = o%sapwmemory n%structmemory = o%structmemory - n%lai = o%lai - n%sai = o%sai + n%lai = o%lai + n%sai = o%sai n%g_sb_laweight = o%g_sb_laweight n%leaf_cost = o%leaf_cost n%canopy_layer = o%canopy_layer @@ -1790,8 +1787,8 @@ subroutine copy_cohort( currentCohort,copyc ) n%nv = o%nv n%status_coh = o%status_coh n%canopy_trim = o%canopy_trim - n%excl_weight = o%excl_weight - n%prom_weight = o%prom_weight + n%excl_weight = o%excl_weight + n%prom_weight = o%prom_weight n%size_class = o%size_class n%size_class_lasttimestep = o%size_class_lasttimestep n%size_by_pft_class = o%size_by_pft_class @@ -1804,7 +1801,7 @@ subroutine copy_cohort( currentCohort,copyc ) n%vcmax25top = o%vcmax25top n%jmax25top = o%jmax25top n%tpu25top = o%tpu25top - n%kp25top = o%kp25top + n%kp25top = o%kp25top ! CARBON FLUXES n%gpp_acc_hold = o%gpp_acc_hold @@ -1834,7 +1831,7 @@ subroutine copy_cohort( currentCohort,copyc ) n%daily_p_need = o%daily_p_need n%daily_n_demand = o%daily_n_demand n%daily_p_demand = o%daily_p_demand - + ! C13 discrimination n%c13disc_clm = o%c13disc_clm n%c13disc_acc = o%c13disc_acc @@ -1847,7 +1844,7 @@ subroutine copy_cohort( currentCohort,copyc ) n%livestem_mr = o%livestem_mr n%livecroot_mr = o%livecroot_mr n%froot_mr = o%froot_mr - + ! ALLOCATION n%dmort = o%dmort n%seed_prod = o%seed_prod @@ -1868,12 +1865,12 @@ subroutine copy_cohort( currentCohort,copyc ) n%lmort_direct =o%lmort_direct n%lmort_collateral =o%lmort_collateral n%lmort_infra =o%lmort_infra - n%l_degrad =o%l_degrad + n%l_degrad =o%l_degrad ! Flags n%isnew = o%isnew - ! VARIABLES NEEDED FOR INTEGRATION + ! VARIABLES NEEDED FOR INTEGRATION n%dndt = o%dndt n%dhdt = o%dhdt n%ddbhdt = o%ddbhdt @@ -1885,7 +1882,7 @@ subroutine copy_cohort( currentCohort,copyc ) n%cambial_mort = o%cambial_mort ! Plant Hydraulics - + if( hlm_use_planthydro.eq.itrue ) then call CopyCohortHydraulics(n,o) endif @@ -1896,11 +1893,11 @@ subroutine copy_cohort( currentCohort,copyc ) n%size_by_pft_class = o%size_by_pft_class n%coage_class = o%coage_class n%coage_by_pft_class = o%coage_by_pft_class - + !Pointers - n%taller => NULL() ! pointer to next tallest cohort - n%shorter => NULL() ! pointer to next shorter cohort - n%patchptr => o%patchptr ! pointer to patch that cohort is in + n%taller => NULL() ! pointer to next tallest cohort + n%shorter => NULL() ! pointer to next shorter cohort + n%patchptr => o%patchptr ! pointer to patch that cohort is in end subroutine copy_cohort @@ -1911,7 +1908,7 @@ subroutine count_cohorts( currentPatch ) ! ! !USES: ! - ! !ARGUMENTS + ! !ARGUMENTS type(ed_patch_type), intent(inout), target :: currentPatch !new site ! ! !LOCAL VARIABLES: @@ -1922,20 +1919,20 @@ subroutine count_cohorts( currentPatch ) currentCohort => currentPatch%shortest currentPatch%countcohorts = 0 - do while (associated(currentCohort)) - currentPatch%countcohorts = currentPatch%countcohorts + 1 - currentCohort => currentCohort%taller + do while (associated(currentCohort)) + currentPatch%countcohorts = currentPatch%countcohorts + 1 + currentCohort => currentCohort%taller enddo backcount = 0 currentCohort => currentPatch%tallest - do while (associated(currentCohort)) + do while (associated(currentCohort)) backcount = backcount + 1 - currentCohort => currentCohort%shorter + currentCohort => currentCohort%shorter enddo if (backcount /= currentPatch%countcohorts) then - write(fates_log(),*) 'problem with linked list, not symmetrical' + write(fates_log(),*) 'problem with linked list, not symmetrical' endif end subroutine count_cohorts @@ -1955,8 +1952,8 @@ subroutine UpdateCohortBioPhysRates(currentCohort) ! -------------------------------------------------------------------------------- type(ed_cohort_type),intent(inout) :: currentCohort - - + + real(r8) :: frac_leaf_aclass(max_nleafage) ! Fraction of leaves in each age-class integer :: iage ! loop index for leaf ages integer :: ipft ! plant functional type index @@ -1973,29 +1970,29 @@ subroutine UpdateCohortBioPhysRates(currentCohort) ! If there are leaves, then perform proportional weighting on the four rates ! We assume that leaf age does not effect the specific leaf area, so the mass ! fractions are applicable to these rates - + if(sum(frac_leaf_aclass(1:nleafage))>nearzero) then ipft = currentCohort%pft frac_leaf_aclass(1:nleafage) = frac_leaf_aclass(1:nleafage) / & sum(frac_leaf_aclass(1:nleafage)) - + currentCohort%vcmax25top = sum(EDPftvarcon_inst%vcmax25top(ipft,1:nleafage) * & frac_leaf_aclass(1:nleafage)) - + currentCohort%jmax25top = sum(param_derived%jmax25top(ipft,1:nleafage) * & frac_leaf_aclass(1:nleafage)) - + currentCohort%tpu25top = sum(param_derived%tpu25top(ipft,1:nleafage) * & frac_leaf_aclass(1:nleafage)) - - currentCohort%kp25top = sum(param_derived%kp25top(ipft,1:nleafage) * & + + currentCohort%kp25top = sum(param_derived%kp25top(ipft,1:nleafage) * & frac_leaf_aclass(1:nleafage)) else - - currentCohort%vcmax25top = 0._r8 + + currentCohort%vcmax25top = 0._r8 currentCohort%jmax25top = 0._r8 currentCohort%tpu25top = 0._r8 currentCohort%kp25top = 0._r8 @@ -2006,15 +2003,15 @@ subroutine UpdateCohortBioPhysRates(currentCohort) return end subroutine UpdateCohortBioPhysRates - + ! ============================================================================ subroutine EvaluateAndCorrectDBH(currentCohort,delta_dbh,delta_hite) ! ----------------------------------------------------------------------------------- - ! If the current diameter of a plant is somehow less than what is allometrically - ! consistent with stuctural biomass (or, in the case of grasses, leaf biomass) + ! If the current diameter of a plant is somehow less than what is allometrically + ! consistent with stuctural biomass (or, in the case of grasses, leaf biomass) ! then correct (increase) the dbh to match that. ! ----------------------------------------------------------------------------------- @@ -2022,7 +2019,7 @@ subroutine EvaluateAndCorrectDBH(currentCohort,delta_dbh,delta_hite) type(ed_cohort_type),intent(inout) :: currentCohort real(r8),intent(out) :: delta_dbh real(r8),intent(out) :: delta_hite - + ! locals real(r8) :: dbh real(r8) :: canopy_trim @@ -2036,44 +2033,44 @@ subroutine EvaluateAndCorrectDBH(currentCohort,delta_dbh,delta_hite) real(r8) :: struct_c real(r8) :: hite_out real(r8) :: leaf_c - + dbh = currentCohort%dbh ipft = currentCohort%pft canopy_trim = currentCohort%canopy_trim delta_dbh = 0._r8 delta_hite = 0._r8 - + if( int(prt_params%woody(currentCohort%pft)) == itrue) then struct_c = currentCohort%prt%GetState(struct_organ, all_carbon_elements) - + ! Target sapwood biomass according to allometry and trimming [kgC] call bsap_allom(dbh,ipft,canopy_trim,sapw_area,target_sapw_c) - + ! Target total above ground biomass in woody/fibrous tissues [kgC] call bagw_allom(dbh,ipft,target_agw_c) - - ! Target total below ground biomass in woody/fibrous tissues [kgC] + + ! Target total below ground biomass in woody/fibrous tissues [kgC] call bbgw_allom(dbh,ipft,target_bgw_c) - + ! Target total dead (structrual) biomass [kgC] call bdead_allom( target_agw_c, target_bgw_c, target_sapw_c, ipft, target_struct_c) - + ! ------------------------------------------------------------------------------------ ! If structure is larger than target, then we need to correct some integration errors ! by slightly increasing dbh to match it. ! For grasses, if leaf biomass is larger than target, then we reset dbh to match ! ----------------------------------------------------------------------------------- - + if( (struct_c - target_struct_c ) > calloc_abs_error ) then call ForceDBH( ipft, canopy_trim, dbh, hite_out, bdead=struct_c ) - delta_dbh = dbh - currentCohort%dbh + delta_dbh = dbh - currentCohort%dbh delta_hite = hite_out - currentCohort%hite currentCohort%dbh = dbh currentCohort%hite = hite_out end if - + else ! This returns the sum of leaf carbon over all (age) bins @@ -2084,15 +2081,15 @@ subroutine EvaluateAndCorrectDBH(currentCohort,delta_dbh,delta_hite) if( ( leaf_c - target_leaf_c ) > calloc_abs_error ) then call ForceDBH( ipft, canopy_trim, dbh, hite_out, bl=leaf_c ) - delta_dbh = dbh - currentCohort%dbh + delta_dbh = dbh - currentCohort%dbh delta_hite = hite_out - currentCohort%hite currentCohort%dbh = dbh currentCohort%hite = hite_out end if - + end if return end subroutine EvaluateAndCorrectDBH - + end module EDCohortDynamicsMod diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 68763c5a97..f0df5f9067 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -242,14 +242,11 @@ subroutine PreDisturbanceLitterFluxes( currentSite, currentPatch, bc_in ) ! as litter fluxes from live trees call CWDInput(currentSite, currentPatch, litt,bc_in) - ! Only calculate fragmentation flux over layers that are active ! (RGK-Mar2019) SHOULD WE MAX THIS AT 1? DONT HAVE TO nlev_eff_decomp = max(bc_in%max_rooting_depth_index_col, 1) call CWDOut(litt,currentPatch%fragmentation_scaler,nlev_eff_decomp) - write(fates_log(),*) 'PreDistLittFlux: sum ag_cwd_frag: ', sum(litt%ag_cwd_frag) - site_mass => currentSite%mass_balance(el) From ec99726ba4e5a9997228198861145da46ec6d1b2 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 13 Aug 2021 15:47:33 -0700 Subject: [PATCH 191/209] refactoring the linked list for zero patch area with nocomp --- main/EDInitMod.F90 | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 991281ec48..bb06f57de1 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -434,7 +434,6 @@ subroutine init_patches( nsites, sites, bc_in) type(ed_site_type), pointer :: sitep type(ed_patch_type), pointer :: newppft(:) type(ed_patch_type), pointer :: newp - type(ed_patch_type), pointer :: recall_older_patch type(ed_patch_type), pointer :: currentPatch ! List out some nominal patch values that are used for Near Bear Ground initializations @@ -469,7 +468,6 @@ subroutine init_patches( nsites, sites, bc_in) else - allocate(recall_older_patch) do s = 1, nsites sites(s)%sp_tlai(:) = 0._r8 sites(s)%sp_tsai(:) = 0._r8 @@ -536,16 +534,15 @@ subroutine init_patches( nsites, sites, bc_in) sites(s)%youngest_patch => newp sites(s)%oldest_patch => newp is_first_patch = ifalse - else ! the new patch is the 'oldest' one, arbitrarily. + 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 => recall_older_patch + newp%older => sites(s)%youngest_patch newp%younger => null() - recall_older_patch%younger => newp + sites(s)%youngest_patch%younger => newp sites(s)%youngest_patch => newp end if - recall_older_patch => newp ! remember this patch for the next one to point at. ! Initialize the litter pools to zero, these ! pools will be populated by looping over the existing patches From 51112204bf678dc9b68d0a80f89e01814b805224 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 13 Aug 2021 16:06:18 -0700 Subject: [PATCH 192/209] Slight refactoring ed_ecosystems_dynamics for simplicity Refactored the do_patch_dynamics check added for SP mode as well as some older duplicate logic checks that can be combined. --- main/EDMainMod.F90 | 310 ++++++++++++++++++++++----------------------- 1 file changed, 149 insertions(+), 161 deletions(-) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 4fcfd82ed0..48820e5ad6 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -1,11 +1,11 @@ module EDMainMod ! =========================================================================== - ! Main ED module. + ! Main ED module. ! ============================================================================ use shr_kind_mod , only : r8 => shr_kind_r8 - + use FatesGlobals , only : fates_log use FatesInterfaceTypesMod , only : hlm_freq_day @@ -13,13 +13,13 @@ module EDMainMod use FatesInterfaceTypesMod , only : hlm_days_per_year use FatesInterfaceTypesMod , only : hlm_current_year use FatesInterfaceTypesMod , only : hlm_current_month - use FatesInterfaceTypesMod , only : hlm_current_day + use FatesInterfaceTypesMod , only : hlm_current_day use FatesInterfaceTypesMod , only : hlm_use_planthydro use FatesInterfaceTypesMod , only : hlm_parteh_mode use FatesInterfaceTypesMod , only : hlm_use_cohort_age_tracking use FatesInterfaceTypesMod , only : hlm_reference_date use FatesInterfaceTypesMod , only : hlm_use_ed_prescribed_phys - use FatesInterfaceTypesMod , only : hlm_use_ed_st3 + use FatesInterfaceTypesMod , only : hlm_use_ed_st3 use FatesInterfaceTypesMod , only : hlm_use_sp use FatesInterfaceTypesMod , only : bc_in_type use FatesInterfaceTypesMod , only : bc_out_type @@ -52,7 +52,7 @@ module EDMainMod use EDCohortDynamicsMod , only : UpdateCohortBioPhysRates use FatesSoilBGCFluxMod , only : PrepNutrientAquisitionBCs use FatesSoilBGCFluxMod , only : PrepCH4BCs - use SFMainMod , only : fire_model + use SFMainMod , only : fire_model use FatesSizeAgeTypeIndicesMod, only : get_age_class_index use FatesSizeAgeTypeIndicesMod, only : coagetype_class_index use FatesLitterMod , only : litter_type @@ -74,7 +74,7 @@ module EDMainMod use FatesPlantHydraulicsMod , only : UpdateSizeDepPlantHydProps use FatesPlantHydraulicsMod , only : UpdateSizeDepPlantHydStates use FatesPlantHydraulicsMod , only : InitPlantHydStates - use FatesPlantHydraulicsMod , only : UpdateSizeDepRhizHydProps + use FatesPlantHydraulicsMod , only : UpdateSizeDepRhizHydProps use FatesPlantHydraulicsMod , only : AccumulateMortalityWaterStorage use FatesAllometryMod , only : h_allom,tree_sai,tree_lai use FatesPlantHydraulicsMod , only : UpdateSizeDepRhizHydStates @@ -112,18 +112,18 @@ module EDMainMod public :: ed_update_site ! ! !PRIVATE MEMBER FUNCTIONS: - + private :: ed_integrate_state_variables private :: TotalBalanceCheck private :: bypass_dynamics - + logical :: debug = .false. integer, parameter :: final_check_id = -1 - + character(len=*), parameter, private :: sourcefile = & __FILE__ - + ! ! 10/30/09: Created by Rosie Fisher !----------------------------------------------------------------------- @@ -134,7 +134,7 @@ module EDMainMod subroutine ed_ecosystem_dynamics(currentSite, bc_in, bc_out) ! ! !DESCRIPTION: - ! Core of ed model, calling all subsequent vegetation dynamics routines + ! Core of ed model, calling all subsequent vegetation dynamics routines ! ! !ARGUMENTS: type(ed_site_type) , intent(inout), target :: currentSite @@ -143,7 +143,7 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in, bc_out) ! ! !LOCAL VARIABLES: type(ed_patch_type), pointer :: currentPatch - integer :: el ! Loop counter for elements + integer :: el ! Loop counter for elements integer :: do_patch_dynamics ! for some modes, we turn off patch dynamics !----------------------------------------------------------------------- @@ -151,9 +151,9 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in, bc_out) if ( hlm_masterproc==itrue ) write(fates_log(),'(A,I4,A,I2.2,A,I2.2)') 'FATES Dynamics: ',& hlm_current_year,'-',hlm_current_month,'-',hlm_current_day - ! Consider moving this towards the end, because some of these + ! Consider moving this towards the end, because some of these ! are being integrated over the short time-step - + do el = 1,num_elements call currentSite%mass_balance(el)%ZeroMassBalFlux() call currentSite%flux_diags(el)%ZeroFluxDiags() @@ -164,9 +164,9 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in, bc_out) call IsItLoggingTime(hlm_masterproc,currentSite) !************************************************************************** - ! Fire, growth, biogeochemistry. + ! Fire, growth, biogeochemistry. !************************************************************************** - + !FIX(SPM,032414) take this out. On startup these values are all zero and on restart it !zeros out values read in the restart file @@ -176,7 +176,7 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in, bc_out) ! Zero fluxes in and out of litter pools call ZeroLitterFluxes(currentSite) - ! Zero mass balance + ! Zero mass balance call TotalBalanceCheck(currentSite, 0) ! We do not allow phenology while in ST3 mode either, it is hypothetically @@ -185,23 +185,22 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in, bc_out) if (hlm_use_ed_st3.eq.ifalse)then if(hlm_use_sp.eq.ifalse) then call phenology(currentSite, bc_in ) - else + else call satellite_phenology(currentSite, bc_in ) end if ! SP phenology end if if (hlm_use_ed_st3.eq.ifalse.and.hlm_use_sp.eq.ifalse) then ! Bypass if ST3 - call fire_model(currentSite, bc_in) + call fire_model(currentSite, bc_in) ! Calculate disturbance and mortality based on previous timestep vegetation. ! disturbance_rates calls logging mortality and other mortalities, Yi Xu call disturbance_rates(currentSite, bc_in) - end if - if (hlm_use_ed_st3.eq.ifalse.and.hlm_use_sp.eq.ifalse) then ! Integrate state variables from annual rates to daily timestep - call ed_integrate_state_variables(currentSite, bc_in, bc_out ) + call ed_integrate_state_variables(currentSite, bc_in, bc_out ) + else ! ed_intergrate_state_variables is where the new cohort flag ! is set. This flag designates wether a cohort has @@ -210,44 +209,41 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in, bc_out) ! Make sure cohorts are marked as non-recruits call bypass_dynamics(currentSite) - + end if !****************************************************************************** - ! Reproduction, Recruitment and Cohort Dynamics : controls cohort organization + ! Reproduction, Recruitment and Cohort Dynamics : controls cohort organization !****************************************************************************** - if(hlm_use_ed_st3.eq.ifalse.and.hlm_use_sp.eq.ifalse) then + if(hlm_use_ed_st3.eq.ifalse.and.hlm_use_sp.eq.ifalse) then currentPatch => currentSite%oldest_patch - do while (associated(currentPatch)) - + do while (associated(currentPatch)) + ! adds small cohort of each PFT call recruitment(currentSite, currentPatch, bc_in) - + currentPatch => currentPatch%younger enddo - end if - - call TotalBalanceCheck(currentSite,1) + call TotalBalanceCheck(currentSite,1) - if( hlm_use_ed_st3.eq.ifalse .and.hlm_use_sp.eq.ifalse ) then currentPatch => currentSite%oldest_patch do while (associated(currentPatch)) - + ! puts cohorts in right order - call sort_cohorts(currentPatch) + call sort_cohorts(currentPatch) ! kills cohorts that are too few call terminate_cohorts(currentSite, currentPatch, 1, 10, bc_in ) ! fuses similar cohorts call fuse_cohorts(currentSite,currentPatch, bc_in ) - + ! kills cohorts for various other reasons call terminate_cohorts(currentSite, currentPatch, 2, 10, bc_in ) - - + + currentPatch => currentPatch%younger enddo end if @@ -259,58 +255,50 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in, bc_out) !********************************************************************************* do_patch_dynamics = itrue - if(hlm_use_ed_st3.eq.itrue)then - do_patch_dynamics = ifalse - end if - - if(hlm_use_nocomp.eq.itrue)then - ! n.b. the this is currently set to false to get around a memory leak that occurs - ! when we have multiple patches for each PFT. + if(hlm_use_ed_st3.eq.itrue .or. & + hlm_use_nocomp.eq.itrue .or. & + hlm_use_sp.eq.itrue)then + ! n.b. this is currently set to false to get around a memory leak that occurs + ! when we have multiple patches for each PFT. ! when this is fixed, we will need another option for 'one patch per PFT' vs 'multiple patches per PFT' - do_patch_dynamics = ifalse - end if - - if(hlm_use_sp.eq.itrue)then ! cover for potential changes in nocomp logic above. + ! hlm_use_sp check provides cover for potential changes in nocomp logic (nocomp required by spmode, but + ! not the other way around). do_patch_dynamics = ifalse end if - + ! make new patches from disturbed land if (do_patch_dynamics.eq.itrue ) then call spawn_patches(currentSite, bc_in) - end if - call TotalBalanceCheck(currentSite,3) + call TotalBalanceCheck(currentSite,3) + + ! fuse on the spawned patches. + call fuse_patches(currentSite, bc_in ) - ! fuse on the spawned patches. - if ( do_patch_dynamics.eq.itrue ) then - call fuse_patches(currentSite, bc_in ) - ! If using BC FATES hydraulics, update the rhizosphere geometry ! based on the new cohort-patch structure - ! 'rhizosphere geometry' (column-level root biomass + rootfr --> root length + ! 'rhizosphere geometry' (column-level root biomass + rootfr --> root length ! density --> node radii and volumes) if( (hlm_use_planthydro.eq.itrue) .and. do_growthrecruiteffects) then call UpdateSizeDepRhizHydProps(currentSite, bc_in) call UpdateSizeDepRhizHydStates(currentSite, bc_in) end if - end if - ! SP has changes in leaf carbon but we don't expect them to be in balance. - call TotalBalanceCheck(currentSite,4) + ! SP has changes in leaf carbon but we don't expect them to be in balance. + call TotalBalanceCheck(currentSite,4) - ! kill patches that are too small - if ( do_patch_dynamics.eq.itrue ) then - call terminate_patches(currentSite) + ! kill patches that are too small + call terminate_patches(currentSite) end if call TotalBalanceCheck(currentSite,5) - + end subroutine ed_ecosystem_dynamics !-------------------------------------------------------------------------------! subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) ! - + ! !DESCRIPTION: ! FIX(SPM,032414) refactor so everything goes through interface ! @@ -318,7 +306,7 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) use FatesInterfaceTypesMod, only : hlm_use_cohort_age_tracking use FatesConstantsMod, only : itrue ! !ARGUMENTS: - + type(ed_site_type) , intent(inout) :: currentSite type(bc_in_type) , intent(in) :: bc_in type(bc_out_type) , intent(inout) :: bc_out @@ -329,7 +317,7 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) type(ed_patch_type) , pointer :: currentPatch type(ed_cohort_type) , pointer :: currentCohort - integer :: c ! Counter for litter size class + integer :: c ! Counter for litter size class integer :: ft ! Counter for PFT integer :: io_si ! global site index for history writing integer :: iscpf ! index for the size-class x pft multiplexed bins @@ -374,7 +362,7 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) ! Update Canopy Biomass Pools currentCohort => currentPatch%shortest - do while(associated(currentCohort)) + do while(associated(currentCohort)) ft = currentCohort%pft @@ -387,20 +375,20 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) ! ----------------------------------------------------------------------------- ! ----------------------------------------------------------------------------- ! Identify the net carbon gain for this dynamics interval - ! Set the available carbon pool, identify allocation portions, and + ! Set the available carbon pool, identify allocation portions, and ! decrement the available carbon pool to zero. ! ----------------------------------------------------------------------------- - - + + if (hlm_use_ed_prescribed_phys .eq. itrue) then if (currentCohort%canopy_layer .eq. 1) then currentCohort%npp_acc = EDPftvarcon_inst%prescribed_npp_canopy(ft) & - * currentCohort%c_area / currentCohort%n / hlm_days_per_year + * currentCohort%c_area / currentCohort%n / hlm_days_per_year else currentCohort%npp_acc = EDPftvarcon_inst%prescribed_npp_understory(ft) & * currentCohort%c_area / currentCohort%n / hlm_days_per_year endif - + ! We don't explicitly define a respiration rate for prescribe phys ! but we do need to pass mass balance. So we say it is zero respiration currentCohort%gpp_acc = currentCohort%npp_acc @@ -416,15 +404,15 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) ! ! convert from kgC/indiv/day into kgC/indiv/year ! _acc_hold is remembered until the next dynamics step (used for I/O) - ! _acc will be reset soon and will be accumulated on the next leaf + ! _acc will be reset soon and will be accumulated on the next leaf ! photosynthesis step ! ----------------------------------------------------------------------------- - + currentCohort%npp_acc_hold = currentCohort%npp_acc * real(hlm_days_per_year,r8) currentCohort%gpp_acc_hold = currentCohort%gpp_acc * real(hlm_days_per_year,r8) currentCohort%resp_acc_hold = currentCohort%resp_acc * real(hlm_days_per_year,r8) - + ! Conduct Maintenance Turnover (parteh) if(debug) call currentCohort%prt%CheckMassConservation(ft,3) if(any(currentSite%dstatus == [phen_dstat_moiston,phen_dstat_timeon])) then @@ -446,10 +434,10 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) ! ----------------------------------------------------------------------------- ! Growth and Allocation (PARTEH) ! ----------------------------------------------------------------------------- - + call currentCohort%prt%DailyPRT() - + ! Update the mass balance tracking for the daily nutrient uptake flux ! Then zero out the daily uptakes, they have been used ! ----------------------------------------------------------------------------- @@ -457,64 +445,64 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) if(hlm_parteh_mode .eq. prt_cnp_flex_allom_hyp ) then ! Mass balance for N uptake - currentSite%mass_balance(element_pos(nitrogen_element))%net_root_uptake = & + currentSite%mass_balance(element_pos(nitrogen_element))%net_root_uptake = & currentSite%mass_balance(element_pos(nitrogen_element))%net_root_uptake + & (currentCohort%daily_nh4_uptake+currentCohort%daily_no3_uptake- & currentCohort%daily_n_efflux)*currentCohort%n - + ! Mass balance for P uptake - currentSite%mass_balance(element_pos(phosphorus_element))%net_root_uptake = & - currentSite%mass_balance(element_pos(phosphorus_element))%net_root_uptake + & + currentSite%mass_balance(element_pos(phosphorus_element))%net_root_uptake = & + currentSite%mass_balance(element_pos(phosphorus_element))%net_root_uptake + & (currentCohort%daily_p_uptake-currentCohort%daily_p_efflux)*currentCohort%n - + ! mass balance for C efflux (if any) - currentSite%mass_balance(element_pos(carbon12_element))%net_root_uptake = & - currentSite%mass_balance(element_pos(carbon12_element))%net_root_uptake - & + currentSite%mass_balance(element_pos(carbon12_element))%net_root_uptake = & + currentSite%mass_balance(element_pos(carbon12_element))%net_root_uptake - & currentCohort%daily_c_efflux*currentCohort%n - + ! size class index iscpf = currentCohort%size_by_pft_class - + ! Diagnostics for uptake, by size and pft, [kgX/ha/day] - + io_si = currentSite%h_gid - + fates_hist%hvars(ih_nh4uptake_scpf)%r82d(io_si,iscpf) = & fates_hist%hvars(ih_nh4uptake_scpf)%r82d(io_si,iscpf) + & currentCohort%daily_nh4_uptake*currentCohort%n fates_hist%hvars(ih_no3uptake_scpf)%r82d(io_si,iscpf) = & - fates_hist%hvars(ih_no3uptake_scpf)%r82d(io_si,iscpf) + & + fates_hist%hvars(ih_no3uptake_scpf)%r82d(io_si,iscpf) + & currentCohort%daily_no3_uptake*currentCohort%n fates_hist%hvars(ih_puptake_scpf)%r82d(io_si,iscpf) = & - fates_hist%hvars(ih_puptake_scpf)%r82d(io_si,iscpf) + & + fates_hist%hvars(ih_puptake_scpf)%r82d(io_si,iscpf) + & currentCohort%daily_p_uptake*currentCohort%n - + fates_hist%hvars(ih_nh4uptake_si)%r81d(io_si) = & - fates_hist%hvars(ih_nh4uptake_si)%r81d(io_si) + & + fates_hist%hvars(ih_nh4uptake_si)%r81d(io_si) + & currentCohort%daily_nh4_uptake*currentCohort%n fates_hist%hvars(ih_no3uptake_si)%r81d(io_si) = & - fates_hist%hvars(ih_no3uptake_si)%r81d(io_si) + & + fates_hist%hvars(ih_no3uptake_si)%r81d(io_si) + & currentCohort%daily_no3_uptake*currentCohort%n fates_hist%hvars(ih_puptake_si)%r81d(io_si) = & - fates_hist%hvars(ih_puptake_si)%r81d(io_si) + & + fates_hist%hvars(ih_puptake_si)%r81d(io_si) + & currentCohort%daily_p_uptake*currentCohort%n - + ! Diagnostics on efflux, size and pft [kgX/ha/day] - currentSite%flux_diags(element_pos(nitrogen_element))%nutrient_efflux_scpf(iscpf) = & - currentSite%flux_diags(element_pos(nitrogen_element))%nutrient_efflux_scpf(iscpf) + & + currentSite%flux_diags(element_pos(nitrogen_element))%nutrient_efflux_scpf(iscpf) = & + currentSite%flux_diags(element_pos(nitrogen_element))%nutrient_efflux_scpf(iscpf) + & currentCohort%daily_n_efflux*currentCohort%n - - currentSite%flux_diags(element_pos(phosphorus_element))%nutrient_efflux_scpf(iscpf) = & - currentSite%flux_diags(element_pos(phosphorus_element))%nutrient_efflux_scpf(iscpf) + & + + currentSite%flux_diags(element_pos(phosphorus_element))%nutrient_efflux_scpf(iscpf) = & + currentSite%flux_diags(element_pos(phosphorus_element))%nutrient_efflux_scpf(iscpf) + & currentCohort%daily_p_efflux*currentCohort%n - - currentSite%flux_diags(element_pos(carbon12_element))%nutrient_efflux_scpf(iscpf) = & - currentSite%flux_diags(element_pos(carbon12_element))%nutrient_efflux_scpf(iscpf) + & + + currentSite%flux_diags(element_pos(carbon12_element))%nutrient_efflux_scpf(iscpf) = & + currentSite%flux_diags(element_pos(carbon12_element))%nutrient_efflux_scpf(iscpf) + & currentCohort%daily_c_efflux*currentCohort%n ! Diagnostics on plant nutrient need @@ -533,7 +521,7 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) currentCohort%gpp_acc * currentCohort%n site_cmass%aresp_acc = site_cmass%aresp_acc + & currentCohort%resp_acc * currentCohort%n - + call currentCohort%prt%CheckMassConservation(ft,5) ! Update the leaf biophysical rates based on proportion of leaf @@ -544,10 +532,10 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) ! This cohort has grown, it is no longer "new" currentCohort%isnew = .false. - + ! Update the plant height (if it has grown) call h_allom(currentCohort%dbh,ft,currentCohort%hite) - + currentCohort%dhdt = (currentCohort%hite-hite_old)/hlm_freq_day currentCohort%ddbhdt = (currentCohort%dbh-dbh_old)/hlm_freq_day @@ -557,9 +545,9 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) currentCohort%npp_acc = 0.0_r8 currentCohort%gpp_acc = 0.0_r8 currentCohort%resp_acc = 0.0_r8 - - ! BOC...update tree 'hydraulic geometry' - ! (size --> heights of elements --> hydraulic path lengths --> + + ! BOC...update tree 'hydraulic geometry' + ! (size --> heights of elements --> hydraulic path lengths --> ! maximum node-to-node conductances) if( (hlm_use_planthydro.eq.itrue) .and. do_growthrecruiteffects) then call UpdateSizeDepPlantHydProps(currentSite,currentCohort, bc_in) @@ -585,10 +573,10 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) currentPatch => currentPatch%older end do - - + + ! When plants die, the water goes with them. This effects - ! the water balance. + ! the water balance. if( hlm_use_planthydro == itrue ) then currentPatch => currentSite%youngest_patch @@ -602,22 +590,22 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) currentPatch => currentPatch%older end do end if - + ! With growth and mortality rates now calculated we can determine the seed rain ! fluxes. However, because this is potentially a cross-patch mixing model ! we will calculate this as a group call SeedIn(currentSite,bc_in) - + ! Calculate all other litter fluxes ! ----------------------------------------------------------------------------------- currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) - + call PreDisturbanceLitterFluxes( currentSite, currentPatch, bc_in) - + call PreDisturbanceIntegrateLitter(currentPatch ) @@ -632,15 +620,15 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) call FluxIntoLitterPools(currentsite, bc_in, bc_out) - ! Update cohort number. - ! This needs to happen after the CWD_input and seed_input calculations as they - ! assume the pre-mortality currentCohort%n. - + ! Update cohort number. + ! This needs to happen after the CWD_input and seed_input calculations as they + ! assume the pre-mortality currentCohort%n. + currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) currentCohort => currentPatch%shortest - do while(associated(currentCohort)) - currentCohort%n = max(0._r8,currentCohort%n + currentCohort%dndt * hlm_freq_day ) + do while(associated(currentCohort)) + currentCohort%n = max(0._r8,currentCohort%n + currentCohort%dndt * hlm_freq_day ) currentCohort => currentCohort%taller enddo currentPatch => currentPatch%older @@ -657,8 +645,8 @@ subroutine ed_update_site( currentSite, bc_in, bc_out ) ! Calls routines to consolidate the ED growth process. ! Canopy Structure to assign canopy layers to cohorts ! Canopy Spread to figure out the size of tree crowns - ! Trim_canopy to figure out the target leaf biomass. - ! Extra recruitment to fill empty patches. + ! Trim_canopy to figure out the target leaf biomass. + ! Extra recruitment to fill empty patches. ! ! !USES: use EDCanopyStructureMod , only : canopy_spread, canopy_structure @@ -669,7 +657,7 @@ subroutine ed_update_site( currentSite, bc_in, bc_out ) type(bc_out_type) , intent(inout) :: bc_out ! ! !LOCAL VARIABLES: - type (ed_patch_type) , pointer :: currentPatch + type (ed_patch_type) , pointer :: currentPatch !----------------------------------------------------------------------- if(hlm_use_sp.eq.ifalse)then call canopy_spread(currentSite) @@ -685,17 +673,17 @@ subroutine ed_update_site( currentSite, bc_in, bc_out ) currentPatch => currentSite%oldest_patch do while(associated(currentPatch)) - - ! Is termination really needed here? + + ! Is termination really needed here? ! Canopy_structure just called it several times! (rgk) - call terminate_cohorts(currentSite, currentPatch, 1, 11, bc_in) + 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) - currentPatch => currentPatch%younger + currentPatch => currentPatch%younger enddo ! The HLMs need to know about nutrient demand, and/or @@ -705,28 +693,28 @@ subroutine ed_update_site( currentSite, bc_in, bc_out ) ! The HLM methane module needs information about ! rooting mass, distributions, respiration rates and NPP call PrepCH4BCs(currentSite,bc_in,bc_out) - + ! FIX(RF,032414). This needs to be monthly, not annual ! If this is the second to last day of the year, then perform trimming if( hlm_day_of_year == hlm_days_per_year-1) then if(hlm_use_sp.eq.ifalse)then - call trim_canopy(currentSite) + call trim_canopy(currentSite) endif endif end subroutine ed_update_site !-------------------------------------------------------------------------------! - + subroutine TotalBalanceCheck (currentSite, call_index ) ! ! !DESCRIPTION: - ! This routine looks at the mass flux in and out of the FATES and compares it to + ! This routine looks at the mass flux in and out of the FATES and compares it to ! the change in total stocks (states). - ! Fluxes in are NPP. Fluxes out are decay of CWD and litter into SOM pools. + ! Fluxes in are NPP. Fluxes out are decay of CWD and litter into SOM pools. ! ! !ARGUMENTS: type(ed_site_type) , intent(inout) :: currentSite @@ -739,7 +727,7 @@ subroutine TotalBalanceCheck (currentSite, call_index ) real(r8) :: seed_stock ! total seed mass in Kg/site real(r8) :: total_stock ! total ED carbon in Kg/site real(r8) :: change_in_stock ! Change since last time we set ed_allsites_inst%old_stock in this routine. KgC/site - real(r8) :: error ! How much carbon did we gain or lose (should be zero!) + real(r8) :: error ! How much carbon did we gain or lose (should be zero!) real(r8) :: error_frac ! Error as a fraction of total biomass real(r8) :: net_flux ! Difference between recorded fluxes in and out. KgC/site real(r8) :: flux_in ! mass flux into fates control volume @@ -753,11 +741,11 @@ subroutine TotalBalanceCheck (currentSite, call_index ) integer :: el ! loop counter for element types - ! nb. There is no time associated with these variables - ! because this routine can be called between any two - ! arbitrary points in code, even if no time has passed. - ! Also, the carbon pools are per site/gridcell, so that - ! we can account for the changing areas of patches. + ! nb. There is no time associated with these variables + ! because this routine can be called between any two + ! arbitrary points in code, even if no time has passed. + ! Also, the carbon pools are per site/gridcell, so that + ! we can account for the changing areas of patches. type(ed_patch_type) , pointer :: currentPatch type(ed_cohort_type) , pointer :: currentCohort @@ -771,32 +759,32 @@ subroutine TotalBalanceCheck (currentSite, call_index ) change_in_stock = 0.0_r8 - + ! Loop through the number of elements in the system do el = 1, num_elements - + site_mass => currentSite%mass_balance(el) call SiteMassStock(currentSite,el,total_stock,biomass_stock,litter_stock,seed_stock) change_in_stock = total_stock - site_mass%old_stock - flux_in = site_mass%seed_in + & + flux_in = site_mass%seed_in + & site_mass%net_root_uptake + & site_mass%gpp_acc + & site_mass%flux_generic_in + & site_mass%patch_resize_err flux_out = site_mass%wood_product + & - site_mass%burn_flux_to_atm + & - site_mass%seed_out + & + site_mass%burn_flux_to_atm + & + site_mass%seed_out + & site_mass%flux_generic_out + & - site_mass%frag_out + & - site_mass%aresp_acc + site_mass%frag_out + & + site_mass%aresp_acc net_flux = flux_in - flux_out - error = abs(net_flux - change_in_stock) + error = abs(net_flux - change_in_stock) if(change_in_stock>0.0)then @@ -823,19 +811,19 @@ subroutine TotalBalanceCheck (currentSite, call_index ) write(fates_log(),*) 'burn_flux_to_atm: ',site_mass%burn_flux_to_atm write(fates_log(),*) 'seed_out: ',site_mass%seed_out write(fates_log(),*) 'flux_generic_out: ',site_mass%flux_generic_out - write(fates_log(),*) 'frag_out: ',site_mass%frag_out + write(fates_log(),*) 'frag_out: ',site_mass%frag_out write(fates_log(),*) 'aresp_acc: ',site_mass%aresp_acc write(fates_log(),*) 'error=net_flux-dstock:', error write(fates_log(),*) 'biomass', biomass_stock write(fates_log(),*) 'litter',litter_stock write(fates_log(),*) 'seeds',seed_stock write(fates_log(),*) 'total stock', total_stock - write(fates_log(),*) 'previous total',site_mass%old_stock + write(fates_log(),*) 'previous total',site_mass%old_stock write(fates_log(),*) 'lat lon',currentSite%lat,currentSite%lon - + ! If this is the first day of simulation, carbon balance reports but does not end the run ! if(( hlm_current_year*10000 + hlm_current_month*100 + hlm_current_day).ne.hlm_reference_date) then - + currentPatch => currentSite%oldest_patch do while(associated(currentPatch)) litt => currentPatch%litter(el) @@ -876,7 +864,7 @@ subroutine TotalBalanceCheck (currentSite, call_index ) write(fates_log(),*) 'C efflux: ',currentCohort%daily_c_efflux*currentCohort%n end if - + currentCohort => currentCohort%shorter enddo !end cohort loop end if @@ -885,7 +873,7 @@ subroutine TotalBalanceCheck (currentSite, call_index ) write(fates_log(),*) 'aborting on date:',hlm_current_year,hlm_current_month,hlm_current_day call endrun(msg=errMsg(sourcefile, __LINE__)) !end if - + endif ! This is the last check of the sequence, where we update our total @@ -896,11 +884,11 @@ subroutine TotalBalanceCheck (currentSite, call_index ) end if end do - end if ! not SP mode + end if ! not SP mode end subroutine TotalBalanceCheck - + ! ===================================================================================== - + subroutine bypass_dynamics(currentSite) ! ---------------------------------------------------------------------------------- @@ -912,15 +900,15 @@ subroutine bypass_dynamics(currentSite) ! Arguments type(ed_site_type) , intent(inout), target :: currentSite - + ! Locals type(ed_patch_type), pointer :: currentPatch type(ed_cohort_type), pointer :: currentCohort - + currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) currentCohort => currentPatch%shortest - do while(associated(currentCohort)) + do while(associated(currentCohort)) currentCohort%isnew=.false. @@ -956,7 +944,7 @@ subroutine bypass_dynamics(currentSite) enddo currentPatch => currentPatch%older enddo - + end subroutine bypass_dynamics end module EDMainMod From 443550de1a9a54ef194c9c3e1128c0ae95b659ef Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 25 Aug 2021 14:59:48 -0600 Subject: [PATCH 193/209] reverting all the area_pft indexing commits --- biogeochem/EDCanopyStructureMod.F90 | 4 ++-- main/EDInitMod.F90 | 14 +++++++------- 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 6d3b6f723b..261d087d3b 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1924,10 +1924,10 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) currentPatch => sites(s)%oldest_patch c = fcolumn(s) do while(associated(currentPatch)) - !if(currentPatch%nocomp_pft_label.ne.0)then + if(currentPatch%nocomp_pft_label.ne.0)then ! only increase ifp for veg patches, not bareground (in SP mode) ifp = ifp+1 - !endif ! stay with ifp=0 for bareground patch. + endif ! stay with ifp=0 for bareground patch. if ( currentPatch%total_canopy_area-currentPatch%area > 0.000001_r8 ) then write(fates_log(),*) 'ED: canopy area bigger than area',currentPatch%total_canopy_area ,currentPatch%area currentPatch%total_canopy_area = currentPatch%area diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index bb06f57de1..89d800df3a 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -133,7 +133,7 @@ subroutine init_site_vars( site_in, bc_in, bc_out ) allocate(site_in%dz_soil(site_in%nlevsoil)) allocate(site_in%z_soil(site_in%nlevsoil)) - allocate(site_in%area_pft(0:numpft)) ! Changing to zero indexing + allocate(site_in%area_pft(1:numpft)) ! Changing to zero indexing allocate(site_in%use_this_pft(1:numpft)) ! SP mode @@ -327,11 +327,11 @@ subroutine set_site_properties( nsites, sites,bc_in ) end do !hlm_pft do ft = 1,numpft - ! if(sites(s)%area_pft(ft).lt.0.01_r8.and.sites(s)%area_pft(ft).gt.0.0_r8)then - ! write(fates_log(),*) 'removing small pft patches',s,ft,sites(s)%area_pft(ft) - ! sites(s)%area_pft(ft)=0.0_r8 - ! ! remove tiny patches to prevent numerical errors in terminate patches - ! endif + if(sites(s)%area_pft(ft).lt.0.01_r8.and.sites(s)%area_pft(ft).gt.0.0_r8)then + write(fates_log(),*) 'removing small pft patches',s,ft,sites(s)%area_pft(ft) + sites(s)%area_pft(ft)=0.0_r8 + ! remove tiny patches to prevent numerical errors in terminate patches + endif if(sites(s)%area_pft(ft).lt.0._r8)then write(fates_log(),*) 'negative area',s,ft,sites(s)%area_pft(ft) call endrun(msg=errMsg(sourcefile, __LINE__)) @@ -482,7 +482,7 @@ subroutine init_patches( nsites, sites, bc_in) if(hlm_use_nocomp.eq.itrue)then num_new_patches = numpft if(hlm_use_sp.eq.itrue)then - !num_new_patches = numpft + 1 ! bare ground patch in SP mode. + num_new_patches = numpft + 1 ! bare ground patch in SP mode. start_patch = 0 ! start at the bare ground patch endif ! allocate(newppft(numpft)) From 28473d095b7d832b8bb5fb5b67096cff8d9aab40 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux <7565064+glemieux@users.noreply.github.com> Date: Wed, 1 Sep 2021 11:28:22 -0700 Subject: [PATCH 194/209] Update biogeochem/EDPhysiologyMod.F90 Updating the element id from a number to the element parameter name to clarify. Co-authored-by: Charlie Koven --- biogeochem/EDPhysiologyMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index f0df5f9067..859f6e3534 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1555,7 +1555,7 @@ subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,l end if !small error if(init.eq.ifalse)then - call SetState(currentCohort%prt,leaf_organ,1,leaf_c,1) + call SetState(currentCohort%prt, leaf_organ, carbon12_element, leaf_c, 1) endif ! assert sai From a260f31d6f31464457b06de6f97761aa6df9b1db Mon Sep 17 00:00:00 2001 From: ckoven Date: Wed, 1 Sep 2021 18:04:39 -0600 Subject: [PATCH 195/209] adding hist var for sp lai by pft --- main/FatesHistoryInterfaceMod.F90 | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 97f3342b43..b06cb828f4 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -505,6 +505,7 @@ module FatesHistoryInterfaceMod ! indices to (site x pft) variables integer :: ih_biomass_si_pft integer :: ih_leafbiomass_si_pft + integer :: ih_splai_si_pft integer :: ih_storebiomass_si_pft integer :: ih_nindivs_si_pft integer :: ih_recruitment_si_pft @@ -1792,6 +1793,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_canopy_spread_si => this%hvars(ih_canopy_spread_si)%r81d, & hio_biomass_si_pft => this%hvars(ih_biomass_si_pft)%r82d, & hio_leafbiomass_si_pft => this%hvars(ih_leafbiomass_si_pft)%r82d, & + hio_splai_si_pft => this%hvars(ih_splai_si_pft)%r82d, & hio_storebiomass_si_pft => this%hvars(ih_storebiomass_si_pft)%r82d, & hio_nindivs_si_pft => this%hvars(ih_nindivs_si_pft)%r82d, & hio_recruitment_si_pft => this%hvars(ih_recruitment_si_pft)%r82d, & @@ -2131,6 +2133,11 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_harvest_carbonflux_si(io_si) = sites(s)%harvest_carbon_flux + do i_pft = 1,numpft + hio_splai_si_pft(io_si,i_pft) = sites(s)%sp_tlai(i_pft) + end do + + ipa = 0 cpatch => sites(s)%oldest_patch do while(associated(cpatch)) @@ -4337,6 +4344,11 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_leafbiomass_si_pft ) + call this%set_history_var(vname='PFT_SP_LAI', units='m2/m2', & + long='total PFT-level LAI', use_default='active', & + avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_splai_si_pft ) + call this%set_history_var(vname='PFTstorebiomass', units='gC/m2', & long='total PFT level stored biomass', use_default='active', & avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & From 455617d9edc070b197f5a62625e878e929225175 Mon Sep 17 00:00:00 2001 From: ckoven Date: Thu, 2 Sep 2021 13:51:24 -0600 Subject: [PATCH 196/209] removing init and c_leaf arguments to assign_cohort_SP_properties --- biogeochem/EDPhysiologyMod.F90 | 15 +++++++-------- main/EDInitMod.F90 | 6 ++++-- 2 files changed, 11 insertions(+), 10 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 859f6e3534..6b0d38c815 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1447,7 +1447,8 @@ subroutine satellite_phenology(currentSite, bc_in) end if ! Call routine to invert SP drivers into cohort properites. - call assign_cohort_SP_properties(currentCohort, currentSite%sp_htop(fates_pft), currentSite%sp_tlai(fates_pft) , currentSite%sp_tsai(fates_pft),currentPatch%area,ifalse,leaf_c) + call assign_cohort_SP_properties(currentCohort, currentSite%sp_htop(fates_pft), currentSite%sp_tlai(fates_pft), & + currentSite%sp_tsai(fates_pft), currentPatch%area) currentCohort => currentCohort%shorter end do !cohort loop @@ -1458,7 +1459,7 @@ end subroutine satellite_phenology ! ===================================================================================== - subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,leaf_c) + subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea) ! -----------------------------------------------------------------------------------! ! Takes the daily inputs of leaf area index, stem area index and canopy height and @@ -1473,9 +1474,8 @@ subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,l real(r8), intent(in) :: tsai ! target stem area index from SP inputs real(r8), intent(in) :: htop ! target tree height from SP inputs real(r8), intent(in) :: parea ! patch area for this PFT - integer, intent(in) :: init ! are we in the initialization routine? if so do not set leaf_c - real(r8), intent(out) :: leaf_c ! leaf carbon estimated to generate target tlai + real(r8) :: leaf_c ! leaf carbon estimated to generate target tlai real(r8) :: dummy_n ! set cohort n to a dummy value of 1.0 integer :: fates_pft ! fates pft numer for weighting loop real(r8) :: spread ! dummy value of canopy spread to estimate c_area @@ -1551,13 +1551,12 @@ subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,l end if else write(fates_log(),*) 'SPassign, big error in c_area',currentCohort%c_area-parea,currentCohort%pft + call endrun(msg=errMsg(sourcefile, __LINE__)) end if ! still broken end if !small error - if(init.eq.ifalse)then - call SetState(currentCohort%prt, leaf_organ, carbon12_element, leaf_c, 1) - endif - + call SetState(currentCohort%prt, leaf_organ, carbon12_element, leaf_c, 1) + ! assert sai currentCohort%treesai = tsai diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 89d800df3a..e086257356 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -739,11 +739,13 @@ subroutine init_cohorts( site_in, patch_in, bc_in) ! h,dbh,leafc,n from SP values or from small initial size. if(hlm_use_sp.eq.itrue)then - init = itrue + ! At this point, we do not know the bc_in values of tlai tsai and htop, ! so this is initializing to an arbitrary value for the very first timestep. ! Not sure if there's a way around this or not. - call assign_cohort_SP_properties(temp_cohort, 0.5_r8,0.2_r8, 0.1_r8,patch_in%area,init,c_leaf) + call assign_cohort_SP_properties(temp_cohort, 0.5_r8,0.2_r8, 0.1_r8,patch_in%area) + + c_leaf = temp_cohort%prt%GetState(leaf_organ, carbon12_element) else temp_cohort%hite = EDPftvarcon_inst%hgt_min(pft) From 919e27fd54d06e25e9707b91d28bc29e8d3fa440 Mon Sep 17 00:00:00 2001 From: ckoven Date: Thu, 2 Sep 2021 20:50:21 -0600 Subject: [PATCH 197/209] Revert "removing init and c_leaf arguments to assign_cohort_SP_properties" This reverts commit 455617d9edc070b197f5a62625e878e929225175. --- biogeochem/EDPhysiologyMod.F90 | 15 ++++++++------- main/EDInitMod.F90 | 6 ++---- 2 files changed, 10 insertions(+), 11 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 6b0d38c815..859f6e3534 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1447,8 +1447,7 @@ subroutine satellite_phenology(currentSite, bc_in) end if ! Call routine to invert SP drivers into cohort properites. - call assign_cohort_SP_properties(currentCohort, currentSite%sp_htop(fates_pft), currentSite%sp_tlai(fates_pft), & - currentSite%sp_tsai(fates_pft), currentPatch%area) + call assign_cohort_SP_properties(currentCohort, currentSite%sp_htop(fates_pft), currentSite%sp_tlai(fates_pft) , currentSite%sp_tsai(fates_pft),currentPatch%area,ifalse,leaf_c) currentCohort => currentCohort%shorter end do !cohort loop @@ -1459,7 +1458,7 @@ end subroutine satellite_phenology ! ===================================================================================== - subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea) + subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,leaf_c) ! -----------------------------------------------------------------------------------! ! Takes the daily inputs of leaf area index, stem area index and canopy height and @@ -1474,8 +1473,9 @@ subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea) real(r8), intent(in) :: tsai ! target stem area index from SP inputs real(r8), intent(in) :: htop ! target tree height from SP inputs real(r8), intent(in) :: parea ! patch area for this PFT + integer, intent(in) :: init ! are we in the initialization routine? if so do not set leaf_c + real(r8), intent(out) :: leaf_c ! leaf carbon estimated to generate target tlai - real(r8) :: leaf_c ! leaf carbon estimated to generate target tlai real(r8) :: dummy_n ! set cohort n to a dummy value of 1.0 integer :: fates_pft ! fates pft numer for weighting loop real(r8) :: spread ! dummy value of canopy spread to estimate c_area @@ -1551,12 +1551,13 @@ subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea) end if else write(fates_log(),*) 'SPassign, big error in c_area',currentCohort%c_area-parea,currentCohort%pft - call endrun(msg=errMsg(sourcefile, __LINE__)) end if ! still broken end if !small error - call SetState(currentCohort%prt, leaf_organ, carbon12_element, leaf_c, 1) - + if(init.eq.ifalse)then + call SetState(currentCohort%prt, leaf_organ, carbon12_element, leaf_c, 1) + endif + ! assert sai currentCohort%treesai = tsai diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index e086257356..89d800df3a 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -739,13 +739,11 @@ subroutine init_cohorts( site_in, patch_in, bc_in) ! h,dbh,leafc,n from SP values or from small initial size. if(hlm_use_sp.eq.itrue)then - + init = itrue ! At this point, we do not know the bc_in values of tlai tsai and htop, ! so this is initializing to an arbitrary value for the very first timestep. ! Not sure if there's a way around this or not. - call assign_cohort_SP_properties(temp_cohort, 0.5_r8,0.2_r8, 0.1_r8,patch_in%area) - - c_leaf = temp_cohort%prt%GetState(leaf_organ, carbon12_element) + call assign_cohort_SP_properties(temp_cohort, 0.5_r8,0.2_r8, 0.1_r8,patch_in%area,init,c_leaf) else temp_cohort%hite = EDPftvarcon_inst%hgt_min(pft) From 5664f68ba89e05544af4035642b4e9dbed10b3fc Mon Sep 17 00:00:00 2001 From: ckoven Date: Fri, 3 Sep 2021 12:59:46 -0600 Subject: [PATCH 198/209] changing area_pft indexing in init --- main/EDInitMod.F90 | 33 +++++++++++++++++---------------- main/EDTypesMod.F90 | 2 -- 2 files changed, 17 insertions(+), 18 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 89d800df3a..49b811f54c 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -133,7 +133,12 @@ subroutine init_site_vars( site_in, bc_in, bc_out ) allocate(site_in%dz_soil(site_in%nlevsoil)) allocate(site_in%z_soil(site_in%nlevsoil)) - allocate(site_in%area_pft(1:numpft)) ! Changing to zero indexing + if (hlm_use_nocomp .eq. itrue) then + allocate(site_in%area_pft(1:numpft)) + else ! SP and nocomp require a bare-ground patch. + allocate(site_in%area_pft(0:numpft)) + endif + allocate(site_in%use_this_pft(1:numpft)) ! SP mode @@ -331,7 +336,7 @@ subroutine set_site_properties( nsites, sites,bc_in ) write(fates_log(),*) 'removing small pft patches',s,ft,sites(s)%area_pft(ft) sites(s)%area_pft(ft)=0.0_r8 ! remove tiny patches to prevent numerical errors in terminate patches - endif + endif if(sites(s)%area_pft(ft).lt.0._r8)then write(fates_log(),*) 'negative area',s,ft,sites(s)%area_pft(ft) call endrun(msg=errMsg(sourcefile, __LINE__)) @@ -344,8 +349,9 @@ subroutine set_site_properties( nsites, sites,bc_in ) ! the bare ground will no longer be proscribed and should emerge from FATES ! this may or may not be the right way to deal with this? - if(hlm_use_sp.eq.ifalse)then ! when not in SP mode, subsume bare ground evenly into the existing patches. - !n.b. that it might be better if nocomp mode used the same bare groud logic as SP mode. + if(hlm_use_nocomp.eq.ifalse)then ! when not in nocomp (i.e. or SP) mode, + ! subsume bare ground evenly into the existing patches. + sumarea = sum(sites(s)%area_pft(1:numpft)) do ft = 1,numpft if(sumarea.gt.0._r8)then @@ -356,23 +362,23 @@ subroutine set_site_properties( nsites, sites,bc_in ) ! all pfts and let the model figure out whether land should be bare or not. end if end do !ft - else ! for sp mode, assert a bare ground patch + else ! for sp and nocomp mode, assert a bare ground patch if needed sumarea = sum(sites(s)%area_pft(1:numpft)) ! In all the other FATES modes, bareground is the area in which plants - ! do not grow of their own accord. In SP mod wweassert that the canopy is full for - ! each PFT patche. Thus, we also need to assert a bare ground area in - ! order to not have all of the ground filled by leaves. + ! do not grow of their own accord. In SP mode we assert that the canopy is full for + ! each PFT patch. Thus, we also need to assert a bare ground area in + ! order to not have all of the ground filled by leaves. ! Further to that, one could calculate bare ground as the remaining area when ! all fhe canopies are accounted for, but this means we don't pass balance checks - ! on canopy are inside FATES, and so in SP mode, we define the bare groud + ! on canopy are inside FATES, and so in SP mode, we define the bare groud ! patch as having a PFT identifier as zero. if(sumarea.lt.area)then !make some bare ground - sites(s)%area_bareground = area - sumarea + sites(s)%area_pft(0) = area - sumarea else - sites(s)%area_bareground = 0.0_r8 + sites(s)%area_pft(0) = 0.0_r8 end if end if !sp mode end if !fixed biogeog @@ -516,11 +522,6 @@ subroutine init_patches( nsites, sites, bc_in) newparea = area end if !nocomp mode - if(hlm_use_sp.eq.itrue.and.n.eq.0)then ! bare ground patch - newparea = sites(s)%area_bareground - nocomp_pft = 0 - end if - if(newparea.gt.0._r8)then ! Stop patches being initilialized when PFT not present in nocomop mode allocate(newp) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 0c7e8ef56e..b7d3eedb96 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -701,8 +701,6 @@ module EDTypesMod real(r8), allocatable :: sp_tsai(:) ! target TSAI per FATES pft real(r8), allocatable :: sp_htop(:) ! target HTOP per FATES pft - real(r8) :: area_bareground ! in SP mode we assert a bare ground fraction - ! Mass Balance (allocation for each element) type(site_massbal_type), pointer :: mass_balance(:) From 482fc9410a4afa0edb5a502fd294d2099059fbc3 Mon Sep 17 00:00:00 2001 From: ckoven Date: Fri, 3 Sep 2021 13:19:39 -0600 Subject: [PATCH 199/209] debug --- main/EDInitMod.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 49b811f54c..77266ef149 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -134,9 +134,9 @@ subroutine init_site_vars( site_in, bc_in, bc_out ) allocate(site_in%z_soil(site_in%nlevsoil)) if (hlm_use_nocomp .eq. itrue) then - allocate(site_in%area_pft(1:numpft)) + allocate(site_in%area_pft(0:numpft)) else ! SP and nocomp require a bare-ground patch. - allocate(site_in%area_pft(0:numpft)) + allocate(site_in%area_pft(1:numpft)) endif allocate(site_in%use_this_pft(1:numpft)) From d2892e4a729b504385a7d97692a527c64c8bf61a Mon Sep 17 00:00:00 2001 From: ckoven Date: Fri, 3 Sep 2021 13:49:40 -0600 Subject: [PATCH 200/209] fixing loop bounds --- main/EDInitMod.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 77266ef149..c3b503a729 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -488,7 +488,6 @@ subroutine init_patches( nsites, sites, bc_in) if(hlm_use_nocomp.eq.itrue)then num_new_patches = numpft if(hlm_use_sp.eq.itrue)then - num_new_patches = numpft + 1 ! bare ground patch in SP mode. start_patch = 0 ! start at the bare ground patch endif ! allocate(newppft(numpft)) From c009135046fe23a394f12730a8e57232e1d08ebd Mon Sep 17 00:00:00 2001 From: ckoven Date: Fri, 3 Sep 2021 14:57:24 -0600 Subject: [PATCH 201/209] indexing bc_outs to ignore the bare-groun PFTs entirely. --- biogeochem/EDCanopyStructureMod.F90 | 158 ++++++++++++++-------------- 1 file changed, 79 insertions(+), 79 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 261d087d3b..1ce56c17af 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1924,97 +1924,97 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) currentPatch => sites(s)%oldest_patch c = fcolumn(s) do while(associated(currentPatch)) - if(currentPatch%nocomp_pft_label.ne.0)then - ! only increase ifp for veg patches, not bareground (in SP mode) - ifp = ifp+1 - endif ! stay with ifp=0 for bareground patch. - if ( currentPatch%total_canopy_area-currentPatch%area > 0.000001_r8 ) then - write(fates_log(),*) 'ED: canopy area bigger than area',currentPatch%total_canopy_area ,currentPatch%area - currentPatch%total_canopy_area = currentPatch%area - endif + ifp = ifp+1 - if (associated(currentPatch%tallest)) then - bc_out(s)%htop_pa(ifp) = currentPatch%tallest%hite - else - ! FIX(RF,040113) - should this be a parameter for the minimum possible vegetation height? - bc_out(s)%htop_pa(ifp) = 0.1_r8 - endif + if(currentPatch%nocomp_pft_label.ne.0)then ! ignore the bare-ground-PFT patch entirely for these BC outs - bc_out(s)%hbot_pa(ifp) = max(0._r8, min(0.2_r8, bc_out(s)%htop_pa(ifp)- 1.0_r8)) - ! Use leaf area weighting for all cohorts in the patch to define the characteristic - ! leaf width used by the HLM - ! ---------------------------------------------------------------------------- - ! bc_out(s)%dleaf_pa(ifp) = 0.0_r8 - ! if(currentPatch%lai>1.0e-9_r8) then - ! currentCohort => currentPatch%shortest - ! do while(associated(currentCohort)) - ! weight = min(1.0_r8,currentCohort%lai/currentPatch%lai) - ! bc_out(s)%dleaf_pa(ifp) = bc_out(s)%dleaf_pa(ifp) + & - ! EDPftvarcon_inst%dleaf(currentCohort%pft)*weight - ! currentCohort => currentCohort%taller - ! enddo - ! end if - - ! Roughness length and displacement height are not PFT properties, they are - ! properties of the canopy assemblage. Defining this needs an appropriate model. - ! Right now z0 and d are pft level parameters. For the time being we will just - ! use the 1st index until a suitable model is defined. (RGK 04-2017) - ! ----------------------------------------------------------------------------- - bc_out(s)%z0m_pa(ifp) = EDPftvarcon_inst%z0mr(1) * bc_out(s)%htop_pa(ifp) - bc_out(s)%displa_pa(ifp) = EDPftvarcon_inst%displar(1) * bc_out(s)%htop_pa(ifp) - bc_out(s)%dleaf_pa(ifp) = EDPftvarcon_inst%dleaf(1) - - ! We are assuming here that grass is all located underneath tree canopies. - ! The alternative is to assume it is all spatial distinct from tree canopies. - ! In which case, the bare area would have to be reduced by the grass area... - ! currentPatch%total_canopy_area/currentPatch%area is fraction of this patch cover by plants - ! currentPatch%area/AREA is the fraction of the soil covered by this patch. - if(currentPatch%area.gt.0.0_r8)then - bc_out(s)%canopy_fraction_pa(ifp) = & - min(1.0_r8,currentPatch%total_canopy_area/currentPatch%area)*(currentPatch%area/AREA) - else - bc_out(s)%canopy_fraction_pa(ifp) = 0.0_r8 - endif + if ( currentPatch%total_canopy_area-currentPatch%area > 0.000001_r8 ) then + write(fates_log(),*) 'ED: canopy area bigger than area',currentPatch%total_canopy_area ,currentPatch%area + currentPatch%total_canopy_area = currentPatch%area + endif - bare_frac_area = (1.0_r8 - min(1.0_r8,currentPatch%total_canopy_area/currentPatch%area)) * & - (currentPatch%area/AREA) + if (associated(currentPatch%tallest)) then + bc_out(s)%htop_pa(ifp) = currentPatch%tallest%hite + else + ! FIX(RF,040113) - should this be a parameter for the minimum possible vegetation height? + bc_out(s)%htop_pa(ifp) = 0.1_r8 + endif - total_patch_area = total_patch_area + bc_out(s)%canopy_fraction_pa(ifp) + bare_frac_area + bc_out(s)%hbot_pa(ifp) = max(0._r8, min(0.2_r8, bc_out(s)%htop_pa(ifp)- 1.0_r8)) + + ! Use leaf area weighting for all cohorts in the patch to define the characteristic + ! leaf width used by the HLM + ! ---------------------------------------------------------------------------- + ! bc_out(s)%dleaf_pa(ifp) = 0.0_r8 + ! if(currentPatch%lai>1.0e-9_r8) then + ! currentCohort => currentPatch%shortest + ! do while(associated(currentCohort)) + ! weight = min(1.0_r8,currentCohort%lai/currentPatch%lai) + ! bc_out(s)%dleaf_pa(ifp) = bc_out(s)%dleaf_pa(ifp) + & + ! EDPftvarcon_inst%dleaf(currentCohort%pft)*weight + ! currentCohort => currentCohort%taller + ! enddo + ! end if + + ! Roughness length and displacement height are not PFT properties, they are + ! properties of the canopy assemblage. Defining this needs an appropriate model. + ! Right now z0 and d are pft level parameters. For the time being we will just + ! use the 1st index until a suitable model is defined. (RGK 04-2017) + ! ----------------------------------------------------------------------------- + bc_out(s)%z0m_pa(ifp) = EDPftvarcon_inst%z0mr(1) * bc_out(s)%htop_pa(ifp) + bc_out(s)%displa_pa(ifp) = EDPftvarcon_inst%displar(1) * bc_out(s)%htop_pa(ifp) + bc_out(s)%dleaf_pa(ifp) = EDPftvarcon_inst%dleaf(1) + + ! We are assuming here that grass is all located underneath tree canopies. + ! The alternative is to assume it is all spatial distinct from tree canopies. + ! In which case, the bare area would have to be reduced by the grass area... + ! currentPatch%total_canopy_area/currentPatch%area is fraction of this patch cover by plants + ! currentPatch%area/AREA is the fraction of the soil covered by this patch. + + if(currentPatch%area.gt.0.0_r8)then + bc_out(s)%canopy_fraction_pa(ifp) = & + min(1.0_r8,currentPatch%total_canopy_area/currentPatch%area)*(currentPatch%area/AREA) + else + bc_out(s)%canopy_fraction_pa(ifp) = 0.0_r8 + endif - total_canopy_area = total_canopy_area + bc_out(s)%canopy_fraction_pa(ifp) + bare_frac_area = (1.0_r8 - min(1.0_r8,currentPatch%total_canopy_area/currentPatch%area)) * & + (currentPatch%area/AREA) - bc_out(s)%nocomp_pft_label_pa(ifp) = currentPatch%nocomp_pft_label + total_patch_area = total_patch_area + bc_out(s)%canopy_fraction_pa(ifp) + bare_frac_area - ! Calculate area indices for output boundary to HLM - ! It is assumed that cpatch%canopy_area_profile and cpat%xai_profiles - ! have been updated (ie ed_leaf_area_profile has been called since dynamics has been called) + total_canopy_area = total_canopy_area + bc_out(s)%canopy_fraction_pa(ifp) - bc_out(s)%elai_pa(ifp) = calc_areaindex(currentPatch,'elai') - bc_out(s)%tlai_pa(ifp) = calc_areaindex(currentPatch,'tlai') - bc_out(s)%esai_pa(ifp) = calc_areaindex(currentPatch,'esai') - bc_out(s)%tsai_pa(ifp) = calc_areaindex(currentPatch,'tsai') + bc_out(s)%nocomp_pft_label_pa(ifp) = currentPatch%nocomp_pft_label - !if(debug) then - ! write(fates_log(),*) 'ifp: ', ifp - ! write(fates_log(),*) 'bc_out(s)%elai_pa(ifp): ', bc_out(s)%elai_pa(ifp) - ! write(fates_log(),*) 'bc_out(s)%tlai_pa(ifp): ', bc_out(s)%tlai_pa(ifp) - ! write(fates_log(),*) 'bc_out(s)%esai_pa(ifp): ', bc_out(s)%esai_pa(ifp) - ! write(fates_log(),*) 'bc_out(s)%tsai_pa(ifp): ', bc_out(s)%tsai_pa(ifp) - !end if + ! Calculate area indices for output boundary to HLM + ! It is assumed that cpatch%canopy_area_profile and cpat%xai_profiles + ! have been updated (ie ed_leaf_area_profile has been called since dynamics has been called) - ! Fraction of vegetation free of snow. This is used to flag those - ! patches which shall under-go photosynthesis - ! INTERF-TODO: we may want to stop using frac_veg_nosno_alb and let - ! FATES internal variables decide if photosynthesis is possible - ! we are essentially calculating it inside FATES to tell the - ! host to tell itself when to do things (circuitous). Just have - ! to determine where else it is used + bc_out(s)%elai_pa(ifp) = calc_areaindex(currentPatch,'elai') + bc_out(s)%tlai_pa(ifp) = calc_areaindex(currentPatch,'tlai') + bc_out(s)%esai_pa(ifp) = calc_areaindex(currentPatch,'esai') + bc_out(s)%tsai_pa(ifp) = calc_areaindex(currentPatch,'tsai') - if ((bc_out(s)%elai_pa(ifp) + bc_out(s)%esai_pa(ifp)) > 0._r8) then - bc_out(s)%frac_veg_nosno_alb_pa(ifp) = 1.0_r8 - else - bc_out(s)%frac_veg_nosno_alb_pa(ifp) = 0.0_r8 + ! Fraction of vegetation free of snow. This is used to flag those + ! patches which shall under-go photosynthesis + ! INTERF-TODO: we may want to stop using frac_veg_nosno_alb and let + ! FATES internal variables decide if photosynthesis is possible + ! we are essentially calculating it inside FATES to tell the + ! host to tell itself when to do things (circuitous). Just have + ! to determine where else it is used + + if ((bc_out(s)%elai_pa(ifp) + bc_out(s)%esai_pa(ifp)) > 0._r8) then + bc_out(s)%frac_veg_nosno_alb_pa(ifp) = 1.0_r8 + else + bc_out(s)%frac_veg_nosno_alb_pa(ifp) = 0.0_r8 + end if + + else ! nocomp or SP, and currentPatch%nocomp_pft_label .eq. 0 + + total_patch_area = total_patch_area + currentPatch%area/AREA + end if currentPatch => currentPatch%younger end do From 3507ad3aa14a0bcae0d19de9529f70c9e625aeac Mon Sep 17 00:00:00 2001 From: ckoven Date: Fri, 3 Sep 2021 15:24:23 -0600 Subject: [PATCH 202/209] Revert "adding hist var for sp lai by pft" This reverts commit a260f31d6f31464457b06de6f97761aa6df9b1db. --- main/FatesHistoryInterfaceMod.F90 | 12 ------------ 1 file changed, 12 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index b06cb828f4..97f3342b43 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -505,7 +505,6 @@ module FatesHistoryInterfaceMod ! indices to (site x pft) variables integer :: ih_biomass_si_pft integer :: ih_leafbiomass_si_pft - integer :: ih_splai_si_pft integer :: ih_storebiomass_si_pft integer :: ih_nindivs_si_pft integer :: ih_recruitment_si_pft @@ -1793,7 +1792,6 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_canopy_spread_si => this%hvars(ih_canopy_spread_si)%r81d, & hio_biomass_si_pft => this%hvars(ih_biomass_si_pft)%r82d, & hio_leafbiomass_si_pft => this%hvars(ih_leafbiomass_si_pft)%r82d, & - hio_splai_si_pft => this%hvars(ih_splai_si_pft)%r82d, & hio_storebiomass_si_pft => this%hvars(ih_storebiomass_si_pft)%r82d, & hio_nindivs_si_pft => this%hvars(ih_nindivs_si_pft)%r82d, & hio_recruitment_si_pft => this%hvars(ih_recruitment_si_pft)%r82d, & @@ -2133,11 +2131,6 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_harvest_carbonflux_si(io_si) = sites(s)%harvest_carbon_flux - do i_pft = 1,numpft - hio_splai_si_pft(io_si,i_pft) = sites(s)%sp_tlai(i_pft) - end do - - ipa = 0 cpatch => sites(s)%oldest_patch do while(associated(cpatch)) @@ -4344,11 +4337,6 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_leafbiomass_si_pft ) - call this%set_history_var(vname='PFT_SP_LAI', units='m2/m2', & - long='total PFT-level LAI', use_default='active', & - avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_splai_si_pft ) - call this%set_history_var(vname='PFTstorebiomass', units='gC/m2', & long='total PFT level stored biomass', use_default='active', & avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & From 70c319557375d650c7dbe1075215a7e662eddd9a Mon Sep 17 00:00:00 2001 From: ckoven Date: Fri, 3 Sep 2021 15:52:42 -0600 Subject: [PATCH 203/209] bugfixes --- biogeochem/EDCanopyStructureMod.F90 | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 1ce56c17af..08e6c0513f 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1925,10 +1925,10 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) c = fcolumn(s) do while(associated(currentPatch)) - ifp = ifp+1 - if(currentPatch%nocomp_pft_label.ne.0)then ! ignore the bare-ground-PFT patch entirely for these BC outs + ifp = ifp+1 + if ( currentPatch%total_canopy_area-currentPatch%area > 0.000001_r8 ) then write(fates_log(),*) 'ED: canopy area bigger than area',currentPatch%total_canopy_area ,currentPatch%area currentPatch%total_canopy_area = currentPatch%area @@ -2040,11 +2040,8 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) if(currentPatch%nocomp_pft_label.ne.0)then ! for vegetated patches only ifp = ifp+1 bc_out(s)%canopy_fraction_pa(ifp) = bc_out(s)%canopy_fraction_pa(ifp)/total_patch_area - else ! for the bareground patch (in SP mode). - bc_out(s)%canopy_fraction_pa(ifp) =0.0_r8 endif ! veg patch - currentPatch => currentPatch%younger end do From cc5b2edaf298e88b3d2e9b59113782ed74caf3e4 Mon Sep 17 00:00:00 2001 From: ckoven Date: Tue, 14 Sep 2021 22:13:27 -0600 Subject: [PATCH 204/209] added fire variables to allow nocomp to pass restart comparison with fire on --- main/FatesRestartInterfaceMod.F90 | 34 +++++++++++++++++++++++++++++++ 1 file changed, 34 insertions(+) diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 81ae74f975..69cc2e3f8b 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -36,6 +36,7 @@ module FatesRestartInterfaceMod use FatesLitterMod, only : litter_type use FatesLitterMod, only : ncwd use FatesLitterMod, only : ndcmpy + use EDTypesMod, only : nfsc use PRTGenericMod, only : prt_global use PRTGenericMod, only : num_elements @@ -174,6 +175,8 @@ module FatesRestartInterfaceMod integer :: ir_lfines_frag_litt integer :: ir_rfines_frag_litt + integer :: ir_scorch_ht_pa_pft + integer :: ir_litter_moisture_pa_nfsc ! Site level integer :: ir_watermem_siwm @@ -920,6 +923,13 @@ subroutine define_restart_vars(this, initialize_variables) long_name='are of the ED patch', units='m2', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_area_pa ) + call this%set_restart_var(vname='fates_scorch_ht_pa_pft', vtype=cohort_r8, & + long_name='scorch height', units='m', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_scorch_ht_pa_pft) + + call this%set_restart_var(vname='fates_litter_moisture_pa_nfsc', vtype=cohort_r8, & + long_name='scorch height', units='m', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_litter_moisture_pa_nfsc) ! Site Level Diagnostics over multiple nutrients @@ -1974,6 +1984,18 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ,io_idx_co,cohortsperpatch endif + io_idx_pa_pft = io_idx_co_1st + do i = 1,numpft + this%rvars(ir_scorch_ht_pa_pft)%r81d(io_idx_pa_pft) = cpatch%scorch_ht(i) + io_idx_pa_pft = io_idx_pa_pft + 1 + end do + + io_idx_pa_cwd = io_idx_co_1st + do i = 1,nfsc + this%rvars(ir_litter_moisture_pa_nfsc)%r81d(io_idx_pa_cwd) = cpatch%litter_moisture(i) + io_idx_pa_cwd = io_idx_pa_cwd + 1 + end do + ! -------------------------------------------------------------------------- ! Send litter to the restart arrays ! Each element has its own variable, so we have to make sure @@ -2761,6 +2783,18 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ,io_idx_co,cohortsperpatch endif + io_idx_pa_pft = io_idx_co_1st + do i = 1,numpft + cpatch%scorch_ht(i) = this%rvars(ir_scorch_ht_pa_pft)%r81d(io_idx_pa_pft) + io_idx_pa_pft = io_idx_pa_pft + 1 + end do + + io_idx_pa_cwd = io_idx_co_1st + do i = 1,nfsc + cpatch%litter_moisture(i) = this%rvars(ir_litter_moisture_pa_nfsc)%r81d(io_idx_pa_cwd) + io_idx_pa_cwd = io_idx_pa_cwd + 1 + end do + ! -------------------------------------------------------------------------- ! Pull litter from the restart arrays ! Each element has its own variable, so we have to make sure From 54e35d19932ea2a827ef6cb6d94b8431cdb898f7 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 15 Sep 2021 16:50:33 -0700 Subject: [PATCH 205/209] correcting the location of the ncl cohort index assignment --- main/FatesRestartInterfaceMod.F90 | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 69cc2e3f8b..5fe3b267a1 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -774,7 +774,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name='fates cohort- daily ammonium [NH4] uptake', & units='kg/plant/day', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_daily_nh4_uptake_co ) - + call this%set_restart_var(vname='fates_daily_no3_uptake', vtype=cohort_r8, & long_name='fates cohort- daily ammonium [NO3] uptake', & units='kg/plant/day', flushval = flushzero, & @@ -976,7 +976,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name_base='seed bank fragmentation flux (germinated)', & units='kg/m2', veclength=num_elements, flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_seedgerm_decay_litt) - + call this%RegisterCohortVector(symbol_base='fates_ag_cwd_frag', vtype=cohort_r8, & long_name_base='above ground CWD frag flux', & units='kg/m2/day', veclength=num_elements, flushval = flushzero, & @@ -1132,7 +1132,7 @@ subroutine define_restart_vars(this, initialize_variables) units='kg/indiv', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_errh2o ) - + end if @@ -1752,7 +1752,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) io_idx_pa_ib = io_idx_co_1st io_idx_si_wmem = io_idx_co_1st io_idx_si_vtmem = io_idx_co_1st - + io_idx_pa_ncl = io_idx_co_1st ! Hydraulics counters lyr = hydraulic layer, shell = rhizosphere shell io_idx_si_lyr_shell = io_idx_co_1st @@ -2009,7 +2009,6 @@ subroutine set_restart_vectors(this,nc,nsites,sites) io_idx_pa_cwsl = io_idx_co_1st io_idx_pa_dcsl = io_idx_co_1st io_idx_pa_dc = io_idx_co_1st - io_idx_pa_ncl = io_idx_co_1st litt => cpatch%litter(el+1) @@ -2179,7 +2178,7 @@ end subroutine set_restart_vectors ! ==================================================================================== - subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in, bc_out) + subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in, bc_out) ! ---------------------------------------------------------------------------------- ! This subroutine takes a peak at the restart file to determine how to allocate @@ -2493,7 +2492,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) rio_hmort_co => this%rvars(ir_hmort_co)%r81d, & rio_cmort_co => this%rvars(ir_cmort_co)%r81d, & rio_daily_nh4_uptake_co => this%rvars(ir_daily_nh4_uptake_co)%r81d, & - rio_daily_no3_uptake_co => this%rvars(ir_daily_no3_uptake_co)%r81d, & + rio_daily_no3_uptake_co => this%rvars(ir_daily_no3_uptake_co)%r81d, & rio_daily_p_uptake_co => this%rvars(ir_daily_p_uptake_co)%r81d, & rio_daily_c_efflux_co => this%rvars(ir_daily_c_efflux_co)%r81d, & rio_daily_n_efflux_co => this%rvars(ir_daily_n_efflux_co)%r81d, & From b7fd5f5a5a0b9f7e351d1140484a74884a9579e2 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 27 Sep 2021 11:59:23 -0400 Subject: [PATCH 206/209] Removed unnecessary manual attribution statement (author history in github) --- biogeophys/FatesPlantHydraulicsMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 58babee43a..8baf2b4df5 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -969,7 +969,7 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) ! to the layer-by-layer absorbing root (which is now a hybrid compartment) ! ------------------------------------------------------------------------------ ccohort_hydr%v_troot = (1._r8-t2aroot_vol_donate_frac) * v_troot - ! modified by Junyan May 29, 2020 + ! Partition the total absorbing root lengths and volumes into the active soil layers ! We have a condition, where we may ignore the first layer ! ------------------------------------------------------------------------------ From a7b29b4e14e16880f1720ea9297ddfabc54b1952 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 30 Sep 2021 17:39:27 -0400 Subject: [PATCH 207/209] Small fix in batch params script to workaround parser bug --- tools/BatchPatchParams.py | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/tools/BatchPatchParams.py b/tools/BatchPatchParams.py index 57edb7dfcb..ee78ebcbd0 100755 --- a/tools/BatchPatchParams.py +++ b/tools/BatchPatchParams.py @@ -51,8 +51,11 @@ def parse_syscall_str(fnamein,fnameout,param_name,param_val): sys_call_str = "../tools/modify_fates_paramfile.py"+" --fin " + fnamein + \ " --fout " + fnameout + " --var " + param_name + " --silent " +\ - " --val " + param_val + " --overwrite --all" + " --val " + "\" "+param_val+"\"" + " --overwrite --all" + + print(sys_call_str) + return(sys_call_str) From a3b094f290ece99730658b0d7c1c5fd2365cb3ee Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 1 Oct 2021 10:05:33 -0400 Subject: [PATCH 208/209] cleaning up root depth branch --- biogeochem/EDCanopyStructureMod.F90 | 12 ++++++------ biogeochem/FatesAllometryMod.F90 | 2 +- biogeophys/FatesPlantHydraulicsMod.F90 | 24 +++++++++--------------- fire/SFMainMod.F90 | 2 +- main/FatesHistoryInterfaceMod.F90 | 5 +++-- main/FatesHydraulicsMemMod.F90 | 10 +++++----- 6 files changed, 25 insertions(+), 30 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 08e6c0513f..586a4b39af 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1601,19 +1601,19 @@ subroutine leaf_area_profile( currentSite ) currentCohort => currentPatch%shortest do while(associated(currentCohort)) ft = currentCohort%pft - min_chite = currentCohort%hite - currentCohort%hite * EDPftvarcon_inst%crown(ft) + min_chite = currentCohort%hite - currentCohort%hite * prt_params%crown(ft) max_chite = currentCohort%hite do iv = 1,N_HITE_BINS frac_canopy(iv) = 0.0_r8 ! this layer is in the middle of the canopy if(max_chite > maxh(iv).and.min_chite < minh(iv))then - frac_canopy(iv)= min(1.0_r8,dh / (currentCohort%hite*EDPftvarcon_inst%crown(ft))) + frac_canopy(iv)= min(1.0_r8,dh / (currentCohort%hite*prt_params%crown(ft))) ! this is the layer with the bottom of the canopy in it. elseif(min_chite < maxh(iv).and.min_chite > minh(iv).and.max_chite > maxh(iv))then - frac_canopy(iv) = (maxh(iv) -min_chite ) / (currentCohort%hite*EDPftvarcon_inst%crown(ft)) + frac_canopy(iv) = (maxh(iv) -min_chite ) / (currentCohort%hite*prt_params%crown(ft)) ! this is the layer with the top of the canopy in it. elseif(max_chite > minh(iv).and.max_chite < maxh(iv).and.min_chite < minh(iv))then - frac_canopy(iv) = (max_chite - minh(iv)) / (currentCohort%hite*EDPftvarcon_inst%crown(ft)) + frac_canopy(iv) = (max_chite - minh(iv)) / (currentCohort%hite*prt_params%crown(ft)) elseif(max_chite < maxh(iv).and.min_chite > minh(iv))then !the whole cohort is within this layer. frac_canopy(iv) = 1.0_r8 endif @@ -1709,11 +1709,11 @@ subroutine leaf_area_profile( currentSite ) layer_top_hite = currentCohort%hite - & ( real(iv-1,r8)/currentCohort%NV * currentCohort%hite * & - EDPftvarcon_inst%crown(currentCohort%pft) ) + prt_params%crown(currentCohort%pft) ) layer_bottom_hite = currentCohort%hite - & ( real(iv,r8)/currentCohort%NV * currentCohort%hite * & - EDPftvarcon_inst%crown(currentCohort%pft) ) + prt_params%crown(currentCohort%pft) ) fraction_exposed = 1.0_r8 if(currentSite%snow_depth > layer_top_hite)then diff --git a/biogeochem/FatesAllometryMod.F90 b/biogeochem/FatesAllometryMod.F90 index c8a38abd8c..6b315d4ef8 100644 --- a/biogeochem/FatesAllometryMod.F90 +++ b/biogeochem/FatesAllometryMod.F90 @@ -2005,7 +2005,7 @@ subroutine CrownDepth(height,ft,crown_depth) ! Original FATES crown depth heigh used for hydraulics ! crown_depth = min(height,0.1_r8) - crown_depth = prt_params%crown(ft) * plant_height + crown_depth = prt_params%crown(ft) * height return diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 87cb52fe0d..586d1b3c68 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -85,8 +85,6 @@ module FatesPlantHydraulicsMod use FatesHydraulicsMemMod, only: aroot_p_media use FatesHydraulicsMemMod, only: rhiz_p_media use FatesHydraulicsMemMod, only: nlevsoi_hyd_max -! use FatesHydraulicsMemMod, only: cohort_recruit_water_layer -! use FatesHydraulicsMemMod, only: recruit_water_avail_layer use FatesHydraulicsMemMod, only: rwccap, rwcft use FatesHydraulicsMemMod, only: ignore_layer1 @@ -1707,8 +1705,6 @@ subroutine ConstrainRecruitNumber(csite,ccohort, bc_in) integer :: element_id ! global element identifier index real(r8) :: leaf_m, store_m, sapw_m ! Element mass in organ tissues real(r8) :: fnrt_m, struct_m, repro_m ! Element mass in organ tissues - real(r8) :: cohort_recruit_water_layer(csite_hydr%nlevrhiz) - real(r8) :: recruit_water_avail_layer(csite_hydr%nlevrhiz) cpatch => ccohort%patchptr csite_hydr => csite%si_hydr @@ -1720,11 +1716,9 @@ subroutine ConstrainRecruitNumber(csite,ccohort, bc_in) sum_l_aroot = sum(ccohort_hydr%l_aroot_layer(:)) do j=1,csite_hydr%nlevrhiz - cohort_recruit_water_layer(j) = recruitw*ccohort_hydr%l_aroot_layer(j)/sum_l_aroot + csite_hydr%cohort_recruit_water_layer(j) = recruitw*ccohort_hydr%l_aroot_layer(j)/sum_l_aroot end do - recruit_water_avail_layer(:) = 0._r8 - do j=1,csite_hydr%nlevrhiz watres_local = csite_hydr%wrf_soil(j)%p%th_from_psi(bc_in%smpmin_si*denh2o*grav_earth*m_per_mm*mpa_per_pa) @@ -1733,14 +1727,14 @@ subroutine ConstrainRecruitNumber(csite,ccohort, bc_in) total_water_min = sum(csite_hydr%v_shell(j,:)*watres_local) !assumes that only 50% is available for recruit water.... - recruit_water_avail_layer(j)=0.5_r8*max(0.0_r8,total_water-total_water_min) + csite_hydr%recruit_water_avail_layer(j)=0.5_r8*max(0.0_r8,total_water-total_water_min) end do nmin = 1.0e+36 do j=1,csite_hydr%nlevrhiz - if(cohort_recruit_water_layer(j)>nearzero) then - n = recruit_water_avail_layer(j)/cohort_recruit_water_layer(j) + if(csite_hydr%cohort_recruit_water_layer(j)>nearzero) then + n = csite_hydr%recruit_water_avail_layer(j)/csite_hydr%cohort_recruit_water_layer(j) nmin = min(n, nmin) endif end do @@ -4315,7 +4309,7 @@ function zeng2001_crootfr(a, b, z, z_max) result(crootfr) if(present(z_max))then ! If the soil depth is larger than the maximum rooting depth of the cohort, ! then the cumulative root fraction of that layer equals that of the maximum rooting depth - crootfr = 1._r8 - .5_r8*(exp(-a*min(z,z_max)) + exp(-b*min(z,z_max)) + crootfr = 1._r8 - .5_r8*(exp(-a*min(z,z_max)) + exp(-b*min(z,z_max))) crootfr_max = 1._r8 - .5_r8*(exp(-a*z_max) + exp(-b*z_max)) crootfr = crootfr/crootfr_max end if @@ -4337,7 +4331,7 @@ end function zeng2001_crootfr ! ===================================================================================== -subroutine shellGeom(l_aroot, rs1, area_site, dz, r_out_shell, r_node_shell, v_shell) +subroutine shellGeom(l_aroot_in, rs1_in, area_site, dz, r_out_shell, r_node_shell, v_shell) ! ! !DESCRIPTION: Updates size of 'representative' rhizosphere -- node radii, volumes. ! As fine root biomass (and thus absorbing root length) increases, this characteristic @@ -4364,11 +4358,11 @@ subroutine shellGeom(l_aroot, rs1, area_site, dz, r_out_shell, r_node_shell, v_s integer :: k ! rhizosphere shell indicies integer :: nshells ! We don't use the global because of unit testing - ! When we have no roots, we use a nominal + + ! When we have no roots, we may choose to use a nominal ! value of 1cm per cubic meter to define the rhizosphere shells ! this "should" help with the transition when roots grow into a layer - - real(r8), parameter :: nominal_l_aroot = 0.01_r8 ! m/m3 + ! real(r8), parameter :: nominal_l_aroot = 0.01_r8 ! m/m3 !----------------------------------------------------------------------- diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index 00470cc6de..1d08ae2e51 100644 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -937,7 +937,7 @@ subroutine crown_damage ( currentSite ) (currentCohort%hite-crown_depth))) then currentCohort%fraction_crown_burned = (currentPatch%Scorch_ht(currentCohort%pft) - & - (currentCohort%hite - crown_depth)/crown_depth + (currentCohort%hite - crown_depth))/crown_depth else ! Flames over top of canopy. diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 3699353de5..a6e93d2a34 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -1775,6 +1775,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) real(r8) :: struct_m_net_alloc real(r8) :: repro_m_net_alloc real(r8) :: area_frac + real(r8) :: crown_depth type(ed_patch_type),pointer :: cpatch type(ed_cohort_type),pointer :: ccohort @@ -2231,8 +2232,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) endif ! what fraction of a cohort's crown is in this height bin? frac_canopy_in_bin = (min(bintop,ccohort%hite) - & - max(binbottom,ccohort%hite * (1._r8 - EDPftvarcon_inst%crown(ft)))) / & - (ccohort%hite * EDPftvarcon_inst%crown(ft)) + max(binbottom,ccohort%hite-crown_depth)) / & + (crown_depth) ! hio_leaf_height_dist_si_height(io_si,i_heightbin) = & hio_leaf_height_dist_si_height(io_si,i_heightbin) + & diff --git a/main/FatesHydraulicsMemMod.F90 b/main/FatesHydraulicsMemMod.F90 index 9fe0f03acd..f971b4f55b 100644 --- a/main/FatesHydraulicsMemMod.F90 +++ b/main/FatesHydraulicsMemMod.F90 @@ -70,9 +70,7 @@ module FatesHydraulicsMemMod ! ---------------------------------------------------------------------------------------------- !temporatory variables - !real(r8), public :: cohort_recruit_water_layer(nlevsoi_hyd_max) ! the recruit water requirement for a - ! single individual at different layer (kg H2o/m2) - !real(r8), public :: recruit_water_avail_layer(nlevsoi_hyd_max) ! the recruit water avaibility from soil (kg H2o/m2) + type, public :: ed_site_hydr_type @@ -185,10 +183,12 @@ module FatesHydraulicsMemMod real(r8), allocatable :: q_flux(:) real(r8), allocatable :: dftc_dpsi_node(:) real(r8), allocatable :: ftc_node(:) - - real(r8), allocatable :: kmax_up(:) real(r8), allocatable :: kmax_dn(:) + + ! Scratch arrays + real(r8) :: cohort_recruit_water_layer(nlevsoi_hyd_max) ! the recruit water requirement for a + real(r8) :: recruit_water_avail_layer(nlevsoi_hyd_max) ! the recruit water avaibility from soil (kg H2o/m2) contains From c94464093e4f1281eaa87dbacb5f1cf94e3d0223 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 1 Oct 2021 13:14:46 -0400 Subject: [PATCH 209/209] Created subroutine for maximum rooting depth, passing that into root bisection method used for getting transporting root depth --- biogeochem/EDCohortDynamicsMod.F90 | 2 +- biogeophys/FatesPlantHydraulicsMod.F90 | 104 ++++++++++++++++++------- 2 files changed, 75 insertions(+), 31 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 2fa98aa59f..ecdb731621 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -324,7 +324,7 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & call InitHydrCohort(currentSite,new_cohort) ! This calculates node heights - call UpdatePlantHydrNodes(new_cohort%co_hydr,new_cohort%pft, & + call UpdatePlantHydrNodes(new_cohort,new_cohort%pft, & new_cohort%hite,currentSite%si_hydr) ! This calculates volumes and lengths diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 586d1b3c68..59b5ad630e 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -350,7 +350,7 @@ subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) ccohort_hydr => ccohort%co_hydr ! This calculates node heights - call UpdatePlantHydrNodes(ccohort_hydr,ccohort%pft,ccohort%hite, & + call UpdatePlantHydrNodes(ccohort,ccohort%pft,ccohort%hite, & sites(s)%si_hydr) ! This calculates volumes and lengths @@ -651,7 +651,7 @@ end subroutine UpdatePlantPsiFTCFromTheta ! ===================================================================================== - subroutine UpdatePlantHydrNodes(ccohort_hydr,ft,plant_height,csite_hydr) + subroutine UpdatePlantHydrNodes(ccohort,ft,plant_height,csite_hydr) ! -------------------------------------------------------------------------------- ! This subroutine calculates the nodal heights critical to hydraulics in the plant @@ -668,13 +668,14 @@ subroutine UpdatePlantHydrNodes(ccohort_hydr,ft,plant_height,csite_hydr) ! -------------------------------------------------------------------------------- ! Arguments - type(ed_cohort_hydr_type), intent(inout) :: ccohort_hydr - integer,intent(in) :: ft ! plant functional type index - real(r8), intent(in) :: plant_height ! [m] - type(ed_site_hydr_type), intent(in) :: csite_hydr + type(ed_cohort_type), intent(inout) :: ccohort + integer,intent(in) :: ft ! plant functional type index + real(r8), intent(in) :: plant_height ! [m] + type(ed_site_hydr_type), intent(in) :: csite_hydr ! Locals + type(ed_cohort_hydr_type), pointer :: ccohort_hydr integer :: nlevrhiz ! number of rhizosphere layers real(r8) :: roota ! root profile parameter a zeng2001_crootfr real(r8) :: rootb ! root profile parameter b zeng2001_crootfr @@ -686,7 +687,11 @@ subroutine UpdatePlantHydrNodes(ccohort_hydr,ft,plant_height,csite_hydr) real(r8) :: cumul_rf ! cumulative root distribution where depth is determined [-] real(r8) :: z_cumul_rf ! depth at which cumul_rf occurs [m] integer :: k ! Loop counter for compartments + real(r8) :: z_fr ! Maximum rooting depth of the plant [m] + ccohort_hydr => ccohort%co_hydr + + ! Crown Nodes ! in special case where n_hypool_leaf = 1, the node height of the canopy ! water pool is 1/2 the distance from the bottom of the canopy to the top of the tree @@ -694,8 +699,9 @@ subroutine UpdatePlantHydrNodes(ccohort_hydr,ft,plant_height,csite_hydr) rootb = prt_params%fnrt_prof_b(ft) nlevrhiz = csite_hydr%nlevrhiz - call CrownDepth(plant_height,ft,crown_depth) - + !call CrownDepth(plant_height,ft,crown_depth) + crown_depth = min(plant_height,0.1_r8) + dz_canopy = crown_depth / real(n_hypool_leaf,r8) do k=1,n_hypool_leaf ccohort_hydr%z_lower_ag(k) = plant_height - dz_canopy*real(k,r8) @@ -715,10 +721,18 @@ subroutine UpdatePlantHydrNodes(ccohort_hydr,ft,plant_height,csite_hydr) ccohort_hydr%z_lower_ag(k) = ccohort_hydr%z_upper_ag(k) - dz_stem enddo + call MaximumRootingDepth(ccohort%dbh,ft,csite_hydr%zi_rhiz(nlevrhiz),z_fr) + ! Transporting Root Node depth [m] (negative from surface) - call bisect_rootfr(roota, rootb, 0._r8, 1.E10_r8, & + call bisect_rootfr(roota, rootb, z_fr, 0._r8, 1.E10_r8, & 0.001_r8, 0.001_r8, 0.5_r8, z_cumul_rf) + + if(z_cumul_rf > csite_hydr%zi_rhiz(nlevrhiz) ) then + print*,"z_cumul_rf > zi_rhiz(nlevrhiz)?",z_cumul_rf,csite_hydr%zi_rhiz(nlevrhiz) + stop + end if + z_cumul_rf = min(z_cumul_rf, abs(csite_hydr%zi_rhiz(nlevrhiz))) ccohort_hydr%z_node_troot = -z_cumul_rf @@ -775,7 +789,7 @@ subroutine UpdateSizeDepPlantHydProps(currentSite,ccohort,bc_in) call SavePreviousCompartmentVolumes(ccohort_hydr) ! This updates all of the z_node positions - call UpdatePlantHydrNodes(ccohort_hydr,ft,ccohort%hite,currentSite%si_hydr) + call UpdatePlantHydrNodes(ccohort,ft,ccohort%hite,currentSite%si_hydr) ! This updates plant compartment volumes, lengths and ! maximum conductances. Make sure for already @@ -862,13 +876,7 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) struct_c = ccohort%prt%GetState(struct_organ, carbon12_element) roota = prt_params%fnrt_prof_a(ft) rootb = prt_params%fnrt_prof_b(ft) - dbh_max = prt_params%allom_zroot_max_dbh(ft) - dbh_0 = prt_params%allom_zroot_min_dbh(ft) - z_fr_max = prt_params%allom_zroot_max_z(ft) - z_fr_0 = prt_params%allom_zroot_min_z(ft) - frk = prt_params%allom_zroot_k(ft) - dbh = ccohort%dbh - dbh_rev = (dbh - dbh_0)/(dbh_max - dbh_0) + ! Leaf Volumes @@ -926,7 +934,8 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) ! alternative cross section calculation ! a_sapwood = a_leaf_tot / ( 0.001_r8 + 0.025_r8 * ccohort%hite ) * 1.e-4_r8 - call CrownDepth(ccohort%hite,ft,crown_depth) + !call CrownDepth(ccohort%hite,ft,crown_depth) + crown_depth = min(ccohort%hite,0.1_r8) z_stem = ccohort%hite - crown_depth v_sapwood = a_sapwood * z_stem ! + 0.333_r8*a_sapwood*crown_depth ccohort_hydr%v_ag(n_hypool_leaf+1:n_hypool_ag) = v_sapwood / n_hypool_stem @@ -962,14 +971,12 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) ! We have a condition, where we may ignore the first layer ! ------------------------------------------------------------------------------ ! Further, incorporate maximum rooting depth parameterization into these - ! calculations. set the rooting depth of the cohort, using the logistic functionbelow: - ! Junyan Ding 2021 - ! z_fr_max/(1 + ((z_fr_max-z_fr_0)/z_fr_0)*exp(-frk*dbh_rev)) - ! which is constrained by the maximum soil depth: site_hydr%zi_rhiz(nlevrhiz) + ! calculations. - ! The dynamic root growth model by Junyan Ding, June 9, 2021 - z_fr = min(site_hydr%zi_rhiz(nlevrhiz), z_fr_max/(1 + ((z_fr_max-z_fr_0)/z_fr_0)*exp(-frk*dbh_rev))) + + call MaximumRootingDepth(ccohort%dbh,ft,site_hydr%zi_rhiz(nlevrhiz),z_fr) + norm = 1._r8 - & zeng2001_crootfr(roota, rootb,site_hydr%zi_rhiz(1)-site_hydr%dz_rhiz(1), z_fr ) @@ -1210,7 +1217,7 @@ subroutine FuseCohortHydraulics(currentSite,currentCohort, nextCohort, bc_in, ne call SavePreviousCompartmentVolumes(ccohort_hydr) ! This updates all of the z_node positions - call UpdatePlantHydrNodes(ccohort_hydr,ft,currentCohort%hite,site_hydr) + call UpdatePlantHydrNodes(currentCohort,ft,currentCohort%hite,site_hydr) ! This updates plant compartment volumes, lengths and ! maximum conductances. Make sure for already @@ -4238,7 +4245,43 @@ end subroutine RecruitWaterStorage ! Utility Functions ! ===================================================================================== -subroutine bisect_rootfr(a, b, lower_init, upper_init, xtol, ytol, crootfr, x_new) +subroutine MaximumRootingDepth(dbh,ft,z_max_soil,z_fr) + + ! --------------------------------------------------------------------------------- + ! Calculate the maximum rooting depth of the plant. + ! + ! This is an exponential which is constrained by the maximum soil depth: + ! site_hydr%zi_rhiz(nlevrhiz) + ! The dynamic root growth model by Junyan Ding, June 9, 2021 + ! --------------------------------------------------------------------------------- + + real(r8),intent(in) :: dbh ! Plant dbh + integer,intent(in) :: ft ! Funtional type index + real(r8),intent(in) :: z_max_soil ! Maximum depth of soil (pos convention) [m] + real(r8),intent(out) :: z_fr ! Maximum depth of plant's roots + ! (pos convention) [m] + + real(r8) :: dbh_rel ! Relative dbh of plant between the diameter at which we + ! define the shallowest rooting depth (dbh_0) and the diameter + ! at which we define the deepest rooting depth (dbh_max) + + associate( & + dbh_max => prt_params%allom_zroot_max_dbh(ft), & + dbh_0 => prt_params%allom_zroot_min_dbh(ft), & + z_fr_max => prt_params%allom_zroot_max_z(ft), & + z_fr_0 => prt_params%allom_zroot_min_z(ft), & + frk => prt_params%allom_zroot_k(ft)) + + dbh_rel = min(1._r8,(max(dbh,dbh_0) - dbh_0)/(dbh_max - dbh_0)) + + z_fr = min(z_max_soil, z_fr_max/(1._r8 + ((z_fr_max-z_fr_0)/z_fr_0)*exp(-frk*dbh_rel))) + + end associate + return +end subroutine MaximumRootingDepth + + +subroutine bisect_rootfr(a, b, z_max, lower_init, upper_init, xtol, ytol, crootfr, x_new) ! ! !DESCRIPTION: Bisection routine for getting the inverse of the cumulative root ! distribution. No analytical soln bc crootfr ~ exp(ax) + exp(bx). @@ -4246,7 +4289,8 @@ subroutine bisect_rootfr(a, b, lower_init, upper_init, xtol, ytol, crootfr, x_ne ! !USES: ! ! !ARGUMENTS - real(r8) , intent(in) :: a, b ! pft root distribution constants + real(r8) , intent(in) :: a, b ! pft root distribution constants + real(r8) , intent(in) :: z_max ! maximum rooting depth real(r8) , intent(in) :: lower_init ! lower bound of initial x estimate [m] real(r8) , intent(in) :: upper_init ! upper bound of initial x estimate [m] real(r8) , intent(in) :: xtol ! error tolerance for x_new [m] @@ -4268,12 +4312,12 @@ subroutine bisect_rootfr(a, b, lower_init, upper_init, xtol, ytol, crootfr, x_ne lower = lower_init upper = upper_init - f_lo = zeng2001_crootfr(a, b, lower) - crootfr - f_hi = zeng2001_crootfr(a, b, upper) - crootfr + f_lo = zeng2001_crootfr(a, b, lower, z_max) - crootfr + f_hi = zeng2001_crootfr(a, b, upper, z_max) - crootfr chg = upper - lower do while(abs(chg) .gt. xtol) x_new = 0.5_r8*(lower + upper) - f_new = zeng2001_crootfr(a, b, x_new) - crootfr + f_new = zeng2001_crootfr(a, b, x_new, z_max) - crootfr if(abs(f_new) .le. ytol) then EXIT end if