From c1f1cd9dda079d499da2563981c2aa49997ade3d Mon Sep 17 00:00:00 2001 From: Ben Andre Date: Wed, 9 Dec 2015 15:12:01 -0700 Subject: [PATCH] pull clm4_5_1_r120 tags from svn --- biogeochem/EDCanopyStructureMod.F90 | 631 ++++++++++ biogeochem/EDCohortDynamicsMod.F90 | 993 ++++++++++++++++ biogeochem/EDGrowthFunctionsMod.F90 | 367 ++++++ biogeochem/EDPatchDynamicsMod.F90 | 1324 +++++++++++++++++++++ biogeochem/EDPhenologyType.F90 | 277 +++++ biogeochem/EDPhysiologyMod.F90 | 1153 ++++++++++++++++++ biogeochem/EDSharedParamsMod.F90 | 54 + biogeophys/EDAccumulateFluxesMod.F90 | 83 ++ biogeophys/EDBtranMod.F90 | 349 ++++++ biogeophys/EDPhotosynthesisMod.F90 | 972 ++++++++++++++++ biogeophys/EDSurfaceAlbedoMod.F90 | 940 +++++++++++++++ fire/SFMainMod.F90 | 936 +++++++++++++++ fire/SFParamsMod.F90 | 212 ++++ main/CMakeLists.txt | 8 + main/EDCLMLinkMod.F90 | 1427 +++++++++++++++++++++++ main/EDEcophysConType.F90 | 110 ++ main/EDInitMod.F90 | 388 ++++++ main/EDMainMod.F90 | 492 ++++++++ main/EDParamsMod.F90 | 149 +++ main/EDPftvarcon.F90 | 138 +++ main/EDRestVectorMod.F90 | 1618 ++++++++++++++++++++++++++ main/EDTypesMod.F90 | 457 ++++++++ main/EDVecCohortType.F90 | 42 + 23 files changed, 13120 insertions(+) create mode 100755 biogeochem/EDCanopyStructureMod.F90 create mode 100755 biogeochem/EDCohortDynamicsMod.F90 create mode 100755 biogeochem/EDGrowthFunctionsMod.F90 create mode 100755 biogeochem/EDPatchDynamicsMod.F90 create mode 100644 biogeochem/EDPhenologyType.F90 create mode 100755 biogeochem/EDPhysiologyMod.F90 create mode 100644 biogeochem/EDSharedParamsMod.F90 create mode 100644 biogeophys/EDAccumulateFluxesMod.F90 create mode 100644 biogeophys/EDBtranMod.F90 create mode 100644 biogeophys/EDPhotosynthesisMod.F90 create mode 100644 biogeophys/EDSurfaceAlbedoMod.F90 create mode 100755 fire/SFMainMod.F90 create mode 100644 fire/SFParamsMod.F90 create mode 100644 main/CMakeLists.txt create mode 100755 main/EDCLMLinkMod.F90 create mode 100644 main/EDEcophysConType.F90 create mode 100755 main/EDInitMod.F90 create mode 100755 main/EDMainMod.F90 create mode 100644 main/EDParamsMod.F90 create mode 100644 main/EDPftvarcon.F90 create mode 100755 main/EDRestVectorMod.F90 create mode 100755 main/EDTypesMod.F90 create mode 100644 main/EDVecCohortType.F90 diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 new file mode 100755 index 0000000000..133639fc67 --- /dev/null +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -0,0 +1,631 @@ + +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 and needs re-writing. + ! ============================================================================ + + use shr_kind_mod , only : r8 => shr_kind_r8; + use clm_varpar , only : nclmax + use clm_varctl , only : iulog + use pftconMod , only : pftcon + use EDGrowthFunctionsMod , only : c_area + use EDCohortDynamicsMod , only : copy_cohort, terminate_cohorts, fuse_cohorts + use EDtypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type, ncwd + + implicit none + private + + public :: canopy_structure + public :: canopy_spread + + ! 10/30/09: Created by Rosie Fisher + ! ============================================================================ + +contains + + ! ============================================================================ + subroutine canopy_structure( currentSite ) + ! + ! !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 clm_varpar, only : nlevcan_ed + use EDParamsMod, only : ED_val_comp_excln, ED_val_ag_biomass + use SFParamsMod, only : SF_val_cwd_frac + use EDtypesMod , only : ncwd + ! + ! !ARGUMENTS + type(ed_site_type) , intent(inout), target :: currentSite + ! + ! !LOCAL VARIABLES: + type(ed_patch_type) , pointer :: currentPatch + type(ed_cohort_type), pointer :: currentCohort,copyc + integer :: i,j + integer :: z ! Current number of canopy layers. (1= canopy, 2 = understorey) + real(r8) :: checkarea + real(r8) :: cc_loss + real(r8) :: lossarea + real(r8) :: newarea + real(r8) :: arealayer(nlevcan_ed) ! Amount of plant area currently in each canopy layer + real(r8) :: sumdiff(nlevcan_ed) ! The total of the exclusion weights for all cohorts in layer z + real(r8) :: weight ! The amount of the total lost area that comes from this cohort + real(r8) :: sum_weights(nlevcan_ed) + real(r8) :: new_total_area_check + real(r8) :: missing_area, promarea,cc_gain,sumgain + integer :: promswitch,lower_cohort_switch + integer :: c + real(r8) :: sumloss,excess_area + integer :: count_mi + !---------------------------------------------------------------------- + + currentPatch => currentSite%oldest_patch + + ! Section 1: Check total canopy area. + + new_total_area_check = 0._r8 + do while (associated(currentPatch)) ! Patch loop + excess_area = 1.0_r8 + + ! Does any layer have excess area in it? Keep going until it does not... + + do while(excess_area > 0.000001_r8) + + ! Calculate the area currently in each canopy layer. + z = 1 + arealayer = 0.0_r8 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + currentCohort%c_area = c_area(currentCohort) ! Reassess cohort area. + arealayer(currentCohort%canopy_layer) = arealayer(currentCohort%canopy_layer) + currentCohort%c_area + z = max(z,currentCohort%canopy_layer) ! What is the current number of canopy layers? + currentCohort => currentCohort%shorter + enddo + + ! Does the bottom layer have more than a full canopy? If so we need to make another layer. + + if(arealayer(z) > currentPatch%area)then ! Do we have too much area in either layer? + !write(iulog,*) 'CANOPY CLOSURE', z + z = z + 1 + endif + + currentPatch%NCL_p = min(nclmax,z) ! Set current canopy layer occupancy indicator. + + do i = 1,z ! Loop around the currently occupied canopy layers. + + do while((arealayer(i)-currentPatch%area) > 0.000001_r8) + ! Is this layer currently over-occupied? + ! In that case, we need to work out which cohorts to demote. + + sumloss = 0.0_r8 + new_total_area_check = 0.0_r8 + sumdiff(i) = 0.0_r8 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + currentCohort%c_area = c_area(currentCohort) + if(arealayer(i) > currentPatch%area.and.currentCohort%canopy_layer == i)then + currentCohort%excl_weight = 1.0_r8/(currentCohort%dbh**ED_val_comp_excln) + sumdiff(i) = sumdiff(i) + currentCohort%excl_weight + endif + currentCohort => currentCohort%shorter + enddo !currentCohort + + lossarea = arealayer(i) - currentPatch%area !how much do we have to lose? + sum_weights(i) = 0.0_r8 + currentCohort => currentPatch%tallest !start from the tallest cohort + + ! Correct the demoted cohorts for + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == i) then + weight = currentCohort%excl_weight/sumdiff(i) + currentCohort%excl_weight = min(currentCohort%c_area/lossarea, weight) + sum_weights(i) = sum_weights(i) + currentCohort%excl_weight + endif + currentCohort => currentCohort%shorter + enddo + + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == i)then !All the trees in this layer need to lose some area... + weight = currentCohort%excl_weight/sum_weights(i) + cc_loss = lossarea*weight !what this cohort has to lose. + !-----------Split and copy boundary cohort-----------------! + if(cc_loss < currentCohort%c_area)then + allocate(copyc) + + call copy_cohort(currentCohort, copyc) !makes an identical copy... + ! n.b this needs to happen BEFORE the cohort goes into the new layer, + ! otherwise currentPatch%spread(i+1) will be higher and the area will change...!!! + sumloss = sumloss + cc_loss + + newarea = currentCohort%c_area - cc_loss + copyc%n = currentCohort%n*newarea/currentCohort%c_area ! + currentCohort%n = currentCohort%n - (currentCohort%n*newarea/currentCohort%c_area) ! + + copyc%canopy_layer = i !the taller cohort is the copy + currentCohort%canopy_layer = i + 1 !demote the current cohort to the understory. + ! seperate cohorts. + ! - 0.000000000001_r8 !needs to be a very small number to avoid + ! causing non-linearity issues with c_area. is this really required? + currentCohort%dbh = currentCohort%dbh + copyc%dbh = copyc%dbh !+ 0.000000000001_r8 + !kill the ones which go into canopy layers that are not allowed... (default nclmax=2) + if(i+1 > nclmax)then + !put the litter from the terminated cohorts into the fragmenting pools + ! write(iulog,*) '3rd canopy layer' + do c=1,ncwd + + currentPatch%CWD_AG(c) = currentPatch%CWD_AG(c) + (currentCohort%bdead+currentCohort%bsw) * & + ED_val_ag_biomass * & + SF_val_CWD_frac(c)*currentCohort%n/currentPatch%area + + currentPatch%CWD_BG(c) = currentPatch%CWD_BG(c) + (currentCohort%bdead+currentCohort%bsw) * & + (1.0_r8-ED_val_ag_biomass) * & + SF_val_CWD_frac(c)*currentCohort%n/currentPatch%area !litter flux per m2. + + enddo + + currentPatch%leaf_litter(currentCohort%pft) = & + currentPatch%leaf_litter(currentCohort%pft) + (currentCohort%bl)* & + currentCohort%n/currentPatch%area ! leaf litter flux per m2. + + currentPatch%root_litter(currentCohort%pft) = & + currentPatch%root_litter(currentCohort%pft) + & + (currentCohort%br+currentCohort%bstore)*currentCohort%n/currentPatch%area + + currentCohort%n = 0.0_r8 + currentCohort%c_area = 0._r8 + else + currentCohort%c_area = c_area(currentCohort) + endif + copyc%c_area = c_area(copyc) + new_total_area_check = new_total_area_check+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 + else + currentCohort%canopy_layer = i + 1 !the whole cohort becomes demoted + sumloss = sumloss + currentCohort%c_area + + !kill the ones which go into canopy layers that are not allowed... (default nclmax=2) + if(i+1 > nclmax)then + !put the litter from the terminated cohorts into the fragmenting pools + do c=1,ncwd + + currentPatch%CWD_AG(c) = currentPatch%CWD_AG(c) + (currentCohort%bdead+currentCohort%bsw) * & + ED_val_ag_biomass * & + SF_val_CWD_frac(c)*currentCohort%n/currentPatch%area + currentPatch%CWD_BG(c) = currentPatch%CWD_BG(c) + (currentCohort%bdead+currentCohort%bsw) * & + (1.0_r8-ED_val_ag_biomass) * & + SF_val_CWD_frac(c)*currentCohort%n/currentPatch%area !litter flux per m2. + + enddo + + currentPatch%leaf_litter(currentCohort%pft) = & + currentPatch%leaf_litter(currentCohort%pft) + currentCohort%bl* & + currentCohort%n/currentPatch%area ! leaf litter flux per m2. + + currentPatch%root_litter(currentCohort%pft) = & + currentPatch%root_litter(currentCohort%pft) + & + (currentCohort%br+currentCohort%bstore)*currentCohort%n/currentPatch%area + currentCohort%n = 0.0_r8 + currentCohort%c_area = 0._r8 + + else + currentCohort%c_area = c_area(currentCohort) + endif + + !write(iulog,*) 'demoting whole cohort', currentCohort%c_area,cc_loss, & + !currentCohort%canopy_layer,currentCohort%dbh + + endif + ! call terminate_cohorts(currentPatch) + + !----------- End of cohort splitting ------------------------------! + endif !canopy layer = i + + currentCohort => currentCohort%shorter + + enddo !currentCohort + + call terminate_cohorts(currentPatch) + arealayer(i) = arealayer(i) - sumloss + !Update arealayer for diff calculations of layer below. + arealayer(i + 1) = arealayer(i + 1) + sumloss + + enddo !arealayer loop + if(arealayer(i)-currentPatch%area > 0.00001_r8)then + write(iulog,*) 'lossarea problem', lossarea,sumloss,z,currentPatch%patchno,currentPatch%clm_pno + endif + + enddo !z + + z = 1 + arealayer = 0.0_r8 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + currentCohort%c_area = c_area(currentCohort) + arealayer(currentCohort%canopy_layer) = arealayer(currentCohort%canopy_layer) + currentCohort%c_area + z = max(z,currentCohort%canopy_layer) + currentCohort => currentCohort%shorter + enddo + + !does the bottom layer have more than a full canopy? If so we need to make another layer. + if(arealayer(z) > currentPatch%area)then + z = z + 1 + endif + excess_area = 0.0_r8 + do j=1,z + if(arealayer(j) > currentPatch%area)then + excess_area = arealayer(j)-currentPatch%area + endif + enddo + currentPatch%ncl_p = min(z,nclmax) + + enddo !is there still excess area in any layer? + + call terminate_cohorts(currentPatch) + call fuse_cohorts(currentPatch) + call terminate_cohorts(currentPatch) + + ! ----------- Check cohort area ------------------------------! + do i = 1,z + checkarea = 0.0_r8 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == i)then + checkarea = checkarea + c_area(currentCohort) + endif + + currentCohort=>currentCohort%shorter + + enddo + + enddo ! + + + ! ----------- 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... + + promswitch = 0 + + missing_area=1.0_r8 + count_mi = 0 + !does any layer have excess area in it? keep going until it does not... + do while(missing_area > 0.000001_r8.and.z > 1) + count_mi = count_mi +1 + do i = 1,z-1 ! if z is greater than one, there is a possibility of too many plants in the understorey. + lower_cohort_switch = 1 + ! is the area of the layer less than the area of the patch, if it is supposed to be closed (z>1) + do while((arealayer(i)-currentPatch%area) < -0.000001_r8.and.lower_cohort_switch == 1) + + if(arealayer(i+1) <= 0.000001_r8)then + currentCohort => currentPatch%tallest + arealayer = 0._r8 + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == i+1)then !look at the cohorts in the canopy layer below... + currentCohort%canopy_layer = i + currentCohort%c_area = c_area(currentCohort) + + ! write(iulog,*) 'promoting very small cohort', currentCohort%c_area,currentCohort%canopy_layer + endif + arealayer(currentCohort%canopy_layer) = arealayer(currentCohort%canopy_layer)+currentCohort%c_area + currentCohort => currentCohort%shorter + enddo + + endif !promoting all of the small amount of area in the lower layers. + + + lower_cohort_switch = 0 + sumgain = 0.0_r8 + sumdiff(i) = 0.0_r8 + ! figure out with what weighting we need to promote cohorts. + ! This is the opposite of the demotion weighting... + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + currentCohort%c_area = c_area(currentCohort) + if(currentCohort%canopy_layer == i+1)then !look at the cohorts in the canopy layer below... + currentCohort%prom_weight = currentCohort%dbh**ED_val_comp_excln !as opposed to 1/(dbh^C_e) + sumdiff(i) = sumdiff(i) + currentCohort%prom_weight + endif + currentCohort => currentCohort%shorter + enddo !currentCohort + + promarea = currentPatch%area -arealayer(i) !how much do we need to gain? + sum_weights(i) = 0.0_r8 + currentCohort => currentPatch%tallest !start from the tallest cohort + + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == i+1) then !still looking at the layer beneath. + weight = currentCohort%prom_weight/sumdiff(i) + if(promarea > 0._r8)then + currentCohort%prom_weight = min(currentCohort%c_area/promarea, weight) + else + currentCohort%prom_weight = 0._r8 + endif + sum_weights(i) = sum_weights(i) + currentCohort%prom_weight + endif + currentCohort => currentCohort%shorter + enddo + + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == i+1)then !All the trees in this layer need to promote some area upwards... + lower_cohort_switch = 1 + weight = currentCohort%prom_weight/sum_weights(i) + cc_gain = promarea*weight !what this cohort has to promote. + !-----------Split and copy boundary cohort-----------------! + if(cc_gain < currentCohort%c_area)then + allocate(copyc) + + call copy_cohort(currentCohort, copyc) !makes an identical copy... + ! n.b this needs to happen BEFORE the cohort goes into the new layer, otherwise currentPatch + ! %spread(+1) will be higher and the area will change...!!! + sumgain = sumgain + cc_gain + + + newarea = currentCohort%c_area - cc_gain !new area of existing cohort + copyc%n = currentCohort%n*cc_gain/currentCohort%c_area !number of individuals in promoted cohort. + ! number of individuals in cohort remianing in understorey + currentCohort%n = currentCohort%n - (currentCohort%n*cc_gain/currentCohort%c_area) + + currentCohort%canopy_layer = i+1 !keep current cohort in the understory. + copyc%canopy_layer = i ! promote copy to the higher canopy layer. + + ! seperate cohorts. + ! needs to be a very small number to avoid causing non-linearity issues with c_area. + ! is this really required? + currentCohort%dbh = currentCohort%dbh - 0.000000000001_r8 + copyc%dbh = copyc%dbh + 0.000000000001_r8 + + currentCohort%c_area = c_area(currentCohort) + copyc%c_area = c_area(copyc) + + !----------- 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 + else + currentCohort%canopy_layer = i !the whole cohort becomes promoted + sumgain = sumgain + currentCohort%c_area !inserting deliberate mistake to see how far we make it... + ! update area AFTER we sum up the losses. the cohort may shrink at this point, + ! if the upper canopy spread is smaller. this shold be dealt with by the 'excess area' loop. + currentCohort%c_area = c_area(currentCohort) + + promswitch = 1 + + ! write(iulog,*) 'promoting whole cohort', currentCohort%c_area,cc_gain,currentCohort%canopy_layer, & + !currentCohort%pft,currentPatch%patchno + + endif + !call terminate_cohorts(currentPatch) + if(promswitch == 1)then + ! write(iulog,*) 'cohort loop',currentCohort%pft,currentCohort%indexnumber,currentPatch%patchno + endif + !----------- End of cohort splitting ------------------------------! + else + if(promswitch == 1)then + ! write(iulog,*) 'cohort list',currentCohort%pft,currentCohort%indexnumber, & + ! currentCohort%canopy_layer,currentCohort%c_area + endif + endif + + currentCohort => currentCohort%shorter + enddo !currentCohort + arealayer(i) = arealayer(i) + sumgain + arealayer(i + 1) = arealayer(i + 1) - sumgain !Update arealayer for diff calculations of layer below. + + if(promswitch == 1)then + ! write(iulog,*) 'arealayer loop',arealayer(1:3),currentPatch%area,promarea,sumgain, & + !currentPatch%patchno,z,i,lower_cohort_switch + endif + if(promswitch == 1.and.associated(currentPatch%tallest))then + ! write(iulog,*) 'cohorts',currentCohort%pft,currentCohort%indexnumber,currentPatch%patchno, & + !currentCohort%c_area + endif + enddo !arealayer loop + + if(currentPatch%area-arealayer(i) < 0.000001_r8)then + !write(iulog,*) 'gainarea problem',sumgain,arealayer(i),currentPatch%area,z, & + !currentPatch%patchno,currentPatch%clm_pno,currentPatch%area - arealayer(i),i,missing_area,count_mi + endif + if(promswitch == 1)then + ! write(iulog,*) 'z loop',arealayer(1:3),currentPatch%patchno,z + endif + enddo !z + + z = 1 + arealayer = 0.0_r8 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + currentCohort%c_area = c_area(currentCohort) + arealayer(currentCohort%canopy_layer) = arealayer(currentCohort%canopy_layer) + currentCohort%c_area + z = max(z,currentCohort%canopy_layer) + currentCohort => currentCohort%shorter + enddo + + missing_area = 0.0_r8 + do j=1,z-1 + if(arealayer(j) < currentPatch%area)then !this is the amount of area that we still have spare in this layer. + missing_area = currentPatch%area - arealayer(j) + if(missing_area <= 0.000001_r8.and.missing_area > 0._r8)then + missing_area = 0.0_r8 + ! write(iulog,*) 'correcting MI',j,currentPatch%area - arealayer(j) + endif + endif + enddo + currentPatch%ncl_p = min(z,nclmax) + if(promswitch == 1)then + ! write(iulog,*) 'missingarea loop',arealayer(1:3),currentPatch%patchno,missing_area,z + endif + enddo !is there still not enough canopy area in any layer? + + call terminate_cohorts(currentPatch) + call fuse_cohorts(currentPatch) + call terminate_cohorts(currentPatch) + + if(promswitch == 1)then + !write(iulog,*) 'going into cohort check',currentPatch%clm_pno + endif + ! ----------- Check cohort area ------------------------------! + do i = 1,z + checkarea = 0.0_r8 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == i)then + checkarea = checkarea + c_area(currentCohort) + endif + + currentCohort => currentCohort%shorter + + enddo + + if(((checkarea-currentPatch%area)) > 0.0001)then + write(iulog,*) 'problem with canopy area', checkarea,currentPatch%area,checkarea-currentPatch%area,i,z,missing_area + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == i)then + write(iulog,*) 'c_areas in top layer', c_area(currentCohort) + endif + currentCohort => currentCohort%shorter + + enddo + + endif + + if ( i > 1) then + if ( (arealayer(i) - arealayer(i-1) )>1e-11 ) then + write(iulog,*) 'smaller top layer than bottom layer ',arealayer(i),arealayer(i-1), & + currentPatch%area,currentPatch%spread(i-1:i) + endif + endif + enddo ! + + if(promswitch == 1)then + ! write(iulog,*) 'end patch loop',currentSite%clmgcell + endif + + currentPatch => currentPatch%younger + enddo !patch + + if(promswitch == 1)then + ! write(iulog,*) 'end canopy structure',currentSite%clmgcell + endif + + end subroutine canopy_structure + + ! ============================================================================ + subroutine canopy_spread( currentSite ) + ! + ! !DESCRIPTION: + ! Calculates the spatial spread of tree canopies based on canopy closure. + ! + ! !USES: + use clm_varpar , only : nlevcan_ed + use EDParamsMod , only : ED_val_maxspread, ED_val_minspread + ! + ! !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) :: arealayer(nlevcan_ed) ! Amount of canopy in each layer. + real(r8) :: inc ! Arbitrary daily incremental change in canopy area + integer :: z + !---------------------------------------------------------------------- + + inc = 0.005_r8 + + currentPatch => currentSite%oldest_patch + + do while (associated(currentPatch)) + + !calculate canopy area in each canopy storey... + arealayer = 0.0_r8 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + currentCohort%c_area = c_area(currentCohort) + if(pftcon%woody(currentCohort%pft) == 1)then + arealayer(currentCohort%canopy_layer) = arealayer(currentCohort%canopy_layer) + currentCohort%c_area + endif + currentCohort => currentCohort%shorter + enddo + + !If the canopy area is approaching closure, squash the tree canopies and make them taller and thinner + do z = 1,nclmax + + if(arealayer(z)/currentPatch%area > 0.9_r8)then + currentPatch%spread(z) = currentPatch%spread(z) - inc + else + currentPatch%spread(z) = currentPatch%spread(z) + inc + endif + if(currentPatch%spread(z) >= ED_val_maxspread)then + currentPatch%spread(z) = ED_val_maxspread + endif + if(currentPatch%spread(z) <= ED_val_minspread)then + currentPatch%spread(z) = ED_val_minspread + endif + enddo !z + !write(iulog,*) 'spread',currentPatch%spread(1:2) + !currentPatch%spread(:) = ED_val_maxspread + !FIX(RF,033114) spread is off + !write(iulog,*) 'canopy_spread',currentPatch%area,currentPatch%spread(1:2) + currentPatch => currentPatch%younger + + enddo !currentPatch + + end subroutine canopy_spread + +end module EDCanopyStructureMod diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 new file mode 100755 index 0000000000..7fe96b45a5 --- /dev/null +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -0,0 +1,993 @@ +module EDCohortDynamicsMod + ! + ! !DESCRIPTION: + ! Cohort stuctures in ED. + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8; + use clm_varctl , only : iulog + use pftconMod , only : pftcon + use EDEcophysContype , only : EDecophyscon + use EDGrowthFunctionsMod , only : c_area, tree_lai + use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type + use EDTypesMod , only : fusetol, nclmax + use EDtypesMod , only : ncwd, numcohortsperpatch, udata + ! + implicit none + private + ! + public :: create_cohort + public :: zero_cohort + public :: nan_cohort + public :: terminate_cohorts + public :: fuse_cohorts + public :: insert_cohort + public :: sort_cohorts + public :: copy_cohort + public :: count_cohorts + public :: countCohorts + public :: allocate_live_biomass + + ! 10/30/09: Created by Rosie Fisher + !-------------------------------------------------------------------------------------! + +contains + + !-------------------------------------------------------------------------------------! + subroutine create_cohort(patchptr, pft, nn, hite, dbh, & + balive, bdead, bstore, laimemory, status, ctrim, clayer) + ! + ! !DESCRIPTION: + ! create new cohort + ! + ! !USES: + ! + ! !ARGUMENTS + type(ed_patch_type), intent(inout), pointer :: patchptr + integer, intent(in) :: pft ! Cohort Plant Functional Type + integer, intent(in) :: clayer ! canopy status of cohort (1 = canopy, 2 = understorey, etc.) + integer, intent(in) :: status ! growth status of plant (2 = leaves on , 1 = leaves off) + 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) :: dbh ! dbh: cm + real(r8), intent(in) :: balive ! total living biomass: kGC per indiv + real(r8), intent(in) :: bdead ! total dead biomass: kGC per indiv + real(r8), intent(in) :: bstore ! stored carbon: kGC per indiv + real(r8), intent(in) :: laimemory ! target leaf 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? :- + ! + ! !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 :: tnull,snull ! are the tallest and shortest cohorts allocate + !---------------------------------------------------------------------- + + allocate(new_cohort) + udata%cohort_number = udata%cohort_number + 1 !give each cohort a unique number for checking cohort fusing routine. + + 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. + + !**********************/ + ! Define cohort state variable + !**********************/ + + new_cohort%indexnumber = udata%cohort_number + new_cohort%siteptr => patchptr%siteptr + new_cohort%patchptr => patchptr + new_cohort%pft = pft + new_cohort%status_coh = status + new_cohort%n = nn + new_cohort%hite = hite + new_cohort%dbh = dbh + new_cohort%canopy_trim = ctrim + new_cohort%canopy_layer = clayer + new_cohort%laimemory = laimemory + new_cohort%bdead = bdead + new_cohort%balive = balive + new_cohort%bstore = bstore + + if (new_cohort%dbh <= 0.0_r8 .or. new_cohort%n == 0._r8 .or. new_cohort%pft == 0 & + .or. new_cohort%canopy_trim <= 0.0_r8 .or. new_cohort%balive <= 0._r8) then + write(iulog,*) 'ED: something is zero in create_cohort',new_cohort%indexnumber,new_cohort%dbh,new_cohort%n, & + new_cohort%pft,new_cohort%canopy_trim,new_cohort%balive + endif + if (new_cohort%siteptr%status==2.and.pftcon%season_decid(pft) == 1) then + new_cohort%laimemory = 0.0_r8 + endif + if (new_cohort%siteptr%dstatus==2.and.pftcon%stress_decid(pft) == 1) then + new_cohort%laimemory = 0.0_r8 + endif + + ! Calculate live biomass allocation + call allocate_live_biomass(new_cohort) + + ! Assign canopy extent and depth + new_cohort%c_area = c_area(new_cohort) + new_cohort%treelai = tree_lai(new_cohort) + new_cohort%lai = new_cohort%treelai * new_cohort%c_area/patchptr%area + new_cohort%treesai = 0.0_r8 !FIX(RF,032414) + + ! Put cohort at the right place in the linked list + storebigcohort => patchptr%tallest + storesmallcohort => patchptr%shortest + + if (associated(patchptr%tallest)) then + tnull = 0 + else + tnull = 1 + patchptr%tallest => new_cohort + endif + + if (associated(patchptr%shortest)) then + snull = 0 + else + snull = 1 + patchptr%shortest => new_cohort + endif + + call insert_cohort(new_cohort, patchptr%tallest, patchptr%shortest, tnull, snull, & + storebigcohort, storesmallcohort) + + patchptr%tallest => storebigcohort + patchptr%shortest => storesmallcohort + + end subroutine create_cohort + + !-------------------------------------------------------------------------------------! + subroutine allocate_live_biomass(cc_p) + ! + ! !DESCRIPTION: + ! Divide alive biomass between leaf, root and sapwood parts. + ! Needs to be called whenver balive changes. + ! + ! !USES: + ! + ! !ARGUMENTS + type (ed_cohort_type), intent(inout), target :: cc_p ! current cohort pointer + ! + ! !LOCAL VARIABLES: + type (ed_cohort_type), pointer :: currentCohort + real(r8) :: leaf_frac ! fraction of live biomass in leaves + real(r8) :: ideal_balive ! theoretical ideal (root and stem) biomass for deciduous trees with leaves off. + ! accounts for the fact that live biomass may decline in the off-season, + ! making leaf_memory unrealistic. + real(r8) :: ratio_balive ! ratio between root+shoot biomass now and root+shoot biomass when leaves fell off. + + integer :: ft ! functional type + integer :: leaves_off_switch + !---------------------------------------------------------------------- + + currentCohort => cc_p + ft = currentcohort%pft + leaf_frac = 1.0_r8/(1.0_r8 + EDecophyscon%sapwood_ratio(ft) * currentcohort%hite + pftcon%froot_leaf(ft)) + + currentcohort%bl = currentcohort%balive*leaf_frac + ratio_balive = 1.0_r8 + !for deciduous trees, there are no leaves + + if (pftcon%evergreen(ft) == 1) then + currentcohort%laimemory = 0._r8 + currentcohort%status_coh = 2 + endif + + !diagnore the root and stem biomass from the functional balance hypothesis. This is used when the leaves are + !fully on. + currentcohort%br = pftcon%froot_leaf(ft) * (currentcohort%balive + currentcohort%laimemory) * leaf_frac + currentcohort%bsw = EDecophyscon%sapwood_ratio(ft) * currentcohort%hite *(currentcohort%balive + & + currentcohort%laimemory)*leaf_frac + + leaves_off_switch = 0 + if (currentcohort%status_coh == 1.and.pftcon%stress_decid(ft) == 1.and.currentcohort%siteptr%dstatus==1) then !no leaves + leaves_off_switch = 1 !drought decid + endif + if (currentcohort%status_coh == 1.and.pftcon%season_decid(ft) == 1.and.currentcohort%siteptr%status==1) then !no leaves + leaves_off_switch = 1 !cold decid + endif + + if (leaves_off_switch==1) then + + !the purpose of this section is to figure out the root and stem biomass when the leaves are off + !at this point, we know the former leaf mass (laimemory) and the current alive mass + !because balive may decline in the off-season, we need to adjust the root and stem biomass that are predicted + !from the laimemory, for the fact that we now might not have enough live biomass to support the hypothesized root mass + !thus, we use 'ratio_balive' to adjust br and bsw. Apologies that this is so complicated! RF + currentcohort%bl = 0.0_r8 + ideal_balive = currentcohort%laimemory * pftcon%froot_leaf(ft) + & + currentcohort%laimemory* EDecophyscon%sapwood_ratio(ft) * currentcohort%hite + currentcohort%br = pftcon%froot_leaf(ft) * (ideal_balive + currentcohort%laimemory) * leaf_frac + currentcohort%bsw = EDecophyscon%sapwood_ratio(ft) * currentcohort%hite *(ideal_balive + & + currentcohort%laimemory)*leaf_frac + + ratio_balive = currentcohort%balive / ideal_balive + currentcohort%br = currentcohort%br * ratio_balive + currentcohort%bsw = currentcohort%bsw * ratio_balive + endif + + + if (abs(currentcohort%balive -currentcohort%bl- currentcohort%br - currentcohort%bsw)>1e-12) then + write(iulog,*) 'issue with carbon allocation in create_cohort',& + currentcohort%balive -currentcohort%bl- currentcohort%br - currentcohort%bsw, currentcohort%status_coh,currentcohort%balive + write(iulog,*) 'actual vs predicted balive',ideal_balive,currentcohort%balive ,ratio_balive,leaf_frac + write(iulog,*) 'leaf,root,stem',currentcohort%bl,currentcohort%br,currentcohort%bsw + endif + currentCohort%b = currentCohort%bdead + currentCohort%balive + + end subroutine allocate_live_biomass + + !-------------------------------------------------------------------------------------! + subroutine nan_cohort(cc_p) + ! + ! !DESCRIPTION: + ! Make all the cohort variables NaN so they aren't used before defined. + ! + ! !USES: + use shr_infnan_mod, only : nan => shr_infnan_nan, assignment(=) + ! + ! !ARGUMENTS + type (ed_cohort_type), intent(inout), target :: cc_p + ! + ! !LOCAL VARIABLES: + type (ed_cohort_type) , pointer :: currentCohort + !---------------------------------------------------------------------- + + currentCohort => cc_p + + 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 + currentCohort%siteptr => null() ! pointer to site that cohort is in + + nullify(currentCohort%taller) + nullify(currentCohort%shorter) + nullify(currentCohort%patchptr) + nullify(currentCohort%siteptr) + + ! VEGETATION STRUCTURE + currentCohort%pft = 999 ! pft number + currentCohort%indexnumber = 999 ! unique number for each cohort. (within clump?) + currentCohort%canopy_layer = 999 ! canopy status of cohort (1 = canopy, 2 = understorey, etc.) + currentCohort%NV = 999 ! Number of leaf layers: - + currentCohort%status_coh = 999 ! growth status of plant (2 = leaves on , 1 = leaves off) + + currentCohort%n = nan ! number of individuals in cohort per 'area' (10000m2 default) + currentCohort%dbh = nan ! 'diameter at breast height' in cm + currentCohort%hite = nan ! height: meters + currentCohort%balive = nan ! total living biomass: kGC per indiv + currentCohort%bdead = nan ! dead biomass: kGC per indiv + currentCohort%bstore = nan ! stored carbon: kGC per indiv + currentCohort%laimemory = nan ! target leaf biomass- set from previous year: kGC per indiv + currentCohort%b = nan ! total biomass: kGC per indiv + currentCohort%bsw = nan ! sapwood in stem and roots: kGC per indiv + currentCohort%bl = nan ! leaf biomass: kGC per indiv + currentCohort%br = nan ! fine root biomass: kGC per indiv + currentCohort%lai = nan ! leaf area index of cohort m2/m2 + currentCohort%sai = nan ! stem area index of cohort m2/m2 + currentCohort%gscan = nan ! Stomatal resistance of cohort. + currentCohort%canopy_trim = nan ! What is the fraction of the maximum leaf biomass that we are targeting? :- + currentCohort%leaf_cost = nan ! How much does it cost to maintain leaves: kgC/m2/year-1 + currentCohort%excl_weight = nan ! How much of this cohort is demoted each year, as a proportion of all cohorts:- + currentCohort%prom_weight = nan ! How much of this cohort is promoted each year, as a proportion of all cohorts:- + currentCohort%c_area = nan ! areal extent of canopy (m2) + currentCohort%treelai = nan ! lai of tree (total leaf area (m2) / canopy area (m2) + currentCohort%treesai = nan ! stem area index of tree (total stem area (m2) / canopy area (m2) + + ! CARBON FLUXES + currentCohort%gpp = nan ! GPP: kgC/indiv/year + currentCohort%gpp_clm = nan ! GPP: kgC/indiv/timestep + currentCohort%gpp_acc = nan ! GPP: kgC/indiv/day + currentCohort%npp = nan ! NPP: kgC/indiv/year + currentCohort%npp_clm = nan ! NPP: kGC/indiv/timestep + 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 = nan ! RESP: kgC/indiv/year + currentCohort%resp_clm = nan ! RESP: kgC/indiv/timestep + currentCohort%resp_acc = nan ! RESP: kGC/cohort/day + + !RESPIRATION + currentCohort%rd = nan + currentCohort%resp_m = nan ! Maintenance respiration. kGC/cohort/year + currentCohort%resp_g = nan ! Growth respiration. kGC/cohort/year + 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 + + ! ALLOCATION + currentCohort%md = nan ! plant maintenance demand: kgC/indiv/year + currentCohort%leaf_md = nan ! leaf maintenance demand: kgC/indiv/year + currentCohort%root_md = nan ! root maintenance demand: kgC/indiv/year + currentCohort%carbon_balance = nan ! carbon remaining for growth and storage: kg/indiv/year + currentCohort%dmort = nan ! proportional mortality rate. (year-1) + currentCohort%seed_prod = nan ! reproduction seed and clonal: KgC/indiv/year + currentCohort%c_area = nan ! areal extent of canopy (m2) + currentCohort%treelai = nan ! lai of tree (total leaf area (m2) / canopy area (m2) + currentCohort%treesai = nan ! stem area index of tree (total stem area (m2) / canopy area (m2) + currentCohort%leaf_litter = nan ! leaf litter from phenology: KgC/m2 + currentCohort%woody_turnover = nan ! amount of wood lost each day: kgC/indiv/year. Currently set to zero. + + ! NITROGEN POOLS + currentCohort%livestemn = nan ! live stem nitrogen : KgN/invid + currentCohort%livecrootn = nan ! live coarse root nitrogen: KgN/invid + currentCohort%frootn = nan ! fine root nitrogen : KgN/invid + + ! VARIABLES NEEDED FOR INTEGRATION + currentCohort%dndt = nan ! time derivative of cohort size + currentCohort%dhdt = nan ! time derivative of height + currentCohort%ddbhdt = nan ! time derivative of dbh + currentCohort%dbalivedt = nan ! time derivative of total living biomass + currentCohort%dbdeaddt = nan ! time derivative of dead biomass + currentCohort%dbstoredt = nan ! time derivative of stored biomass + currentCohort%storage_flux = nan ! flux from npp into bstore + + ! FIRE + currentCohort%cfa = nan ! proportion of crown affected by fire + currentCohort%cambial_mort = nan ! probability that trees dies due to cambial char P&R (1986) + currentCohort%crownfire_mort = nan ! probability of tree post-fire mortality due to crown scorch + currentCohort%fire_mort = nan ! post-fire mortality from cambial and crown damage assuming two are independent + + 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. + ! + ! !USES: + ! + ! !ARGUMENTS + type (ed_cohort_type), intent(inout), target :: cc_p + ! + ! !LOCAL VARIABLES: + type (ed_cohort_type) , pointer :: currentCohort + !---------------------------------------------------------------------- + + currentCohort => cc_p + + currentCohort%NV = 0 + currentCohort%status_coh = 0 + currentCohort%rd = 0._r8 + currentCohort%resp_m = 0._r8 + currentCohort%resp_g = 0._r8 + currentCohort%livestem_mr = 0._r8 + currentCohort%livecroot_mr = 0._r8 + currentCohort%froot_mr = 0._r8 + currentCohort%fire_mort = 0._r8 + currentcohort%npp_acc = 0._r8 + currentcohort%gpp_acc = 0._r8 + currentcohort%resp_acc = 0._r8 + currentcohort%npp_clm = 0._r8 + currentcohort%gpp_clm = 0._r8 + currentcohort%resp_clm = 0._r8 + currentcohort%resp = 0._r8 + currentcohort%carbon_balance = 0._r8 + currentcohort%leaf_litter = 0._r8 + currentcohort%year_net_uptake(:) = 999 ! this needs to be 999, or trimming of new cohorts will break. + currentcohort%ts_net_uptake(:) = 0._r8 + currentcohort%seed_prod = 0._r8 + currentcohort%cfa = 0._r8 + currentcohort%md = 0._r8 + currentcohort%root_md = 0._r8 + currentcohort%leaf_md = 0._r8 + currentcohort%npp = 0._r8 + currentcohort%gpp = 0._r8 + currentcohort%storage_flux = 0._r8 + currentcohort%dmort = 0._r8 + currentcohort%gscan = 0._r8 + currentcohort%treesai = 0._r8 + + end subroutine zero_cohort + + !-------------------------------------------------------------------------------------! + subroutine terminate_cohorts( patchptr ) + ! + ! !DESCRIPTION: + ! terminates cohorts when they get too small + ! + ! !USES: + use EDParamsMod, only : ED_val_ag_biomass + use SFParamsMod, only : SF_val_CWD_frac + ! + ! !ARGUMENTS + type (ed_patch_type), intent(inout), target :: patchptr + ! + ! !LOCAL VARIABLES: + type (ed_patch_type) , pointer :: currentPatch + type (ed_cohort_type) , pointer :: currentCohort + type (ed_cohort_type) , pointer :: nextc + integer :: terminate ! do we terminate (1) or not (0) + integer :: c ! counter for litter size class. + !---------------------------------------------------------------------- + + currentPatch => patchptr + currentCohort => currentPatch%tallest + + do while (associated(currentCohort)) + nextc => currentCohort%shorter + terminate = 0 + + ! Not enough n or dbh + if (currentCohort%n/currentPatch%area <= 0.00001_r8 .or. currentCohort%dbh < & + 0.00001_r8.and.currentCohort%bstore < 0._r8) then + terminate = 1 + ! write(iulog,*) 'terminating cohorts 1',currentCohort%n/currentPatch%area,currentCohort%dbh + endif + + ! In the third canopy layer + if (currentCohort%canopy_layer > NCLMAX) then + terminate = 1 + ! write(iulog,*) 'terminating cohorts 2', currentCohort%canopy_layer + endif + + ! live biomass pools are terminally depleted + if (currentCohort%balive < 1e-10_r8 .or. currentCohort%bstore < 1e-10_r8) then + terminate = 1 + ! write(iulog,*) 'terminating cohorts 3', currentCohort%balive,currentCohort%bstore + endif + + ! Total cohort biomass is negative + if (currentCohort%balive+currentCohort%bdead+currentCohort%bstore < 0._r8) then + terminate = 1 + ! write(iulog,*) 'terminating cohorts 4', currentCohort%balive, currentCohort%bstore, currentCohort%bdead, & + ! currentCohort%balive+currentCohort%bdead+& + ! currentCohort%bstore, currentCohort%n + endif + + + if (terminate == 1) then + if (.not. associated(currentCohort%taller)) then + currentPatch%tallest => currentCohort%shorter + else + currentCohort%taller%shorter => currentCohort%shorter + endif + if (.not. associated(currentCohort%shorter)) then + currentPatch%shortest => currentCohort%taller + else + currentCohort%shorter%taller => currentCohort%taller + endif + + !put the litter from the terminated cohorts straight into the fragmenting pools + if (currentCohort%n.gt.0.0_r8) then + do c=1,ncwd + + currentPatch%CWD_AG(c) = currentPatch%CWD_AG(c) + currentCohort%n*(currentCohort%bdead+currentCohort%bsw) / & + currentPatch%area & + * SF_val_CWD_frac(c) * ED_val_ag_biomass + currentPatch%CWD_BG(c) = currentPatch%CWD_BG(c) + currentCohort%n*(currentCohort%bdead+currentCohort%bsw) / & + currentPatch%area & + * SF_val_CWD_frac(c) * (1.0_r8 - ED_val_ag_biomass) + enddo + + currentPatch%leaf_litter(currentCohort%pft) = currentPatch%leaf_litter(currentCohort%pft) + currentCohort%n* & + (currentCohort%bl)/currentPatch%area + currentPatch%root_litter(currentCohort%pft) = currentPatch%root_litter(currentCohort%pft) + currentCohort%n* & + (currentCohort%br+currentCohort%bstore)/currentPatch%area + + deallocate(currentCohort) + endif + endif + currentCohort => nextc + enddo + + end subroutine terminate_cohorts + + !-------------------------------------------------------------------------------------! + subroutine fuse_cohorts(patchptr) + ! + ! !DESCRIPTION: + ! Join similar cohorts to reduce total number + ! + ! !USES: + use clm_varpar , only : nlevcan_ed + ! + ! !ARGUMENTS + type (ed_patch_type), intent(inout), target :: patchptr + ! + ! !LOCAL VARIABLES: + type (ed_patch_type) , pointer :: currentPatch + type (ed_cohort_type) , pointer :: currentCohort, nextc, nextnextc + integer :: i + integer :: fusion_took_place + integer :: maxcohorts !maximum total no of cohorts. Needs to be >numpft_edx2 + integer :: iterate !do we need to keep fusing to get below maxcohorts? + integer :: nocohorts + real(r8) :: newn + real(r8) :: diff + real(r8) :: dynamic_fusion_tolerance + !---------------------------------------------------------------------- + + !set initial fusion tolerance + dynamic_fusion_tolerance = fusetol + + !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. + iterate = 1 + fusion_took_place = 0 + currentPatch => patchptr + maxcohorts = currentPatch%NCL_p * numCohortsPerPatch + !---------------------------------------------------------------------! + ! Keep doing this until nocohorts <= maxcohorts ! + !---------------------------------------------------------------------! + if (associated(currentPatch%shortest)) then + do while(iterate == 1) + + currentCohort => currentPatch%tallest + + !CHANGED FROM C VERSION loop from tallest to smallest, fusing if they are similar + do while (currentCohort%indexnumber /= currentPatch%shortest%indexnumber) + nextc => currentPatch%tallest + + do while (associated(nextc)) + nextnextc => nextc%shorter + diff = abs((currentCohort%dbh - nextc%dbh)/(0.5*(currentCohort%dbh + nextc%dbh))) + + !Criteria used to divide up the height continuum into different cohorts. + + if (diff < dynamic_fusion_tolerance) then + + if (currentCohort%indexnumber /= nextc%indexnumber) then + + if (currentCohort%pft == nextc%pft) then + + ! check cohorts in same c. layer. before fusing + if (currentCohort%canopy_layer == nextc%canopy_layer) then + fusion_took_place = 1 + newn = currentCohort%n + nextc%n ! sum individuals in both cohorts. + + currentCohort%balive = (currentCohort%n*currentCohort%balive + nextc%n*nextc%balive)/newn + currentCohort%bdead = (currentCohort%n*currentCohort%bdead + nextc%n*nextc%bdead)/newn + currentCohort%bstore = (currentCohort%n*currentCohort%bstore + nextc%n*nextc%bstore)/newn + currentCohort%seed_prod = (currentCohort%n*currentCohort%seed_prod + nextc%n*nextc%seed_prod)/newn + currentCohort%root_md = (currentCohort%n*currentCohort%root_md + nextc%n*nextc%root_md)/newn + currentCohort%leaf_md = (currentCohort%n*currentCohort%leaf_md + nextc%n*nextc%leaf_md)/newn + currentCohort%laimemory = (currentCohort%n*currentCohort%laimemory + nextc%n*nextc%laimemory)/newn + currentCohort%md = (currentCohort%n*currentCohort%md + nextc%n*nextc%md)/newn + + currentCohort%carbon_balance = (currentCohort%n*currentCohort%carbon_balance + & + nextc%n*nextc%carbon_balance)/newn + currentCohort%storage_flux = (currentCohort%n*currentCohort%storage_flux + & + nextc%n*nextc%storage_flux)/newn + + currentCohort%b = (currentCohort%n*currentCohort%b + nextc%n*nextc%b)/newn + currentCohort%bsw = (currentCohort%n*currentCohort%bsw + nextc%n*nextc%bsw)/newn + currentCohort%bl = (currentCohort%n*currentCohort%bl + nextc%n*nextc%bl)/newn + currentCohort%br = (currentCohort%n*currentCohort%br + nextc%n*nextc%br)/newn + currentCohort%hite = (currentCohort%n*currentCohort%hite + nextc%n*nextc%hite)/newn + currentCohort%dbh = (currentCohort%n*currentCohort%dbh + nextc%n*nextc%dbh)/newn + currentCohort%gpp_acc = (currentCohort%n*currentCohort%gpp_acc + nextc%n*nextc%gpp_acc)/newn + currentCohort%npp_acc = (currentCohort%n*currentCohort%npp_acc + nextc%n*nextc%npp_acc)/newn + currentCohort%resp_acc = (currentCohort%n*currentCohort%resp_acc + nextc%n*nextc%resp_acc)/newn + currentCohort%resp = (currentCohort%n*currentCohort%resp + nextc%n*nextc%resp)/newn + currentCohort%npp = (currentCohort%n*currentCohort%npp + nextc%n*nextc%npp)/newn + currentCohort%gpp = (currentCohort%n*currentCohort%gpp + nextc%n*nextc%gpp)/newn + currentCohort%canopy_trim = (currentCohort%n*currentCohort%canopy_trim + nextc%n*nextc%canopy_trim)/newn + currentCohort%dmort = (currentCohort%n*currentCohort%dmort + nextc%n*nextc%dmort)/newn + currentCohort%fire_mort = (currentCohort%n*currentCohort%fire_mort + nextc%n*nextc%fire_mort)/newn + currentCohort%leaf_litter = (currentCohort%n*currentCohort%leaf_litter + nextc%n*nextc%leaf_litter)/newn + + do i=1, nlevcan_ed + if (currentCohort%year_net_uptake(i) == 999._r8 .or. nextc%year_net_uptake(i) == 999._r8) then + currentCohort%year_net_uptake(i) = min(nextc%year_net_uptake(i),currentCohort%year_net_uptake(i)) + else + currentCohort%year_net_uptake(i) = (currentCohort%n*currentCohort%year_net_uptake(i) + & + nextc%n*nextc%year_net_uptake(i))/newn + endif + enddo + + currentCohort%n = newn + !remove fused cohort from the list + nextc%taller%shorter => nextnextc + if (.not. associated(nextc%shorter)) then !this is the shortest cohort. + currentPatch%shortest => nextc%taller + else + nextnextc%taller => nextc%taller + endif + if (associated(nextc)) then + deallocate(nextc) + endif + endif !canopy layer + endif !pft + endif !index no. + endif !diff + + if (associated(nextc)) then + nextc => nextc%shorter + else + nextc => nextnextc !if we have removed next + endif + enddo !end checking nextc cohort loop + + 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)) + nocohorts = nocohorts + 1 + currentCohort => currentCohort%shorter + enddo + + if (nocohorts > maxcohorts) then + iterate = 1 + dynamic_fusion_tolerance = dynamic_fusion_tolerance * 1.1_r8 + !write(iulog,*) 'maxcohorts exceeded',dynamic_fusion_tolerance + !---------------------------------------------------------------------! + ! Making profile tolerance larger means that more fusion will happen ! + !---------------------------------------------------------------------! + else + iterate = 0 + endif + + enddo !do while nocohorts>maxcohorts + + endif ! patch. + + if (fusion_took_place == 1) then ! if fusion(s) occured sort cohorts + call sort_cohorts(currentPatch) + endif + + end subroutine fuse_cohorts + +!-------------------------------------------------------------------------------------! + + subroutine sort_cohorts(patchptr) + ! ============================================================================ + ! sort cohorts into the correct order DO NOT CHANGE THIS IT WILL BREAK + ! ============================================================================ + + type(ed_patch_type) , intent(inout), target :: 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 + integer :: snull,tnull + + current_patch => patchptr + tallestc => NULL() + shortestc => NULL() + storebigcohort => null() + storesmallcohort => null() + current_c => current_patch%tallest + + do while (associated(current_c)) + next_c => current_c%shorter + tallestc => storebigcohort + shortestc => storesmallcohort + if (associated(tallestc)) then + tnull = 0 + else + tnull = 1 + tallestc => current_c + endif + + if (associated(shortestc)) then + snull = 0 + else + snull = 1 + shortestc => current_c + endif + + call insert_cohort(current_c, tallestc, shortestc, tnull, snull, storebigcohort, storesmallcohort) + + current_patch%tallest => storebigcohort + current_patch%shortest => storesmallcohort + current_c => next_c + + enddo + + end subroutine sort_cohorts + + !-------------------------------------------------------------------------------------! + subroutine insert_cohort(pcc, ptall, pshort, tnull, snull, storebigcohort, storesmallcohort) + ! + ! !DESCRIPTION: + ! Insert cohort into linked list + ! + ! !USES: + ! + ! !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 + ! + ! !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 + real(r8) :: tsp + integer :: tallptrnull,exitloop + !---------------------------------------------------------------------- + + currentPatch => pcc%patchptr + ptallest => ptall + pshortest => pshort + + if (tnull == 1) then + ptallest => null() + endif + if (snull == 1) then + 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 + tsp = icohort%dbh + + current => pshortest + exitloop = 0 + !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%dbh < tsp) then + current => current%taller + else + exitloop = 1 + endif + enddo + endif + + if (associated(current)) then + tallptr => current + tallptrnull = 0 + else + tallptr => null() + tallptrnull = 1 + endif + + !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 + ptallest => icohort + if (present(storebigcohort)) then + storebigcohort => icohort + end if + 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 + shortptr => tallptr%shorter + + !new cohort becomes the next shorter cohort to the cohort + !just taller than the new cohort + tallptr%shorter => icohort + endif + + !new cohort is shortest + if (.not.associated(shortptr)) then + !next shorter reamins null + !cohort is placed at the bottom of the list + pshortest => icohort + if (present(storesmallcohort)) then + storesmallcohort => icohort + end if + 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 + shortptr%taller => icohort + endif + + ! assign taller and shorter links for the new cohort + icohort%taller => tallptr + if (tallptrnull == 1) then + icohort%taller=> null() + endif + icohort%shorter => shortptr + + end subroutine insert_cohort + + !-------------------------------------------------------------------------------------! + subroutine copy_cohort( currentCohort,copyc ) + ! + ! !DESCRIPTION: + ! Copies all the variables in one cohort into another empty cohort + ! + ! !USES: + ! + ! !ARGUMENTS + type(ed_cohort_type), intent(inout) , target :: copyc ! New cohort argument. + type(ed_cohort_type), intent(in) , target :: currentCohort ! Old cohort argument. + ! + ! !LOCAL VARIABLES: + type(ed_cohort_type), pointer :: n,o ! New and old cohort pointers + !---------------------------------------------------------------------- + + o => currentCohort + n => copyc + + udata%cohort_number = udata%cohort_number + 1 + n%indexnumber = udata%cohort_number + + ! VEGETATION STRUCTURE + n%pft = o%pft + n%n = o%n + n%dbh = o%dbh + n%hite = o%hite + n%b = o%b + n%balive = o%balive + n%bdead = o%bdead + n%bstore = o%bstore + n%laimemory = o%laimemory + n%bsw = o%bsw + n%bl = o%bl + n%br = o%br + n%lai = o%lai + n%sai = o%sai + n%gscan = o%gscan + n%leaf_cost = o%leaf_cost + n%canopy_layer = o%canopy_layer + n%nv = o%nv + n%status_coh = o%status_coh + n%canopy_trim = o%canopy_trim + n%status_coh = o%status_coh + n%excl_weight = o%excl_weight + n%prom_weight = o%prom_weight + + ! CARBON FLUXES + n%gpp = o%gpp + n%gpp_acc = o%gpp_acc + n%gpp_clm = o%gpp_clm + n%npp = o%npp + n%npp_clm = o%npp_clm + n%npp_acc = o%npp_acc + n%resp_clm = o%resp_clm + n%resp_acc = o%resp_acc + n%resp = o%resp + n%year_net_uptake = o%year_net_uptake + n%ts_net_uptake = o%ts_net_uptake + + !RESPIRATION + n%rd = o%rd + n%resp_m = o%resp_m + n%resp_g = o%resp_g + n%livestem_mr = o%livestem_mr + n%livecroot_mr = o%livecroot_mr + n%froot_mr = o%froot_mr + + ! NITROGEN POOLS + n%livestemn = o%livestemn + n%livecrootn = o%livecrootn + n%frootn = o%frootn + + ! ALLOCATION + n%md = o%md + n%leaf_md = o%leaf_md + n%root_md = o%root_md + n%carbon_balance = o%carbon_balance + n%dmort = o%dmort + n%seed_prod = o%seed_prod + n%treelai = o%treelai + n%treesai = o%treesai + n%leaf_litter = o%leaf_litter + n%c_area = o%c_area + n%woody_turnover = o%woody_turnover + + ! VARIABLES NEEDED FOR INTEGRATION + n%dndt = o%dndt + n%dhdt = o%dhdt + n%ddbhdt = o%ddbhdt + n%dbalivedt = o%dbalivedt + n%dbdeaddt = o%dbdeaddt + n%dbstoredt = o%dbstoredt + n%storage_flux = o%storage_flux + + ! FIRE + n%cfa = o%cfa + n%fire_mort = o%fire_mort + n%crownfire_mort = o%crownfire_mort + n%cambial_mort = o%cambial_mort + + !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%siteptr => o%siteptr ! pointer to site that cohort is in + + end subroutine copy_cohort + + !-------------------------------------------------------------------------------------! + function count_cohorts( currentPatch ) result ( backcount ) + ! + ! !DESCRIPTION: + ! + ! !USES: + ! + ! !ARGUMENTS + type(ed_patch_type), intent(inout), target :: currentPatch !new site + ! + ! !LOCAL VARIABLES: + type(ed_cohort_type), pointer ::currentCohort !new patch + integer backcount + !---------------------------------------------------------------------- + + currentCohort => currentPatch%shortest + + currentPatch%countcohorts = 0 + do while (associated(currentCohort)) + currentPatch%countcohorts = currentPatch%countcohorts + 1 + currentCohort => currentCohort%taller + enddo + + backcount = 0 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + backcount = backcount + 1 + currentCohort => currentCohort%shorter + enddo + + if (backcount /= currentPatch%countcohorts) then + write(iulog,*) 'problem with linked list, not symmetrical' + endif + + end function count_cohorts + + !-------------------------------------------------------------------------------------! + function countCohorts( bounds, ed_allsites_inst ) result ( totNumCohorts ) + ! + ! !DESCRIPTION: + ! counts the total number of cohorts over all p levels (ed_patch_type) so we + ! can allocate vectors, copy from LL -> vector and read/write restarts. + ! + ! !USES: + use decompMod, only : bounds_type + ! + ! !ARGUMENTS + type(bounds_type) , intent(in) :: bounds + type(ed_site_type) , intent(inout), target :: ed_allsites_inst( bounds%begg: ) + ! + ! !LOCAL VARIABLES: + type (ed_patch_type) , pointer :: currentPatch + type (ed_cohort_type) , pointer :: currentCohort + integer :: g, totNumCohorts + logical :: error + !---------------------------------------------------------------------- + + totNumCohorts = 0 + + do g = bounds%begg,bounds%endg + + if (ed_allsites_inst(g)%istheresoil) then + + currentPatch => ed_allsites_inst(g)%oldest_patch + do while(associated(currentPatch)) + + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + totNumCohorts = totNumCohorts + 1 + currentCohort => currentCohort%taller + enddo !currentCohort + currentPatch => currentPatch%younger + end do + + end if + end do + + end function countCohorts + +end module EDCohortDynamicsMod diff --git a/biogeochem/EDGrowthFunctionsMod.F90 b/biogeochem/EDGrowthFunctionsMod.F90 new file mode 100755 index 0000000000..a497df202a --- /dev/null +++ b/biogeochem/EDGrowthFunctionsMod.F90 @@ -0,0 +1,367 @@ +module EDGrowthFunctionsMod + + ! ============================================================================ + ! Functions that control the trajectory of plant growth. + ! Ideally these would all use parameters that are fed in from the parameter file. + ! At present, there is only a single allocation trajectory. + ! ============================================================================ + + use shr_kind_mod , only : r8 => shr_kind_r8 + use clm_varctl , only : iulog + use pftconMod , only : pftcon + use EDEcophysContype , only : EDecophyscon + use EDTypesMod , only : ed_cohort_type, nlevcan_ed, dinc_ed + + implicit none + private + + public :: bleaf + public :: hite + public :: ddbhdbd + public :: ddbhdbl + public :: dhdbd + public :: dbh + public :: bdead + public :: tree_lai + public :: tree_sai + public :: c_area + public :: mortality_rates + + logical :: DEBUG_growth = .false. + + ! ============================================================================ + ! 10/30/09: Created by Rosie Fisher + ! ============================================================================ + +contains + + real(r8) function Dbh( cohort_in ) + + ! ============================================================================ + ! Creates diameter in cm as a function of height in m + ! Height(m) diameter(cm) relationships. O'Brien et al - for 56 patch at BCI + ! ============================================================================ + + type(ed_cohort_type), intent(in) :: cohort_in + + !FIX(SPM,040214) - move to param file + real(r8) :: m !parameter of allometric equation (needs to not be hardwired... + real(r8) :: c !parameter of allometric equation (needs to not be hardwired... + + m = 0.64_r8 + c = 0.37_r8 + + dbh = (10.0_r8**((log10(cohort_in%hite) - c)/m)) + + return + + end function dbh + +! ============================================================================ + + real(r8) function Hite( cohort_in ) + + ! ============================================================================ + ! Creates height in m as a function of diameter in cm. + ! Height(m) diameter(cm) relationships. O'Brien et al - for 56 pft at BCI + ! ============================================================================ + + type(ed_cohort_type), intent(inout) :: cohort_in + + real(r8) :: m + real(r8) :: c + real(r8) :: h + + m = 0.64_r8 + c = 0.37_r8 + + if(cohort_in%dbh <= 0._r8)then + write(iulog,*) 'ED: dbh less than zero problem!',cohort_in%indexnumber + cohort_in%dbh = 0.1_r8 + endif + + ! if the hite is larger than the maximum allowable height (set by dbhmax) then + ! set the height to the maximum value. + ! this could do with at least re-factoring and probably re-thinking. RF + if(cohort_in%dbh <= EDecophyscon%max_dbh(cohort_in%pft)) then + h = (10.0_r8**(log10(cohort_in%dbh) * m + c)) + else + h = (10.0_r8**(log10(EDecophyscon%max_dbh(cohort_in%pft))*m + c)) + endif + Hite = h + + return + + end function Hite + +! ============================================================================ + + real(r8) function Bleaf( cohort_in ) + + ! ============================================================================ + ! Creates leaf biomass (kGC) as a function of tree diameter. + ! ============================================================================ + + type(ed_cohort_type), intent(in) :: cohort_in + + if(cohort_in%dbh < 0._r8.or.cohort_in%pft == 0.or.cohort_in%dbh > 1000.0_r8)then + write(iulog,*) 'problems in bleaf',cohort_in%dbh,cohort_in%pft + endif + + if(cohort_in%dbh <= EDecophyscon%max_dbh(cohort_in%pft))then + bleaf = 0.0419_r8 * (cohort_in%dbh**1.56) * EDecophyscon%wood_density(cohort_in%pft)**0.55_r8 + else + bleaf = 0.0419_r8 * (EDecophyscon%max_dbh(cohort_in%pft)**1.56) * EDecophyscon%wood_density(cohort_in%pft)**0.55_r8 + endif + + !Adjust for canopies that have become so deep that their bottom layer is not producing any carbon... + !nb this will change the allometry and the effects of this remain untested. RF. April 2014 + bleaf = bleaf*cohort_in%canopy_trim + + return + end function Bleaf + +! ============================================================================ + + real(r8) function tree_lai( cohort_in ) + + ! ============================================================================ + ! LAI of individual trees is a function of the total leaf area and the total canopy area. + ! ============================================================================ + + type(ed_cohort_type), intent(inout) :: cohort_in + + 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 + + if( cohort_in%bl < 0._r8 .or. cohort_in%pft == 0 ) then + write(iulog,*) 'problem in treelai',cohort_in%bl,cohort_in%pft + endif + + if( cohort_in%status_coh == 2 ) then ! are the leaves on? + slat = 1000.0_r8 * pftcon%slatop(cohort_in%pft) ! m2/g to m2/kg + cohort_in%c_area = c_area(cohort_in) ! call the tree area + leafc_per_unitarea = cohort_in%bl/(cohort_in%c_area/cohort_in%n) !KgC/m2 + if(leafc_per_unitarea > 0.0_r8)then + tree_lai = leafc_per_unitarea * slat !kg/m2 * m2/kg = unitless LAI + else + tree_lai = 0.0_r8 + endif + else + tree_lai = 0.0_r8 + endif !status + cohort_in%treelai = tree_lai + + ! here, if the LAI exceeeds the maximum size of the possible array, then we have no way of accomodating it + ! at the moments nlevcan_ed default is 40, which is very large, so exceeding this would clearly illustrate a + ! huge error + if(cohort_in%treelai > nlevcan_ed*dinc_ed)then + write(iulog,*) 'too much lai' , cohort_in%treelai , cohort_in%pft , nlevcan_ed * dinc_ed + endif + + return + + end function tree_lai + + ! ============================================================================ + + real(r8) function tree_sai( cohort_in ) + + ! ============================================================================ + ! SAI of individual trees is a function of the total dead biomass per unit canopy area. + ! ============================================================================ + + type(ed_cohort_type), intent(inout) :: cohort_in + + real(r8) :: bdead_per_unitarea ! KgC of leaf per m2 area of ground. + real(r8) :: sai_scaler ! This is hardwired, but should be made a parameter - + ! I need to add a new parameter to the 'standard' parameter file but don't have permission... RF 2 july. + + sai_scaler = 0.05_r8 ! here, a high biomass of 20KgC per m2 gives us a high SAI of 1.0. + + if( cohort_in%bdead < 0._r8 .or. cohort_in%pft == 0 ) then + write(iulog,*) 'problem in treesai',cohort_in%bdead,cohort_in%pft + endif + + cohort_in%c_area = c_area(cohort_in) ! call the tree area + bdead_per_unitarea = cohort_in%bdead/(cohort_in%c_area/cohort_in%n) !KgC/m2 + tree_sai = bdead_per_unitarea * sai_scaler !kg/m2 * m2/kg = unitless LAI + + cohort_in%treesai = tree_sai + + ! here, if the LAI exceeeds the maximum size of the possible array, then we have no way of accomodating it + ! at the moments nlevcan_ed default is 40, which is very large, so exceeding this would clearly illustrate a + ! huge error + if(cohort_in%treesai > nlevcan_ed*dinc_ed)then + write(iulog,*) 'too much sai' , cohort_in%treesai , cohort_in%pft , nlevcan_ed * dinc_ed + endif + + return + + end function tree_sai + + +! ============================================================================ + + real(r8) function c_area( cohort_in ) + + ! ============================================================================ + ! Calculate area of ground covered by entire cohort. (m2) + ! Function of DBH (cm) canopy spread (m/cm) and number of individuals. + ! ============================================================================ + + use EDParamsMod , only : ED_val_grass_spread + + type(ed_cohort_type), intent(in) :: cohort_in + + real(r8) :: dbh ! Tree diameter at breat height. cm. + + if (DEBUG_growth) then + write(iulog,*) 'z_area 1',cohort_in%dbh,cohort_in%pft + write(iulog,*) 'z_area 2',EDecophyscon%max_dbh + write(iulog,*) 'z_area 3',pftcon%woody + write(iulog,*) 'z_area 4',cohort_in%n + write(iulog,*) 'z_area 5',cohort_in%patchptr%spread + write(iulog,*) 'z_area 6',cohort_in%canopy_layer + write(iulog,*) 'z_area 7',ED_val_grass_spread + end if + + dbh = min(cohort_in%dbh,EDecophyscon%max_dbh(cohort_in%pft)) + if(pftcon%woody(cohort_in%pft) == 1)then + c_area = 3.142_r8 * cohort_in%n * & + (cohort_in%patchptr%spread(cohort_in%canopy_layer)*dbh)**1.56_r8 + else + c_area = 3.142_r8 * cohort_in%n * (ED_val_grass_spread*dbh)**1.56_r8 + end if + + end function c_area + +! ============================================================================ + + real(r8) function Bdead( cohort_in ) + + ! ============================================================================ + ! Calculate stem biomass from height(m) dbh(cm) and wood density(g/cm3) + ! using allometry of J.G. Saldarriaga et al 1988 - Rio Negro + ! Journal of Ecology vol 76 p938-958 + ! ============================================================================ + + type(ed_cohort_type), intent(in) :: cohort_in + + bdead = 0.06896_r8*(cohort_in%hite**0.572_r8)*(cohort_in%dbh**1.94_r8)* & + (EDecophyscon%wood_density(cohort_in%pft)**0.931_r8) + + end function Bdead + +! ============================================================================ + + real(r8) function dHdBd( cohort_in ) + + ! ============================================================================ + ! convert changes in structural biomass to changes in height + ! consistent with Bstem and h-dbh allometries + ! ============================================================================ + + type(ed_cohort_type), intent(in) :: cohort_in + + real(r8) :: dbddh ! rate of change of dead biomass (KgC) per unit change of height (m) + + dbddh = 0.06896_r8*0.572_r8*(cohort_in%hite**(-0.428_r8))*(cohort_in%dbh**1.94_r8)* & + (EDecophyscon%wood_density(cohort_in%pft)**0.931_r8) + dHdBd = 1.0_r8/dbddh !m/KgC + + return + + end function dHdBd + +! ============================================================================ + real(r8) function dDbhdBd( cohort_in ) + + ! ============================================================================ + ! convert changes in structural biomass to changes in diameter + ! consistent with Bstem and h-dbh allometries + ! ============================================================================ + + type(ed_cohort_type), intent(in) :: cohort_in + + real(r8) :: dBD_dDBH !Rate of change of dead biomass (KgC) with change in DBH (cm) + real(r8) :: dH_dDBH !Rate of change of height (m) with change in DBH (cm) + + dBD_dDBH = 1.94_r8*0.06896_r8*(cohort_in%hite**0.572_r8)*(cohort_in%dbh**0.94_r8)* & + (EDecophyscon%wood_density(cohort_in%pft)**0.931_r8) + if(cohort_in%dbh < EDecophyscon%max_dbh(cohort_in%pft))then + dH_dDBH = 1.4976_r8*(cohort_in%dbh**(-0.36_r8)) + dBD_dDBH = dBD_dDBH + 0.572_r8*0.06896_r8*(cohort_in%hite**(0.572_r8 - 1.0_r8))* & + (cohort_in%dbh**1.94_r8)*(EDecophyscon%wood_density(cohort_in%pft)**0.931_r8)*dH_dDBH + endif + + dDbhdBd = 1.0/dBD_dDBH + + return + + end function dDbhdBd + +! ============================================================================ + + real(r8) function dDbhdBl( cohort_in ) + + ! ============================================================================ + ! convert changes in leaf biomass (KgC) to changes in DBH (cm) + ! ============================================================================ + + type(ed_cohort_type), intent(in) :: cohort_in + + real(r8) :: dblddbh ! Rate of change of leaf biomass with change in DBH + + dblddbh = 1.56_r8*0.0419_r8*(cohort_in%dbh**0.56_r8)*(EDecophyscon%wood_density(cohort_in%pft)**0.55_r8) + dblddbh = dblddbh*cohort_in%canopy_trim + + dDbhdBl = 1.0_r8/dblddbh + + return + + end function dDbhdBl + +! ============================================================================ + + real(r8) function mortality_rates( cohort_in ) + + ! ============================================================================ + ! Calculate mortality rates as a function of carbon storage + ! ============================================================================ + + use EDParamsMod, only : ED_val_stress_mort + + type (ed_cohort_type), intent(in) :: cohort_in + + real(r8) :: frac ! relativised stored carbohydrate + real(r8) :: smort ! stress mortality : Fraction per year + real(r8) :: bmort ! background mortality : Fraction per year + + ! 'Background' mortality (can vary as a function of density as in ED1.0 and ED2.0, but doesn't here for tractability) + bmort = 0.014_r8 + + ! Proxy for hydraulic failure induced mortality. + smort = 0.0_r8 + if(cohort_in%patchptr%btran_ft(cohort_in%pft) <= 0.000001_r8)then + smort = smort + ED_val_stress_mort + endif + + ! Carbon Starvation induced mortality. + if ( cohort_in%dbh > 0._r8 ) then + if(Bleaf(cohort_in) > 0._r8.and.cohort_in%bstore <= Bleaf(cohort_in))then + frac = cohort_in%bstore/(Bleaf(cohort_in)) + smort = smort + max(0.0_r8,ED_val_stress_mort*(1.0_r8 - frac)) + endif + else + write(iulog,*) 'dbh problem in mortality_rates', & + cohort_in%dbh,cohort_in%pft,cohort_in%n,cohort_in%canopy_layer,cohort_in%indexnumber + endif + + mortality_rates = smort + bmort + + end function mortality_rates + +! ============================================================================ + +end module EDGrowthFunctionsMod diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 new file mode 100755 index 0000000000..826e7a60ac --- /dev/null +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -0,0 +1,1324 @@ +module EDPatchDynamicsMod + + ! ============================================================================ + ! Controls formation, creation, fusing and termination of patch level processes. + ! ============================================================================ + + use shr_kind_mod , only : r8 => shr_kind_r8; + use clm_varctl , only : iulog + use pftconMod , only : pftcon + use EDCohortDynamicsMod , only : fuse_cohorts, sort_cohorts, insert_cohort + use EDtypesMod , only : ncwd, n_dbh_bins, ntol, numpft_ed, area, dbhmax + use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type, udata + ! + implicit none + private + ! + public :: create_patch + public :: spawn_patches + public :: zero_patch + public :: fuse_patches + public :: terminate_patches + public :: patch_pft_size_profile + public :: disturbance_rates + public :: check_patch_area + public :: set_patchno + + private:: fuse_2_patches + + ! 10/30/09: Created by Rosie Fisher + ! ============================================================================ + +contains + + ! ============================================================================ + subroutine disturbance_rates( site_in) + ! + ! !DESCRIPTION: + ! Calculates the fire and mortality related disturbance rates for each patch, + ! and then determines which is the larger at the patch scale (for now, there an only + ! be one disturbance type for each timestep. + ! all disturbance rates here are per daily timestep. + ! + ! !USES: + use EDGrowthFunctionsMod , only : c_area, mortality_rates + use EDTypesMod , only : udata + ! + ! !ARGUMENTS: + type(ed_site_type) , intent(inout), target :: site_in + ! + ! !LOCAL VARIABLES: + type (ed_patch_type) , pointer :: currentPatch + type (ed_cohort_type), pointer :: currentCohort + !--------------------------------------------------------------------- + + !MORTALITY + site_in%disturbance_mortality = 0.0_r8 + + currentPatch => site_in%oldest_patch + + do while (associated(currentPatch)) + + currentCohort => currentPatch%shortest + + do while(associated(currentCohort)) + ! Mortality for trees in the understorey. + currentCohort%patchptr => currentPatch + + currentCohort%dmort = mortality_rates(currentCohort) + currentCohort%c_area = c_area(currentCohort) + + if(currentCohort%canopy_layer == 1)then + + currentPatch%disturbance_rates(1) = currentPatch%disturbance_rates(1) + & + min(1.0_r8,currentCohort%dmort)*udata%deltat*currentCohort%c_area/currentPatch%area + + endif + + currentCohort => currentCohort%taller + + enddo !currentCohort + + ! if fires occur at site + ! Fudge - fires can't burn the whole patch, as this causes /0 errors. + ! This is accumulating the daily fires over the whole 30 day patch generation phase. + currentPatch%disturbance_rates(2) = min(0.99_r8,currentPatch%disturbance_rates(2) + currentPatch%frac_burnt) + + if (currentPatch%disturbance_rates(2) > 0.98_r8)then + write(iulog,*) 'very high fire areas',currentPatch%disturbance_rates(2),currentPatch%frac_burnt + endif + + !Only use larger of two natural disturbance modes WHY? + if(currentPatch%disturbance_rates(2) > currentPatch%disturbance_rates(1))then ! DISTURBANCE IS FIRE + currentPatch%disturbance_rate = currentPatch%disturbance_rates(2) + else + currentPatch%disturbance_rate = currentPatch%disturbance_rates(1) ! DISTURBANCE IS MORTALITY + endif + + site_in%disturbance_mortality = site_in%disturbance_mortality + & + currentPatch%disturbance_rates(1)*currentPatch%area/area + currentPatch => currentPatch%younger + + enddo !patch loop + + ! FIRE + site_in%disturbance_fire = site_in%frac_burnt/AREA + + ! Use largest disturbance mode and ignore the other... This is necessary to + ! have a single type of disturbance and to calculate the survival rates etc... + if (site_in%disturbance_fire > site_in%disturbance_mortality) then + site_in%disturbance_rate = site_in%disturbance_fire + site_in%dist_type = 2 + else + site_in%disturbance_rate = site_in%disturbance_mortality + site_in%dist_type = 1 + endif + + end subroutine disturbance_rates + + ! ============================================================================ + subroutine spawn_patches( currentSite ) + ! + ! !DESCRIPTION: + ! In this subroutine, the following happens + ! 1) the total area disturbed is calculated + ! 2) a new patch is created + ! 3) properties are averaged + ! 4) litter fluxes from fire and mortality are added + ! 5) For mortality, plants in existing patch canopy are killed. + ! 6) For mortality, Plants in new and existing understorey are killed + ! 7) For fire, burned plants are killed, and unburned plants are added to new patch. + ! 8) New cohorts are added to new patch and sorted. + ! 9) New patch is added into linked list + ! 10) Area checked, and patchno recalculated. + ! + ! !USES: + use clm_varpar , only : nclmax + use EDParamsMod , only : ED_val_maxspread, ED_val_understorey_death + use EDCohortDynamicsMod , only : zero_cohort, copy_cohort, terminate_cohorts + ! + ! !ARGUMENTS: + type (ed_site_type), intent(inout), target :: currentSite + ! + ! !LOCAL VARIABLES: + type (ed_patch_type) , pointer :: new_patch + type (ed_patch_type) , pointer :: currentPatch + 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 ! total area disturbed in m2 per site 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 :: tnull ! is there a tallest cohort? + integer :: snull ! is there a shortest cohort? + real(r8) :: root_litter_local(numpft_ed) ! initial value of root litter. KgC/m2 + real(r8) :: leaf_litter_local(numpft_ed) ! initial value of leaf litter. KgC/m2 + real(r8) :: cwd_ag_local(ncwd) ! initial value of above ground coarse woody debris. KgC/m2 + real(r8) :: cwd_bg_local(ncwd) ! initial value of below ground coarse woody debris. KgC/m2 + real(r8) :: seed_bank_local(numpft_ed) ! initial value of seed bank. KgC/m2 + real(r8) :: spread_local(nclmax) ! initial value of canopy spread parameter.no units + !--------------------------------------------------------------------- + + storesmallcohort => null() ! storage of the smallest cohort for insertion routine + storebigcohort => null() ! storage of the largest cohort for insertion routine + + ! calculate area of disturbed land, in this timestep, by summing contributions from each existing patch. + currentPatch => currentSite%youngest_patch + currentSite%cwd_ag_burned = 0.0_r8 + currentSite%leaf_litter_burned = 0.0_r8 + + site_areadis = 0.0_r8 + do while(associated(currentPatch)) + + !FIX(RF,032414) Does using the max(fire,mort) actually make sense here? + site_areadis = site_areadis + currentPatch%area * min(1.0_r8,currentPatch%disturbance_rate) + currentPatch => currentPatch%older + + enddo ! end loop over patches. sum area disturbed for all patches. + + if (site_areadis > 0.0_r8) then + cwd_ag_local = 0.0_r8 + cwd_bg_local = 0.0_r8 + leaf_litter_local = 0.0_r8 + root_litter_local = 0.0_r8 + spread_local(1:nclmax) = ED_val_maxspread + age = 0.0_r8 + seed_bank_local = 0.0_r8 + + allocate(new_patch) + + call zero_patch(new_patch) + + call create_patch(currentSite, new_patch, age, site_areadis, & + spread_local, cwd_ag_local, cwd_bg_local, leaf_litter_local, & + root_litter_local, seed_bank_local) + + new_patch%tallest => null() + new_patch%shortest => null() + + currentPatch => currentSite%oldest_patch + ! loop round all the patches that contribute surviving indivduals and litter pools to the new patch. + do while(associated(currentPatch)) + patch_site_areadis = currentPatch%area * currentPatch%disturbance_rate ! how much land is disturbed in this donor patch? + + call average_patch_properties(currentPatch, new_patch, patch_site_areadis) + if (currentSite%disturbance_mortality > currentSite%disturbance_fire) then !mortality is dominant disturbance + call mortality_litter_fluxes(currentPatch, new_patch, patch_site_areadis) + else + call fire_litter_fluxes(currentPatch, new_patch, patch_site_areadis) + endif + + !INSERT SURVIVORS FROM DISTURBANCE INTO NEW PATCH + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + + allocate(nc) + call zero_cohort(nc) + + ! nc is the new cohort that goes in the disturbed patch (new_patch)... currentCohort + ! is the curent cohort that stays in the donor patch (currentPatch) + call copy_cohort(currentCohort, nc) + + !this is the case as the new patch probably doesn't have a closed canopy, and + ! even if it does, that will be sorted out in canopy_structure. + nc%canopy_layer = 1 + + !mortality is dominant disturbance + if(currentPatch%disturbance_rates(1) > currentPatch%disturbance_rates(2))then + if(currentCohort%canopy_layer == 1)then + ! keep the trees that didn't die + currentCohort%n = currentCohort%n * (1.0_r8 - min(1.0_r8,currentCohort%dmort * udata%deltat)) + nc%n = 0.0_r8 ! kill all of the trees who caused the disturbance. + else + if(pftcon%woody(currentCohort%pft) == 1)then + + ! remaining of understory plants of those that are knocked over by the overstorey trees dying... + nc%n = (1.0_r8 - ED_val_understorey_death) * currentCohort%n * patch_site_areadis/currentPatch%area + ! understory trees that might potentially be knocked over in the disturbance. + currentCohort%n = currentCohort%n * (1._r8 - patch_site_areadis/currentPatch%area) + ! grass is not killed by mortality disturbance events. Just move it into the new patch area. + + else + + ! remaining of understory plants of those that are knocked over by the overstorey trees dying... + nc%n = currentCohort%n * patch_site_areadis/currentPatch%area + ! understory trees that might potentially be knocked over in the disturbance. + currentCohort%n = currentCohort%n * (1._r8 - patch_site_areadis/currentPatch%area) + + endif + endif + else !fire + + ! loss of individual from fire in new patch. + nc%n = currentCohort%n * patch_site_areadis/currentPatch%area * (1.0_r8 - currentCohort%fire_mort) + ! loss of individuals from source patch + currentCohort%n = currentCohort%n * (1._r8 - patch_site_areadis/currentPatch%area) + + endif + + if (nc%n > 0.0_r8) then + storebigcohort => new_patch%tallest + storesmallcohort => new_patch%shortest + if(associated(new_patch%tallest))then + tnull = 0 + else + tnull = 1 + new_patch%tallest => nc + nc%taller => null() + endif + + if(associated(new_patch%shortest))then + snull = 0 + else + snull = 1 + new_patch%shortest => nc + nc%shorter => null() + endif + nc%patchptr => new_patch + call insert_cohort(nc, new_patch%tallest, new_patch%shortest, tnull, snull, storebigcohort, storesmallcohort) + + new_patch%tallest => storebigcohort + new_patch%shortest => storesmallcohort + else + deallocate(nc) !get rid of the new memory. + endif + + currentCohort => currentCohort%taller + enddo ! currentCohort + call sort_cohorts(currentPatch) + + !zero disturbance accumulators + currentPatch%disturbance_rate = 0._r8 + currentPatch%disturbance_rates = 0._r8 + + !update area of donor patch + currentPatch%area = currentPatch%area - patch_site_areadis + + !sort out the cohorts, since some of them may be so small as to need removing. + call fuse_cohorts(currentPatch) + call terminate_cohorts(currentPatch) + call sort_cohorts(currentPatch) + + currentPatch => currentPatch%younger + + enddo ! currentPatch patch loop. + + !*************************/ + !** INSERT NEW PATCH INTO LINKED LIST + !**********`***************/ + currentPatch => currentSite%youngest_patch + new_patch%older => currentPatch + new_patch%younger => NULL() + currentPatch%younger => new_patch + currentSite%youngest_patch => new_patch + + call fuse_cohorts(new_patch) + call terminate_cohorts(new_patch) + call sort_cohorts(new_patch) + + endif !end new_patch area + + call check_patch_area(currentSite) + call set_patchno(currentSite) + + end subroutine spawn_patches + + ! ============================================================================ + subroutine check_patch_area( currentSite ) + ! + ! !DESCRIPTION: + ! Check to see that total area is not exceeded. + ! + ! !USES: + ! + ! !ARGUMENTS: + type(ed_site_type), intent(in), target :: currentSite + ! + ! !LOCAL VARIABLES: + real(r8) :: areatot + type(ed_patch_type), pointer :: currentPatch + !--------------------------------------------------------------------- + + areatot = 0._r8 + currentPatch => currentSite%oldest_patch + do while(associated(currentPatch)) + areatot = areatot + currentPatch%area + currentPatch => currentPatch%younger + if (( areatot - area ) > 0._r8 ) then + write(iulog,*) 'trimming patch area - is too big' , areatot-area + currentSite%oldest_patch%area = currentSite%oldest_patch%area - (areatot - area) + endif + enddo + + end subroutine check_patch_area + + ! ============================================================================ + subroutine set_patchno( currentSite ) + ! + ! !DESCRIPTION: + ! Give patches an order number from the oldest to youngest. + ! + ! !USES: + ! + ! !ARGUMENTS: + type(ed_site_type),intent(in), target :: currentSite + ! + ! !LOCAL VARIABLES: + type(ed_patch_type), pointer :: currentPatch + integer patchno + !--------------------------------------------------------------------- + + patchno = 1 + currentPatch => currentSite%oldest_patch + do while(associated(currentPatch)) + currentPatch%patchno = patchno + patchno = patchno + 1 + currentPatch => currentPatch%younger + enddo + + end subroutine set_patchno + + ! ============================================================================ + subroutine average_patch_properties( currentPatch, newPatch, patch_site_areadis ) + ! + ! !DESCRIPTION: + ! Average together the state properties of all of the donor patches that + ! make up the new patch. + ! + ! !USES: + ! + ! !ARGUMENTS: + type(ed_patch_type) , intent(in), target :: currentPatch + type(ed_patch_type) , intent(inout) :: newPatch + real(r8) , intent(out) :: patch_site_areadis ! amount of land disturbed in this patch. m2 + ! + ! !LOCAL VARIABLES: + integer :: c,p ! counters for PFT and litter size class. + !--------------------------------------------------------------------- + + patch_site_areadis = currentPatch%area * currentPatch%disturbance_rate ! how much land is disturbed in this donor patch? + + do p=1,numpft_ed + newPatch%seed_bank(p) = newPatch%seed_bank(p) + currentPatch%seed_bank(p) * patch_site_areadis/newPatch%area + enddo + + do c = 1,ncwd !move litter pool en mass into the new patch. + newPatch%cwd_ag(c) = newPatch%cwd_ag(c) + currentPatch%cwd_ag(c) * patch_site_areadis/newPatch%area + newPatch%cwd_bg(c) = newPatch%cwd_bg(c) + currentPatch%cwd_bg(c) * patch_site_areadis/newPatch%area + enddo + + do p = 1,numpft_ed !move litter pool en mass into the new patch + newPatch%root_litter(p) = newPatch%root_litter(p) + currentPatch%root_litter(p) * patch_site_areadis/newPatch%area + newPatch%leaf_litter(p) = newPatch%leaf_litter(p) + currentPatch%leaf_litter(p) * patch_site_areadis/newPatch%area + enddo + + newPatch%spread = newPatch%spread + currentPatch%spread * patch_site_areadis/newPatch%area + + end subroutine average_patch_properties + + ! ============================================================================ + subroutine fire_litter_fluxes(cp_target, new_patch_target, patch_site_areadis) + ! + ! !DESCRIPTION: + ! CWD pool burned by a fire. + ! Carbon going from burned trees into CWD pool + ! Burn parts of trees that don't die in fire + ! Burn live grasses and kill them. + ! + ! !USES: + use EDParamsMod, only : ED_val_ag_biomass + use SFParamsMod, only : SF_VAL_CWD_FRAC + use EDGrowthFunctionsMod, only : c_area + use EDtypesMod , only : dg_sf + ! + ! !ARGUMENTS: + type(ed_patch_type) , intent(inout), target :: cp_target + type(ed_patch_type) , intent(inout), target :: new_patch_target + real(r8) , intent(inout) :: patch_site_areadis + ! + ! !LOCAL VARIABLES: + type(ed_site_type) , pointer :: currentSite + type(ed_patch_type) , pointer :: currentPatch + type(ed_patch_type) , pointer :: new_patch + type(ed_cohort_type), pointer :: currentCohort + real(r8) :: bcroot ! amount of below ground coarse root per cohort kgC. (goes into CWD_BG) + real(r8) :: bstem ! amount of above ground stem biomass per cohort kgC.(goes into CWG_AG) + real(r8) :: dead_tree_density ! no trees killed by fire per m2 + reaL(r8) :: burned_litter ! amount of each litter pool burned by fire. kgC/m2/day + real(r8) :: burned_leaves ! amount of tissue consumed by fire for grass. KgC/individual/day + integer :: c, p + !--------------------------------------------------------------------- + + !check that total area is not exceeded. + currentPatch => cp_target + new_patch => new_patch_target + + if ( currentPatch%fire == 1 ) then !only do this if there was a fire in this actual patch. + patch_site_areadis = currentPatch%area * currentPatch%disturbance_rate ! how much land is disturbed in this donor patch? + currentSite => currentPatch%siteptr + + !************************************/ + !PART 1) Burn the fractions of existing litter in the new patch that were consumed by the fire. + !************************************/ + do c = 1,ncwd + burned_litter = new_patch%cwd_ag(c) * patch_site_areadis/new_patch%area * currentPatch%burnt_frac_litter(c+1) !kG/m2/day + new_patch%cwd_ag(c) = new_patch%cwd_ag(c) - burned_litter + currentSite%flux_out = currentSite%flux_out + burned_litter * new_patch%area !kG/site/day + enddo + + do p = 1,numpft_ed + burned_litter = new_patch%leaf_litter(p) * patch_site_areadis/new_patch%area * currentPatch%burnt_frac_litter(dg_sf) + new_patch%leaf_litter(p) = new_patch%leaf_litter(p) - burned_litter + currentSite%flux_out = currentSite%flux_out + burned_litter * new_patch%area !kG/site/dat + enddo + + !************************************/ + !PART 2) Put unburned parts of plants that died in the fire into the litter pool of new and old patches + ! This happens BEFORE the plant numbers have been updated. So we are working with the + ! pre-fire population of plants, which is the right way round. + !************************************/ + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + p = currentCohort%pft + if(pftcon%woody(p) == 1)then !DEAD (FROM FIRE) TREES + !************************************/ + ! Number of trees that died because of the fire, per m2 of ground. + ! Divide their litter into the four litter streams, and spread evenly across ground surface. + !************************************/ + ! stem biomass per tree + bstem = (currentCohort%bsw + currentCohort%bdead) * ED_val_ag_biomass + ! coarse root biomass per tree + bcroot = (currentCohort%bsw + currentCohort%bdead) * (1.0_r8 - ED_val_ag_biomass) + ! density of dead trees per m2. + dead_tree_density = (currentCohort%fire_mort * currentCohort%n*patch_site_areadis/currentPatch%area) / AREA + + ! Unburned parts of dead tree pool. + ! Unburned leaves and roots + + new_patch%leaf_litter(p) = new_patch%leaf_litter(p) + dead_tree_density * (currentCohort%bl) & + * (1.0_r8-currentCohort%cfa) + new_patch%root_litter(p) = new_patch%root_litter(p) + dead_tree_density * (currentCohort%br+currentCohort%bstore) + currentPatch%leaf_litter(p) = currentPatch%leaf_litter(p) + dead_tree_density * & + (currentCohort%bl) * (1.0_r8-currentCohort%cfa) + currentPatch%root_litter(p) = currentPatch%root_litter(p) + dead_tree_density * & + (currentCohort%br+currentCohort%bstore) + + ! below ground coarse woody debris from burned trees + do c = 1,ncwd + new_patch%cwd_bg(c) = new_patch%cwd_bg(c) + dead_tree_density * SF_val_CWD_frac(c) * bcroot + currentPatch%cwd_bg(c) = currentPatch%cwd_bg(c) + dead_tree_density * SF_val_CWD_frac(c) * bcroot + enddo + + ! above ground coarse woody debris from unburned twigs and small branches + do c = 1,2 + new_patch%cwd_ag(c) = new_patch%cwd_ag(c) + dead_tree_density * SF_val_CWD_frac(c) * bstem & + * (1.0_r8-currentCohort%cfa) + currentPatch%cwd_ag(c) = currentPatch%cwd_ag(c) + dead_tree_density * SF_val_CWD_frac(c) * & + bstem * (1.0_r8-currentCohort%cfa) + enddo + + ! above ground coarse woody debris from large branches and stems: these do not burn in crown fires. + do c = 3,4 + new_patch%cwd_ag(c) = new_patch%cwd_ag(c) + dead_tree_density * SF_val_CWD_frac(c) * bstem + currentPatch%cwd_ag(c) = currentPatch%cwd_ag(c) + dead_tree_density * SF_val_CWD_frac(c) * bstem + enddo + + ! Burned parts of dead tree pool. + ! Burned twigs and small branches. + do c = 1,2 + + currentSite%cwd_ag_burned(c) = currentSite%cwd_ag_burned(c) + dead_tree_density * & + SF_val_CWD_frac(c) * bstem * currentCohort%cfa + currentSite%flux_out = currentSite%flux_out + dead_tree_density * & + AREA * SF_val_CWD_frac(c) * bstem * currentCohort%cfa + + enddo + + !burned leaves. + do p = 1,numpft_ed + + currentSite%leaf_litter_burned(p) = currentSite%leaf_litter_burned(p) + & + dead_tree_density * currentCohort%bl * currentCohort%cfa + currentSite%flux_out = currentSite%flux_out + & + dead_tree_density * AREA * currentCohort%bl * currentCohort%cfa + + enddo + + endif + + currentCohort => currentCohort%taller + + enddo ! currentCohort + + !************************************/ + ! PART 3) Burn parts of trees that did *not* die in the fire. + ! PART 4) Burn parts of grass that are consumed by the fire. + ! grasses are not killed directly by fire. They die by losing all of their leaves and starving. + !************************************/ + currentCohort => new_patch%shortest + do while(associated(currentCohort)) + + currentCohort%c_area = c_area(currentCohort) + if(pftcon%woody(currentCohort%pft) == 1)then + burned_leaves = (currentCohort%bl+currentCohort%bsw) * currentCohort%cfa + else + burned_leaves = (currentCohort%bl+currentCohort%bsw) * currentPatch%burnt_frac_litter(6) + endif + if (burned_leaves > 0.0_r8) then + + currentCohort%balive = max(currentCohort%br,currentCohort%balive - burned_leaves) + currentCohort%bl = max(0.00001_r8, currentCohort%bl - burned_leaves) + !KgC/gridcell/day + currentSite%flux_out = currentSite%flux_out + burned_leaves * currentCohort%n * & + patch_site_areadis/currentPatch%area * AREA + + endif + currentCohort%cfa = 0.0_r8 + + currentCohort => currentCohort%taller + + enddo + + endif !currentPatch%fire. + + end subroutine fire_litter_fluxes + + ! ============================================================================ + subroutine mortality_litter_fluxes(cp_target, new_patch_target, patch_site_areadis) + ! + ! !DESCRIPTION: + ! Carbon going from ongoing mortality into CWD pools. + ! + ! !USES: + use EDParamsMod, only : ED_val_ag_biomass, ED_val_understorey_death + use SFParamsMod, only : SF_val_cwd_frac + ! + ! !ARGUMENTS: + type(ed_patch_type) , intent(inout), target :: cp_target + type(ed_patch_type) , intent(inout), target :: new_patch_target + real(r8) , intent(in) :: patch_site_areadis + ! + ! !LOCAL VARIABLES: + real(r8) :: cwd_litter_density + real(r8) :: litter_area ! area over which to distribute this litter. + type(ed_cohort_type), pointer :: currentCohort + type(ed_patch_type) , pointer :: currentPatch + type(ed_patch_type) , pointer :: new_patch + real(r8) :: understorey_dead !Number of individual dead from the canopy layer /day + real(r8) :: canopy_dead !Number of individual dead from the understorey layer /day + real(r8) :: np_mult !Fraction of the new patch which came from the current patch (and so needs the same litter) + integer :: p,c + !--------------------------------------------------------------------- + + currentPatch => cp_target + new_patch => new_patch_target + currentPatch%canopy_mortality_woody_litter = 0.0_r8 ! mortality generated litter. KgC/m2/day + currentPatch%canopy_mortality_leaf_litter(:) = 0.0_r8 + currentPatch%canopy_mortality_root_litter(:) = 0.0_r8 + + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + p = currentCohort%pft + if(currentPatch%disturbance_rates(1) > currentPatch%disturbance_rates(2))then !mortality is dominant disturbance + if(currentCohort%canopy_layer == 1)then + !currentCohort%dmort = mortality_rates(currentCohort) + !the disturbance calculations are done with the previous n, c_area and d_mort. So it's probably & + !not right to recalcualte dmort here. + canopy_dead = currentCohort%n * min(1.0_r8,currentCohort%dmort * udata%deltat) + + currentPatch%canopy_mortality_woody_litter = currentPatch%canopy_mortality_woody_litter + & + canopy_dead*(currentCohort%bdead+currentCohort%bsw) + currentPatch%canopy_mortality_leaf_litter(p) = currentPatch%canopy_mortality_leaf_litter(p)+ & + canopy_dead*(currentCohort%bl) + currentPatch%canopy_mortality_root_litter(p) = currentPatch%canopy_mortality_root_litter(p)+ & + canopy_dead*(currentCohort%br+currentCohort%bstore) + + else + if(pftcon%woody(currentCohort%pft) == 1)then + + understorey_dead = ED_val_understorey_death * currentCohort%n * (patch_site_areadis/currentPatch%area) !kgC/site/day + currentPatch%canopy_mortality_woody_litter = currentPatch%canopy_mortality_woody_litter + & + understorey_dead*(currentCohort%bdead+currentCohort%bsw) + currentPatch%canopy_mortality_leaf_litter(p)= currentPatch%canopy_mortality_leaf_litter(p)+ & + understorey_dead* currentCohort%bl + currentPatch%canopy_mortality_root_litter(p)= currentPatch%canopy_mortality_root_litter(p)+ & + understorey_dead*(currentCohort%br+currentCohort%bstore) + + ! FIX(SPM,040114) - clarify this comment + ! grass is not killed by canopy mortality disturbance events. + ! Just move it into the new patch area. + else + ! no-op + endif + endif + endif + + currentCohort => currentCohort%taller + + enddo !currentCohort + + !************************************/ + !Evenly distribute the litter from the trees that died across the new and old patches + !************************************/ + !************************************/ + !Evenly distribute the litter from the trees that died across the new and old patches + !'litter' fluxes here are in KgC + !************************************/ + litter_area = currentPatch%area + np_mult = patch_site_areadis/new_patch%area + ! This litter is distributed between the current and new patches, & + ! not to any other patches. This is really the eventually area of the current patch & + ! (currentPatch%area-patch_site_areadis) +patch_site_areadis... + ! For the new patch, only some fraction of its land area (patch_areadis/np%area) is derived from the current patch + ! so we need to multiply by patch_areadis/np%area + do c = 1,ncwd + + cwd_litter_density = SF_val_CWD_frac(c) * currentPatch%canopy_mortality_woody_litter / litter_area + + new_patch%cwd_ag(c) = new_patch%cwd_ag(c) + ED_val_ag_biomass * cwd_litter_density * np_mult + currentPatch%cwd_ag(c) = currentPatch%cwd_ag(c) + ED_val_ag_biomass * cwd_litter_density + new_patch%cwd_bg(c) = new_patch%cwd_bg(c) + (1._r8-ED_val_ag_biomass) * cwd_litter_density * np_mult + currentPatch%cwd_bg(c) = currentPatch%cwd_bg(c) + (1._r8-ED_val_ag_biomass) * cwd_litter_density + + enddo + + do p = 1,numpft_ed + + new_patch%leaf_litter(p) = new_patch%leaf_litter(p) + currentPatch%canopy_mortality_leaf_litter(p) / litter_area * np_mult + new_patch%root_litter(p) = new_patch%root_litter(p) + currentPatch%canopy_mortality_root_litter(p) / litter_area * np_mult + currentPatch%leaf_litter(p) = currentPatch%leaf_litter(p) + currentPatch%canopy_mortality_leaf_litter(p) / litter_area + currentPatch%root_litter(p) = currentPatch%root_litter(p) + currentPatch%canopy_mortality_root_litter(p) / litter_area + + enddo + + end subroutine mortality_litter_fluxes + + ! ============================================================================ + subroutine create_patch(currentSite, new_patch, age, areap, spread_local,cwd_ag_local,cwd_bg_local, & + leaf_litter_local,root_litter_local,seed_bank_local) + ! + ! !DESCRIPTION: + ! Set default values for creating a new patch + ! + ! !USES: + use clm_varpar , only : nlevgrnd + ! + ! !ARGUMENTS: + type(ed_site_type) , intent(inout), target :: currentSite + type(ed_patch_type), intent(inout), target :: new_patch + real(r8), intent(in) :: age ! notional age of this patch in years + real(r8), intent(in) :: areap ! initial area of this patch in m2. + real(r8), intent(in) :: cwd_ag_local(:) ! initial value of above ground coarse woody debris. KgC/m2 + real(r8), intent(in) :: cwd_bg_local(:) ! initial value of below ground coarse woody debris. KgC/m2 + real(r8), intent(in) :: root_litter_local(:)! initial value of root litter. KgC/m2 + real(r8), intent(in) :: leaf_litter_local(:)! initial value of leaf litter. KgC/m2 + real(r8), intent(in) :: spread_local(:) ! initial value of canopy spread parameter.no units + real(r8), intent(in) :: seed_bank_local(:) ! initial value of seed bank. KgC/m2 + ! + ! !LOCAL VARIABLES: + !--------------------------------------------------------------------- + + call zero_patch(new_patch) !The nan value in here is not working?? + + new_patch%tallest => null() ! pointer to patch's tallest cohort + new_patch%shortest => null() ! pointer to patch's shortest cohort + new_patch%older => null() ! pointer to next older patch + new_patch%younger => null() ! pointer to next shorter patch + new_patch%siteptr => null() ! pointer to the site that the patch is in + + ! assign known patch attributes + + new_patch%siteptr => currentSite + new_patch%age = age + new_patch%area = areap + new_patch%spread = spread_local + new_patch%cwd_ag = cwd_ag_local + new_patch%cwd_bg = cwd_bg_local + new_patch%leaf_litter = leaf_litter_local + new_patch%root_litter = root_litter_local + new_patch%seed_bank = seed_bank_local + + !zeroing things because of the surfacealbedo problem... shouldnt really be necesary + new_patch%cwd_ag_in(:) = 0._r8 + new_patch%cwd_bg_in(:) = 0._r8 + + new_patch%f_sun = 0._r8 + new_patch%ed_laisun_z(:,:,:) = 0._r8 + new_patch%ed_laisha_z(:,:,:) = 0._r8 + new_patch%ed_parsun_z(:,:,:) = 0._r8 + new_patch%ed_parsha_z(:,:,:) = 0._r8 + new_patch%fabi = 0._r8 + new_patch%fabd = 0._r8 + new_patch%tr_soil_dir(:) = 1._r8 + new_patch%tr_soil_dif(:) = 1._r8 + new_patch%tr_soil_dir_dif(:) = 0._r8 + new_patch%fabd_sun_z(:,:,:) = 0._r8 + new_patch%fabd_sha_z(:,:,:) = 0._r8 + new_patch%fabi_sun_z(:,:,:) = 0._r8 + new_patch%fabi_sha_z(:,:,:) = 0._r8 + new_patch%frac_burnt = 0._r8 + new_patch%total_tree_area = 0.0_r8 + new_patch%NCL_p = 1 + + allocate(new_patch%rootfr_ft(numpft_ed,nlevgrnd)) + allocate(new_patch%rootr_ft(numpft_ed,nlevgrnd)) + + end subroutine create_patch + + ! ============================================================================ + subroutine zero_patch(cp_p) + ! + ! !DESCRIPTION: + ! Sets all the variables in the patch to nan or zero + ! (this needs to be two seperate routines, one for nan & one for zero + ! + ! !USES: + use shr_infnan_mod, only : nan => shr_infnan_nan, assignment(=) + ! + ! !ARGUMENTS: + type(ed_patch_type), intent(inout), target :: cp_p + ! + ! !LOCAL VARIABLES: + type(ed_patch_type), pointer :: currentPatch + !--------------------------------------------------------------------- + + currentPatch => cp_p + + currentPatch%tallest => null() + currentPatch%shortest => null() + currentPatch%older => null() + currentPatch%younger => null() + currentPatch%siteptr => null() + + currentPatch%patchno = 999 + currentPatch%clm_pno = 999 + + currentPatch%age = nan + currentPatch%area = nan + currentPatch%canopy_layer_lai(:) = nan + currentPatch%total_canopy_area = nan + currentPatch%canopy_area = nan + currentPatch%bare_frac_area = nan + + currentPatch%tlai_profile(:,:,:) = nan + currentPatch%elai_profile(:,:,:) = nan + currentPatch%tsai_profile(:,:,:) = nan + currentPatch%esai_profile(:,:,:) = nan + currentPatch%canopy_area_profile(:,:,:) = nan + + currentPatch%fabd_sun_z(:,:,:) = nan + currentPatch%fabd_sha_z(:,:,:) = nan + currentPatch%fabi_sun_z(:,:,:) = nan + currentPatch%fabi_sha_z(:,:,:) = nan + + currentPatch%ed_laisun_z(:,:,:) = nan + currentPatch%ed_laisha_z(:,:,:) = nan + currentPatch%ed_parsun_z(:,:,:) = nan + currentPatch%ed_parsha_z(:,:,:) = nan + currentPatch%psn_z(:,:,:) = nan + + currentPatch%f_sun(:,:,:) = nan + currentPatch%tr_soil_dir(:) = nan ! fraction of incoming direct radiation that is transmitted to the soil as direct + currentPatch%tr_soil_dif(:) = nan ! fraction of incoming diffuse radiation that is transmitted to the soil as diffuse + currentPatch%tr_soil_dir_dif(:) = nan ! fraction of incoming direct radiation that is transmitted to the soil as diffuse + currentPatch%fab(:) = nan ! fraction of incoming total radiation that is absorbed by the canopy + currentPatch%fabd(:) = nan ! fraction of incoming direct radiation that is absorbed by the canopy + currentPatch%fabi(:) = nan ! fraction of incoming diffuse radiation that is absorbed by the canopy + + currentPatch%present(:,:) = 999 ! is there any of this pft in this layer? + currentPatch%nrad(:,:) = 999 ! number of exposed leaf layers for each canopy layer and pft + currentPatch%ncan(:,:) = 999 ! number of total leaf layers for each canopy layer and pft + currentPatch%lai = nan ! leaf area index of patch + currentPatch%spread(:) = nan ! dynamic ratio of dbh to canopy area. + currentPatch%pft_agb_profile(:,:) = nan + currentPatch%gpp = 0._r8 + currentPatch%npp = 0._r8 + currentPatch%seed_bank(:) = 0._r8 + currentPatch%dseed_dt(:) = 0._r8 + + ! DISTURBANCE + currentPatch%disturbance_rates = 0._r8 + currentPatch%disturbance_rate = 0._r8 + + ! LITTER + currentPatch%cwd_ag(:) = 0.0_r8 ! above ground coarse woody debris gc/m2. + currentPatch%cwd_bg(:) = 0.0_r8 ! below ground coarse woody debris + currentPatch%root_litter(:) = 0.0_r8 + currentPatch%leaf_litter(:) = 0.0_r8 + + ! FIRE + currentPatch%fuel_eff_moist = 0.0_r8 ! average fuel moisture content of the ground fuel + ! (incl. live grasses. omits 1000hr fuels) + currentPatch%livegrass = 0.0_r8 ! total ag grass biomass in patch. 1=c3 grass, 2=c4 grass. gc/m2 + currentPatch%sum_fuel = 0.0_r8 ! total ground fuel related to ros (omits 1000hr fuels). gc/m2 + currentPatch%fuel_bulkd = 0.0_r8 ! average fuel bulk density of the ground fuel + ! (incl. live grasses. omits 1000hr fuels). kgc/m3 + currentPatch%fuel_sav = 0.0_r8 ! average surface area to volume ratio of the ground fuel + ! (incl. live grasses. omits 1000hr fuels). + currentPatch%fuel_mef = 0.0_r8 ! average moisture of extinction factor of the ground fuel + ! (incl. live grasses. omits 1000hr fuels). + currentPatch%ros_front = 0.0_r8 ! average rate of forward spread of each fire in the patch. m/min. + currentPatch%effect_wspeed = 0.0_r8 ! dailywind modified by fraction of relative grass and tree cover. m/min. + currentPatch%tau_l = 0.0_r8 ! mins p&r(1986) + currentPatch%fuel_frac(:) = 0.0_r8 ! fraction of each litter class in the sum_fuel + !- for purposes of calculating weighted averages. + currentPatch%tfc_ros = 0.0_r8 ! used in fi calc + currentPatch%fi = 0._r8 ! average fire intensity of flaming front during day. + ! backward ros plays no role. kj/m/s or kw/m. + currentPatch%fire = 999 ! sr decide_fire.1=fire hot enough to proceed. 0=stop everything- no fires today + currentPatch%fd = 0.0_r8 ! fire duration (mins) + currentPatch%ros_back = 0.0_r8 ! backward ros (m/min) + currentPatch%ab = 0.0_r8 ! area burnt daily m2 + currentPatch%nf = 0.0_r8 ! number of fires initiated daily + currentPatch%sh = 0.0_r8 ! average scorch height for the patch(m) + currentPatch%frac_burnt = 0.0_r8 ! fraction burnt in each timestep. + currentPatch%burnt_frac_litter(:) = 0.0_r8 + currentPatch%btran_ft(:) = 0.0_r8 + + currentPatch%canopy_layer_lai(:) = 0.0_r8 + currentPatch%seeds_in(:) = 0.0_r8 + currentPatch%seed_decay(:) = 0.0_r8 + currentPatch%seed_germination(:) = 0.0_r8 + currentPatch%fab(:) = 0.0_r8 + currentPatch%sabs_dir(:) = 0.0_r8 + currentPatch%sabs_dif(:) = 0.0_r8 + + + end subroutine zero_patch + + ! ============================================================================ + subroutine fuse_patches( csite ) + ! + ! !DESCRIPTION: + ! Decide to fuse patches if their cohort structures are similar + ! + ! !USES: + ! + ! !ARGUMENTS: + type(ed_site_type), intent(inout), target :: csite + ! + ! !LOCAL VARIABLES: + type(ed_site_type) , pointer :: currentSite + type(ed_patch_type), pointer :: currentPatch,tpp,tmpptr + integer :: ft,z !counters for pft and height class + real(r8) :: norm !normalized difference between biomass profiles + real(r8) :: profiletol !tolerance of patch fusion routine. Starts off high and is reduced if there are too many patches. + integer :: maxpatch !maximum number of allowed patches. FIX-RF. These should be namelist variables. + integer :: nopatches !number of patches presently in gridcell + integer :: iterate !switch of patch reduction iteration scheme. 1 to keep going, 0 to stop + integer :: fuse_flag !do patches get fused (1) or not (0). + !--------------------------------------------------------------------- + + maxpatch = 4 + + currentSite => csite + + profiletol = 0.6_r8 !start off with a very small profile tol, or a predefined parameter? + + nopatches = 0 + currentPatch => currentSite%youngest_patch + do while(associated(currentPatch)) + nopatches = nopatches +1 + currentPatch => currentPatch%older + enddo + !---------------------------------------------------------------------! + ! We only really care about fusing patches if nopatches > 1 ! + !---------------------------------------------------------------------! + iterate = 1 + + !---------------------------------------------------------------------! + ! Keep doing this until nopatches >= maxpatch ! + !---------------------------------------------------------------------! + + do while(iterate == 1) + !---------------------------------------------------------------------! + ! Calculate the biomass profile of each patch ! + !---------------------------------------------------------------------! + currentPatch => currentSite%youngest_patch + do while(associated(currentPatch)) + call patch_pft_size_profile(currentPatch) + currentPatch => currentPatch%older + enddo + + !---------------------------------------------------------------------! + ! Loop round current & target (currentPatch,tpp) patches to assess combinations ! + !---------------------------------------------------------------------! + currentPatch => currentSite%youngest_patch + do while(associated(currentPatch)) + tpp => currentSite%youngest_patch + do while(associated(tpp)) + + if(.not.associated(currentPatch))then + write(iulog,*) 'ED: issue with currentPatch' + endif + + if(associated(tpp).and.associated(currentPatch))then + fuse_flag = 1 !the default is to fuse the patches + if(currentPatch%patchno /= tpp%patchno) then !these should be the same patch + + !---------------------------------------------------------------------! + ! Calculate the difference criteria for each pft and dbh class ! + !---------------------------------------------------------------------! + do ft = 1,numpft_ed ! loop over pfts + do z = 1,n_dbh_bins ! loop over hgt bins + !is there biomass in this category? + if(currentPatch%pft_agb_profile(ft,z) > 0.0_r8.or.tpp%pft_agb_profile(ft,z) > 0.0_r8)then + norm = abs(currentPatch%pft_agb_profile(ft,z) - tpp%pft_agb_profile(ft,z))/(0.5_r8*& + &(currentPatch%pft_agb_profile(ft,z) + tpp%pft_agb_profile(ft,z))) + !---------------------------------------------------------------------! + ! Look for differences in profile biomass, above the minimum biomass ! + !---------------------------------------------------------------------! + + if(norm > profiletol)then + !looking for differences between profile density. + if(currentPatch%pft_agb_profile(ft,z) > NTOL.or.tpp%pft_agb_profile(ft,z) > NTOL)then + fuse_flag = 0 !do not fuse - keep apart. + endif + endif ! profile tol + endif ! NTOL + enddo !ht bins + enddo ! PFT + + !---------------------------------------------------------------------! + ! Call the patch fusion routine if there is a meaningful difference ! + ! any of the pft x height categories ! + !---------------------------------------------------------------------! + + if(fuse_flag == 1)then + tmpptr => currentPatch%older + call fuse_2_patches(currentPatch, tpp) + call fuse_cohorts(tpp) + call sort_cohorts(tpp) + currentPatch => tmpptr + else + ! write(iulog,*) 'patches not fused' + endif + endif !are both patches associated? + endif !are these different patches? + tpp => tpp%older + enddo !tpp loop + + if(associated(currentPatch))then + currentPatch => currentPatch%older + else + currentPatch => null() + endif !associated currentPatch + + enddo ! currentPatch loop + + !---------------------------------------------------------------------! + ! Is the number of patches larger than the maximum? ! + !---------------------------------------------------------------------! + nopatches = 0 + currentPatch => currentSite%youngest_patch + do while(associated(currentPatch)) + nopatches = nopatches +1 + currentPatch => currentPatch%older + enddo + + if(nopatches > maxpatch)then + iterate = 1 + profiletol = profiletol * 1.1_r8 + write(iulog,*) 'maxpatch exceeded, triggering patch fusion iteration.',profiletol,nopatches + !---------------------------------------------------------------------! + ! Making profile tolerance larger means that more fusion will happen ! + !---------------------------------------------------------------------! + else + iterate = 0 + endif + + enddo !do while nopatches>maxpatch + + end subroutine fuse_patches + + ! ============================================================================ + subroutine fuse_2_patches(dp, rp) + ! + ! !DESCRIPTION: + ! This function fuses the two patches specified in the argument. + ! It fuses the first patch in the argument (the "donor") into the second + ! patch in the argument (the "recipient"), and frees the memory + ! associated with the secnd patch + ! + ! !USES: + ! + ! !ARGUMENTS: + type (ed_patch_type) , intent(inout), pointer :: dp ! Donor Patch + type (ed_patch_type) , intent(inout), pointer :: rp ! Recipient Patch + ! + ! !LOCAL VARIABLES: + type (ed_cohort_type), pointer :: currentCohort ! Current Cohort + type (ed_cohort_type), pointer :: nextc ! Remembers next cohort in list + type (ed_cohort_type), pointer :: storesmallcohort + type (ed_cohort_type), pointer :: storebigcohort + integer :: c,p !counters for pft and litter size class. + integer :: tnull,snull ! are the tallest and shortest cohorts associated? + !--------------------------------------------------------------------- + + !area weighted average of ages & litter & seed bank + rp%age = (dp%age * dp%area + rp%age * rp%area)/(dp%area + rp%area) + + do p = 1,numpft_ed + rp%seed_bank(p) = (rp%seed_bank(p)*rp%area + dp%seed_bank(p)*dp%area)/(rp%area + dp%area) + rp%seeds_in(p) = (rp%seeds_in(p)*rp%area + dp%seeds_in(p)*dp%area)/(rp%area + dp%area) + rp%seed_decay(p) = (rp%seed_decay(p)*rp%area + dp%seed_decay(p)*dp%area)/(rp%area + dp%area) + rp%seed_germination(p) = (rp%seed_germination(p)*rp%area + dp%seed_germination(p)*dp%area)/(rp%area + dp%area) + enddo + + do c = 1,ncwd + rp%cwd_ag(c) = (dp%cwd_ag(c)*dp%area + rp%cwd_ag(c)*rp%area)/(dp%area + rp%area) + rp%cwd_bg(c) = (dp%cwd_bg(c)*dp%area + rp%cwd_bg(c)*rp%area)/(dp%area + rp%area) + enddo + + do p = 1,numpft_ed + rp%leaf_litter(p) = (dp%leaf_litter(p)*dp%area + rp%leaf_litter(p)*rp%area)/(dp%area + rp%area) + rp%root_litter(p) = (dp%root_litter(p)*dp%area + rp%root_litter(p)*rp%area)/(dp%area + rp%area) + enddo + + rp%fuel_eff_moist = (dp%fuel_eff_moist*dp%area + rp%fuel_eff_moist*rp%area)/(dp%area + rp%area) + rp%livegrass = (dp%livegrass*dp%area + rp%livegrass*rp%area)/(dp%area + rp%area) + rp%sum_fuel = (dp%sum_fuel*dp%area + rp%sum_fuel*rp%area)/(dp%area + rp%area) + rp%fuel_bulkd = (dp%fuel_bulkd*dp%area + rp%fuel_bulkd*rp%area)/(dp%area + rp%area) + rp%fuel_sav = (dp%fuel_sav*dp%area + rp%fuel_sav*rp%area)/(dp%area + rp%area) + rp%fuel_mef = (dp%fuel_mef*dp%area + rp%fuel_mef*rp%area)/(dp%area + rp%area) + rp%ros_front = (dp%ros_front*dp%area + rp%ros_front*rp%area)/(dp%area + rp%area) + rp%effect_wspeed = (dp%effect_wspeed*dp%area + rp%effect_wspeed*rp%area)/(dp%area + rp%area) + rp%tau_l = (dp%tau_l*dp%area + rp%tau_l*rp%area)/(dp%area + rp%area) + rp%fuel_frac(:) = (dp%fuel_frac(:)*dp%area + rp%fuel_frac(:)*rp%area)/(dp%area + rp%area) + rp%tfc_ros = (dp%tfc_ros*dp%area + rp%tfc_ros*rp%area)/(dp%area + rp%area) + rp%fi = (dp%fi*dp%area + rp%fi*rp%area)/(dp%area + rp%area) + rp%fd = (dp%fd*dp%area + rp%fd*rp%area)/(dp%area + rp%area) + rp%ros_back = (dp%ros_back*dp%area + rp%ros_back*rp%area)/(dp%area + rp%area) + rp%ab = (dp%ab*dp%area + rp%ab*rp%area)/(dp%area + rp%area) + rp%nf = (dp%nf*dp%area + rp%nf*rp%area)/(dp%area + rp%area) + rp%sh = (dp%sh*dp%area + rp%sh*rp%area)/(dp%area + rp%area) + rp%frac_burnt = (dp%frac_burnt*dp%area + rp%frac_burnt*rp%area)/(dp%area + rp%area) + rp%burnt_frac_litter(:) = (dp%burnt_frac_litter(:)*dp%area + rp%burnt_frac_litter(:)*rp%area)/(dp%area + rp%area) + rp%btran_ft(:) = (dp%btran_ft(:)*dp%area + rp%btran_ft(:)*rp%area)/(dp%area + rp%area) + + rp%area = rp%area + dp%area !THIS MUST COME AT THE END! + + !insert donor cohorts into recipient patch + if(associated(dp%shortest))then + + currentCohort => dp%shortest + if(associated(currentCohort)) then + nextc => currentCohort%taller + endif + + do while(associated(dp%shortest)) + + storebigcohort => rp%tallest + storesmallcohort => rp%shortest + + if(associated(rp%tallest))then + tnull = 0 + else + tnull = 1 + rp%tallest => currentCohort + endif + + if(associated(rp%shortest))then + snull = 0 + else + snull = 1 + rp%shortest => currentCohort + endif + + call insert_cohort(currentCohort, rp%tallest, rp%shortest, tnull, snull, storebigcohort, storesmallcohort) + + rp%tallest => storebigcohort + rp%shortest => storesmallcohort + + currentCohort%patchptr => rp + currentCohort => nextc + + dp%shortest => currentCohort + + if(associated(currentCohort)) then + nextc => currentCohort%taller + endif + + enddo !cohort + endif !are there any cohorts? + + call patch_pft_size_profile(rp) ! Recalculate the patch size profile for the resulting patch + + ! FIX(SPM,032414) dangerous code here. Passing in dp as a pointer allows the code below + ! to effect the currentPatch that is the actual argument when in reality, dp should be + ! intent in only with these pointers being set on the actual argument + ! outside of this routine (in fuse_patches). basically this should be split + ! into a copy, then change pointers, then delete. + + if(associated(dp%younger)) then + dp%younger%older => dp%older + else + dp%siteptr%youngest_patch => dp%older !youngest + endif + if(associated(dp%older)) then + dp%older%younger => dp%younger + else + dp%siteptr%oldest_patch => dp%younger !oldest + endif + + deallocate(dp) + + end subroutine fuse_2_patches + + ! ============================================================================ + subroutine terminate_patches(cs_pnt) + ! + ! !DESCRIPTION: + ! Terminate Patches if they are too small + ! + ! !USES: + ! + ! !ARGUMENTS: + type(ed_site_type), target, intent(in) :: cs_pnt + ! + ! !LOCAL VARIABLES: + type(ed_site_type), pointer :: currentSite + type(ed_patch_type), pointer :: currentPatch + real(r8) areatot ! variable for checking whether the total patch area is wrong. + !--------------------------------------------------------------------- + + currentSite => cs_pnt + + currentPatch => currentSite%oldest_patch + + !fuse patches if one of them is very small.... + currentPatch => currentSite%youngest_patch + do while(associated(currentPatch)) + if(currentPatch%area <= 0.001_r8)then + if(associated(currentPatch%older).and.currentPatch%patchno /= currentSite%youngest_patch%patchno)then + ! Do not force the fusion of the youngest patch to its neighbour. + ! This is only really meant for very old patches. + write(iulog,*) 'fusing patches because one is too small',currentPatch%area, currentPatch%lai, & + currentPatch%older%area,currentPatch%older%lai,currentPatch%seed_bank(1) + call fuse_2_patches(currentPatch%older, currentPatch) + deallocate(currentPatch%older) + write(iulog,*) 'after fusion',currentPatch%area,currentPatch%seed_bank(1) + endif + endif + + currentPatch => currentPatch%older + + enddo + + !check area is not exceeded + areatot = 0._r8 + currentPatch => currentSite%oldest_patch + do while(associated(currentPatch)) + areatot = areatot + currentPatch%area + currentPatch => currentPatch%younger + if((areatot-area) > 0.0000001_r8)then + write(iulog,*) 'ED: areatot too large. end terminate', areatot,currentSite%clmgcell + endif + enddo + + end subroutine terminate_patches + + ! ============================================================================ + subroutine patch_pft_size_profile(cp_pnt) + ! + ! !DESCRIPTION: + ! Binned patch size profiles generated for patch fusion routine + ! + ! !USES: + ! + ! !ARGUMENTS: + type(ed_patch_type), target, intent(inout) :: cp_pnt + ! + ! !LOCAL VARIABLES: + type(ed_patch_type) , pointer :: currentPatch + type(ed_cohort_type), pointer :: currentCohort + real(r8) :: mind(N_DBH_BINS) ! Bottom of DBH bin + real(r8) :: maxd(N_DBH_BINS) ! Top of DBH bin + real(r8) :: delta_dbh ! Size of DBH bin + integer :: p ! Counter for PFT + integer :: j ! Counter for DBH bins + !--------------------------------------------------------------------- + + currentPatch => cp_pnt + + delta_dbh = (DBHMAX/N_DBH_BINS) + + do p = 1,numpft_ed + do j = 1,N_DBH_BINS + currentPatch%pft_agb_profile(p,j) = 0.0_r8 + enddo + enddo + + do j = 1,N_DBH_BINS + if (j == 1) then + mind(j) = 0.0_r8 + maxd(j) = delta_dbh + else + mind(j) = (j-1) * delta_dbh + maxd(j) = (j)*delta_dbh + endif + enddo + + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + do j = 1,N_DBH_BINS + if((currentCohort%dbh > mind(j)) .AND. (currentCohort%dbh <= maxd(j)))then + + currentPatch%pft_agb_profile(currentCohort%pft,j) = currentPatch%pft_agb_profile(currentCohort%pft,j) + & + currentCohort%bdead*currentCohort%n/currentPatch%area + + endif + enddo ! dbh bins + + ! Deal with largest dbh bin + j = N_DBH_BINS-1 + if(currentCohort%dbh > j*delta_dbh)then + + currentPatch%pft_agb_profile(currentCohort%pft,j) = currentPatch%pft_agb_profile(currentCohort%pft,j) + & + currentCohort%bdead*currentCohort%n/currentPatch%area + + endif ! + + currentCohort => currentCohort%taller + + enddo !currentCohort + + end subroutine patch_pft_size_profile + + ! ============================================================================ + function countPatches( bounds, ed_allsites_inst ) result ( totNumPatches ) + ! + ! !DESCRIPTION: + ! Loop over all Patches to count how many there are + ! + ! !USES: + use decompMod , only : bounds_type + use abortutils , only : endrun + use EDTypesMod , only : ed_site_type + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + type(ed_site_type) , intent(inout), target :: ed_allsites_inst( bounds%begg: ) + ! + ! !LOCAL VARIABLES: + type (ed_patch_type), pointer :: currentPatch + integer :: g ! gridcell + integer :: totNumPatches ! total number of patches. + !--------------------------------------------------------------------- + + totNumPatches = 0 + + do g = bounds%begg,bounds%endg + if (ed_allsites_inst(g)%istheresoil) then + currentPatch => ed_allsites_inst(g)%oldest_patch + do while(associated(currentPatch)) + totNumPatches = totNumPatches + 1 + currentPatch => currentPatch%younger + enddo + endif + enddo + + end function countPatches + +end module EDPatchDynamicsMod diff --git a/biogeochem/EDPhenologyType.F90 b/biogeochem/EDPhenologyType.F90 new file mode 100644 index 0000000000..f948fc7024 --- /dev/null +++ b/biogeochem/EDPhenologyType.F90 @@ -0,0 +1,277 @@ +module EDPhenologyType + +#include "shr_assert.h" + + !------------------------------------------------------------------------------ + ! !DESCRIPTION: + ! This module holds routines dealing with phenology in ED. The primary use + ! is to hold extract and accumulate routines + + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_cal_mod , only : calParams + use shr_const_mod , only : SHR_CONST_CDAY, SHR_CONST_TKFRZ + use shr_log_mod , only : errMsg => shr_log_errMsg + use abortutils , only : endrun + use decompMod , only : bounds_type + use accumulMod , only : update_accum_field, extract_accum_field, accumResetVal + use clm_varctl , only : iulog + use clm_time_manager , only : get_nstep, get_step_size + ! + ! !USES: + implicit none + private + ! + type, public :: ed_phenology_type + ! + ! change these to allocatable + ! add a rbuf variable that is a part of this type + ! + real(r8), pointer :: ED_GDD_patch (:) ! ED Phenology growing degree days. + ! This (phen_cd_status_patch?) could and should be site-level. RF + integer , pointer :: phen_cd_status_patch (:) ! ED Phenology cold deciduous status + character(10) :: accString = 'ED_GDD0' + real(r8) :: checkRefVal = 26._r8 + + contains + + ! Public procedures + procedure, public :: accumulateAndExtract + procedure, public :: init + procedure, public :: initAccVars + procedure, public :: initAccBuffer + procedure, public :: clean + + ! Private procedures + procedure, private :: initAllocate + procedure, private :: initHistory + + end type ed_phenology_type + !------------------------------------------------------------------------------ + +contains + + !------------------------------------------------------------------------------ + subroutine accumulateAndExtract( this, bounds, & + t_ref2m_patch, & + gridcell, latdeg, & + day, month, secs ) + ! + ! start formal argument list -- + ! group formal (dummy) arguments by use/similarity + ! + class(ed_phenology_type) , intent(inout) :: this + type(bounds_type) , intent(in) :: bounds ! beginning and ending pft index + ! data arguments + real(r8) , intent(in) :: t_ref2m_patch(bounds%begp: ) ! patch 2 m height surface air temperature (K) + ! arguments for the grid + integer , intent(in) :: gridcell(bounds%begp: ) ! gridcell + real(r8) , intent(in) :: latdeg(bounds%begg: ) ! latitude (degrees) + ! time related arguments + integer , intent(in) :: day ! day + integer , intent(in) :: month ! month + integer , intent(in) :: secs ! secs + ! + ! -- end formal argument list + ! + + ! + ! local variables + ! + ! update_accum_field expects a pointer, can't make this an allocatable + real(r8), pointer :: rbufslp(:) ! temporary single level - pft level + integer :: g, p ! local index for gridcell and pft + integer :: ier ! error code + integer :: m ! local month variable + + allocate(rbufslp(bounds%begp:bounds%endp), stat=ier) + if (ier/=0) then + call endrun(msg="extract_accum_hist allocation error for rbufslp"//& + errMsg(__FILE__, __LINE__)) + endif + + ! Accumulate and extract GDD0 for ED + do p = bounds%begp,bounds%endp + + g = gridcell(p) + + if (latdeg(g) >= 0._r8) then + m = calParams%january + else + m = calParams%june + endif + + ! FIX(RF,032414) - is this accumulation a bug in the normal phenology code, + ! as it means to count from november but ctually counts from january? + if ( month==m .and. day==calParams%firstDayOfMonth .and. secs==get_step_size() ) then + rbufslp(p) = accumResetVal ! reset ED_GDD + else + rbufslp(p) = max(0._r8, min(this%checkRefVal, t_ref2m_patch(p)-SHR_CONST_TKFRZ)) & + * get_step_size()/SHR_CONST_CDAY + end if + + if( this%phen_cd_status_patch(p) == 2 ) then ! we have over-counted past the maximum possible range + rbufslp(p) = accumResetVal !don't understand how this doens't make it negative, but it doesn't. RF + endif + + if( latdeg(g) >= 0._r8 .and. month >= calParams%july ) then !do not accumulate in latter half of year. + rbufslp(p) = accumResetVal + endif + + if( latdeg(g) < 0._r8 .and. month < calParams%june ) then !do not accumulate in earlier half of year. + rbufslp(p) = accumResetVal + endif + + end do + + call update_accum_field ( trim(this%accString), rbufslp, get_nstep() ) + call extract_accum_field ( trim(this%accstring), this%ED_GDD_patch, get_nstep() ) + + deallocate(rbufslp) + + end subroutine accumulateAndExtract + + !--------------------------------------------------------------------- + subroutine clean( this ) + ! + ! !DESCRIPTION: + ! clean up memory + ! + ! !USES: + ! + ! !ARGUMENTS: + class(ed_phenology_type), intent(inout) :: this + ! + ! !LOCAL VARIABLES: + !--------------------------------------------------------------------- + + deallocate(this%ED_GDD_patch) + deallocate(this%phen_cd_status_patch) + + end subroutine clean + + subroutine init(this, bounds) + + class(ed_phenology_type), intent(inout) :: this + type(bounds_type), intent(in) :: bounds + + call this%initAllocate ( bounds ) + call this%initHistory () + + end subroutine init + + !------------------------------------------------------------------------ + subroutine initAllocate(this, bounds) + ! + ! !DESCRIPTION: + ! Initialize module data structure + ! + ! !USES: + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + ! + ! !ARGUMENTS: + class(ed_phenology_type), intent(inout) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + !------------------------------------------------------------------------ + + allocate(this%ED_GDD_patch (bounds%begp:bounds%endp)) ; this%ED_GDD_patch (:) = 0.0_r8 + allocate(this%phen_cd_status_patch (bounds%begp:bounds%endp)) ; this%phen_cd_status_patch (:) = 0 + + end subroutine initAllocate + + !------------------------------------------------------------------------ + subroutine initHistory(this) + ! + ! !DESCRIPTION: + ! add history fields for all CN variables, always set as default='inactive' + ! + ! !USES: + use histFileMod, only : hist_addfld1d + ! + ! !ARGUMENTS: + class(Ed_phenology_type), intent(inout) :: this + ! + ! !LOCAL VARIABLES: + !--------------------------------------------------------------------- + + call hist_addfld1d (fname=trim(this%accString), units='deg C', & + avgflag='A', long_name='ED phenology growing degree days', & + ptr_patch=this%ED_GDD_patch, set_lake=0._r8, set_urb=0._r8) + + end subroutine initHistory + + !----------------------------------------------------------------------- + subroutine initAccBuffer (this, bounds) + ! + ! !DESCRIPTION: + ! Initialize accumulation buffer for all required module accumulated fields + ! This routine set defaults values that are then overwritten by the + ! restart file for restart or branch runs + ! Each interval and accumulation type is unique to each field processed. + ! Routine [initAccBuffer] defines the fields to be processed + ! and the type of accumulation. + ! Routine [updateAccVars] does the actual accumulation for a given field. + ! Fields are accumulated by calls to subroutine [update_accum_field]. + ! To accumulate a field, it must first be defined in subroutine [initAccVars] + ! and then accumulated by calls to [updateAccVars]. + ! Four types of accumulations are possible: + ! o average over time interval + ! o running mean over time interval + ! o running accumulation over time interval + ! Time average fields are only valid at the end of the averaging interval. + ! Running means are valid once the length of the simulation exceeds the + ! averaging interval. Accumulated fields are continuously accumulated. + ! The trigger value "-99999." resets the accumulation to zero. + ! + ! !USES + use accumulMod , only : init_accum_field + ! + ! !ARGUMENTS: + class(ed_phenology_type), intent(inout) :: this + type(bounds_type), intent(in) :: bounds + + ! + ! !LOCAL VARIABLES: + !--------------------------------------------------------------------- + + call init_accum_field (name=this%accString, units='K', & + desc='growing degree-days base 0C from planting', accum_type='runaccum', accum_period=huge(1), & + subgrid_type='pft', numlev=1, init_value=0._r8) + + end subroutine initAccBuffer + + !----------------------------------------------------------------------- + subroutine initAccVars(this, bounds) + ! + ! !DESCRIPTION: + ! Initialize module variables that are associated with + ! time accumulated fields. This routine is called for both an initial run + ! and a restart run (and must therefore must be called after the restart file + ! is read in and the accumulation buffer is obtained) + ! + ! !USES + ! + ! !ARGUMENTS: + class(ed_phenology_type), intent(inout) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: ier + real(r8), pointer :: rbufslp(:) ! temporary + !--------------------------------------------------------------------- + + allocate(rbufslp(bounds%begp:bounds%endp), stat=ier) + if (ier/=0) then + call endrun(msg="extract_accum_hist allocation error for rbufslp"//& + errMsg(__FILE__, __LINE__)) + endif + + call extract_accum_field (this%accString, rbufslp, get_nstep()) + this%ED_GDD_patch(bounds%begp:bounds%endp) = rbufslp(bounds%begp:bounds%endp) + + deallocate(rbufslp) + + end subroutine initAccVars + +end module EDPhenologyType diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 new file mode 100755 index 0000000000..ab543045de --- /dev/null +++ b/biogeochem/EDPhysiologyMod.F90 @@ -0,0 +1,1153 @@ +module EDPhysiologyMod + +#include "shr_assert.h" + + ! ============================================================================ + ! Miscellaneous physiology routines from ED. + ! ============================================================================ + + use shr_kind_mod , only : r8 => shr_kind_r8 + use clm_varctl , only : iulog + use TemperatureType , only : temperature_type + use SoilStateType , only : soilstate_type + use WaterstateType , only : waterstate_type + use pftconMod , only : pftcon + use EDEcophysContype , only : EDecophyscon + use EDCohortDynamicsMod , only : allocate_live_biomass, zero_cohort, create_cohort, fuse_cohorts, sort_cohorts + use EDPhenologyType , only : ed_phenology_type + use EDTypesMod , only : dg_sf, dinc_ed, external_recruitment + use EDTypesMod , only : ncwd, nlevcan_ed, n_sub, numpft_ed, senes + use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type + + implicit none + private + + public :: canopy_derivs + public :: non_canopy_derivs + public :: trim_canopy + public :: phenology + public :: phenology_leafonoff + public :: Growth_Derivatives + public :: recruitment + public :: cwd_input + public :: cwd_out + public :: fragmentation_scaler + public :: seeds_in + public :: seed_decay + public :: seed_germination + ! ============================================================================ + +contains + + ! ============================================================================ + subroutine canopy_derivs( currentPatch ) + ! + ! !DESCRIPTION: + ! spawn new cohorts of juveniles of each PFT + ! + ! !USES: + ! + ! !ARGUMENTS + type(ed_patch_type) , intent(inout), target :: currentPatch + ! + ! !LOCAL VARIABLES: + type(ed_cohort_type), pointer ::currentCohort + !---------------------------------------------------------------------- + + ! call plant growth functions + + currentCohort => currentPatch%shortest + + do while(associated(currentCohort)) + call Growth_Derivatives(currentCohort) + currentCohort => currentCohort%taller + enddo + + end subroutine canopy_derivs + + ! ============================================================================ + subroutine non_canopy_derivs( currentPatch, temperature_inst, soilstate_inst, waterstate_inst) + ! + ! !DESCRIPTION: + ! Returns time differentials of the state vector + ! + ! !USES: + ! + ! !ARGUMENTS + type(ed_patch_type) , intent(inout) :: currentPatch + type(temperature_type) , intent(in) :: temperature_inst + type(soilstate_type) , intent(in) :: soilstate_inst + type(waterstate_type) , intent(in) :: waterstate_inst + ! + ! !LOCAL VARIABLES: + integer c,p + !---------------------------------------------------------------------- + + currentPatch%leaf_litter_in(:) = 0.0_r8 + currentPatch%root_litter_in(:) = 0.0_r8 + currentPatch%leaf_litter_out(:) = 0.0_r8 + currentPatch%root_litter_out(:) = 0.0_r8 + currentPatch%cwd_AG_in(:) = 0.0_r8 + currentPatch%cwd_BG_in(:) = 0.0_r8 + currentPatch%cwd_AG_out(:) = 0.0_r8 + currentPatch%cwd_BG_out(:) = 0.0_r8 + currentPatch%seeds_in(:) = 0.0_r8 + currentPatch%seed_decay(:) = 0.0_r8 + currentPatch%seed_germination(:) = 0.0_r8 + + ! update seed fluxes + call seeds_in(currentPatch) + call seed_decay(currentPatch) + call seed_germination(currentPatch) + + ! update fragmenting pool fluxes + call cwd_input(currentPatch) + call cwd_out( currentPatch, temperature_inst, soilstate_inst, waterstate_inst) + + do p = 1,numpft_ed + currentPatch%dseed_dt(p) = currentPatch%seeds_in(p) - currentPatch%seed_decay(p) - currentPatch%seed_germination(p) + enddo + + do c = 1,ncwd + currentPatch%dcwd_AG_dt(c) = currentPatch%cwd_AG_in(c) - currentPatch%cwd_AG_out(c) + currentPatch%dcwd_BG_dt(c) = currentPatch%cwd_BG_in(c) - currentPatch%cwd_BG_out(c) + enddo + + do p = 1,numpft_ed + currentPatch%dleaf_litter_dt(p) = currentPatch%leaf_litter_in(p) - currentPatch%leaf_litter_out(p) + currentPatch%droot_litter_dt(p) = currentPatch%root_litter_in(p) - currentPatch%root_litter_out(p) + enddo + + currentPatch%leaf_litter_in(:) = 0.0_r8 + currentPatch%root_litter_in(:) = 0.0_r8 + currentPatch%leaf_litter_out(:) = 0.0_r8 + currentPatch%root_litter_out(:) = 0.0_r8 + currentPatch%CWD_AG_in(:) = 0.0_r8 + currentPatch%cwd_bg_in(:) = 0.0_r8 + currentPatch%CWD_AG_out(:) = 0.0_r8 + currentPatch%cwd_bg_out(:) = 0.0_r8 + + end subroutine non_canopy_derivs + + ! ============================================================================ + subroutine trim_canopy( currentSite ) + ! + ! !DESCRIPTION: + ! Canopy trimming / leaf optimisation. Removes leaves in negative annual carbon balance. + ! + ! !USES: + ! + use EDParamsMod, only : ED_val_grperc + use EDGrowthFunctionsMod, only : tree_lai + ! + ! !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) :: inc ! rate at which canopy acclimates to uptake + real(r8) :: trim_limit ! this is the limit of the canopy trimming routine, so that trees + ! can't just lose all their leaves and have no reproductive costs. + integer :: z ! leaf layer + integer :: trimmed ! was this layer trimmed in this year? If not expand the canopy. + + trim_limit = 0.3_r8 ! Arbitrary limit to reductions in leaf area with stress. Without this nothing ever dies. + inc = 0.03_r8 ! Arbitrary incremental change in trimming function. Controls + ! rate at which leaves are optimised to their environment. + !---------------------------------------------------------------------- + + currentPatch => currentSite%youngest_patch + + do while(associated(currentPatch)) + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + trimmed = 0 + currentCohort%treelai = tree_lai(currentCohort) + currentCohort%nv = ceiling((currentCohort%treelai+currentCohort%treesai)/dinc_ed) + if (currentCohort%nv > nlevcan_ed)then + write(iulog,*) 'nv > nlevcan_ed',currentCohort%nv,currentCohort%treelai,currentCohort%treesai, & + currentCohort%c_area,currentCohort%n,currentCohort%bl + endif + + !Leaf cost vs netuptake for each leaf layer. + do z = 1,nlevcan_ed + if (currentCohort%year_net_uptake(z) /= 999._r8)then !there was activity this year in this leaf layer. + !Leaf Cost kgC/m2/year-1 + !decidous costs. + if (pftcon%season_decid(currentCohort%pft) == 1.or.pftcon%stress_decid(currentCohort%pft) == 1)then + currentCohort%leaf_cost = 1._r8/(pftcon%slatop(currentCohort%pft)*1000.0_r8) + currentCohort%leaf_cost = currentCohort%leaf_cost + 1.0_r8/(pftcon%slatop(currentCohort%pft)*1000.0_r8) * & + pftcon%froot_leaf(currentCohort%pft) / EDecophyscon%root_long(currentCohort%pft) + currentCohort%leaf_cost = currentCohort%leaf_cost * (ED_val_grperc+1._r8) + else !evergreen costs + currentCohort%leaf_cost = 1.0_r8/(pftcon%slatop(currentCohort%pft)* & + pftcon%leaf_long(currentCohort%pft)*1000.0_r8) !convert from sla in m2g-1 to m2kg-1 + currentCohort%leaf_cost = currentCohort%leaf_cost + 1.0_r8/(pftcon%slatop(currentCohort%pft)*1000.0_r8) * & + pftcon%froot_leaf(currentCohort%pft) / EDecophyscon%root_long(currentCohort%pft) + currentCohort%leaf_cost = currentCohort%leaf_cost * (ED_val_grperc+1._r8) + endif + if (currentCohort%year_net_uptake(z) < currentCohort%leaf_cost)then + if (currentCohort%canopy_trim > trim_limit)then + ! write(iulog,*) 'trimming leaves',currentCohort%canopy_trim,currentCohort%leaf_cost + ! keep trimming until none of the canopy is in negative carbon balance. + if (currentCohort%hite > EDecophyscon%hgt_min(currentCohort%pft))then + currentCohort%canopy_trim = currentCohort%canopy_trim - inc + if (pftcon%evergreen(currentCohort%pft) /= 1)then + currentCohort%laimemory = currentCohort%laimemory*(1.0_r8 - inc) + endif + trimmed = 1 + endif + endif + endif + endif !leaf activity? + enddo !z + if (currentCohort%NV.gt.2)then + write(iulog,*) 'nv>4',currentCohort%year_net_uptake(1:6),currentCohort%leaf_cost,& + currentCohort%canopy_trim + endif + + currentCohort%year_net_uptake(:) = 999.0_r8 + if (trimmed == 0.and.currentCohort%canopy_trim < 1.0_r8)then + currentCohort%canopy_trim = currentCohort%canopy_trim + inc + endif + ! write(iulog,*) 'trimming',currentCohort%canopy_trim + + ! currentCohort%canopy_trim = 1.0_r8 !FIX(RF,032414) this turns off ctrim for now. + currentCohort => currentCohort%shorter + enddo + currentPatch => currentPatch%older + enddo + + end subroutine trim_canopy + + ! ============================================================================ + subroutine phenology( currentSite, ed_phenology_inst, temperature_inst, waterstate_inst) + ! + ! !DESCRIPTION: + ! Phenology. + ! + ! !USES: + use clm_varcon, only : tfrz + use EDTypesMod, only : udata + ! + ! !ARGUMENTS: + type(ed_site_type) , intent(inout), pointer:: currentSite + type(ed_phenology_type) , intent(in) :: ed_phenology_inst + type(temperature_type) , intent(in) :: temperature_inst + type(waterstate_type) , intent(in) :: waterstate_inst + ! + ! !LOCAL VARIABLES: + real(r8), pointer :: t_veg24(:) + real(r8), pointer :: ED_GDD_patch(:) + integer :: g ! grid point + integer :: t ! day of year + integer :: ncolddays ! no days underneath the threshold for leaf drop + integer :: ncolddayslim ! critical no days underneath the threshold for leaf drop + integer :: i + integer :: timesincedleafon,timesincedleafoff,timesinceleafon,timesinceleafoff + real(r8) :: gdd_threshold + real(r8) :: a,b,c ! params of leaf-pn model from botta et al. 2000. + real(r8) :: cold_t ! threshold below which cold days are counted + real(r8) :: coldday ! definition of a 'chilling day' for botta model + real(r8) :: ncdstart ! beginning of counting period for growing degree days. + real(r8) :: drought_threshold + real(r8) :: off_time ! minimum number of days between leaf off and leaf on for drought phenology + real(r8) :: temp_in_C ! daily averaged temperature in celcius + real(r8) :: mindayson + !------------------------------------------------------------------------ + + t_veg24 => temperature_inst%t_veg24_patch ! Input: [real(r8) (:)] avg pft vegetation temperature for last 24 hrs + ED_GDD_patch => ed_phenology_inst%ED_GDD_patch ! Input: [real(r8) (:)] growing deg. days base 0 deg C (ddays) + + g = currentSite%clmgcell + + ! Parameter of drought decid leaf loss in mm in top layer...FIX(RF,032414) + ! - this is arbitrary and poorly understood. Needs work. ED_ + drought_threshold = 0.15 + off_time = 100.0_r8 + + !Parameters of Botta et al. 2000 GCB,6 709-725 + a = -68.0_r8 + b = 638.0_r8 + c = -0.001_r8 + coldday = 5.0_r8 + + mindayson = 30 + + !Parameters from SDGVM model of senesence + ncolddayslim = 5 + cold_t = 7.5_r8 + + t = udata%time_period + temp_in_C = t_veg24(currentSite%oldest_patch%clm_pno-1) - tfrz + + !-----------------Cold Phenology--------------------! + + !Zero growing degree and chilling day counters + if (currentSite%lat > 0)then + ncdstart = 270._r8; !Northern Hemisphere begining November + else + ncdstart = 120._r8; !Southern Hemisphere beginning May + endif + + ! FIX(SPM,032414) - this will only work for the first year, no? + if (t == ncdstart)then + currentSite%ncd = 0._r8 + endif + + !Accumulate growing/chilling days after start of counting period + if (temp_in_C < coldday)then + currentSite%ncd = currentSite%ncd + 1.0_r8 + endif + + gdd_threshold = a + b*exp(c*currentSite%ncd) !GDD accumulation function, which also depends on chilling days. + + !Accumulate temperature of last 10 days. + currentSite%last_n_days(2:senes) = currentSite%last_n_days(1:senes-1) + currentSite%last_n_days(1) = temp_in_C + !count number of days for leaves off + ncolddays = 0 + do i = 1,senes + if (currentSite%last_n_days(i) < cold_t)then + ncolddays = ncolddays + 1 + endif + enddo + + timesinceleafoff = t - currentSite%leafoffdate + if (t < currentSite%leafoffdate)then + timesinceleafoff = t +(365-currentSite%leafoffdate) + endif + + !LEAF ON: COLD DECIDUOUS. Needs to + !1) have exceeded the growing degree day threshold + !2) The leaves should not be on already + !3) There should have been at least on chilling day in the counting period. + if (ED_GDD_patch(currentSite%oldest_patch%clm_pno) > gdd_threshold)then + if (currentSite%status == 1)then + if (currentSite%ncd >= 1)then + currentSite%status = 2 !alter status of site to 'leaves on' + currentSite%leafondate = t !record leaf on date + write(iulog,*) 'leaves on' + endif !ncd + endif !status + endif !GDD + + timesinceleafon = t - currentSite%leafondate + if (t < currentSite%leafondate)then + timesinceleafon = t +(365-currentSite%leafondate) + endif + + !LEAF OFF: COLD THRESHOLD + !Needs to: + !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 the year should be larger than the counting period. (not sure if we need this/if it will break the restarting) + + if (ncolddays > ncolddayslim)then + if (timesinceleafon > mindayson)then + if (currentSite%status == 2)then + currentSite%status = 1 !alter status of site to 'leaves on' + currentSite%leafoffdate = t !record leaf off date + write(iulog,*) 'leaves off' + endif + endif + endif + + !LEAF OFF: COLD LIFESPAN THRESHOLD + if (timesinceleafoff > 360)then !remove leaves after a whole year when there is no 'off' period. + if (currentSite%status == 2)then + currentSite%status = 1 !alter status of site to 'leaves on' + currentSite%leafoffdate = t !record leaf off date + write(iulog,*) 'leaves off' + endif + endif + + !-----------------Drought Phenology--------------------! + ! Principles of drought-deciduos phenology model... + ! The 'dstatus' flag is 2 when leaves are on, and 1 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, + ! 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 equlibirum. + ! 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, 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 might come on + ! in the dry season, using up stored reserves + ! 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. + ! 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? 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??).... + + !Accumulate surface water memory of last 10 days. + currentSite%water_memory(1) = waterstate_inst%h2osoi_vol_col(currentSite%clmcolumn,1) + do i = 1,9 !shift memory along one + currentSite%water_memory(11-i) = currentSite%water_memory(10-i) + enddo + + !In drought phenology, we often need to force the leaves to stay on or off as moisture fluctuates... + timesincedleafoff = 0 + if (currentSite%dstatus == 1)then !the leaves are off. How long have they been off? + !leaves have come on, but last year, so at a later date than now. + if (currentSite%dleafoffdate > 0.and.currentSite%dleafoffdate > t)then + timesincedleafoff = t + (360 - currentSite%dleafoffdate) + else + timesincedleafoff = t - currentSite%dleafoffdate + endif + endif + + timesincedleafon = 0 + !the leaves are on. How long have they been on? + if (currentSite%dstatus == 2)then + !leaves have come on, but last year, so at a later date than now. + if (currentSite%dleafondate > 0.and.currentSite%dleafondate > t)then + timesincedleafon = t + (360 - currentSite%dleafondate) + else + timesincedleafon = t - currentSite%dleafondate + endif + endif + + !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 + if ((t >= currentSite%dleafondate - 30.and.t <= currentSite%dleafondate + 30).or.(t > 360 - 15.and. & + currentSite%dleafondate < 15))then ! are we in the window? + if (sum(currentSite%water_memory(1:10)/10._r8) >= drought_threshold.and.currentSite%dstatus == 1.and.t >= 10)then + ! leave some minimum time between leaf off and leaf on to prevent 'flickering'. + if (timesincedleafoff > off_time)then + currentSite%dstatus = 2 !alter status of site to 'leaves on' + currentSite%dleafondate = t !record leaf on date + endif + endif + endif + + !we still haven't done budburst by end of window + if (t == currentSite%dleafondate+30.and.currentSite%dstatus == 1)then + currentSite%dstatus = 2 ! force budburst! + currentSite%dleafondate = t ! record leaf on date + endif + + !LEAF OFF: DROUGHT DECIDUOUS LIFESPAN - if the leaf gets to the end of its useful life. A*, E* + if (currentSite%dstatus == 2.and.t >= 10)then !D* + !Are the leaves at the end of their lives? !FIX(RF,0401014)- this is hardwiring.... + if (timesincedleafon > 365.0*pftcon%leaf_long(7))then + currentSite%dstatus = 1 !alter status of site to 'leaves on' + currentSite%dleafoffdate = t !record leaf on date + endif + endif + + !LEAF OFF: DROUGHT DECIDUOUS DRYNESS - if the soil gets too dry, and the leaves have already been on a while... + if (currentSite%dstatus == 2.and.t >= 10)then !D* + if (sum(currentSite%water_memory(1:10)/10._r8) <= drought_threshold)then + if (timesincedleafon > 100)then !B* Have the leaves been on for some reasonable length of time? To prevent flickering. + currentSite%dstatus = 1 !alter status of site to 'leaves on' + currentSite%dleafoffdate = t !record leaf on date + endif + endif + endif + + call phenology_leafonoff(currentSite) + + end subroutine phenology + + ! ============================================================================ + subroutine phenology_leafonoff(currentSite) + ! + ! !DESCRIPTION: + ! Controls the leaf on and off economics + ! + ! !USES: + ! + ! !ARGUMENTS: + type(ed_site_type), intent(inout), pointer:: currentSite + ! + ! !LOCAL VARIABLES: + type(ed_patch_type) , pointer :: currentPatch + type(ed_cohort_type), pointer :: currentCohort + !------------------------------------------------------------------------ + + currentPatch => CurrentSite%oldest_patch + + do while(associated(currentPatch)) + currentCohort => currentPatch%tallest + do while(associated(currentCohort)) + + !COLD LEAF ON + if (pftcon%season_decid(currentCohort%pft) == 1)then + if (currentSite%status == 2)then !we have just moved to leaves being on . + if (currentCohort%status_coh == 1)then !Are the leaves currently off? + currentCohort%status_coh = 2 !Leaves are on, so change status to stop flow of carbon out of bstore. + if (currentCohort%laimemory <= currentCohort%bstore)then + currentCohort%bl = currentCohort%laimemory !extract stored carbon to make new leaves. + else + currentCohort%bl = currentCohort%bstore !we can only put on as much carbon as there is in the store... + !nb. Putting all of bstore into leaves is C-starvation suicidal. The tendency for this could be parameterized + endif + currentCohort%balive = currentCohort%balive + currentCohort%bl ! Add deployed carbon to alive biomass pool + currentCohort%bstore = currentCohort%bstore - currentCohort%bl ! Drain store + currentCohort%laimemory = 0.0_r8 + endif !pft phenology + endif ! growing season + + !COLD LEAF OFF + currentCohort%leaf_litter = 0.0_r8 !zero leaf litter for today. + if (currentSite%status == 1)then !past leaf drop day? Leaves still on tree? + if (currentCohort%status_coh == 2)then ! leaves have not dropped + currentCohort%status_coh = 1 + !remember what the lai was this year to put the same amount back on in the spring... + currentCohort%laimemory = currentCohort%bl + ! decrement balive for leaf litterfall + currentCohort%balive = currentCohort%balive - currentCohort%bl + ! add lost carbon to litter + currentCohort%leaf_litter = currentCohort%bl + currentCohort%bl = 0.0_r8 + endif !leaf status + endif !currentSite status + endif !season_decid + + !DROUGHT LEAF ON + if (pftcon%stress_decid(currentCohort%pft) == 1)then + if (currentSite%dstatus == 2)then !we have just moved to leaves being on . + if (currentCohort%status_coh == 1)then !is it the leaf-on day? Are the leaves currently off? + currentCohort%status_coh = 2 !Leaves are on, so change status to stop flow of carbon out of bstore. + if (currentCohort%laimemory <= currentCohort%bstore)then + currentCohort%bl = currentCohort%laimemory !extract stored carbon to make new leaves. + else + currentCohort%bl = currentCohort%bstore !we can only put on as much carbon as there is in the store... + endif + currentCohort%balive = currentCohort%balive + currentCohort%bl + currentCohort%bstore = currentCohort%bstore - currentCohort%bl ! empty store + currentCohort%laimemory = 0.0_r8 + endif !currentCohort status again? + endif !currentSite status + + !DROUGHT LEAF OFF + if (currentSite%dstatus == 1)then + if (currentCohort%status_coh == 2)then ! leaves have not dropped + currentCohort%status_coh = 1 + currentCohort%laimemory = currentCohort%bl + ! decrement balive for leaf litterfall + currentCohort%balive = currentCohort%balive - currentCohort%bl + ! add retranslocated carbon (very small) to store. + currentCohort%bstore = currentCohort%bstore + ! add falling leaves to litter pools . convert to KgC/m2 + currentCohort%leaf_litter = currentCohort%bl + currentCohort%bl = 0.0_r8 + endif + endif !status + endif !drought dec. + currentCohort => currentCohort%shorter + enddo !currentCohort + + currentPatch => currentPatch%younger + + enddo !currentPatch + + end subroutine phenology_leafonoff + + + ! ============================================================================ + subroutine seeds_in( cp_pnt ) + ! + ! !DESCRIPTION: + ! Flux from plants into seed pool. + ! + ! !USES: + ! + ! !ARGUMENTS + type(ed_patch_type), intent(inout), target :: cp_pnt ! seeds go to these patches. + ! + ! !LOCAL VARIABLES: + type(ed_patch_type), pointer :: currentPatch + type(ed_site_type), pointer :: currentSite + type(ed_cohort_type), pointer :: currentCohort + integer :: p + !---------------------------------------------------------------------- + + currentPatch => cp_pnt + currentSite => currentPatch%siteptr + + currentPatch%seeds_in(:) = 0.0_r8 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + p = currentCohort%pft + currentPatch%seeds_in(p) = currentPatch%seeds_in(p) + currentCohort%seed_prod * currentCohort%n/currentPatch%area + currentCohort => currentCohort%shorter + enddo !cohort loop + + currentPatch => currentSite%oldest_patch + + do while(associated(currentPatch)) + if (EXTERNAL_RECRUITMENT == 1) then !external seed rain - needed to prevent extinction + do p = 1,numpft_ed + currentPatch%seeds_in(p) = currentPatch%seeds_in(p) + EDecophyscon%seed_rain(p) !KgC/m2/year + enddo + endif + currentPatch => currentPatch%younger + enddo + + end subroutine seeds_in + + ! ============================================================================ + subroutine seed_decay( currentPatch ) + ! + ! !DESCRIPTION: + ! Flux from seed pool into leaf litter pool + ! + ! !USES: + ! + ! !ARGUMENTS + type(ed_patch_type),intent(inout) :: currentPatch ! seeds go to these patches. + ! + ! !LOCAL VARIABLES: + integer :: p + real(r8) :: seed_turnover !complete seed turnover rate in yr-1. + !---------------------------------------------------------------------- + + seed_turnover = 0.51_r8 ! from Liscke and Loffler 2006 + ! decays the seed pool according to exponential model + ! sd_mort is in yr-1 + do p = 1,numpft_ed + currentPatch%seed_decay(p) = currentPatch%seed_bank(p) * seed_turnover + enddo + + end subroutine seed_decay + + ! ============================================================================ + subroutine seed_germination( currentPatch ) + ! + ! !DESCRIPTION: + ! Flux from seed pool into sapling pool + ! + ! !USES: + ! + ! !ARGUMENTS + type(ed_patch_type),intent(inout) :: currentPatch ! seeds go to these patches. + ! + ! !LOCAL VARIABLES: + integer :: p + real(r8) max_germination !cap on germination rates. KgC/m2/yr Lishcke et al. 2009 + real(r8) germination_timescale !yr-1 + !---------------------------------------------------------------------- + + germination_timescale = 0.5_r8 !this is arbitrary + max_germination = 1.0_r8 !this is arbitrary + + do p = 1,numpft_ed + currentPatch%seed_germination(p) = min(currentPatch%seed_bank(p) * germination_timescale,max_germination) + enddo + + end subroutine seed_germination + + ! ============================================================================ + subroutine Growth_Derivatives( currentCohort) + ! + ! !DESCRIPTION: + ! Main subroutine controlling growth and allocation derivatives + ! + ! !USES: + use EDGrowthFunctionsMod , only : Bleaf, dDbhdBd, dhdbd, hite, mortality_rates,dDbhdBl + use EDTypesMod , only : udata + ! + ! !ARGUMENTS + type(ed_cohort_type),intent(inout), target :: currentCohort + ! + ! !LOCAL VARIABLES: + type(ed_site_type), pointer :: currentSite + real(r8) :: dbldbd !rate of change of dead biomass per unit dbh + real(r8) :: dbrdbd !rate of change of root biomass per unit dbh + real(r8) :: dbswdbd !rate of change of sapwood biomass per unit dbh + real(r8) :: dhdbd_fn !rate of change of height per unit dbh + real(r8) :: va !fraction of growth going to alive biomass + real(r8) :: vs !fraction of growth going to structural biomass + real(r8) :: u,h !intermediates + real(r8) :: frac !fraction the stored carbon is of target store amount + real(r8) :: f_store !fraction of NPP allocated to storage in this timestep (functionf of stored pool) + real(r8) :: gr_fract !fraction of carbon balance that is allocated to growth (not reproduction) + real(r8) :: target_balive !target leaf biomass under allometric optimum. + real(r8) :: balive_loss + !---------------------------------------------------------------------- + + currentSite => currentCohort%siteptr + + ! Mortality for trees in the understorey. + !if trees are in the canopy, then their death is 'disturbance'. This probably needs a different terminology + if (currentCohort%canopy_layer > 1)then + currentCohort%dndt = -1.0_r8 * mortality_rates(currentCohort) * currentCohort%n + else + currentCohort%dndt = 0._r8 + endif + + ! Height + currentCohort%hite = Hite(currentCohort) + h = currentCohort%hite + + call allocate_live_biomass(currentCohort) + + ! calculate target size of living biomass compartment for a given dbh. + target_balive = Bleaf(currentCohort) * (1.0_r8 + pftcon%froot_leaf(currentCohort%pft) + & + EDecophyscon%sapwood_ratio(currentCohort%pft)*h) + !target balive without leaves. + if (currentCohort%status_coh == 1)then + target_balive = Bleaf(currentCohort) * (pftcon%froot_leaf(currentCohort%pft) + & + EDecophyscon%sapwood_ratio(currentCohort%pft) * h) + endif + + ! NPP + currentCohort%npp = currentCohort%npp_acc * N_SUB !Link to CLM. convert from kgC/indiv/day into kgC/indiv/year + currentCohort%gpp = currentCohort%gpp_acc * N_SUB !Link to CLM. convert from kgC/indiv/day into kgC/indiv/year + currentCohort%resp = currentCohort%resp_acc * N_SUB !Link to CLM. convert from kgC/indiv/day into kgC/indiv/year + + currentSite%flux_in = currentSite%flux_in + currentCohort%npp_acc * currentCohort%n + + ! Maintenance demands + if (pftcon%evergreen(currentCohort%pft) == 1)then !grass and EBT + currentCohort%leaf_md = currentCohort%bl / pftcon%leaf_long(currentCohort%pft) + currentCohort%root_md = currentCohort%br / EDecophyscon%root_long(currentCohort%pft) + currentCohort%md = currentCohort%root_md + currentCohort%leaf_md + endif + + !FIX(RF,032414) - I took out the stem turnover demand as it seemed excesively high and caused odd size-reated + ! decline affect + !with which I am not especially comfortable, particularly as the concept of sapwood turnover is unclear for trees that + !are still in an expansion phase. + + if (pftcon%season_decid(currentCohort%pft) == 1)then + currentCohort%root_md = currentCohort%br /EDecophyscon%root_long(currentCohort%pft) + currentCohort%leaf_md = 0._r8 + currentCohort%md = currentCohort%root_md + currentCohort%leaf_md + endif + + if (pftcon%stress_decid(currentCohort%pft) == 1)then + currentCohort%root_md = currentCohort%br /EDecophyscon%root_long(currentCohort%pft) + currentCohort%leaf_md = 0._r8 + currentCohort%md = currentCohort%root_md + currentCohort%leaf_md + endif + + if (pftcon%stress_decid(currentCohort%pft) /= 1.and.pftcon%season_decid(currentCohort%pft) /= 1.and. & + pftcon%evergreen(currentCohort%pft) /= 1)then + write(iulog,*) 'problem with phenology definitions',currentCohort%pft,pftcon%stress_decid(currentCohort%pft), & + pftcon%season_decid(currentCohort%pft),pftcon%evergreen(currentCohort%pft) + endif + + ! FIX(RF,032414) -turned off for now as it makes balive go negative.... + ! FIX(RF,032414) jan2012 0.01_r8 * currentCohort%bdead + currentCohort%woody_turnover = 0.0_r8 + currentCohort%md = currentCohort%md + currentCohort%woody_turnover + + ! Calculate carbon balance + ! this is the fraction of maintenance demand we -have- to do... + + currentCohort%carbon_balance = currentCohort%npp - currentCohort%md * EDecophyscon%leaf_stor_priority(currentCohort%pft) + + if (Bleaf(currentCohort) > 0._r8)then + + if (currentCohort%carbon_balance > 0._r8)then !spend C on growing and storing + + !what fraction of the target storage do we have? + frac = max(0.0_r8,currentCohort%bstore/(Bleaf(currentCohort) * EDecophyscon%cushion(currentCohort%pft))) + ! FIX(SPM,080514,fstore never used ) + f_store = max(exp(-1.*frac**4._r8) - exp( -1.0_r8 ),0.0_r8) + !what fraction of allocation do we divert to storage? + !what is the flux into the store? + currentCohort%storage_flux = currentCohort%carbon_balance * f_store + !what is the tax on the carbon available for growth? + currentCohort%carbon_balance = currentCohort%carbon_balance * (1.0_r8 - f_store) + else !cbalance is negative. Take C out of store to pay for maintenance respn. + currentCohort%storage_flux = currentCohort%carbon_balance + currentCohort%carbon_balance = 0._r8 + endif + + else + + currentCohort%storage_flux = 0._r8 + currentCohort%carbon_balance = 0._r8 + write(iulog,*) 'ED: no leaf area in gd', currentCohort%indexnumber,currentCohort%n,currentCohort%bdead, & + currentCohort%dbh,currentCohort%balive + + endif + + !Do we have enough carbon left over to make up the rest of the turnover demand? + balive_loss = 0._r8 + if (currentCohort%carbon_balance > currentCohort%md*(1.0_r8- EDecophyscon%leaf_stor_priority(currentCohort%pft)))then ! Yes... + currentCohort%carbon_balance = currentCohort%carbon_balance - currentCohort%md * (1.0_r8 - & + EDecophyscon%leaf_stor_priority(currentCohort%pft)) + else ! we can't maintain constant leaf area and root area. Balive is reduced + balive_loss = currentCohort%md *(1.0_r8- EDecophyscon%leaf_stor_priority(currentCohort%pft))- currentCohort%carbon_balance + currentCohort%carbon_balance = 0._r8 + endif + + !********************************************/ + ! Allometry & allocation of remaining carbon*/ + !********************************************/ + !Use remaining carbon to refill balive or to get larger. + + !only if carbon balance is +ve + if ((currentCohort%balive >= target_balive).AND.(currentCohort%carbon_balance > 0._r8))then + ! fraction of carbon going into active vs structural carbon + if (currentCohort%dbh <= EDecophyscon%max_dbh(currentCohort%pft))then ! cap on leaf biomass + dbldbd = dDbhdBd(currentCohort)/dDbhdBl(currentCohort) + dbrdbd = pftcon%froot_leaf(currentCohort%pft) * dbldbd + dhdbd_fn = dhdbd(currentCohort) + dbswdbd = EDecophyscon%sapwood_ratio(currentCohort%pft) * (h*dbldbd + currentCohort%bl*dhdbd_fn) + u = 1.0_r8 / (dbldbd + dbrdbd + dbswdbd) + va = 1.0_r8 / (1.0_r8 + u) + vs = u / (1.0_r8 + u) + gr_fract = 1.0_r8 - EDecophyscon%seed_alloc(currentCohort%pft) + else + dbldbd = 0._r8; dbrdbd = 0._r8 ;dbswdbd = 0._r8 + va = 0.0_r8 + vs = 1.0_r8 + gr_fract = 1.0_r8 - (EDecophyscon%seed_alloc(currentCohort%pft) + EDecophyscon%clone_alloc(currentCohort%pft)) + endif + + !FIX(RF,032414) - to fix high bl's. needed to prevent numerical errors without the ODEINT. + if (currentCohort%balive > target_balive*1.1_r8)then + va = 0.0_r8; vs = 1._r8 + write(iulog,*) 'using high bl cap',target_balive,currentCohort%balive + endif + + else + dbldbd = 0._r8; dbrdbd = 0._r8; dbswdbd = 0._r8 + va = 1.0_r8; vs = 0._r8 + gr_fract = 1.0_r8 + endif + + ! calculate derivatives of living and dead carbon pools + currentCohort%dbalivedt = gr_fract * va * currentCohort%carbon_balance - balive_loss + currentCohort%dbdeaddt = gr_fract * vs * currentCohort%carbon_balance + currentCohort%dbstoredt = currentCohort%storage_flux + currentCohort%seed_prod = (1.0_r8 - gr_fract) * currentCohort%carbon_balance + if (abs(currentCohort%npp-(currentCohort%dbalivedt+currentCohort%dbdeaddt+currentCohort%dbstoredt+ & + currentCohort%seed_prod+currentCohort%md)) > 0.0000000001_r8)then + write(iulog,*) 'error in carbon check growth derivs',currentCohort%npp- & + (currentCohort%dbalivedt+currentCohort%dbdeaddt+currentCohort%dbstoredt+currentCohort%seed_prod+currentCohort%md) + write(iulog,*) 'cohort fluxes',currentCohort%pft,currentCohort%canopy_layer,currentCohort%n, & + currentCohort%npp,currentCohort%dbalivedt,balive_loss, & + currentCohort%dbdeaddt,currentCohort%dbstoredt,currentCohort%seed_prod,currentCohort%md * & + EDecophyscon%leaf_stor_priority(currentCohort%pft) + write(iulog,*) 'proxies' ,target_balive,currentCohort%balive,currentCohort%dbh,va,vs,gr_fract + endif + + ! prevent negative leaf pool (but not negative store pool). This is also a numerical error prevention, + ! but it shouldn't happen actually... + if (-1.0_r8*currentCohort%dbalivedt * udata%deltat > currentCohort%balive*0.99)then + write(iulog,*) 'using non-neg leaf mass cap',currentCohort%balive , currentCohort%dbalivedt,currentCohort%dbstoredt, & + currentCohort%carbon_balance + currentCohort%dbstoredt = currentCohort%dbstoredt + currentCohort%dbalivedt + currentCohort%dbalivedt = 0._r8 + endif + + ! calculate change in diameter and height + currentCohort%ddbhdt = currentCohort%dbdeaddt * dDbhdBd(currentCohort) + currentCohort%dhdt = currentCohort%dbdeaddt * dHdBd(currentCohort) + + end subroutine Growth_Derivatives + + ! ============================================================================ + subroutine recruitment( t, currentPatch ) + ! + ! !DESCRIPTION: + ! spawn new cohorts of juveniles of each PFT + ! + ! !USES: + use EDGrowthFunctionsMod, only : bdead,dbh, Bleaf + use EDTypesMod, only : udata + ! + ! !ARGUMENTS + integer, intent(in) :: t + type(ed_patch_type), intent(inout), pointer :: currentPatch + ! + ! !LOCAL VARIABLES: + integer :: ft + type (ed_cohort_type) , pointer :: temp_cohort + integer :: cohortstatus + !---------------------------------------------------------------------- + + allocate(temp_cohort) ! create temporary cohort + call zero_cohort(temp_cohort) + + do ft = 1,numpft_ed + + temp_cohort%canopy_trim = 0.8_r8 !starting with the canopy not fully expanded + temp_cohort%pft = ft + temp_cohort%hite = EDecophyscon%hgt_min(ft) + temp_cohort%dbh = Dbh(temp_cohort) + temp_cohort%bdead = Bdead(temp_cohort) + temp_cohort%balive = Bleaf(temp_cohort)*(1.0_r8 + pftcon%froot_leaf(ft) & + + EDecophyscon%sapwood_ratio(ft)*temp_cohort%hite) + temp_cohort%bstore = EDecophyscon%cushion(ft)*(temp_cohort%balive/ (1.0_r8 + pftcon%froot_leaf(ft) & + + EDecophyscon%sapwood_ratio(ft)*temp_cohort%hite)) + temp_cohort%n = currentPatch%area * currentPatch%seed_germination(ft)*udata%deltat & + / (temp_cohort%bdead+temp_cohort%balive+temp_cohort%bstore) + + if (t == 1)then + write(iulog,*) 'filling in cohorts where there are none left; this will break carbon balance', & + currentPatch%patchno,currentPatch%area + temp_cohort%n = 0.1_r8*currentPatch%area + write(iulog,*) 'cohort n',ft,temp_cohort%n + endif + + temp_cohort%laimemory = 0.0_r8 + if (pftcon%season_decid(temp_cohort%pft) == 1.and.currentPatch%siteptr%status == 1)then + temp_cohort%laimemory = (1.0_r8/(1.0_r8 + pftcon%froot_leaf(ft) + & + EDecophyscon%sapwood_ratio(ft)*temp_cohort%hite))*temp_cohort%balive + endif + if (pftcon%stress_decid(temp_cohort%pft) == 1.and.currentPatch%siteptr%dstatus == 1)then + temp_cohort%laimemory = (1.0_r8/(1.0_r8 + pftcon%froot_leaf(ft) + & + EDecophyscon%sapwood_ratio(ft)*temp_cohort%hite))*temp_cohort%balive + endif + + cohortstatus = currentPatch%siteptr%status + if (pftcon%stress_decid(ft) == 1)then !drought decidous, override status. + cohortstatus = currentPatch%siteptr%dstatus + endif + + if (temp_cohort%n > 0.0_r8)then + call create_cohort(currentPatch, temp_cohort%pft, temp_cohort%n, temp_cohort%hite, temp_cohort%dbh, & + temp_cohort%balive, temp_cohort%bdead, temp_cohort%bstore, & + temp_cohort%laimemory, cohortstatus, temp_cohort%canopy_trim, currentPatch%NCL_p) + endif + enddo !pft loop + + deallocate(temp_cohort) ! delete temporary cohort + + call fuse_cohorts(currentPatch) + call sort_cohorts(currentPatch) + + end subroutine recruitment + + ! ============================================================================ + subroutine CWD_Input( currentPatch) + ! + ! !DESCRIPTION: + ! Generate litter fields from turnover. + ! + ! !USES: + use SFParamsMod , only : SF_val_CWD_frac + use EDParamsMod , only : ED_val_ag_biomass + use EDTypesMod , only : udata + ! + ! !ARGUMENTS + type(ed_patch_type),intent(inout), target :: currentPatch + ! + ! !LOCAL VARIABLES: + type(ed_cohort_type), pointer :: currentCohort + integer :: c,p + real(r8) :: not_dead_n !projected remaining number of trees in understorey cohort after turnover + real(r8) :: dead_n !understorey dead tree density + integer :: pft + !---------------------------------------------------------------------- + + ! ================================================ + ! Other direct litter fluxes happen in phenology and in spawn_patches. + ! ================================================ + + currentCohort => currentPatch%shortest + + do while(associated(currentCohort)) + pft = currentCohort%pft + ! ================================================ + ! Litter from tissue turnover. KgC/m2/year + ! ================================================ + currentPatch%leaf_litter_in(pft) = currentPatch%leaf_litter_in(pft) + & + currentCohort%leaf_md * currentCohort%n/currentPatch%area !turnover + + currentPatch%root_litter_in(pft) = currentPatch%root_litter_in(pft) + & + currentCohort%root_md * currentCohort%n/currentPatch%area !turnover + currentPatch%leaf_litter_in(pft) = currentPatch%leaf_litter_in(pft) + & + currentCohort%leaf_litter * currentCohort%n/currentPatch%area/udata%deltat + + !daily leaf loss needs to be scaled up to the annual scale here. + + do c = 1,ncwd + currentPatch%cwd_AG_in(c) = currentPatch%cwd_AG_in(c) + currentCohort%woody_turnover * & + SF_val_CWD_frac(c) * currentCohort%n/currentPatch%area *ED_val_ag_biomass + currentPatch%cwd_BG_in(c) = currentPatch%cwd_BG_in(c) + currentCohort%woody_turnover * & + SF_val_CWD_frac(c) * currentCohort%n/currentPatch%area *(1.0_r8-ED_val_ag_biomass) + enddo + + if (currentCohort%canopy_layer > 1)then + + ! ================================================ + ! Litter fluxes for understorey mortality. KgC/m2/year + ! ================================================ + dead_n = -1.0_r8 * currentCohort%dndt / currentPatch%area + + currentPatch%leaf_litter_in(pft) = currentPatch%leaf_litter_in(pft) + & + (currentCohort%bl+currentCohort%leaf_litter/udata%deltat)* dead_n + currentPatch%root_litter_in(pft) = currentPatch%root_litter_in(pft) + & + (currentCohort%br+currentCohort%bstore) * dead_n + + do c = 1,ncwd + currentPatch%cwd_AG_in(c) = currentPatch%cwd_AG_in(c) + (currentCohort%bdead+currentCohort%bsw) * & + SF_val_CWD_frac(c) * dead_n * ED_val_ag_biomass + currentPatch%cwd_BG_in(c) = currentPatch%cwd_BG_in(c) + (currentCohort%bdead+currentCohort%bsw) * & + SF_val_CWD_frac(c) * dead_n * (1.0_r8-ED_val_ag_biomass) + + if (currentPatch%cwd_AG_in(c) < 0.0_r8)then + write(iulog,*) 'negative CWD in flux',currentPatch%cwd_AG_in(c), & + (currentCohort%bdead+currentCohort%bsw), dead_n + endif + enddo + + endif !canopy layer + + currentCohort => currentCohort%taller + + enddo ! end loop over cohorts + + do p = 1,numpft_ed + currentPatch%leaf_litter_in(p) = currentPatch%leaf_litter_in(p) + currentPatch%seed_decay(p) !KgC/m2/yr + enddo + + end subroutine CWD_Input + + ! ============================================================================ + subroutine fragmentation_scaler( currentPatch, temperature_inst ) + ! + ! !DESCRIPTION: + ! Simple CWD fragmentation Model + ! FIX(SPM, 091914) this should be a function as it returns a value in currentPatch%fragmentation_scaler + ! + ! !USES: + use shr_const_mod , only : SHR_CONST_PI, SHR_CONST_TKFRZ + use EDSharedParamsMod , only : EDParamsShareInst + ! + ! !ARGUMENTS + type(ed_patch_type) , intent(inout) :: currentPatch + type(temperature_type) , intent(in) :: temperature_inst + ! + ! !LOCAL VARIABLES: + logical :: use_century_tfunc = .false. + type(ed_site_type), pointer :: currentSite + integer :: c,p,j + real(r8) :: t_scalar + real(r8) :: w_scalar + real(r8) :: catanf ! hyperbolic temperature function from CENTURY + real(r8) :: catanf_30 ! hyperbolic temperature function from CENTURY + real(r8) :: t1 ! temperature argument + real(r8) :: Q10 ! temperature dependence + real(r8) :: froz_q10 ! separate q10 for frozen soil respiration rates. default to same as above zero rates + real(r8), pointer :: t_veg24(:) + !---------------------------------------------------------------------- + + catanf(t1) = 11.75_r8 +(29.7_r8 / SHR_CONST_PI) * atan( SHR_CONST_PI * 0.031_r8 * ( t1 - 15.4_r8 )) + + t_veg24 => temperature_inst%t_veg24_patch ! Input: [real(r8) (:)] avg pft vegetation temperature for last 24 hrs + + catanf_30 = catanf(30._r8) + + c = currentPatch%siteptr%clmcolumn + p = currentPatch%clm_pno + + ! set "froz_q10" parameter + froz_q10 = EDParamsShareInst%froz_q10 + Q10 = EDParamsShareInst%Q10 + + 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 (t_veg24(p) >= SHR_CONST_TKFRZ) then + t_scalar = Q10**((t_veg24(p)-(SHR_CONST_TKFRZ+25._r8))/10._r8) + ! Q10**((t_soisno(c,j)-(SHR_CONST_TKFRZ+25._r8))/10._r8) + else + t_scalar = (Q10**(-25._r8/10._r8))*(froz_q10**((t_veg24(p)-SHR_CONST_TKFRZ)/10._r8)) + !Q10**(-25._r8/10._r8))*(froz_q10**((t_soisno(c,j)-SHR_CONST_TKFRZ)/10._r8) + endif + else + ! original century uses an arctangent function to calculate the temperature dependence of decomposition + t_scalar = max(catanf(t_veg24(p)-SHR_CONST_TKFRZ)/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_ed))/numpft_ed + + currentPatch%fragmentation_scaler = min(1.0_r8,max(0.0_r8,t_scalar * w_scalar)) + + end subroutine fragmentation_scaler + + ! ============================================================================ + subroutine cwd_out( currentPatch, temperature_inst, soilstate_inst, waterstate_inst) + ! + ! !DESCRIPTION: + ! Simple CWD fragmentation Model + ! spawn new cohorts of juveniles of each PFT + ! + ! !USES: + use SFParamsMod, only : SF_val_max_decomp + use EDTypesMod , only : udata + ! + ! !ARGUMENTS + type(ed_patch_type) , intent(inout), target :: currentPatch + type(temperature_type) , intent(in) :: temperature_inst + type(soilstate_type) , intent(in) :: soilstate_inst + type(waterstate_type) , intent(in) :: waterstate_inst + ! + ! !LOCAL VARIABLES: + type(ed_site_type), pointer :: currentSite + integer :: c,ft + !---------------------------------------------------------------------- + + currentSite => currentPatch%siteptr + currentPatch%root_litter_out = 0.0_r8 + currentPatch%leaf_litter_out = 0.0_r8 + + call fragmentation_scaler(currentPatch, temperature_inst) + + !Flux of coarse woody debris into decomposing litter pool. + + currentPatch%cwd_ag_out(1:ncwd) = 0.0_r8 + currentPatch%cwd_bg_out(1:ncwd) = 0.0_r8 + currentPatch%leaf_litter_out(1:numpft_ed) = 0.0_r8 + currentPatch%root_litter_out(1:numpft_ed) = 0.0_r8 + + do c = 1,ncwd + currentPatch%cwd_ag_out(c) = max(0.0_r8, currentPatch%cwd_ag(c) * & + SF_val_max_decomp(c+1) * currentPatch%fragmentation_scaler ) + currentPatch%cwd_bg_out(c) = max(0.0_r8, currentPatch%cwd_bg(c) * & + SF_val_max_decomp(c+1) * currentPatch%fragmentation_scaler ) + enddo + + ! 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 ft = 1,numpft_ed + currentPatch%leaf_litter_out(ft) = max(0.0_r8,currentPatch%leaf_litter(ft)* SF_val_max_decomp(dg_sf) * & + currentPatch%fragmentation_scaler ) + currentPatch%root_litter_out(ft) = max(0.0_r8,currentPatch%root_litter(ft)* SF_val_max_decomp(dg_sf) * & + currentPatch%fragmentation_scaler ) + if ( currentPatch%leaf_litter_out(ft)<0.0_r8.or.currentPatch%root_litter_out(ft)<0.0_r8)then + write(iulog,*) 'root or leaf out is negative?',SF_val_max_decomp(dg_sf),currentPatch%fragmentation_scaler + endif + enddo + + !add up carbon going into fragmenting pools + currentSite%flux_out = currentSite%flux_out + sum(currentPatch%leaf_litter_out) * & + currentPatch%area *udata%deltat!kgC/site/day + currentSite%flux_out = currentSite%flux_out + sum(currentPatch%root_litter_out) * & + currentPatch%area *udata%deltat!kgC/site/day + currentSite%flux_out = currentSite%flux_out + sum(currentPatch%cwd_ag_out) * & + currentPatch%area *udata%deltat!kgC/site/day + currentSite%flux_out = currentSite%flux_out + sum(currentPatch%cwd_bg_out) * & + currentPatch%area *udata%deltat!kgC/site/day + + end subroutine cwd_out + +end module EDPhysiologyMod diff --git a/biogeochem/EDSharedParamsMod.F90 b/biogeochem/EDSharedParamsMod.F90 new file mode 100644 index 0000000000..a51fbb5f24 --- /dev/null +++ b/biogeochem/EDSharedParamsMod.F90 @@ -0,0 +1,54 @@ +module EDSharedParamsMod + + !----------------------------------------------------------------------- + ! + ! !USES: + use shr_kind_mod , only: r8 => shr_kind_r8 + implicit none + + ! EDParamsShareInst. PGI wants the type decl. public but the instance + ! is indeed protected. A generic private statement at the start of the module + ! overrides the protected functionality with PGI + + type, public :: EDParamsShareType + real(r8) :: Q10 ! temperature dependence + real(r8) :: froz_q10 ! separate q10 for frozen soil respiration rates + end type EDParamsShareType + + type(EDParamsShareType), protected :: EDParamsShareInst + + !----------------------------------------------------------------------- + +contains + + !----------------------------------------------------------------------- + subroutine EDParamsReadShared(ncid) + ! + use ncdio_pio , only : file_desc_t,ncd_io + use abortutils , only : endrun + use shr_log_mod , only : errMsg => shr_log_errMsg + ! + type(file_desc_t),intent(inout) :: ncid ! pio netCDF file id + ! + character(len=32) :: subname = 'EDParamsReadShared' + character(len=100) :: errCode = '-Error reading in ED shared params file. Var:' + logical :: readv ! has variable been read in or not + real(r8) :: tempr ! temporary to read in parameter + character(len=100) :: tString ! temp. var for reading + !----------------------------------------------------------------------- + ! + ! netcdf read here + ! + tString='q10_mr' + call ncd_io(varname=trim(tString),data=tempr, flag='read', ncid=ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(__FILE__, __LINE__)) + EDParamsShareInst%Q10=tempr + + tString='froz_q10' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(__FILE__, __LINE__)) + EDParamsShareInst%froz_q10=tempr + + end subroutine EDParamsReadShared + +end module EDSharedParamsMod diff --git a/biogeophys/EDAccumulateFluxesMod.F90 b/biogeophys/EDAccumulateFluxesMod.F90 new file mode 100644 index 0000000000..29312bb317 --- /dev/null +++ b/biogeophys/EDAccumulateFluxesMod.F90 @@ -0,0 +1,83 @@ +module EDAccumulateFluxesMod + + !------------------------------------------------------------------------------ + ! !DESCRIPTION: + ! This routine accumulates NPP, GPP and respiration of each cohort over the course of each 24 hour period. + ! The fluxes are stored per cohort, and the npp_clm (etc) fluxes are calcualted in EDPhotosynthesis + ! This routine cannot be in EDPhotosynthesis because EDPhotosynthesis is a loop and therefore would + ! erroneously add these things up multiple times. + ! Rosie Fisher. March 2014. + ! + ! !USES: + implicit none + ! + public :: AccumulateFluxes_ED + !------------------------------------------------------------------------------ + +contains + + !------------------------------------------------------------------------------ + subroutine AccumulateFluxes_ED(bounds, p, ed_allsites_inst, photosyns_inst) + ! + ! !DESCRIPTION: + ! see above + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use decompMod , only : bounds_type + use EDTypesMod , only : ed_patch_type, ed_cohort_type, ed_site_type, map_clmpatch_to_edpatch + use PatchType , only : patch + use PhotosynthesisMod , only : photosyns_type + ! + ! !ARGUMENTS + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: p !patch/'p' + type(ed_site_type) , intent(inout), target :: ed_allsites_inst( bounds%begg: ) + type(photosyns_type) , intent(inout) :: photosyns_inst + ! + ! !LOCAL VARIABLES: + type(ed_cohort_type), pointer :: currentCohort ! current cohort + type(ed_patch_type) , pointer :: currentPatch ! current patch + integer :: iv !leaf layer + integer :: g !gridcell + !---------------------------------------------------------------------- + + associate(& + fpsn => photosyns_inst%fpsn_patch , & ! Output: [real(r8) (:)] photosynthesis (umol CO2 /m**2 /s) + psncanopy => photosyns_inst%psncanopy_patch & ! Output: [real(r8) (:,:)] canopy scale photosynthesis umol CO2 /m**2/ s + ) + + fpsn(p) = psncanopy(p) + + if (patch%is_veg(p)) then + + g = patch%gridcell(p) + currentPatch => map_clmpatch_to_edpatch(ed_allsites_inst(g), p) + currentCohort => currentPatch%shortest + + do while(associated(currentCohort)) + + ! Accumulate fluxes from hourly to daily values. + ! _clm fluxes are KgC/indiv/timestep _acc are KgC/indiv/day + + currentCohort%npp_acc = currentCohort%npp_acc + currentCohort%npp_clm + currentCohort%gpp_acc = currentCohort%gpp_acc + currentCohort%gpp_clm + currentCohort%resp_acc = currentCohort%resp_acc + currentCohort%resp_clm + + do iv=1,currentCohort%nv + if(currentCohort%year_net_uptake(iv) == 999._r8)then ! note that there were leaves in this layer this year. + currentCohort%year_net_uptake(iv) = 0._r8 + end if + currentCohort%year_net_uptake(iv) = currentCohort%year_net_uptake(iv) + currentCohort%ts_net_uptake(iv) + enddo + + currentCohort => currentCohort%taller + enddo ! while(associated(currentCohort) + + end if !is_veg + + end associate + + end subroutine AccumulateFluxes_ED + +end module EDAccumulateFluxesMod diff --git a/biogeophys/EDBtranMod.F90 b/biogeophys/EDBtranMod.F90 new file mode 100644 index 0000000000..5cfb93c74b --- /dev/null +++ b/biogeophys/EDBtranMod.F90 @@ -0,0 +1,349 @@ +module EDBtranMod + + !------------------------------------------------------------------------------ + ! !DESCRIPTION: + ! This routine accumulates NPP, GPP and respiration of each cohort over the course of each 24 hour period. + ! The fluxes are stored per cohort, and the npp_clm (etc) fluxes are calcualted in EDPhotosynthesis + ! This routine cannot be in EDPhotosynthesis because EDPhotosynthesis is a loop and therefore would + ! erroneously add these things up multiple times. + ! Rosie Fisher. March 2014. + ! + ! !USES: + use pftconMod , only : pftcon + use EDTypesMod , only : ed_patch_type, ed_cohort_type, numpft_ed + use EDEcophysContype , only : EDecophyscon + ! + implicit none + private + ! + public :: BTRAN_ED + ! + type(ed_cohort_type), pointer :: currentCohort ! current cohort + type(ed_patch_type) , pointer :: currentPatch ! current patch + !------------------------------------------------------------------------------ + +contains + + !------------------------------------------------------------------------------ + subroutine btran_ed( bounds, p, ed_allsites_inst, & + soilstate_inst, waterstate_inst, temperature_inst, energyflux_inst) + ! + ! !DESCRIPTION: + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_const_mod , only : shr_const_pi + use decompMod , only : bounds_type + use clm_varpar , only : nlevgrnd + use clm_varctl , only : iulog + use clm_varcon , only : tfrz, denice, denh2o + use SoilStateType , only : soilstate_type + use WaterStateType , only : waterstate_type + use TemperatureType , only : temperature_type + use EnergyFluxType , only : energyflux_type + use GridcellType , only : grc + use ColumnType , only : col + use PatchType , only : patch + use EDTypesMod , only : ed_site_type, map_clmpatch_to_edpatch + ! + ! !ARGUMENTS + type(bounds_type) , intent(in) :: bounds ! clump bounds + integer , intent(in) :: p ! patch/'p' + type(ed_site_type) , intent(inout), target :: ed_allsites_inst( bounds%begg: ) + type(soilstate_type) , intent(inout) :: soilstate_inst + type(waterstate_type) , intent(in) :: waterstate_inst + type(temperature_type) , intent(in) :: temperature_inst + type(energyflux_type) , intent(inout) :: energyflux_inst + ! + ! !LOCAL VARIABLES: + integer :: iv !leaf layer + integer :: g !gridcell + integer :: c !column + integer :: j !soil layer + integer :: ft ! plant functional type index + !---------------------------------------------------------------------- + + ! Inputs to model from CLM. To be read in through an input file for the purposes of this program. + integer, parameter :: nv = 5 ! Number of canopy layers + real(r8) :: xksat ! maximum hydraulic conductivity of soil [mm/s] + real(r8) :: s1 ! HC intermediate + real(r8) :: swp_mpa(nlevgrnd) ! matrix potential - MPa + real(r8) :: hk(nlevgrnd) ! hydraulic conductivity [mm h2o/s] + real(r8) :: rootxsecarea ! root X-sectional area (m2) + real(r8) :: rootmass(nlevgrnd) ! root mass in each layer (g) + real(r8) :: rootlength(nlevgrnd) ! root length in each layer (m) + real(r8) :: soilr1(nlevgrnd) ! soil-to-root resistance in each layer (MPa s m2 mmol-1) + real(r8) :: soilr2(nlevgrnd) ! internal root resistance in each layer (MPa s m2 mmol-1) + real(r8) :: rs ! intermediate variable + real(r8) :: soilr_z(nlevgrnd) ! soil-to-xylem resistance in each layer (MPa s m2 mmol-1) + real(r8) :: lsoil(nlevgrnd) ! hydraulic conductivity in each soil layer + + real(r8) :: estevap(nlevgrnd) ! potential suction from each soil layer (mmol m-2 s-1) + real(r8) :: totestevap ! potential suction from each soil layer (mmol m-2 s-1) + real(r8) :: fraction_uptake(nlevgrnd) ! Uptake of water from each soil layer (-) + real(r8) :: maxevap(nlevgrnd) ! potential suction from each soil layer (mmol m-2 s-1) + real(r8) :: totmaxevap ! potential suction from each soil layer (mmol m-2 s-1) + real(r8) :: fleaf ! fraction of leaves in each canopy layer + + ! Model parameters + real(r8) :: head = 0.009807_r8 ! head of pressure (MPa/m) + real(r8) :: rootdens = 0.5e6_r8 ! root density, g biomass m-3 root + real(r8) :: pi = shr_const_pi + real(r8) :: vol_ice ! partial volume of ice lens in layer + real(r8) :: eff_porosity ! effective porosity in layer + real(r8) :: vol_liq ! partial volume of liquid water in layer + real(r8) :: s_node ! vol_liq/eff_porosity + real(r8) :: smp_node ! matrix potential + + ! To be read in from pft file ultimately. + real(r8) :: minlwp = -2.5_r8 ! minimum leaf water potential in MPa + real(r8) :: rootrad = 0.001_r8 ! root radius in metres + + ! Outputs to CLM_SPA + real(r8) :: weighted_SWP ! weighted apparent soil water potential: MPa. + real(r8) :: canopy_soil_resistance(nv) ! Resistance experienced by each canopy layer: MPa s m2 mmol-1 + + ! SPA Pointers from CLM type. + logical, parameter :: SPA_soil=.false. ! Is the BTRAN model SPA or CLM? FIX(SPM,032414) ed - make this a namelist var + + real(r8) :: rresis_ft(numpft_ed,nlevgrnd) ! resistance to water uptake per pft and soil layer. + real(r8) :: pftgs(numpft_ed) ! pft weighted stomatal conductance s/m + real(r8) :: temprootr + !------------------------------------------------------------------------------ + + associate(& + dz => col%dz , & ! Input: [real(r8) (:,:) ] layer depth (m) + + smpso => pftcon%smpso , & ! Input: soil water potential at full stomatal opening (mm) + smpsc => pftcon%smpsc , & ! Input: soil water potential at full stomatal closure (mm) + + sucsat => soilstate_inst%sucsat_col , & ! Input: [real(r8) (:,:) ] minimum soil suction (mm) + watsat => soilstate_inst%watsat_col , & ! Input: [real(r8) (:,:) ] volumetric soil water at saturation (porosity) + watdry => soilstate_inst%watdry_col , & ! Input: [real(r8) (:,:) ] btran parameter for btran=0 + watopt => soilstate_inst%watopt_col , & ! Input: [real(r8) (:,:) ] btran parameter for btran = 1 + bsw => soilstate_inst%bsw_col , & ! Input: [real(r8) (:,:) ] Clapp and Hornberger "b" + soilbeta => soilstate_inst%soilbeta_col , & ! Input: [real(r8) (:) ] soil wetness relative to field capacity + sand => soilstate_inst%sandfrac_patch , & ! Input: [real(r8) (:) ] % sand of soil + rootr => soilstate_inst%rootr_patch , & ! Output: [real(r8) (:,:) ] Fraction of water uptake in each layer + + h2osoi_ice => waterstate_inst%h2osoi_ice_col , & ! Input: [real(r8) (:,:) ] ice lens (kg/m2) + h2osoi_vol => waterstate_inst%h2osoi_vol_col , & ! Input: [real(r8) (:,:) ] volumetric soil water (0<=h2osoi_vol<=watsat) [m3/m3] + h2osoi_liq => waterstate_inst%h2osoi_liq_col , & ! Input: [real(r8) (:,:) ] liquid water (kg/m2) + + t_soisno => temperature_inst%t_soisno_col , & ! Input: [real(r8) (:,:) ] soil temperature (Kelvin) + + btran => energyflux_inst%btran_patch , & ! Output: [real(r8) (:) ] transpiration wetness factor (0 to 1) + btran2 => energyflux_inst%btran2_patch , & ! Output: [real(r8) (:) ] + rresis => energyflux_inst%rresis_patch & ! Output: [real(r8) (:,:) ] root resistance by layer (0-1) (nlevgrnd) + ) + + if (patch%is_veg(p)) then + + c = patch%column(p) + g = patch%gridcell(p) + + currentPatch => map_clmpatch_to_edpatch(ed_allsites_inst(g), p) + do FT = 1,numpft_ed + currentPatch%btran_ft(FT) = 0.0_r8 + do j = 1,nlevgrnd + + !Root resistance factors + vol_ice = min(watsat(c,j), h2osoi_ice(c,j)/(dz(c,j)*denice)) + eff_porosity = watsat(c,j)-vol_ice + vol_liq = min(eff_porosity, h2osoi_liq(c,j)/(dz(c,j)*denh2o)) + if (vol_liq <= 0._r8 .or. t_soisno(c,j) <= tfrz-2._r8) then + currentPatch%rootr_ft(FT,j) = 0._r8 + else + s_node = max(vol_liq/eff_porosity,0.01_r8) + smp_node = max(smpsc(FT), -sucsat(c,j)*s_node**(-bsw(c,j))) + !FIX(RF,032414) for junipers + rresis_ft(FT,j) = min( (eff_porosity/watsat(c,j))* & + (smp_node - smpsc(FT)) / (smpso(FT) - smpsc(FT)), 1._r8) + + currentPatch%rootr_ft(FT,j) = currentPatch%rootfr_ft(FT,j)*rresis_FT(FT,j) + ! 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) + ! currentPatch%rootr_ft(FT,j) = currentPatch%rootfr_ft(FT,j)**0.3*rresis_FT(FT,j)/ & + ! sum(currentPatch%rootfr_ft(FT,1:nlevgrnd)**0.3) + currentPatch%btran_ft(FT) = currentPatch%btran_ft(FT) + currentPatch%rootr_ft(FT,j) + end if + end do !j + + btran(p) = currentPatch%btran_ft(1) !FIX(RF,032414) for TRF where is this used? + + ! Normalize root resistances to get layer contribution to ET + do j = 1,nlevgrnd + if (currentPatch%btran_ft(FT) > 0.0_r8) then + currentPatch%rootr_ft(FT,j) = currentPatch%rootr_ft(FT,j)/currentPatch%btran_ft(FT) + else + currentPatch%rootr_ft(FT,j) = 0._r8 + end if + end do + + end do !PFT + + ! PFT-averaged point level root fraction for extraction purposese. + ! This probably needs to be weighted by actual transpiration from each pft. FIX(RF,032414). + pftgs(:) = 0._r8 + currentCohort => currentPatch%tallest + do while(associated(currentCohort)) + pftgs(currentCohort%pft) = pftgs(currentCohort%pft) + currentCohort%gscan * currentCohort%n + currentCohort => currentCohort%shorter + enddo + + do j = 1,nlevgrnd + rootr(p,j) = 0._r8 + btran(p) = 0.0_r8 + do FT = 1,numpft_ed + if(sum(pftgs) > 0._r8)then !prevent problem with the first timestep - might fail + !bit-retart test as a result? FIX(RF,032414) + rootr(p,j) = rootr(p,j) + currentPatch%rootr_ft(FT,j) * pftgs(ft)/sum(pftgs) + else + rootr(p,j) = rootr(p,j) + currentPatch%rootr_ft(FT,j) * 1./numpft_ed + end if + enddo + enddo + + + !--------------------------------------------------------------------------------------- + ! SPA based recalculation of BTRAN and water uptake. + !--------------------------------------------------------------------------------------- + + if (SPA_soil) then ! normal case don't run this. + rootr(p,:) = 0._r8 + do FT = 1,numpft_ed + + ! Soil Physics + do j = 1,nlevgrnd + ! CLM water retention curve. Clapp and Hornberger equation. + s1 = max(h2osoi_vol(c,j)/watsat(c,j), 0.01_r8) + s1 = min(1.0_r8,s1) + smp_node = -sucsat(c,j)*s1**(-bsw(c,j)) + swp_mpa(j) = smp_node *10.0_r8/1000000.0_r8 !convert from mm to Mpa + + ! CLM hydraulic conductivity curve. + ! As opposed to the Richard's equation solution in SoilHydrology.Mod + ! the conductivity here is defined in the middle of the layer in question, not at the edge... + xksat = 0.0070556_r8 * (10._r8**(-0.884_r8+0.0153_r8*sand(p)) ) + hk(j) = xksat*s1**(2._r8*bsw(c,j)+2._r8) !removed the ice from here to avoid 1st ts crashing + enddo + + ! Root resistance + rootxsecarea=3.14159*rootrad**2 + do j = 1,nlevgrnd + rootmass(j) = EDecophyscon%soilbeta(FT) * currentPatch%rootfr_ft(FT,j) + rootlength(j) = rootmass(j)/(rootdens*rootxsecarea) !m m-3 soil + Lsoil(j) = hk(j)/1000/head !converts from mms-1 to ms-1 and then to m2 s-1 MPa-1 + if(Lsoil(j) < 1e-35_r8.or.currentPatch%rootfr_ft(ft,j) <= 0.0_r8)then !prevent floating point error + soilr_z(j) = 1e35_r8 + soilr2(j) = 1e35_r8 + else + ! Soil-to-root water uptake from Newman (1969). + rs = sqrt (1._r8 / (rootlength(j) * pi)) + soilr1(j) = log(rs/rootrad) / (2.0_r8 * pi * rootlength(j) * Lsoil(j) * dz(c,j)) + ! convert from MPa s m2 m-3 to MPa s m2 mmol-1 + soilr1(j) = soilr1(j) * 1E-6_r8 * 18_r8 * 0.001_r8 + ! second component of below ground resistance is related to root hydraulics + soilr2(j) = EDecophyscon%rootresist(FT)/(rootmass(j)*dz(c,j)) + soilr_z(j) = soilr1(j)+soilr2(j) + end if + enddo + + ! Aggregate soil layers + totestevap=0._r8 + weighted_SWP=0._r8 + estevap=0._r8 + fraction_uptake=0._r8 + canopy_soil_resistance=0._r8 !Reset Counters + totmaxevap = 0._r8 + + ! Estimated max transpiration from LWP gradient / soil resistance + do j = 1,nlevgrnd + estevap(j) = (swp_mpa(j) - minlwp)/(soilr_z(j)) + estevap(j) = max(0._r8,estevap(j)) ! no negative uptake + maxevap(j) = (0.0_r8 - minlwp)/(soilr2(j)) + enddo + totestevap = sum(estevap) + totmaxevap = sum(maxevap) + + ! Weighted soil water potential + do j = 1,nlevgrnd + if(totestevap > 0._r8)then + fraction_uptake(j) = estevap(j)/totestevap !Fraction of total ET taken from this soil layer + else + estevap(j) = 0._r8 + fraction_uptake(j)=1._r8/nlevgrnd + end if + weighted_SWP = weighted_SWP + swp_mpa(j) * estevap(j) + enddo + + + if(totestevap > 0._r8)then + weighted_swp = weighted_swp/totestevap + ! weight SWP for the total evaporation + else + write(iulog,*) 'empty soil', totestevap + ! error check + weighted_swp = minlwp + end if + + ! Weighted soil-root resistance. Aggregate the conductances (1/soilR) for each soil layer + do iv = 1,nv !leaf layers + fleaf = 1.0_r8/nv + do j = 1,nlevgrnd !root layers + ! Soil resistance for each canopy layer is related to leaf area + ! The conductance of the root system to the + ! whole canopy is reduced by the fraction of leaves in this layer... + canopy_soil_resistance(iv) = canopy_soil_resistance(iv)+fleaf * 1.0_r8/(soilr_z(j)) + enddo + ! Turn aggregated conductance back into resistance. mmol MPa-1 s-1 m-2 to MPa s m2 mmol-1 + canopy_soil_resistance(iv) = 1./canopy_soil_resistance(iv) + enddo + + currentPatch%btran_ft(FT) = totestevap/totmaxevap + do j = 1,nlevgrnd + if(sum(pftgs) > 0._r8)then !prevent problem with the first timestep - might fail + !bit-retart test as a result? FIX(RF,032414) + rootr(p,j) = rootr(p,j) + fraction_uptake(j) * pftgs(ft)/sum(pftgs) + else + rootr(p,j) = rootr(p,j) + fraction_uptake(j) * 1./numpft_ed + end if + enddo + + enddo !pft loop + + end if ! + !--------------------------------------------------------------------------------------- + ! end of SPA based recalculation of BTRAN and water uptake. + !--------------------------------------------------------------------------------------- + + !weight patch level output BTRAN for the + btran(p) = 0.0_r8 + do FT = 1,numpft_ed + if(sum(pftgs) > 0._r8)then !prevent problem with the first timestep - might fail + !bit-retart test as a result? FIX(RF,032414) + btran(p) = btran(p) + currentPatch%btran_ft(FT) * pftgs(ft)/sum(pftgs) + else + btran(p) = btran(p) + currentPatch%btran_ft(FT) * 1./numpft_ed + end if + enddo + + temprootr = sum(rootr(p,:)) + if(temprootr /= 1.0_r8)then + !write(iulog,*) 'error with rootr in canopy fluxes',sum(rootr(p,:)) + if(temprootr > 0._r8)then + do j = 1,nlevgrnd + rootr(p,j) = rootr(p,j) / temprootr + enddo + end if + end if + + else ! edpatch + currentPatch%btran_ft(1:numpft_ed) = 1._r8 + end if ! edpatch + + end associate + + end subroutine btran_ed + +end module EDBtranMod diff --git a/biogeophys/EDPhotosynthesisMod.F90 b/biogeophys/EDPhotosynthesisMod.F90 new file mode 100644 index 0000000000..889c905412 --- /dev/null +++ b/biogeophys/EDPhotosynthesisMod.F90 @@ -0,0 +1,972 @@ +module EDPhotosynthesisMod + + !------------------------------------------------------------------------------ + ! !DESCRIPTION: + ! Calculates the photosynthetic fluxes for the ED model + ! This code is equivalent to the 'photosynthesis' subroutine in PhotosynthesisMod.F90. + ! We have split this out to reduce merge conflicts until we can pull out + ! common code used in both the ED and CLM versions. + ! + ! !USES: + ! + implicit none + private + ! + ! PUBLIC MEMBER FUNCTIONS: + public :: Photosynthesis_ED !ED specific photosynthesis routine + !------------------------------------------------------------------------------ + +contains + + !--------------------------------------------------------- + subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & + rb, dayl_factor, ed_allsites_inst, & + atm2lnd_inst, temperature_inst, canopystate_inst, photosyns_inst) + ! + ! !DESCRIPTION: + ! Leaf photosynthesis and stomatal conductance calculation as described by + ! Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 and extended to + ! a multi-layer canopy + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_log_mod , only : errMsg => shr_log_errMsg + use abortutils , only : endrun + use decompMod , only : bounds_type + use clm_time_manager , only : get_step_size + use clm_varcon , only : rgas, tfrz, namep + use clm_varpar , only : nlevcan_ed, nclmax, nlevsoi, mxpft + use clm_varctl , only : iulog + use pftconMod , only : pftcon + use perf_mod , only : t_startf, t_stopf + use atm2lndType , only : atm2lnd_type + use CanopyStateType , only : canopystate_type + use PhotosynthesisMod , only : photosyns_type + use TemperatureType , only : temperature_type + use PatchType , only : patch + use quadraticMod , only : quadratic + use EDParamsMod , only : ED_val_grperc + use EDSharedParamsMod , only : EDParamsShareInst + use EDTypesMod , only : numpft_ed, dinc_ed + use EDtypesMod , only : ed_patch_type, ed_cohort_type, ed_site_type, numpft_ed, map_clmpatch_to_edpatch + use EDEcophysContype , only : EDecophyscon + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds ! bounds + integer , intent(in) :: fn ! size of pft filter + integer , intent(in) :: filterp(fn) ! pft filter + real(r8) , intent(in) :: esat_tv(bounds%begp: ) ! saturation vapor pressure at t_veg (Pa) + real(r8) , intent(in) :: eair( bounds%begp: ) ! vapor pressure of canopy air (Pa) + real(r8) , intent(in) :: oair( bounds%begp: ) ! Atmospheric O2 partial pressure (Pa) + real(r8) , intent(in) :: cair( bounds%begp: ) ! Atmospheric CO2 partial pressure (Pa) + real(r8) , intent(inout) :: rb( bounds%begp: ) ! boundary layer resistance (s/m) + real(r8) , intent(in) :: dayl_factor( bounds%begp: ) ! scalar (0-1) for daylength + type(ed_site_type) , intent(inout), target :: ed_allsites_inst( bounds%begg: ) + type(atm2lnd_type) , intent(in) :: atm2lnd_inst + type(temperature_type) , intent(in) :: temperature_inst + type(canopystate_type) , intent(inout) :: canopystate_inst + type(photosyns_type) , intent(inout) :: photosyns_inst + ! + ! !CALLED FROM: + ! subroutine CanopyFluxes + ! + ! !LOCAL VARIABLES: + type (ed_patch_type) , pointer :: currentPatch + type (ed_cohort_type), pointer :: currentCohort + ! + integer , parameter :: psn_type = 2 !c3 or c4. + ! + ! Leaf photosynthesis parameters + real(r8) :: vcmax_z(nclmax,mxpft,nlevcan_ed) ! maximum rate of carboxylation (umol co2/m**2/s) + real(r8) :: jmax_z(nclmax,mxpft,nlevcan_ed) ! maximum electron transport rate (umol electrons/m**2/s) + real(r8) :: tpu_z(nclmax,mxpft,nlevcan_ed) ! triose phosphate utilization rate (umol CO2/m**2/s) + real(r8) :: kp_z(nclmax,mxpft,nlevcan_ed) ! initial slope of CO2 response curve (C4 plants) + real(r8) :: lmr_z(nclmax,mxpft,nlevcan_ed) ! initial slope of CO2 response curve (C4 plants) + real(r8) :: rs_z(nclmax,mxpft,nlevcan_ed) ! stomatal resistance s/m + real(r8) :: gs_z(nclmax,mxpft,nlevcan_ed) ! stomatal conductance m/s + + real(r8) :: ci(nclmax,mxpft,nlevcan_ed) ! intracellular leaf CO2 (Pa) + real(r8) :: lnc(mxpft) ! leaf N concentration (gN leaf/m^2) + real(r8) :: kc( bounds%begp:bounds%endp ) ! Michaelis-Menten constant for CO2 (Pa) + real(r8) :: ko( bounds%begp:bounds%endp ) ! Michaelis-Menten constant for O2 (Pa) + real(r8) :: co2_cp( bounds%begp:bounds%endp ) ! CO2 compensation point (Pa) + real(r8) :: bbbopt(psn_type) ! Ball-Berry minimum leaf conductance, unstressed (umol H2O/m**2/s) + real(r8) :: bbb(mxpft) ! Ball-Berry minimum leaf conductance (umol H2O/m**2/s) + real(r8) :: mbbopt(psn_type) ! Ball-Berry slope of conductance-photosynthesis relationship, unstressed + real(r8) :: mbb(mxpft) ! Ball-Berry slope of conductance-photosynthesis relationship + + real(r8) :: kn(mxpft) ! leaf nitrogen decay coefficient + real(r8) :: vcmax25top(mxpft) ! canopy top: maximum rate of carboxylation at 25C (umol CO2/m**2/s) + real(r8) :: jmax25top(mxpft) ! canopy top: maximum electron transport rate at 25C (umol electrons/m**2/s) + real(r8) :: tpu25top(mxpft) ! canopy top: triose phosphate utilization rate at 25C (umol CO2/m**2/s) + real(r8) :: lmr25top(mxpft) ! canopy top: leaf maintenance respiration rate at 25C (umol CO2/m**2/s) + real(r8) :: kp25top(mxpft) ! canopy top: initial slope of CO2 response curve (C4 plants) at 25C + + 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) :: lmr25 ! leaf layer: leaf maintenance respiration rate at 25C (umol CO2/m**2/s) + real(r8) :: kp25 ! leaf layer: Initial slope of CO2 response curve (C4 plants) at 25C + real(r8) :: kc25 ! Michaelis-Menten constant for CO2 at 25C (Pa) + real(r8) :: ko25 ! Michaelis-Menten constant for O2 at 25C (Pa) + real(r8) :: cp25 ! CO2 compensation point at 25C (Pa) + + 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) :: lmrha ! activation energy for lmr (J/mol) + real(r8) :: kcha ! activation energy for kc (J/mol) + real(r8) :: koha ! activation energy for ko (J/mol) + real(r8) :: cpha ! activation energy for cp (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) :: lmrhd ! deactivation energy for lmr (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) :: lmrse ! entropy term for lmr (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) + real(r8) :: lmrc ! scaling factor for high temperature inhibition (25 C = 1.0) + + real(r8) :: qe(psn_type) ! quantum efficiency, used only for C4 (mol CO2 / mol photons) + real(r8) :: fnps ! fraction of light absorbed by non-photosynthetic pigments + real(r8) :: theta_psii ! empirical curvature parameter for electron transport rate + + real(r8) :: theta_cj(psn_type) ! empirical curvature parameter for ac, aj photosynthesis co-limitation + real(r8) :: theta_ip ! empirical curvature parameter for ap photosynthesis co-limitation + + ! Other + integer :: c,CL,f,g,iv,j,p,ps,ft ! indices + integer :: NCL_p ! number of canopy layers in patch + real(r8) :: cf ! s m**2/umol -> s/m + real(r8) :: rsmax0 ! maximum stomatal resistance [s/m] + real(r8) :: gb ! leaf boundary layer conductance (m/s) + real(r8) :: gb_mol ! leaf boundary layer conductance (umol H2O/m**2/s) + real(r8) :: cs ! CO2 partial pressure at leaf surface (Pa) + 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) :: sco ! relative specificity of rubisco + real(r8) :: tl ! leaf temperature in photosynthesis temperature function (K) + real(r8) :: ha ! activation energy in photosynthesis temperature function (J/mol) + real(r8) :: hd ! deactivation energy in photosynthesis temperature function (J/mol) + real(r8) :: se ! entropy term in photosynthesis temperature function (J/mol/K) + real(r8) :: cc2 ! scaling factor for high temperature inhibition (25 C = 1.0) + real(r8) :: ciold ! previous value of Ci for convergence check + real(r8) :: gs_mol_err ! gs_mol for error check + 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) :: ceair ! vapor pressure of air, constrained (Pa) + real(r8) :: act25 ! (umol/mgRubisco/min) Rubisco activity at 25 C + integer :: niter ! iteration loop index + real(r8) :: nscaler ! leaf nitrogen scaling coefficient + real(r8) :: leaf_frac ! ratio of to leaf biomass to total alive biomass + + 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) :: ag(nclmax,mxpft,nlevcan_ed) ! co-limited gross leaf photosynthesis (umol CO2/m**2/s) + real(r8) :: an(nclmax,mxpft,nlevcan_ed) ! net leaf photosynthesis (umol CO2/m**2/s) + real(r8) :: an_av(nclmax,mxpft,nlevcan_ed) ! net leaf photosynthesis (umol CO2/m**2/s) averaged over sun and shade leaves. + real(r8) :: ai ! intermediate co-limited photosynthesis (umol CO2/m**2/s) + + real(r8) :: laican ! canopy sum of lai_z + real(r8) :: vai ! leaf and steam area in ths layer. + integer :: exitloop + real(r8) :: laifrac + real(r8) :: tcsoi ! Temperature response function for root respiration. + real(r8) :: tc ! Temperature response function for wood + + real(r8) :: br ! Base rate of root respiration. (gC/gN/s) + real(r8) :: q10 ! temperature dependence of root respiration + integer :: sunsha ! sun (1) or shaded (2) leaves... + real(r8) :: dr(2) + real(r8) :: coarse_wood_frac ! amount of woody biomass that is coarse... + real(r8) :: tree_area + real(r8) :: gs_cohort + + ! FIX(SPM, 040714) [I]- these should be proper functions... + real(r8) :: ft1 ! photosynthesis temperature response (statement function) + real(r8) :: fth ! photosynthesis temperature inhibition (statement function) + real(r8) :: fth25 ! scaling factor for photosynthesis temperature inhibition (statement function) + ! ... get rid of function statements [I] + + real(r8) dtime ! stepsize in seconds + !------------------------------------------------------------------------------ + + ! + ! FIX(SPM, 040714) [I]- these should be proper functions...Jinyun might be doing this in his refactor...check. + ! + ! Temperature and soil water response functions + ft1(tl,ha) = exp( ha / (rgas*1.e-3_r8*(tfrz+25._r8)) * (1._r8 - (tfrz+25._r8)/tl) ) + fth(tl,hd,se,cc2) = cc2 / ( 1._r8 + exp( (-hd+se*tl) / (rgas*1.e-3_r8*tl) ) ) + fth25(hd,se) = 1._r8 + exp( (-hd+se*(tfrz+25._r8)) / (rgas*1.e-3_r8*(tfrz+25._r8)) ) + ! ... get rid of function statements [I] + + associate( & + c3psn => pftcon%c3psn , & ! photosynthetic pathway: 0. = c4, 1. = c3 + slatop => pftcon%slatop , & ! specific leaf area at top of canopy, projected area basis [m^2/gC] + flnr => pftcon%flnr , & ! fraction of leaf N in the Rubisco enzyme (gN Rubisco / gN leaf) + woody => pftcon%woody , & ! Is vegetation woody or not? + fnitr => pftcon%fnitr , & ! foliage nitrogen limitation factor (-) + leafcn => pftcon%leafcn , & ! leaf C:N (gC/gN) + + bb_slope => EDecophyscon%BB_slope , & ! slope of BB relationship + + forc_pbot => atm2lnd_inst%forc_pbot_downscaled_col , & ! Input: [real(r8) (:) ] atmospheric pressure (Pa) + + t_soisno => temperature_inst%t_soisno_col , & ! Input: [real(r8) (:,:) ] soil temperature (Kelvin) + t_veg => temperature_inst%t_veg_patch , & ! Input: [real(r8) (:) ] vegetation temperature (Kelvin) + tgcm => temperature_inst%thm_patch , & ! Input: [real(r8) (:) ] air temperature at agcm reference height (kelvin) + + psncanopy => photosyns_inst%psncanopy_patch , & ! Output: [real(r8) (:,:) ] canopy scale photosynthesis umol CO2 /m**2/ s + lmrcanopy => photosyns_inst%lmrcanopy_patch , & ! Output: [real(r8) (:,:) ] canopy scale leaf maintenance respiration umol CO2 /m**2/ s + + elai => canopystate_inst%elai_patch , & ! Input: [real(r8) (:) ] one-sided leaf area index with burying by snow + tlai => canopystate_inst%tlai_patch , & ! Input: [real(r8) (:) ] one-sided leaf area index + rscanopy => canopystate_inst%rscanopy_patch , & ! Output: [real(r8) (:,:) ] canopy resistance s/m + gccanopy => canopystate_inst%gccanopy_patch & ! Output: [real(r8) (:,:) ] canopy conductance mmol m-2 s-1 + ) + + !set timestep + dtime = get_step_size() + + ! Assign local pointers to derived type members (gridcell-level) + dr(1) = 0.025_r8; dr(2) = 0.015_r8 + + ! Peter Thornton: 3/13/09 + ! Q10 was originally set to 2.0, an arbitrary choice, but reduced to 1.5 as part of the tuning + ! to improve seasonal cycle of atmospheric CO2 concentration in global + ! simulatoins + q10 = 1.5_r8 + Q10 = EDParamsShareInst%Q10 + + !==============================================================================! + ! Photosynthesis and stomatal conductance parameters, from: + ! Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 + !==============================================================================! + + ! vcmax25 parameters, from CN + + act25 = 3.6_r8 !umol/mgRubisco/min + ! Convert rubisco activity units from umol/mgRubisco/min -> umol/gRubisco/s + act25 = act25 * 1000.0_r8 / 60.0_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 + + kcha = 79430._r8 + koha = 36380._r8 + cpha = 37830._r8 + vcmaxha = 65330._r8 + jmaxha = 43540._r8 + tpuha = 53100._r8 + lmrha = 46390._r8 + + ! 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 + + vcmaxhd = 149250._r8 + jmaxhd = 152040._r8 + tpuhd = 150650._r8 + lmrhd = 150650._r8 + + vcmaxse = 485._r8 + jmaxse = 495._r8 + tpuse = 490._r8 + lmrse = 490._r8 + + vcmaxc = fth25(vcmaxhd, vcmaxse) + jmaxc = fth25(jmaxhd, jmaxse) + tpuc = fth25(tpuhd, tpuse) + lmrc = fth25(lmrhd, lmrse) + + ! Miscellaneous parameters, from Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 + + fnps = 0.15_r8 + theta_psii = 0.7_r8 + theta_ip = 0.95_r8 + + qe(1) = 0._r8 + theta_cj(1) = 0.98_r8 + bbbopt(1) = 10000._r8 + mbbopt(1) = 9._r8 + + qe(2) = 0.05_r8 + theta_cj(2) = 0.80_r8 + bbbopt(2) = 40000._r8 + mbbopt(2) = 4._r8 + + do f = 1,fn + p = filterp(f) + call t_startf('edfluxes') + + ! NOTE: THESE ARE ZEROED EVEN IF THERE'S NO PATCH! + + psncanopy(p) = 0._r8 + lmrcanopy(p) = 0._r8 + rscanopy(p) = 0._r8 + gccanopy(p) = 0._r8 + + if (patch%is_veg(p)) then + g = patch%gridcell(p) + c = patch%column(p) + + currentPatch => map_clmpatch_to_edpatch(ed_allsites_inst(g), p) + + 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 + + currentPatch%nrad = currentPatch%ncan + do CL = 1,nclmax + do ft = 1,numpft_ed + currentPatch%present(CL,ft) = 0 + do iv = 1, currentPatch%nrad(CL,ft); + if(currentPatch%canopy_area_profile(CL,ft,iv) > 0._r8)then + currentPatch%present(CL,ft) = 1 + end if + end do !iv + enddo !ft + enddo !CL + + ! Soil water stress applied to Ball-Berry parameters + do FT = 1,numpft_ed + if (nint(c3psn(FT)) == 1)then + ps = 1 + else + ps = 2 + end if + bbb(FT) = max (bbbopt(ps)*currentPatch%btran_ft(FT), 1._r8) + + mbb(FT) = bb_slope(ft) ! mbbopt(ps) + end do + + ! kc, ko, currentPatch, from: Bernacchi et al (2001) Plant, Cell and Environment 24:253-259 + ! + ! kc25 = 404.9 umol/mol + ! ko25 = 278.4 mmol/mol + ! cp25 = 42.75 umol/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 + ! + + kc25 = (404.9_r8 / 1.e06_r8) * forc_pbot(c) + ko25 = (278.4_r8 / 1.e03_r8) * forc_pbot(c) + sco = 0.5_r8 * 0.209_r8 / (42.75_r8 / 1.e06_r8) + cp25 = 0.5_r8 * oair(p) / sco + + if(t_veg(p).gt.150_r8.and.t_veg(p).lt.350_r8)then + kc(p) = kc25 * ft1(t_veg(p), kcha) + ko(p) = ko25 * ft1(t_veg(p), koha) + co2_cp(p) = cp25 * ft1(t_veg(p), cpha) + else + kc(p) = 1 + ko(p) = 1 + co2_cp(p) = 1 + write(iulog,*) 'something wrong with temperature',t_veg(p),p,elai(p),tlai(p) + end if + + end if + end do + + ! 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 + + + do f = 1,fn + p = filterp(f) + c = patch%column(p) + + if (patch%is_veg(p)) then + g = patch%gridcell(p) + currentPatch => map_clmpatch_to_edpatch(ed_allsites_inst(g), p) + + do FT = 1,numpft_ed + if (nint(c3psn(FT)) == 1)then + ps = 1 + else + ps = 2 + end if + bbb(FT) = max (bbbopt(ps)*currentPatch%btran_ft(FT), 1._r8) + mbb(FT) = mbbopt(ps) + + if (nint(c3psn(FT)) == 1)then + ci(:,FT,:) = 0.7_r8 * cair(p) + else + ci(:,FT,:) = 0.4_r8 * cair(p) + end if + enddo + + NCL_p = currentPatch%NCL_p + + do FT = 1,numpft_ed !calculate patch and pft specific propserties at canopy top. + + ! Leaf nitrogen concentration at the top of the canopy (g N leaf / m**2 leaf) + lnc(FT) = 1._r8 / (slatop(FT) * leafcn(FT)) + + !at the moment in ED we assume that there is no active N cycle. This should change, of course. FIX(RF,032414) Sep2011. + vcmax25top(FT) = fnitr(FT) !fudge - shortcut using fnitr as a proxy for vcmax... + + ! Parameters derived from vcmax25top. Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 + ! used jmax25 = 1.97 vcmax25, from Wullschleger (1993) Journal of Experimental Botany 44:907-920. + ! Here use a factor "1.67", from Medlyn et al (2002) Plant, Cell and Environment 25:1167-1179 + + !RF - copied this from the CLM trunk code, but where did it come from, and how can we make these consistant? + !jmax25top(FT) = (2.59_r8 - 0.035_r8*min(max((t10(p)-tfrz),11._r8),35._r8)) * vcmax25top(FT) + jmax25top(FT) = 0.167_r8 * vcmax25top(FT) + tpu25top(FT) = 0.167_r8 * vcmax25top(FT) + kp25top(FT) = 20000._r8 * vcmax25top(FT) + + + + ! Nitrogen scaling factor. 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 + ! Remove daylength factor from vcmax25 so that kn is based on maximum vcmax25 + + if (dayl_factor(p) == 0._r8) then + kn(FT) = 0._r8 + else + kn(FT) = exp(0.00963_r8 * vcmax25top(FT) - 2.43_r8) + end if + + ! Leaf maintenance respiration to match the base rate used in CN + ! but with the new temperature functions for C3 and C4 plants. + ! + ! Base rate for maintenance respiration is from: + ! M. Ryan, 1991. Effects of climate change on plant respiration. + ! Ecological Applications, 1(2), 157-167. + ! Original expression is br = 0.0106 molC/(molN h) + ! Conversion by molecular weights of C and N gives 2.525e-6 gC/(gN s) + ! + ! Base rate is at 20C. Adjust to 25C using the CN Q10 = 1.5 + ! + ! 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 + + lmr25top(FT) = 2.525e-6_r8 * (1.5_r8 ** ((25._r8 - 20._r8)/10._r8)) + lmr25top(FT) = lmr25top(FT) * lnc(FT) / 12.e-06_r8 + + end do !FT + + !==============================================================================! + ! Calculate Nitrogen scaling factors and photosynthetic parameters. + !==============================================================================! + do CL = 1, NCL_p + do FT = 1,numpft_ed + + do iv = 1, currentPatch%nrad(CL,FT) + if(currentPatch%canopy_area_profile(CL,FT,iv)>0._r8.and.currentPatch%present(CL,FT) /= 1)then + write(iulog,*) 'CF: issue with present structure',CL,FT,iv, & + currentPatch%canopy_area_profile(CL,FT,iv),currentPatch%present(CL,FT), & + currentPatch%nrad(CL,FT),currentPatch%ncl_p,nclmax + currentPatch%present(CL,FT) = 1 + end if + enddo + + if(currentPatch%present(CL,FT) == 1)then ! are there any leaves of this pft in this layer? + + if(CL==NCL_p)then !are we in the top canopy layer or a shaded layer? + laican = 0._r8 + else + laican = sum(currentPatch%canopy_layer_lai(CL+1:NCL_p)) + end if + + ! Loop through canopy layers (above snow). Respiration needs to be + ! calculated every timestep. Others are calculated only if daytime + do iv = 1, currentPatch%nrad(CL,FT) + vai = (currentPatch%elai_profile(CL,FT,iv)+currentPatch%esai_profile(CL,FT,iv)) !vegetation area index. + if (iv == 1) then + laican = laican + 0.5_r8 * vai + else + laican = laican + 0.5_r8 * (currentPatch%elai_profile(CL,FT,iv-1)+ & + currentPatch%esai_profile(CL,FT,iv-1))+vai + end if + + ! Scale for leaf nitrogen profile + nscaler = exp(-kn(FT) * laican) + + + ! Maintenance respiration: umol CO2 / m**2 [leaf] / s + lmr25 = lmr25top(FT) * nscaler + + if (nint(c3psn(FT)) == 1)then + lmr_z(CL,FT,iv) = lmr25 * ft1(t_veg(p), lmrha) * fth(t_veg(p), lmrhd, lmrse, lmrc) + else + lmr_z(CL,FT,iv) = lmr25 * 2._r8**((t_veg(p)-(tfrz+25._r8))/10._r8) + lmr_z(CL,FT,iv) = lmr_z(CL,FT,iv) / (1._r8 + exp( 1.3_r8*(t_veg(p)-(tfrz+55._r8)) )) + end if + + + if (currentPatch%ed_parsun_z(CL,FT,iv) <= 0._r8) then ! night time + vcmax_z(CL,FT,iv) = 0._r8 + jmax_z(CL,FT,iv) = 0._r8 + tpu_z(CL,FT,iv) = 0._r8 + kp_z(CL,FT,iv) = 0._r8 + else ! day time + vcmax25 = vcmax25top(FT) * nscaler + jmax25 = jmax25top(FT) * nscaler + tpu25 = tpu25top(FT) * nscaler + kp25 = kp25top(FT) * nscaler + + ! Adjust for temperature + vcmax_z(CL,FT,iv) = vcmax25 * ft1(t_veg(p), vcmaxha) * fth(t_veg(p), vcmaxhd, vcmaxse, vcmaxc) + jmax_z(CL,FT,iv) = jmax25 * ft1(t_veg(p), jmaxha) * fth(t_veg(p), jmaxhd, jmaxse, jmaxc) + tpu_z(CL,FT,iv) = tpu25 * ft1(t_veg(p), tpuha) * fth(t_veg(p), tpuhd, tpuse, tpuc) + + if (nint(c3psn(FT)) /= 1) then + vcmax_z(CL,FT,iv) = vcmax25 * 2._r8**((t_veg(p)-(tfrz+25._r8))/10._r8) + vcmax_z(CL,FT,iv) = vcmax_z(CL,FT,iv) / (1._r8 + exp( 0.2_r8*((tfrz+15._r8)-t_veg(p)) )) + vcmax_z(CL,FT,iv) = vcmax_z(CL,FT,iv) / (1._r8 + exp( 0.3_r8*(t_veg(p)-(tfrz+40._r8)) )) + end if + kp_z(CL,FT,iv) = kp25 * 2._r8**((t_veg(p)-(tfrz+25._r8))/10._r8) !q10 response of product limited psn. + end if + ! Adjust for soil water:(umol co2/m**2/s) + + vcmax_z(CL,FT,iv) = vcmax_z(CL,FT,iv) * currentPatch%btran_ft(FT) + ! completely removed respiration drought response + ! - (lmr_z(CL,FT,iv) * (1.0_r8-currentPatch%btran_ft(FT)) *pftcon%resp_drought_response(FT)) + lmr_z(CL,FT,iv) = lmr_z(CL,FT,iv) + + end do ! iv + end if !present + enddo !PFT + enddo !CL + + !==============================================================================! + ! Leaf-level photosynthesis and stomatal conductance + !==============================================================================! + + rsmax0 = 2.e4_r8 + + ! Leaf boundary layer conductance, umol/m**2/s + + cf = forc_pbot(c)/(rgas*1.e-3_r8*tgcm(p))*1.e06_r8 + gb = 1._r8/rb(p) + gb_mol = gb * 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 <= esat_tv so that hs <= 1 + + ceair = min( max(eair(p), 0.05_r8*esat_tv(p)), esat_tv(p) ) + ! Loop through canopy layers (above snow). Only do calculations if daytime + do CL = 1, NCL_p + do FT = 1,numpft_ed + if (nint(c3psn(FT)) == 1)then + ps = 1 + else + ps = 2 + end if + if(currentPatch%present(CL,FT) == 1)then ! are there any leaves of this pft in this layer? + do iv = 1, currentPatch%nrad(CL,FT) + if (currentPatch%ed_parsun_z(CL,FT,iv) <= 0._r8) then ! night time + ac = 0._r8 + aj = 0._r8 + ap = 0._r8 + ag(CL,FT,iv) = 0._r8 + an(CL,FT,iv) = ag(CL,FT,iv) - lmr_z(CL,FT,iv) + an_av(cl,ft,iv) = 0._r8 + currentPatch%psn_z(cl,ft,iv) = 0._r8 + rs_z(CL,FT,iv) = min(rsmax0, 1._r8/bbb(FT) * cf) + + + else ! day time + !is there leaf area? - (NV can be larger than 0 with only stem area if deciduous) + if(currentPatch%ed_laisun_z(CL,ft,iv)+currentPatch%ed_laisha_z(cl,ft,iv) > 0._r8)then + !Loop aroun shaded and unshaded leaves + currentPatch%psn_z(CL,ft,iv) = 0._r8 ! psn is accumulated across sun and shaded leaves. + rs_z(CL,FT,iv) = 0._r8 ! 1/rs is accumulated across sun and shaded leaves. + gs_z(CL,FT,iv) = 0._r8 + an_av(CL,FT,iv) = 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((currentPatch%ed_laisun_z(CL,FT,iv) * currentPatch%canopy_area_profile(CL,FT,iv)) > & + 0.0000000001_r8)then + + qabs = currentPatch%ed_parsun_z(CL,FT,iv) / (currentPatch%ed_laisun_z(CL,FT,iv) * & + currentPatch%canopy_area_profile(CL,FT,iv)) + qabs = qabs * 0.5_r8 * (1._r8 - fnps) * 4.6_r8 + + else + qabs = 0.0_r8 + end if + else + + qabs = currentPatch%ed_parsha_z(CL,FT,iv) / (currentPatch%ed_laisha_z(CL,FT,iv) * & + currentPatch%canopy_area_profile(CL,FT,iv)) + qabs = qabs * 0.5_r8 * (1._r8 - fnps) * 4.6_r8 + + end if + + !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_z(cl,ft,iv)) + cquad = qabs * jmax_z(cl,ft,iv) + call quadratic (aquad, bquad, cquad, r1, r2) + je = min(r1,r2) + + ! Iterative loop for ci beginning with initial guess + if (nint(c3psn(FT)) == 1)then + ci(cl,ft,iv) = 0.7_r8 * cair(p) + else + ci(cl,ft,iv) = 0.4_r8 * cair(p) + end if + + niter = 0 + exitloop = 0 + do while(exitloop == 0) + ! Increment iteration counter. Stop if too many iterations + niter = niter + 1 + + ! Save old ci + ciold = ci(cl,ft,iv) + + ! Photosynthesis limitation rate calculations + if (nint(c3psn(FT)) == 1)then + ! C3: Rubisco-limited photosynthesis + ac = vcmax_z(cl,ft,iv) * max(ci(cl,ft,iv)-co2_cp(p), 0._r8) / (ci(cl,ft,iv)+kc(p)* & + (1._r8+oair(p)/ko(p))) + ! C3: RuBP-limited photosynthesis + aj = je * max(ci(cl,ft,iv)-co2_cp(p), 0._r8) / (4._r8*ci(cl,ft,iv)+8._r8*co2_cp(p)) + ! C3: Product-limited photosynthesis + ap = 3._r8 * tpu_z(cl,ft,iv) + else + ! C4: Rubisco-limited photosynthesis + ac = vcmax_z(cl,ft,iv) + ! C4: RuBP-limited photosynthesis + if(sunsha == 1)then !sunlit + if((currentPatch%ed_laisun_z(cl,ft,iv) * currentPatch%canopy_area_profile(cl,ft,iv)) > & + 0.0000000001_r8)then !guard against /0's in the night. + aj = qe(ps) * currentPatch%ed_parsun_z(cl,ft,iv) * 4.6_r8 + !convert from per cohort to per m2 of leaf) + aj = aj / (currentPatch%ed_laisun_z(cl,ft,iv) * & + currentPatch%canopy_area_profile(cl,ft,iv)) + else + aj = 0._r8 + end if + else + aj = qe(ps) * currentPatch%ed_parsha_z(cl,ft,iv) * 4.6_r8 + aj = aj / (currentPatch%ed_laisha_z(cl,ft,iv) * & + currentPatch%canopy_area_profile(cl,ft,iv)) + end if + + ! C4: PEP carboxylase-limited (CO2-limited) + ap = kp_z(cl,ft,iv) * max(ci(cl,ft,iv), 0._r8) / forc_pbot(c) + end if + ! Gross photosynthesis smoothing calculations. First co-limit ac and aj. Then co-limit ap + aquad = theta_cj(ps) + bquad = -(ac + aj) + cquad = ac * aj + call quadratic (aquad, bquad, cquad, r1, r2) + ai = min(r1,r2) + + aquad = theta_ip + bquad = -(ai + ap) + cquad = ai * ap + call quadratic (aquad, bquad, cquad, r1, r2) + ag(cl,ft,iv) = min(r1,r2) + + ! Net carbon assimilation. Exit iteration if an < 0 + an(cl,ft,iv) = ag(cl,ft,iv) - lmr_z(cl,ft,iv) + if (an(cl,ft,iv) < 0._r8) then + exitloop = 1 + end if + + ! Quadratic gs_mol calculation with an known. Valid for an >= 0. + ! With an <= 0, then gs_mol = bbb + + cs = cair(p) - 1.4_r8/gb_mol * an(cl,ft,iv) * forc_pbot(c) + cs = max(cs,1.e-06_r8) + aquad = cs + bquad = cs*(gb_mol - bbb(FT)) - mbb(FT)*an(cl,ft,iv)*forc_pbot(c) + cquad = -gb_mol*(cs*bbb(FT) + mbb(FT)*an(cl,ft,iv)*forc_pbot(c)*ceair/esat_tv(p)) + call quadratic (aquad, bquad, cquad, r1, r2) + gs_mol = max(r1,r2) + + ! Derive new estimate for ci + ci(cl,ft,iv) = cair(p) - an(cl,ft,iv) * forc_pbot(c) * & + (1.4_r8*gs_mol+1.6_r8*gb_mol) / (gb_mol*gs_mol) + + ! Check for ci convergence. Delta ci/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(ci(cl,ft,iv)-ciold)/forc_pbot(c)*1.e06_r8 <= 2.e-06_r8) .or. niter == 5) then + exitloop = 1 + end if + end do !iteration loop + + ! End of ci iteration. Check for an < 0, in which case gs_mol = bbb + if (an(cl,ft,iv) < 0._r8) then + gs_mol = bbb(FT) + end if + + ! Final estimates for cs and ci (needed for early exit of ci iteration when an < 0) + cs = cair(p) - 1.4_r8/gb_mol * an(cl,ft,iv) * forc_pbot(c) + cs = max(cs,1.e-06_r8) + ci(cl,ft,iv) = cair(p) - an(cl,ft,iv) * forc_pbot(c) * (1.4_r8*gs_mol+1.6_r8*gb_mol) / & + (gb_mol*gs_mol) + ! Convert gs_mol (umol H2O/m**2/s) to gs (m/s) and then to rs (s/m) + gs = gs_mol / cf + + !accumulate total photosynthesis umol/m2 ground/s-1. weight per unit sun and sha leaves. + if(sunsha == 1)then !sunlit + + currentPatch%psn_z(cl,ft,iv) = currentPatch%psn_z(cl,ft,iv) + ag(cl,ft,iv) * & + currentPatch%f_sun(cl,ft,iv) + an_av(cl,ft,iv) = an_av(cl,ft,iv) + an(cl,ft,iv) * & + currentPatch%f_sun(cl,ft,iv) + gs_z(cl,ft,iv) = gs_z(cl,ft,iv) + 1._r8/(min(1._r8/gs, rsmax0)) * & + currentPatch%f_sun(cl,ft,iv) + + else + + currentPatch%psn_z(cl,ft,iv) = currentPatch%psn_z(cl,ft,iv) + ag(cl,ft,iv) & + * (1.0_r8-currentPatch%f_sun(cl,ft,iv)) + an_av(cl,ft,iv) = an_av(cl,ft,iv) + an(cl,ft,iv) & + * (1.0_r8-currentPatch%f_sun(cl,ft,iv)) + gs_z(cl,ft,iv) = gs_z(cl,ft,iv) + & + 1._r8/(min(1._r8/gs, rsmax0)) * (1.0_r8-currentPatch%f_sun(cl,ft,iv)) + + end if + + ! Make sure iterative solution is correct + if (gs_mol < 0._r8) then + write (iulog,*)'Negative stomatal conductance:' + write (iulog,*)'p,iv,gs_mol= ',p,iv,gs_mol + call endrun(decomp_index=p, clmlevel=namep, msg=errmsg(__FILE__, __LINE__)) + end if + + ! Compare with Ball-Berry model: gs_mol = m * an * hs/cs p + b + hs = (gb_mol*ceair + gs_mol*esat_tv(p)) / ((gb_mol+gs_mol)*esat_tv(p)) + gs_mol_err = mbb(FT)*max(an(cl,ft,iv), 0._r8)*hs/cs*forc_pbot(c) + bbb(FT) + + if (abs(gs_mol-gs_mol_err) > 1.e-01_r8) then + write (iulog,*) 'CF: Ball-Berry error check - stomatal conductance error:' + write (iulog,*) gs_mol, gs_mol_err + end if + + enddo !sunsha loop + !average leaf-level stomatal resistance rate over sun and shade leaves... + rs_z(cl,ft,iv) = 1._r8/gs_z(cl,ft,iv) + end if !is there leaf area? + end if ! night or day + end do ! iv canopy layer + end if ! present(L,ft) ? rd_array + end do ! PFT loop + end do !canopy layer + + call t_stopf('edfluxes') + call t_startf('edunpack') + + !==============================================================================! + ! Unpack fluxes from arrays into cohorts + !==============================================================================! + + call currentPatch%set_root_fraction() + + if(currentPatch%countcohorts > 0.0)then !avoid errors caused by empty patches + + currentCohort => currentPatch%tallest ! Cohort loop + + do while (associated(currentCohort)) ! Cohort loop + call t_startf('edfluxunpack1') + if(currentCohort%n > 0._r8)then + ! Zero cohort flux accumulators. + currentCohort%npp_clm = 0._r8 + currentCohort%resp_clm = 0._r8 + + ! Select canopy layer and PFT. + FT = currentCohort%pft !are we going to have ftindex? + CL = currentCohort%canopy_layer + !------------------------------------------------------------------------------ + ! Accumulate fluxes over the sub-canopy layers of each cohort. + !------------------------------------------------------------------------------ + ! Convert from umolC/m2leaf/s to umolC/indiv/s ( x canopy area x 1m2 leaf area). + tree_area = currentCohort%c_area/currentCohort%n + if(currentCohort%nv > 1)then + + currentCohort%gpp_clm = sum(currentPatch%psn_z(cl,ft,1:currentCohort%nv-1) * & + currentPatch%elai_profile(cl,ft,1:currentCohort%nv-1)) * tree_area + currentCohort%rd = sum(lmr_z(cl,ft,1:currentCohort%nv-1) * & + currentPatch%elai_profile(cl,ft,1:currentCohort%nv-1)) * tree_area + + currentCohort%gscan = sum((1.0_r8/(rs_z(cl,ft,1:currentCohort%nv-1)+rb(p)))) * tree_area + currentCohort%ts_net_uptake(1:currentCohort%nv) = an_av(cl,ft,1:currentCohort%nv) * 12E-9 * dtime + + else + + currentCohort%gpp_clm = 0.0_r8 + currentCohort%rd = 0._r8 + currentCohort%gscan = 0._r8 + currentCohort%ts_net_uptake(:) = 0._r8 + + end if + + laifrac = (currentCohort%treelai+currentCohort%treesai)-(currentCohort%nv-1)*dinc_ed + + gs_cohort = 1.0_r8/(rs_z(cl,ft,currentCohort%nv)+rb(p))*laifrac*tree_area + currentCohort%gscan = currentCohort%gscan+gs_cohort + + currentCohort%gpp_clm = currentCohort%gpp_clm + currentPatch%psn_z(cl,ft,currentCohort%nv) * & + currentPatch%elai_profile(cl,ft,currentCohort%nv) * laifrac * tree_area + currentCohort%rd = currentCohort%rd + lmr_z(cl,ft,currentCohort%nv) * & + currentPatch%elai_profile(cl,ft,currentCohort%nv) * laifrac * tree_area + + call t_stopf('edfluxunpack1') + call t_startf('edfluxunpack2') + + !------------------------------------------------------------------------------ + ! Calculate Whole Plant Respiration (this doesn't really need to be in this iteration at all, surely?) + ! Leaf respn needs to be in the sub-layer loop to account for changing N through canopy. + ! + ! base rate for maintenance respiration is from: + ! M. Ryan, 1991. Effects of climate change on plant respiration. + ! Ecological Applications, 1(2), 157-167. + ! Original expression is br = 0.0106 molC/(molN h) + ! Conversion by molecular weights of C and N gives 2.525e-6 gC/(gN s) + !------------------------------------------------------------------------------ + + br = 2.525e-6_r8 + + leaf_frac = 1.0_r8/(currentCohort%canopy_trim + EDecophyscon%sapwood_ratio(currentCohort%pft) * & + currentCohort%hite + pftcon%froot_leaf(currentCohort%pft)) + currentCohort%bsw = EDecophyscon%sapwood_ratio(currentCohort%pft) * currentCohort%hite * & + (currentCohort%balive + currentCohort%laimemory)*leaf_frac + currentCohort%livestemn = currentCohort%bsw / pftcon%leafcn(currentCohort%pft) + + currentCohort%livestem_mr = 0._r8 + currentCohort%livecroot_mr = 0._r8 + if (woody(FT) == 1) then + tc = q10**((t_veg(p)-tfrz - 20.0_r8)/10.0_r8) + currentCohort%livestem_mr = currentCohort%livestemn * br * tc !*currentPatch%btran_ft(currentCohort%pft) + currentCohort%livecroot_mr = currentCohort%livecrootn * br * tc !*currentPatch%btran_ft(currentCohort%pft) + + !convert from gC /indiv/s-1 to kgC/indiv/s-1 + currentCohort%livestem_mr = currentCohort%livestem_mr /1000 + currentCohort%livecroot_mr = currentCohort%livecroot_mr /1000 + else + tc = 1.0_r8 + currentCohort%livestem_mr = 0._r8 + currentCohort%livecroot_mr = 0._r8 + end if + + if (pftcon%woody(currentCohort%pft) == 1) then + coarse_wood_frac = 0.5_r8 + else + coarse_wood_frac = 0.0_r8 + end if + + ! Soil temperature. + currentCohort%froot_mr = 0._r8 + + do j = 1,nlevsoi + tcsoi = q10**((t_soisno(c,j)-tfrz - 20.0_r8)/10.0_r8) + !fine root respn. + currentCohort%froot_mr = currentCohort%froot_mr + (1.0_r8 - coarse_wood_frac) * & + currentCohort%br*br*tcsoi * currentPatch%rootfr_ft(ft,j)/leafcn(currentCohort%pft) + ! convert from gC/indiv/s-1 to kgC/indiv/s-1 + currentCohort%froot_mr = currentCohort%froot_mr /1000.0_r8 + enddo + + call t_stopf('edfluxunpack2') + call t_startf('edfluxunpack3') + ! convert gpp and resp from umol/indiv/s-1 to kgC/indiv/s-1 = X * 12 *10-6 * 10-3 + !currentCohort%resp_m = currentCohort%rd * 12.0E-9 + currentCohort%gpp_clm = currentCohort%gpp_clm * 12.0E-9 + ! 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 * (1.0_r8 - currentPatch%btran_ft(currentCohort%pft)*pftcon%resp_drought_response(FT)) + currentCohort%resp_m = currentCohort%resp_m + currentCohort%rd * 12.0E-9 !this was already corrected fo BTRAN + + ! convert from kgC/indiv/s to kgC/indiv/timestep + currentCohort%resp_m = currentCohort%resp_m * dtime + currentCohort%gpp_clm = currentCohort%gpp_clm * dtime + currentCohort%resp_g = ED_val_grperc * (max(0._r8,currentCohort%gpp_clm - currentCohort%resp_m)) + currentCohort%resp_clm = currentCohort%resp_m + currentCohort%resp_g ! kgC/indiv/ts + currentCohort%npp_clm = currentCohort%gpp_clm - currentCohort%resp_clm ! kgC/indiv/ts + + !------------------------------------------------------------------------------ + ! Remove whole plant respiration from net uptake. (kgC/indiv/ts) + if(currentCohort%treelai > 0._r8)then + ! do iv =1,currentCohort%NV + ! currentCohort%year_net_uptake(iv) = currentCohort%year_net_uptake(iv) - & + ! (timestep_secs*(currentCohort%livestem_mr + currentCohort%livecroot_mr & + ! minus contribution to whole plant respn. + ! + currentCohort%froot_mr))/(currentCohort%treelai*currentCohort%c_area/currentCohort%n) + ! enddo + else !lai<0 + currentCohort%gpp_clm = 0._r8 + currentCohort%resp_m = 0._r8 + currentCohort%gscan = 0._r8 + end if + else !pft<0 n<0 + write(iulog,*) 'CF: pft 0 or n 0',currentCohort%pft,currentCohort%n,currentCohort%indexnumber + currentCohort%gpp_clm = 0._r8 + currentCohort%resp_m = 0._r8 + currentCohort%gscan = 0._r8 + currentCohort%ts_net_uptake(1:currentCohort%nv) = 0._r8 + end if !pft<0 n<0 + + psncanopy(p) = psncanopy(p) + currentCohort%gpp_clm + lmrcanopy(p) = lmrcanopy(p) + currentCohort%resp_m + ! accumulate cohort level canopy conductances over whole area before dividing by total area. + gccanopy(p) = gccanopy(p) + currentCohort%gscan * currentCohort%n /currentPatch%total_canopy_area + + currentCohort => currentCohort%shorter + + enddo ! end cohort loop. + end if !count_cohorts is more than zero. + + psncanopy(p) = psncanopy(p) / currentPatch%area + lmrcanopy(p) = lmrcanopy(p) / currentPatch%area + if(gccanopy(p) > 1._r8/rsmax0.and.elai(p) > 0.0_r8)then + rscanopy(p) = (1.0_r8/gccanopy(p))-rb(p)/elai(p) ! this needs to be resistance per unit leaf area. + else + rscanopy(p) = rsmax0 + end if + gccanopy(p) = 1.0_r8/rscanopy(p) *cf /1000 !convert into umol m02 s-1 then mmol m-2 s-1. + + else !EDpatch + + rscanopy(p) = rsmax0 + + end if !edpatch + + call t_stopf('edfluxunpack3') + call t_stopf('edunpack') + + end do !patch loop + + end associate + + end subroutine Photosynthesis_ED + +end module EDPhotosynthesisMod diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 new file mode 100644 index 0000000000..868bd98491 --- /dev/null +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -0,0 +1,940 @@ +module EDSurfaceAlbedoMod + +#include "shr_assert.h" + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Performs surface albedo calculations + ! + ! !PUBLIC TYPES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_log_mod , only : errMsg => shr_log_errMsg + use clm_varpar , only : numrad, nclmax + use decompMod , only : bounds_type + + implicit none + private + ! + ! !PUBLIC MEMBER FUNCTIONS: + public :: ED_Norman_Radiation ! Surface albedo and two-stream fluxes + ! + ! !PUBLIC DATA MEMBERS: + ! The CLM default albice values are too high. + ! Full-spectral albedo for land ice is ~0.5 (Paterson, Physics of Glaciers, 1994, p. 59) + ! This is the value used in CAM3 by Pritchard et al., GRL, 35, 2008. + + real(r8), public :: albice(numrad) = & ! albedo land ice by waveband (1=vis, 2=nir) + (/ 0.80_r8, 0.55_r8 /) + ! + ! !PRIVATE MEMBER FUNCTIONS: + !----------------------------------------------------------------------- + +contains + + !----------------------------------------------------------------------- + subroutine ED_Norman_Radiation (bounds, & + filter_vegsol, num_vegsol, filter_nourbanp, num_nourbanp, & + coszen, ed_allsites_inst, surfalb_inst) + ! + ! !DESCRIPTION: + ! Two-stream fluxes for canopy radiative transfer + ! Use two-stream approximation of Dickinson (1983) Adv Geophysics + ! 25:305-353 and Sellers (1985) Int J Remote Sensing 6:1335-1372 + ! to calculate fluxes absorbed by vegetation, reflected by vegetation, + ! and transmitted through vegetation for unit incoming direct or diffuse + ! flux given an underlying surface with known albedo. + ! Calculate sunlit and shaded fluxes as described by + ! Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 and extended to + ! a multi-layer canopy to calculate APAR profile + ! + ! !USES: + use clm_varctl , only : iulog + use pftconMod , only : pftcon + use EDtypesMod , only : ed_patch_type, numpft_ed, nlevcan_ed + use EDTypesMod , only : ed_site_type, map_clmpatch_to_edpatch + use PatchType , only : patch + use SurfaceAlbedoType , only : surfalb_type + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds ! bounds + integer , intent(in) :: filter_vegsol(:) ! filter for vegetated pfts with coszen>0 + integer , intent(in) :: num_vegsol ! number of vegetated pfts where coszen>0 + integer , intent(in) :: filter_nourbanp(:) ! patch filter for non-urban points + integer , intent(in) :: num_nourbanp ! number of patches in non-urban filter + real(r8) , intent(in) :: coszen( bounds%begp: ) ! cosine solar zenith angle for next time step [pft] + type(ed_site_type) , intent(inout), target :: ed_allsites_inst( bounds%begg: ) + type(surfalb_type) , intent(inout) :: surfalb_inst + ! + ! !LOCAL VARIABLES: + ! ============================================================================ + ! ED/NORMAN RADIATION DECS + ! ============================================================================ + type (ed_patch_type) , pointer :: currentPatch + integer :: radtype, L, ft, g ,j + integer :: iter ! Iteration index + integer :: irep ! Flag to exit iteration loop + real(r8) :: sb + real(r8) :: error ! Error check + real(r8) :: down_rad, up_rad ! Iterative solution do Dif_dn and Dif_up + real(r8) :: ftweight(nclmax,numpft_ed,nlevcan_ed) + real(r8) :: k_dir(numpft_ed) ! Direct beam extinction coefficient + real(r8) :: tr_dir_z(nclmax,numpft_ed,nlevcan_ed) ! Exponential transmittance of direct beam radiation through a single layer + real(r8) :: tr_dif_z(nclmax,numpft_ed,nlevcan_ed) ! Exponential transmittance of diffuse radiation through a single layer + real(r8) :: forc_dir(bounds%begp:bounds%endp,numrad) + real(r8) :: forc_dif(bounds%begp:bounds%endp,numrad) + real(r8) :: weighted_dir_tr(nclmax) + real(r8) :: weighted_fsun(nclmax) + real(r8) :: weighted_dif_ratio(nclmax,numrad) + real(r8) :: weighted_dif_down(nclmax) + real(r8) :: weighted_dif_up(nclmax) + real(r8) :: refl_dif(nclmax,numpft_ed,nlevcan_ed,numrad) ! Term for diffuse radiation reflected by laye + real(r8) :: tran_dif(nclmax,numpft_ed,nlevcan_ed,numrad) ! Term for diffuse radiation transmitted by layer + real(r8) :: dif_ratio(nclmax,numpft_ed,nlevcan_ed,numrad) ! Ratio of upward to forward diffuse fluxes + real(r8) :: Dif_dn(nclmax,numpft_ed,nlevcan_ed) ! Forward diffuse flux onto canopy layer J (W/m**2 ground area) + real(r8) :: Dif_up(nclmax,numpft_ed,nlevcan_ed) ! Upward diffuse flux above canopy layer J (W/m**2 ground area) + real(r8) :: lai_change(nclmax,numpft_ed,nlevcan_ed) ! Forward diffuse flux onto canopy layer J (W/m**2 ground area) + + real(r8) :: f_not_abs(numpft_ed,numrad) ! Fraction reflected + transmitted. 1-absorbtion. + real(r8) :: tolerance + real(r8) :: Abs_dir_z(numpft_ed,nlevcan_ed) + real(r8) :: Abs_dif_z(numpft_ed,nlevcan_ed) + real(r8) :: abs_rad(numrad) !radiation absorbed by soil + real(r8) :: tr_soili ! Radiation transmitted to the soil surface. + real(r8) :: tr_soild ! Radiation transmitted to the soil surface. + real(r8) :: phi1b(bounds%begp:bounds%endp,numpft_ed) ! Radiation transmitted to the soil surface. + real(r8) :: phi2b(bounds%begp:bounds%endp,numpft_ed) + real(r8) :: laisum ! cumulative lai+sai for canopy layer (at middle of layer) + + real(r8) :: angle + real(r8), parameter :: pi = 3.141592654 ! PI + real(r8) :: denom + real(r8) :: lai_reduction(2) + + integer :: fp,p,c,iv ! array indices + integer :: ib ! waveband number + real(r8) :: cosz ! 0.001 <= coszen <= 1.000 + real(r8) :: chil(bounds%begp:bounds%endp) ! -0.4 <= xl <= 0.6 + real(r8) :: gdir(bounds%begp:bounds%endp) ! leaf projection in solar direction (0 to 1) + !----------------------------------------------------------------------- + + ! Enforce expected array sizes + ! What is this about? (FIX(RF,032414)) + SHR_ASSERT_ALL((ubound(coszen) == (/bounds%endp/)), errMsg(__FILE__, __LINE__)) + + associate(& + rhol => pftcon%rhol , & ! Input: [real(r8) (:) ] leaf reflectance: 1=vis, 2=nir + rhos => pftcon%rhos , & ! Input: [real(r8) (:) ] stem reflectance: 1=vis, 2=nir + taul => pftcon%taul , & ! Input: [real(r8) (:) ] leaf transmittance: 1=vis, 2=nir + taus => pftcon%taus , & ! Input: [real(r8) (:) ] stem transmittance: 1=vis, 2=nir + xl => pftcon%xl , & ! Input: [real(r8) (:) ] ecophys const - leaf/stem orientation index + + albgrd => surfalb_inst%albgrd_col , & ! Input: [real(r8) (:,:) ] ground albedo (direct) (column-level) + albgri => surfalb_inst%albgri_col , & ! Input: [real(r8) (:,:) ] ground albedo (diffuse)(column-level) + albd => surfalb_inst%albd_patch , & ! Output: [real(r8) (:,:) ] surface albedo (direct) + albi => surfalb_inst%albi_patch , & ! Output: [real(r8) (:,:) ] surface albedo (diffuse) + fabd => surfalb_inst%fabd_patch , & ! Output: [real(r8) (:,:) ] flux absorbed by canopy per unit direct flux + fabd_sun => surfalb_inst%fabd_sun_patch , & ! Output: [real(r8) (:,:) ] flux absorbed by sunlit canopy per unit direct flux + fabd_sha => surfalb_inst%fabd_sha_patch , & ! Output: [real(r8) (:,:) ] flux absorbed by shaded canopy per unit direct flux + fabi => surfalb_inst%fabi_patch , & ! Output: [real(r8) (:,:) ] flux absorbed by canopy per unit diffuse flux + fabi_sun => surfalb_inst%fabi_sun_patch , & ! Output: [real(r8) (:,:) ] flux absorbed by sunlit canopy per unit diffuse flux + fabi_sha => surfalb_inst%fabi_sha_patch , & ! Output: [real(r8) (:,:) ] flux absorbed by shaded canopy per unit diffuse flux + ftdd => surfalb_inst%ftdd_patch , & ! Output: [real(r8) (:,:) ] down direct flux below canopy per unit direct flx + ftid => surfalb_inst%ftid_patch , & ! Output: [real(r8) (:,:) ] down diffuse flux below canopy per unit direct flx + ftii => surfalb_inst%ftii_patch , & ! Output: [real(r8) (:,:) ] down diffuse flux below canopy per unit diffuse flx + nrad => surfalb_inst%nrad_patch , & ! Input: [integer (:) ] number of canopy layers, above snow for radiative transfer + fabd_sun_z => surfalb_inst%fabd_sun_z_patch , & ! Output: [real(r8) (:,:) ] absorbed sunlit leaf direct PAR (per unit lai+sai) for each canopy layer + fabd_sha_z => surfalb_inst%fabd_sha_z_patch , & ! Output: [real(r8) (:,:) ] absorbed shaded leaf direct PAR (per unit lai+sai) for each canopy layer + fabi_sun_z => surfalb_inst%fabi_sun_z_patch , & ! Output: [real(r8) (:,:) ] absorbed sunlit leaf diffuse PAR (per unit lai+sai) for each canopy layer + fabi_sha_z => surfalb_inst%fabi_sha_z_patch , & ! Output: [real(r8) (:,:) ] absorbed shaded leaf diffuse PAR (per unit lai+sai) for each canopy layer + fsun_z => surfalb_inst%fsun_z_patch & ! Output: [real(r8) (:,:) ] sunlit fraction of canopy layer + ) + + + + ! 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 + + do fp = 1,num_nourbanp + p = filter_nourbanp(fp) + if (patch%is_veg(p)) then + g = patch%gridcell(p) + currentPatch => map_clmpatch_to_edpatch(ed_allsites_inst(g), p) + 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 + end if + end do + + !================================================================ + ! NORMAN RADIATION CODE + ! ============================================================================ + ! FIX(SPM,032414) refactor this...too long for one routine. + tolerance = 0.000000001_r8 ! FIX(SPM,032414) make this a param + + do fp = 1,num_vegsol + p = filter_vegsol(fp) + c = patch%column(p) + g = patch%gridcell(p) + + weighted_dir_tr(:) = 0._r8 + weighted_dif_down(:) = 0._r8 + weighted_dif_up(:) = 0._r8 + albd(p,:) = 0._r8 + albi(p,:) = 0._r8 + fabi(p,:) = 0._r8 + fabd(p,:) = 0._r8 + tr_dir_z(:,:,:) = 0._r8 + tr_dif_z(:,:,:) = 0._r8 + ftweight(:,:,:) = 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 + ftdd(p,:) = 1._r8 + ftid(p,:) = 1._r8 + ftii(p,:) = 1._r8 + + if (patch%is_veg(p)) then ! We have vegetation... + + currentPatch => map_clmpatch_to_edpatch(ed_allsites_inst(g), p) + + if (associated(currentPatch))then + !zero all of the matrices used here to reduce potential for errors. + 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 + + if (maxval(currentPatch%nrad(1,:))==0)then + !there are no leaf layers in this patch. it is effectively bare ground. + ! no radiation is absorbed + fabd(p,:) = 0.0_r8 + fabi(p,:) = 0.0_r8 + do ib = 1,numrad + albd(p,ib) = albgrd(c,ib) + albd(p,ib) = albgri(c,ib) + ftdd(p,ib)= 1.0_r8 + ftid(p,ib)= 1.0_r8 + ftii(p,ib)= 1.0_r8 + enddo + else + + ! Is this pft/canopy layer combination present in this patch? + do L = 1,nclmax + do ft = 1,numpft_ed + currentPatch%present(L,ft) = 0 + do iv = 1, currentPatch%nrad(L,ft) + if (currentPatch%canopy_area_profile(L,ft,iv) > 0._r8)then + currentPatch%present(L,ft) = 1 + !I think 'present' is only used here... + endif + end do !iv + end do !ft + end do !L + g = currentPatch%siteptr%clmgcell + + do radtype = 1,2 !do this once for one unit of diffuse, and once for one unit of direct radiation + do ib = 1,numrad + if (radtype == 1) then + ! Set the hypothetical driving radiation. We do this once for a single unit of direct and + ! once for a single unit of diffuse radiation. + forc_dir(p,ib) = 1.00_r8 + forc_dif(p,ib) = 0.00_r8 + else !dif + forc_dir(p,ib) = 0.00_r8 + forc_dif(p,ib) = 1.00_r8 + end if + end do !ib + + !Extract information that needs to be provided by ED into local array. + ftweight(:,:,:) = 0._r8 + do L = 1,currentPatch%NCL_p + do ft = 1,numpft_ed + 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(iulog,*) 'canopy not full',ftweight(1,:,1) + endif + if (sum(ftweight(1,:,1))>1.0001_r8)then + write(iulog,*) 'canopy too full',ftweight(1,:,1) + endif + + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! Direct beam extinction coefficient, k_dir. PFT specific. + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + cosz = max(0.001_r8, coszen(p)) !copied from previous radiation code... + do ft = 1,numpft_ed + sb = (90._r8 - (acos(cosz)*180/pi)) * (pi / 180._r8) + chil(p) = xl(ft) !min(max(xl(ft), -0.4_r8), 0.6_r8 ) + if (abs(chil(p)) <= 0.01_r8) then + chil = 0.01_r8 + end if + phi1b(p,ft) = 0.5_r8 - 0.633_r8*chil(p) - 0.330_r8*chil(p)*chil(p) + phi2b(p,ft) = 0.877_r8 * (1._r8 - 2._r8*phi1b(p,ft)) !0 = horiz leaves, 1 - vert leaves. + gdir(p) = phi1b(p,ft) + phi2b(p,ft) * sin(sb) + !how much direct light penetrates a singleunit of lai? + k_dir(ft) = gdir(p) / sin(sb) + end do !FT + + 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:numrad) = 0._r8 + !Each canopy layer (canopy, understorey) has multiple 'parallel' pft's + do ft =1,numpft_ed + if (currentPatch%present(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 + (j - 1) * 10._r8) * 3.142 / 180._r8 + gdir(p) = phi1b(p,ft) + phi2b(p,ft) * sin(angle) !This line is redundant FIX(RF,032414). + tr_dif_z(L,ft,iv) = tr_dif_z(L,ft,iv) + exp(-gdir(p) / 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.00*pi/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(iulog,*) '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_ed + if (currentPatch%present(L,ft) == 1)then + !==============================================================================! + ! Iterative solution do scattering + !==============================================================================! + + do ib = 1,numrad !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) = albgri(c,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!numrad + endif ! currentPatch%present + end do!ft + end do!L + + do ib = 1,numrad + 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_ed + if (currentPatch%present(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(p,ib) + 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_ed + if (currentPatch%present(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) =albgri(c,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-sum(ftweight(L,:,1))) * & + weighted_dif_down(L-1) * albgri(c,ib) + !direct to diffuse + weighted_dif_up(L) = weighted_dif_up(L) + forc_dir(p,ib) * & + weighted_dir_tr(L-1) * (1.0-sum(ftweight(L,:,1)))*albgrd(c,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_ed + if (currentPatch%present(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(p,ib) + 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(p,ib) * 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-sum(ftweight(L,:,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_ed + if (currentPatch%present(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) *albgri(c,ib) + & + forc_dir(p,ib) * tr_dir_z(L,ft,iv) *albgrd(c,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(p,ib) * 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))) * & + weighted_dif_down(L-1) * albgri(c,ib) + weighted_dif_up(L) = weighted_dif_up(L) + forc_dir(p,ib) * & + weighted_dir_tr(L-1) * (1.0_r8-sum(ftweight(L,:,1)))*albgrd(c,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_ed + if (currentPatch%present(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(p,ib) * 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 -albgri(c,ib)) + Abs_dir_z(ft,iv) = ftweight(L,ft,1)*forc_dir(p,ib) * & + tr_dir_z(L,ft,iv) * (1.0_r8 -albgrd(c,ib)) + tr_soild = tr_soild + ftweight(L,ft,1)*forc_dir(p,ib) * 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? + do iv = 1, currentPatch%nrad(L,ft) + if (radtype==1)then + 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) + end if + end do + + !==============================================================================! + ! 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 == 1)then + currentPatch%fabd(ib) = currentPatch%fabd(ib) + Abs_dir_z(ft,iv)+Abs_dif_z(ft,iv) + ! fabd(p,ib) = currentPatch%fabd(ib) + else + currentPatch%fabi(ib) = currentPatch%fabi(ib) + Abs_dif_z(ft,iv) + ! fabi(p,ib) = currentPatch%fabi(ib) + endif + end do + ! Albefor + if (L==1)then !top canopy layer. + if (radtype == 1)then + albd(p,ib) = albd(p,ib) + Dif_up(L,ft,1) * ftweight(L,ft,1) + else + albi(p,ib) = albi(p,ib) + Dif_up(L,ft,1) * ftweight(L,ft,1) + end if + end if + end if ! present + end do !ft + if (radtype == 1)then + fabd(p,ib) = currentPatch%fabd(ib) + else + fabi(p,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)))*(1.0_r8-albgri(c,ib)) + abs_rad(ib) = abs_rad(ib) + forc_dir(p,ib) * weighted_dir_tr(L-1) * & + (1.0_r8-sum(ftweight(L,:,1)))*(1.0_r8-albgrd(c,ib)) + tr_soili = tr_soili + weighted_dif_down(L-1) * (1.0_r8-sum(ftweight(L,:,1))) + tr_soild = tr_soild + forc_dir(p,ib) * weighted_dir_tr(L-1) * (1.0_r8-sum(ftweight(L,:,1))) + endif + + if (radtype == 1)then + currentPatch%tr_soil_dir(ib) = tr_soild + currentPatch%tr_soil_dir_dif(ib) = tr_soili + currentPatch%sabs_dir(ib) = abs_rad(ib) + ftdd(p,ib) = tr_soild + ftid(p,ib) = tr_soili + else + currentPatch%tr_soil_dif(ib) = tr_soili + currentPatch%sabs_dif(ib) = abs_rad(ib) + ftii(p,ib) = tr_soili + end if + + end do!l + + + !==============================================================================! + ! Conservation check + !==============================================================================! + ! Total radiation balance: absorbed = incoming - outgoing + + if (radtype == 1)then + error = abs(currentPatch%sabs_dir(ib)-(currentPatch%tr_soil_dir(ib)*(1.0_r8-albgrd(c,ib))+ & + currentPatch%tr_soil_dir_dif(ib)*(1.0_r8-albgri(c,ib)))) + if ( abs(error) > 0.0001)then + write(iulog,*)'dir ground absorption error',p,g,error,currentPatch%sabs_dir(ib), & + currentPatch%tr_soil_dir(ib)* & + (1.0_r8-albgrd(c,ib)),currentPatch%NCL_p,ib,sum(ftweight(1,:,1)) + write(iulog,*) 'albedos',currentPatch%sabs_dir(ib) ,currentPatch%tr_soil_dir(ib), & + (1.0_r8-albgrd(c,ib)),currentPatch%lai + + do ft =1,3 + iv = currentPatch%nrad(1,ft) + 1 + write(iulog,*) '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-albgri(c,ib)))) > 0.0001)then + write(iulog,*)'dif ground absorption error',p,g,currentPatch%sabs_dif(ib) , & + (currentPatch%tr_soil_dif(ib)* & + (1.0_r8-albgri(c,ib))),currentPatch%NCL_p,ib,sum(ftweight(1,:,1)) + endif + endif + + if (radtype == 1)then + error = (forc_dir(p,ib) + forc_dif(p,ib)) - (fabd(p,ib) + albd(p,ib) + currentPatch%sabs_dir(ib)) + else + error = (forc_dir(p,ib) + forc_dif(p,ib)) - (fabi(p,ib) + albi(p,ib) + currentPatch%sabs_dif(ib)) + endif + lai_reduction(:) = 0.0_r8 + do L = 1, currentPatch%NCL_p + do ft =1,numpft_ed + if (currentPatch%present(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 (lai_change(1,2,1).gt.0.0.and.lai_change(1,2,2).gt.0.0)then + write(iulog,*) 'lai_change(1,2,12)',lai_change(1,2,1:4) + endif + if (lai_change(1,2,2).gt.0.0.and.lai_change(1,2,3).gt.0.0)then + write(iulog,*) ' lai_change (1,2,23)',lai_change(1,2,1:4) + endif + if (lai_change(1,1,3).gt.0.0.and.lai_change(1,1,2).gt.0.0)then + ! write(iulog,*) 'first layer of lai_change 2 3',lai_change(1,1,1:3) + endif + if (lai_change(1,1,3).gt.0.0.and.lai_change(1,1,4).gt.0.0)then + ! write(iulog,*) 'first layer of lai_change 3 4',lai_change(1,1,1:4) + endif + if (lai_change(1,1,4).gt.0.0.and.lai_change(1,1,5).gt.0.0)then + ! write(iulog,*) 'first layer of lai_change 4 5',lai_change(1,1,1:5) + endif + + + + if (radtype == 1)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 + ! write(iulog,*) 'Dir error',error,fabd(p,ib),& + ! albd(p,ib),currentPatch%sabs_dir(ib) + ! write(iulog,*) 'elai',pps%elai(p),pps%tlai(p), currentPatch%NCL_p,currentPatch%nrad(1:2,1:2) + albd(p,ib) = albd(p,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(iulog,*) 'Large Dir Radn consvn error',error ,p,ib + write(iulog,*) 'diags',albd(p,ib),ftdd(p,ib),ftid(p,ib),fabd(p,ib) + write(iulog,*) 'lai_change',lai_change(currentpatch%ncl_p,1:2,1:4) + write(iulog,*) 'elai',currentpatch%elai_profile(currentpatch%ncl_p,1:2,1:4) + write(iulog,*) 'esai',currentpatch%esai_profile(currentpatch%ncl_p,1:2,1:4) + write(iulog,*) 'ftweight',ftweight(1,1:2,1:4) + write(iulog,*) 'cp',currentPatch%area, currentPatch%patchno + write(iulog,*) 'albgrd(c,ib)',albgrd(c,ib) + + ! albd(p,ib) = albd(p,ib) + error + end if + else + + if (abs(error) > 1.e-9_r8 .and. abs(error) < 0.15_r8)then + ! write(iulog,*) 'Dif error',error,fabi(p,ib),& + ! albi(p,ib),currentPatch%sabs_dif(ib) + albi(p,ib) = albi(p,ib) + error + end if + if (abs(error) > 0.15_r8)then + write(iulog,*) '>5% Dif Radn consvn error',error ,p,ib + write(iulog,*) 'diags',albi(p,ib),ftii(p,ib),fabi(p,ib) + write(iulog,*) 'lai_change',lai_change(currentpatch%ncl_p,1:2,1:4) + write(iulog,*) 'elai',currentpatch%elai_profile(currentpatch%ncl_p,1:2,1:4) + write(iulog,*) 'esai',currentpatch%esai_profile(currentpatch%ncl_p,1:2,1:4) + write(iulog,*) 'ftweight',ftweight(currentpatch%ncl_p,1:2,1:4) + write(iulog,*) 'cp',currentPatch%area, currentPatch%patchno + write(iulog,*) 'albgri(c,ib)',albgri(c,ib) + write(iulog,*) 'rhol',rhol(1:2,:) + write(iulog,*) 'ftw',sum(ftweight(1,:,1)),ftweight(1,1:2,1) + write(iulog,*) 'present',currentPatch%present(1,1:2) + write(iulog,*) 'CAP',currentPatch%canopy_area_profile(1,1:2,1) + + + ! albi(p,ib) = albi(p,ib) + error + end if + + + if (radtype == 1)then + error = (forc_dir(p,ib) + forc_dif(p,ib)) - (fabd(p,ib) + albd(p,ib) + currentPatch%sabs_dir(ib)) + else + error = (forc_dir(p,ib) + forc_dif(p,ib)) - (fabi(p,ib) + albi(p,ib) + currentPatch%sabs_dif(ib)) + endif + if (abs(error) > 0.00000001_r8)then + write(iulog,*) 'there is still error after correction',error ,p,ib + end if + + end if + + end do !numrad + + enddo ! rad-type + + endif ! is there vegetation? + endif !associated + endif ! EDPATCH + enddo ! loop over fp and indirection to p + + end associate +end subroutine ED_Norman_Radiation + +end module EDSurfaceAlbedoMod diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 new file mode 100755 index 0000000000..60194c1735 --- /dev/null +++ b/fire/SFMainMod.F90 @@ -0,0 +1,936 @@ +module SFMainMod + + ! ============================================================================ + ! All subroutines realted to the SPITFIRE fire routine. + ! Code originally developed by Allan Spessa & Rosie Fisher as part of the NERC-QUEST project. + ! ============================================================================ + + use shr_kind_mod , only : r8 => shr_kind_r8; + use spmdMod , only : masterproc + use clm_varctl , only : iulog + use atm2lndType , only : atm2lnd_type + use TemperatureType , only : temperature_type + use pftconMod , only : pftcon + use EDEcophysconType , only : EDecophyscon + use EDtypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type, AREA, DG_SF, FIRE_THRESHOLD + use EDtypesMod , only : LB_SF, LG_SF, NCWD, TR_SF + + implicit none + private + + public :: fire_model + public :: fire_danger_index + public :: charecteristics_of_fuel + public :: rate_of_spread + public :: ground_fuel_consumption + public :: fire_intensity + public :: wind_effect + public :: area_burnt + public :: crown_scorching + public :: crown_damage + public :: cambial_damage_kill + public :: post_fire_mortality + + integer :: write_SF = 0 ! for debugging + logical :: DEBUG = .false. ! for debugging + + ! ============================================================================ + ! ============================================================================ + +contains + + ! ============================================================================ + ! Area of site burned by fire + ! ============================================================================ + subroutine fire_model( currentSite, atm2lnd_inst, temperature_inst) + + use clm_varctl, only : use_ed_spit_fire + + type(ed_site_type) , intent(inout), target :: currentSite + type(atm2lnd_type) , intent(in) :: atm2lnd_inst + type(temperature_type) , intent(in) :: temperature_inst + + type (ed_patch_type), pointer :: currentPatch + + integer temporary_SF_switch + + !zero fire things + currentPatch => currentSite%youngest_patch + temporary_SF_switch = 0 + do while(associated(currentPatch)) + currentPatch%frac_burnt = 0.0_r8 + currentPatch%AB = 0.0_r8 + currentPatch%fire = 0 + currentPatch => currentPatch%older + enddo + + if(write_SF==1)then + write(iulog,*) 'use_ed_spit_fire',use_ed_spit_fire + endif + + if(use_ed_spit_fire.and.temporary_SF_switch==1)then + call fire_danger_index(currentSite, temperature_inst, atm2lnd_inst) + call wind_effect(currentSite, atm2lnd_inst) + call charecteristics_of_fuel(currentSite) + call rate_of_spread(currentSite) + call ground_fuel_consumption(currentSite) + call fire_intensity(currentSite) + call area_burnt(currentSite) + call crown_scorching(currentSite) + call crown_damage(currentSite) + call cambial_damage_kill(currentSite) + call post_fire_mortality(currentSite) + end if + + end subroutine fire_model + + !***************************************************************** + subroutine fire_danger_index ( currentSite, temperature_inst, atm2lnd_inst) + + !***************************************************************** + ! currentSite%acc_NI is the accumulated Nesterov fire danger index + + use clm_varcon , only : tfrz + + use SFParamsMod, only : SF_val_fdi_a, SF_val_fdi_b + + type(ed_site_type) , intent(inout), target :: currentSite + type(temperature_type) , intent(in) :: temperature_inst + type(atm2lnd_type) , intent(in) :: atm2lnd_inst + + real(r8) :: temp_in_C ! daily averaged temperature in celcius + real(r8) :: rainfall ! daily precip + real(r8) :: rh ! daily rh + + real yipsolon; !intermediate varable for dewpoint calculation + real dewpoint; !dewpoint in K + real d_NI; !daily change in Nesterov Index. C^2 + + associate( & + t_veg24 => temperature_inst%t_veg24_patch , & ! Input: [real(r8) (:)] avg pft vegetation temperature for last 24 hrs + + prec24 => atm2lnd_inst%prec24_patch , & ! Input: [real(r8) (:)] avg pft rainfall for last 24 hrs + rh24 => atm2lnd_inst%rh24_patch & ! Input: [real(r8) (:)] avg pft relative humidity for last 24 hrs + ) + + ! NOTE: t_veg24(:), prec24(:) and rh24(:) are p level temperatures, precipitation and RH, + ! which probably won't have much inpact, unless we decide to ever calculated the NI for each patch. + + temp_in_C = t_veg24(currentSite%oldest_patch%clm_pno) - tfrz + rainfall = prec24(currentSite%oldest_patch%clm_pno) *24.0_r8*3600._r8 + rh = rh24(currentSite%oldest_patch%clm_pno) + + if (rainfall > 3.0_r8) then !rezero NI if it rains... + d_NI = 0.0_r8 + currentSite%acc_NI = 0.0_r8 + else + yipsolon = (SF_val_fdi_a* temp_in_C)/(SF_val_fdi_b+ temp_in_C)+log(rh/100.0_r8) + dewpoint = (SF_val_fdi_b*yipsolon)/(SF_val_fdi_a-yipsolon) !Standard met. formula + d_NI = ( temp_in_C-dewpoint)* temp_in_C !follows Nesterov 1968. Equation 5. Thonicke et al. 2010. + if (d_NI < 0.0_r8) then !Change in NI cannot be negative. + d_NI = 0.0_r8 !check + endif + endif + currentSite%acc_NI = currentSite%acc_NI + d_NI !Accumulate Nesterov index over the fire season. + + end associate + + end subroutine fire_danger_index + + + !***************************************************************** + subroutine charecteristics_of_fuel ( currentSite ) + !***************************************************************** + + use SFParamsMod, only : SF_val_alpha_FMC, SF_val_SAV, SF_val_FBD + + type(ed_site_type), intent(in), target :: currentSite + + type(ed_patch_type), pointer :: currentPatch + type(ed_cohort_type), pointer :: currentCohort + + real(r8) timeav_swc + real(r8) fuel_moisture(ncwd+2) ! Scaled moisture content of small litter fuels. + real(r8) MEF(ncwd+2) ! Moisture extinction factor of fuels integer n + + fuel_moisture(:) = 0.0_r8 + + currentPatch => currentSite%oldest_patch; + do while(associated(currentPatch)) + ! How much live grass is there? + currentPatch%livegrass = 0.0_r8 + currentCohort => currentPatch%tallest + do while(associated(currentCohort)) + if(pftcon%woody(currentCohort%pft) == 0)then + currentPatch%livegrass = currentPatch%livegrass + currentCohort%bl*currentCohort%n/currentPatch%area + endif + currentCohort => currentCohort%shorter + enddo + + ! There are SIX fuel classes + ! 1) Leaf litter, 2:5) four CWD_AG pools (twig, s branch, l branch, trunk) and 6) live grass + ! NCWD =4 + ! dg_sf = 1, lb_sf, = 4, tr_sf = 5, lg_sf = 6, + + ! zero fire arrays. + currentPatch%fuel_eff_moist = 0.0_r8 + currentPatch%fuel_bulkd = 0.0_r8 + currentPatch%fuel_sav = 0.0_r8 + currentPatch%fuel_frac(:) = 0.0_r8 + currentPatch%fuel_mef = 0.0_r8 + currentPatch%sum_fuel = 0.0_r8 + currentPatch%fuel_frac = 0.0_r8 + + if(write_sf == 1)then + if (masterproc) write(iulog,*) ' leaf_litter1 ',currentPatch%leaf_litter + if (masterproc) write(iulog,*) ' leaf_litter2 ',sum(currentPatch%CWD_AG) + if (masterproc) write(iulog,*) ' leaf_litter3 ',currentPatch%livegrass + if (masterproc) write(iulog,*) ' sum fuel', currentPatch%sum_fuel + endif + + currentPatch%sum_fuel = sum(currentPatch%leaf_litter) + sum(currentPatch%CWD_AG) + currentPatch%livegrass + if(write_SF == 1)then + if (masterproc) write(iulog,*) 'sum fuel', currentPatch%sum_fuel,currentPatch%area + endif + ! =============================================== + ! Average moisture, bulk density, surface area-volume and moisture extinction of fuel + ! ================================================ + + if (currentPatch%sum_fuel > 0.0) then + ! Fraction of fuel in litter classes + currentPatch%fuel_frac(dg_sf) = sum(currentPatch%leaf_litter)/ currentPatch%sum_fuel + currentPatch%fuel_frac(dg_sf+1:tr_sf) = currentPatch%CWD_AG / currentPatch%sum_fuel + + if(write_sf == 1)then + if (masterproc) write(iulog,*) 'ff1 ',currentPatch%fuel_frac + if (masterproc) write(iulog,*) 'ff2 ',currentPatch%fuel_frac + if (masterproc) write(iulog,*) 'ff2a ',lg_sf,currentPatch%livegrass,currentPatch%sum_fuel + endif + + currentPatch%fuel_frac(lg_sf) = currentPatch%livegrass / currentPatch%sum_fuel + MEF(1:ncwd+2) = 0.524_r8 - 0.066_r8 * log10(SF_val_SAV(1:ncwd+2)) + + !Equation 6 in Thonicke et al. 2010. + fuel_moisture(dg_sf+1:tr_sf) = exp(-1.0_r8 * SF_val_alpha_FMC(dg_sf+1:tr_sf) * currentSite%acc_NI) + if(write_SF == 1)then + if (masterproc) write(iulog,*) 'ff3 ',currentPatch%fuel_frac + if (masterproc) write(iulog,*) 'fm ',fuel_moisture + if (masterproc) write(iulog,*) 'csa ',currentSite%acc_NI + if (masterproc) write(iulog,*) 'sfv ',SF_val_alpha_FMC + endif + ! FIX(RF,032414): needs refactoring. + ! average water content !is this the correct metric? + timeav_swc = sum(currentSite%water_memory(1:10)) / 10._r8 + ! Equation B2 in Thonicke et al. 2010 + fuel_moisture(dg_sf) = max(0.0_r8, 10.0_r8/9._r8 * timeav_swc - 1.0_r8/9.0_r8) + + ! Average properties over the first four litter pools (dead leaves, twigs, s branches, l branches) + currentPatch%fuel_bulkd = sum(currentPatch%fuel_frac(dg_sf:lb_sf) * SF_val_FBD(dg_sf:lb_sf)) + currentPatch%fuel_sav = sum(currentPatch%fuel_frac(dg_sf:lb_sf) * SF_val_SAV(dg_sf:lb_sf)) + currentPatch%fuel_mef = sum(currentPatch%fuel_frac(dg_sf:lb_sf) * MEF(dg_sf:lb_sf)) + currentPatch%fuel_eff_moist = sum(currentPatch%fuel_frac(dg_sf:lb_sf) * fuel_moisture(dg_sf:lb_sf)) + if(write_sf == 1)then + if (masterproc) write(iulog,*) 'ff4 ',currentPatch%fuel_eff_moist + endif + ! Add on properties of live grass multiplied by grass fraction. (6) + currentPatch%fuel_bulkd = currentPatch%fuel_bulkd + currentPatch%fuel_frac(lg_sf) * SF_val_FBD(lg_sf) + currentPatch%fuel_sav = currentPatch%fuel_sav + currentPatch%fuel_frac(lg_sf) * SF_val_SAV(lg_sf) + currentPatch%fuel_mef = currentPatch%fuel_mef + currentPatch%fuel_frac(lg_sf) * MEF(lg_sf) + currentPatch%fuel_eff_moist = currentPatch%fuel_eff_moist + currentPatch%fuel_frac(lg_sf) * fuel_moisture(lg_sf) + + ! Correct averaging for the fact that we are not using the trunks pool (5) + currentPatch%fuel_bulkd = currentPatch%fuel_bulkd * (1.0_r8/(1.0_r8-currentPatch%fuel_frac(tr_sf))) + currentPatch%fuel_sav = currentPatch%fuel_sav * (1.0_r8/(1.0_r8-currentPatch%fuel_frac(tr_sf))) + currentPatch%fuel_mef = currentPatch%fuel_mef * (1.0_r8/(1.0_r8-currentPatch%fuel_frac(tr_sf))) + currentPatch%fuel_eff_moist = currentPatch%fuel_eff_moist * (1.0_r8/(1.0_r8-currentPatch%fuel_frac(tr_sf))) + + ! Convert from biomass to carbon. Which variables is this needed for? + currentPatch%fuel_bulkd = currentPatch%fuel_bulkd * 0.45_r8 + + ! Pass litter moisture into the fuel burning routine + ! (wo/me term in Thonicke et al. 2010) + currentPatch%litter_moisture(dg_sf:lb_sf) = fuel_moisture(dg_sf:lb_sf)/MEF(dg_sf:lb_sf) + currentPatch%litter_moisture(tr_sf) = 0.0_r8 + currentPatch%litter_moisture(lg_sf) = fuel_moisture(lg_sf)/MEF(lg_sf) + + else + + if(write_SF == 1)then + + if (masterproc) write(iulog,*) 'no litter fuel at all',currentPatch%patchno, & + currentPatch%sum_fuel,sum(currentPatch%cwd_ag), & + sum(currentPatch%cwd_bg),sum(currentPatch%leaf_litter) + + endif + currentPatch%fuel_sav = sum(SF_val_SAV(1:ncwd+2))/(ncwd+2) ! make average sav to avoid crashing code. + + if (masterproc) write(iulog,*) 'problem with spitfire fuel averaging' + + ! FIX(SPM,032414) refactor...should not have 0 fuel unless everything is burnt + ! off. + currentPatch%fuel_eff_moist = 0.0000000001_r8 + currentPatch%fuel_bulkd = 0.0000000001_r8 + currentPatch%fuel_frac(:) = 0.0000000001_r8 + currentPatch%fuel_mef = 0.0000000001_r8 + currentPatch%sum_fuel = 0.0000000001_r8 + currentPatch%fuel_frac = 0.0000000001_r8 + + endif + ! check values. + ! FIX(SPM,032414) refactor... + if(write_SF == 1.and.currentPatch%fuel_sav <= 0.0_r8.or.currentPatch%fuel_bulkd <= & + 0.0_r8.or.currentPatch%fuel_mef <= 0.0_r8.or.currentPatch%fuel_eff_moist <= 0.0_r8)then + if (masterproc) write(iulog,*) 'problem with spitfire fuel averaging' + endif + + currentPatch => currentPatch%younger + + enddo !end patch loop + + end subroutine charecteristics_of_fuel + + + !***************************************************************** + subroutine wind_effect ( currentSite, atm2lnd_inst) + !*****************************************************************. + + ! Routine called daily from within ED within a site loop. + ! Calculates the effective windspeed based on vegetation charecteristics. + + type(ed_site_type) , intent(inout), target :: currentSite + type(atm2lnd_type) , intent(in) :: atm2lnd_inst + + type(ed_patch_type) , pointer :: currentPatch + type(ed_cohort_type), pointer :: currentCohort + + ! note - this is a p level temperature, which probably won't have much inpact, + ! unless we decide to ever calculated the NI for each patch. + real(r8), pointer :: wind24(:) + + real(r8) :: wind ! daily wind + real(r8) :: total_grass_area ! per patch,in m2 + real(r8) :: tree_fraction ! site level. no units + real(r8) :: grass_fraction ! site level. no units + real(r8) :: bare_fraction ! site level. no units + + wind24 => atm2lnd_inst%wind24_patch ! Input: [real(r8) (:)] avg pft windspeed (m/s) + + wind = wind24(currentSite%oldest_patch%clm_pno) * 60._r8 ! Convert to m/min for SPITFIRE units. + if(write_SF == 1)then + if (masterproc) write(iulog,*) 'wind24', wind24(currentSite%oldest_patch%clm_pno) + endif + ! --- influence of wind speed, corrected for surface roughness---- + ! --- averaged over the whole grid cell to prevent extreme divergence + ! average_wspeed = 0.0_r8 + tree_fraction = 0.0_r8 + grass_fraction = 0.0_r8 + currentPatch=>currentSite%oldest_patch; + do while(associated(currentPatch)) + currentPatch%total_tree_area = 0.0_r8 + total_grass_area = 0.0_r8 + currentCohort => currentPatch%tallest + + do while(associated(currentCohort)) + write(iulog,*) 'SF currentCohort%c_area ',currentCohort%c_area + if(pftcon%woody(currentCohort%pft) == 1)then + currentPatch%total_tree_area = currentPatch%total_tree_area + currentCohort%c_area + else + total_grass_area = total_grass_area + currentCohort%c_area + endif + currentCohort => currentCohort%shorter + enddo + tree_fraction = tree_fraction + min(currentPatch%area,currentPatch%total_tree_area)/AREA + grass_fraction = grass_fraction + min(currentPatch%area,total_grass_area)/AREA + + if(DEBUG)then + !write(iulog,*) 'SF currentPatch%area ',currentPatch%area + !write(iulog,*) 'SF currentPatch%total_area ',currentPatch%total_tree_area + !write(iulog,*) 'SF total_grass_area ',tree_fraction,grass_fraction + !write(iulog,*) 'SF AREA ',AREA + endif + + currentPatch => currentPatch%younger + enddo !currentPatch loop + + !if there is a cover of more than one, then the grasses are under the trees + grass_fraction = min(grass_fraction,1.0_r8-tree_fraction) + bare_fraction = 1.0 - tree_fraction - grass_fraction + if(write_sf == 1)then + if (masterproc) write(iulog,*) 'grass, trees, bare',grass_fraction, tree_fraction, bare_fraction + endif + + currentPatch=>currentSite%oldest_patch; + + do while(associated(currentPatch)) + currentPatch%total_tree_area = min(currentPatch%total_tree_area,currentPatch%area) + currentPatch%effect_wspeed = wind * (tree_fraction*0.6+grass_fraction*0.4+bare_fraction*1.0) + + currentPatch => currentPatch%younger + enddo !end patch loop + + end subroutine wind_effect + + !***************************************************************** + subroutine rate_of_spread ( currentSite ) + !*****************************************************************. + !Routine called daily from within ED within a site loop. + !Returns the updated currentPatch%ROS_front value for each patch. + + use SFParamsMod, only : SF_val_miner_total, SF_val_part_dens, & + SF_val_miner_damp, SF_val_fuel_energy + + type(ed_site_type), intent(in), target :: currentSite + + type(ed_patch_type), pointer :: currentPatch + + real(r8) dummy + + ! Rothermal fire spread model parameters. + real(r8) beta + real(r8) ir !reaction intensity + real(r8) xi,eps,q_ig,phi_wind + real(r8) gamma_aptr,gamma_max + real(r8) moist_damp,mw_weight + real(r8) bet,beta_op + real(r8) a,b,c,e + + currentPatch=>currentSite%oldest_patch; + + do while(associated(currentPatch)) + + ! ---initialise parameters to zero.--- + bet = 0.0_r8; q_ig = 0.0_r8; eps = 0.0_r8; a = 0.0_r8; b = 0.0_r8; c = 0.0_r8; e = 0.0_r8 + phi_wind = 0.0_r8; xi = 0.0_r8; gamma_max = 0.0_r8; gamma_aptr = 0.0_r8; mw_weight = 0.0_r8 + moist_damp = 0.0_r8; ir = 0.0_r8; dummy = 0.0_r8; + currentPatch%ROS_front = 0.0_r8 + currentPatch%sum_fuel = currentPatch%sum_fuel * (1.0_r8 - SF_val_miner_total) !net of minerals + + ! ----start spreading--- + if (masterproc.and.DEBUG) write(iulog,*) 'SF - currentPatch%fuel_bulkd ',currentPatch%fuel_bulkd + if (masterproc.and.DEBUG) write(iulog,*) 'SF - SF_val_part_dens ',SF_val_part_dens + + beta = (currentPatch%fuel_bulkd / 0.45_r8) / SF_val_part_dens + + ! Equation A6 in Thonicke et al. 2010 + beta_op = 0.200395_r8 *(currentPatch%fuel_sav**(-0.8189_r8)) + if (masterproc.and.DEBUG) write(iulog,*) 'SF - beta ',beta + if (masterproc.and.DEBUG) write(iulog,*) 'SF - beta_op ',beta_op + bet = beta/beta_op + if(write_sf == 1)then + if (masterproc) write(iulog,*) 'esf ',currentPatch%fuel_eff_moist + endif + ! ---heat of pre-ignition--- + ! Equation A4 in Thonicke et al. 2010 + q_ig = 581.0_r8 +2594.0_r8 * currentPatch%fuel_eff_moist + + ! ---effective heating number--- + ! Equation A3 in Thonicke et al. 2010. + eps = exp(-4.528_r8 / currentPatch%fuel_sav) + ! Equation A7 in Thonicke et al. 2010 + b = 0.15988_r8 * (currentPatch%fuel_sav**0.54_r8) + ! Equation A8 in Thonicke et al. 2010 + c = 7.47_r8 * (exp(-0.8711_r8 * (currentPatch%fuel_sav**0.55_r8))) + ! Equation A9 in Thonicke et al. 2010. + e = 0.715_r8 * (exp(-0.01094_r8 * currentPatch%fuel_sav)) + ! Equation A5 in Thonicke et al. 2010 + + if (DEBUG) then + if (masterproc.and.DEBUG) write(iulog,*) 'SF - c ',c + if (masterproc.and.DEBUG) write(iulog,*) 'SF - currentPatch%effect_wspeed ',currentPatch%effect_wspeed + if (masterproc.and.DEBUG) write(iulog,*) 'SF - b ',b + if (masterproc.and.DEBUG) write(iulog,*) 'SF - bet ',bet + if (masterproc.and.DEBUG) write(iulog,*) 'SF - e ',e + endif + + ! convert from m/min to ft/min for Rothermel ROS eqn + phi_wind = c * ((3.281_r8*currentPatch%effect_wspeed)**b)*(bet**(-e)) + + ! ---propagating flux---- + ! Equation A2 in Thonicke et al. + + xi = (exp((0.792_r8 + 3.7597_r8 * (currentPatch%fuel_sav**0.5_r8)) * (beta+0.1_r8))) / & + (192_r8+7.9095_r8 * currentPatch%fuel_sav) + + ! ---reaction intensity---- + ! Equation in table A1 Thonicke et al. 2010. + a = 8.9033_r8 * (currentPatch%fuel_sav**(-0.7913_r8)) + dummy = exp(a*(1-bet)) + ! Equation in table A1 Thonicke et al. 2010. + gamma_max = 1.0_r8 / (0.0591_r8 + 2.926_r8* (currentPatch%fuel_sav**(-1.5_r8))) + gamma_aptr = gamma_max*(bet**a)*dummy + + mw_weight = currentPatch%fuel_eff_moist/currentPatch%fuel_mef + + ! Equation in table A1 Thonicke et al. 2010. + moist_damp = max(0.0_r8,(1.0_r8 - (2.59_r8 * mw_weight) + (5.11_r8 * (mw_weight**2.0_r8)) - & + (3.52_r8*(mw_weight**3.0_r8)))) + + ! FIX(SPM, 040114) ask RF if this should be an endrun + ! if(write_SF == 1)then + ! write(iulog,*) 'moist_damp' ,moist_damp,mw_weight,currentPatch%fuel_eff_moist,currentPatch%fuel_mef + ! endif + + ir = gamma_aptr*(currentPatch%sum_fuel/0.45_r8)*SF_val_fuel_energy*moist_damp*SF_val_miner_damp + ! currentPatch%sum_fuel needs to be converted from kgC/m2 to kgBiomass/m2 + ! write(iulog,*) 'ir',gamma_aptr,moist_damp,SF_val_fuel_energy,SF_val_miner_damp + if (((currentPatch%fuel_bulkd/0.45_r8) <= 0.0_r8).or.(eps <= 0.0_r8).or.(q_ig <= 0.0_r8)) then + currentPatch%ROS_front = 0.0_r8 + else ! Equation 9. Thonicke et al. 2010. + currentPatch%ROS_front = (ir*xi*(1.0_r8+phi_wind)) / (currentPatch%fuel_bulkd/0.45_r8*eps*q_ig) + ! write(iulog,*) 'ROS',currentPatch%ROS_front,phi_wind,currentPatch%effect_wspeed + ! write(iulog,*) 'ros calcs',currentPatch%fuel_bulkd,ir,xi,eps,q_ig + endif + ! Equation 10 in Thonicke et al. 2010 + ! Can FBP System in m/min + currentPatch%ROS_back = currentPatch%ROS_front*exp(-0.012_r8*currentPatch%effect_wspeed) + + currentPatch => currentPatch%younger + + enddo !end patch loop + + end subroutine rate_of_spread + + !***************************************************************** + subroutine ground_fuel_consumption ( currentSite ) + !***************************************************************** + !returns the the hypothetic fuel consumed by the fire + + use SFParamsMod, only : SF_val_miner_total, SF_val_min_moisture, & + SF_val_mid_moisture, SF_val_low_moisture_C, SF_val_low_moisture_S, & + SF_val_mid_moisture_C, SF_val_mid_moisture_S + + type(ed_site_type) , intent(in), target :: currentSite + + type(ed_patch_type), pointer :: currentPatch + + real(r8) :: moist !effective fuel moisture + real(r8) :: tau_b(ncwd+2) !lethal heating rates for each fuel class (min) + real(r8) :: fc_ground(ncwd+2) !propn of fuel consumed + + integer :: c + + currentPatch => currentSite%oldest_patch; + + do while(associated(currentPatch)) + currentPatch%burnt_frac_litter = 1.0_r8 + ! Calculate fraction of litter is burnt for all classes. + ! Equation B1 in Thonicke et al. 2010--- + do c = 1, ncwd+2 !work out the burnt fraction for all pools, even if those pools dont exist. + moist = currentPatch%litter_moisture(c) + ! 1. Very dry litter + if (moist <= SF_val_min_moisture(c)) then + currentPatch%burnt_frac_litter(c) = 1.0_r8 + endif + ! 2. Low to medium moistures + if (moist > SF_val_min_moisture(c).and.moist <= SF_val_mid_moisture(c)) then + currentPatch%burnt_frac_litter(c) = max(0.0_r8,min(1.0_r8,SF_val_low_moisture_C(c)- & + SF_val_low_moisture_S(c)*moist)) + else + ! For medium to high moistures. + if (moist > SF_val_mid_moisture(c).and.moist <= 1.0_r8) then + currentPatch%burnt_frac_litter(c) = max(0.0_r8,min(1.0_r8,SF_val_mid_moisture_C(c)- & + SF_val_mid_moisture_S(c)*moist)) + endif + + endif + ! Very wet litter + if (moist >= 1.0_r8) then !this shouldn't happen? + currentPatch%burnt_frac_litter(c) = 0.0_r8 + endif + enddo !c + + ! we can't ever kill -all- of the grass. + currentPatch%burnt_frac_litter(lg_sf) = min(0.8_r8,currentPatch%burnt_frac_litter(lg_sf )) + ! reduce burnt amount for mineral content. + currentPatch%burnt_frac_litter = currentPatch%burnt_frac_litter * (1.0_r8-SF_val_miner_total) + + !---Calculate amount of fuel burnt.--- + FC_ground(dg_sf) = currentPatch%burnt_frac_litter(dg_sf) * sum(currentPatch%leaf_litter) + FC_ground(2:tr_sf) = currentPatch%burnt_frac_litter(2:tr_sf) * currentPatch%CWD_AG + FC_ground(lg_sf) = currentPatch%burnt_frac_litter(lg_sf) * currentPatch%livegrass + + ! Following used for determination of cambial kill follows from Peterson & Ryan (1986) scheme + ! less empirical cf current scheme used in SPITFIRE which attempts to mesh Rothermel + ! and P&R, and while solving potential inconsistencies, actually results in BIG values for + ! fire residence time, thus lots of vegetation death! + ! taul is the duration of the lethal heating. + ! The /10 is to convert from kgC/m2 into gC/cm2, as in the Peterson and Ryan paper #Rosie,Jun 2013 + + do c = 1,ncwd+2 + tau_b(c) = 39.4_r8 *(currentPatch%fuel_frac(c)*currentPatch%sum_fuel/0.45_r8/10._r8)* & + (1.0_r8-((1.0_r8-currentPatch%burnt_frac_litter(c))**0.5_r8)) + enddo + tau_b(tr_sf) = 0.0_r8 + ! Cap the residence time to 8mins, as suggested by literature survey by P&R (1986). + currentPatch%tau_l = min(8.0_r8,sum(tau_b)) + + !---calculate overall fuel consumed by spreading fire --- + ! ignore 1000hr fuels. Just interested in fuels affecting ROS + currentPatch%TFC_ROS = sum(FC_ground)-FC_ground(tr_sf) + + currentPatch=>currentPatch%younger; + enddo !end patch loop + + end subroutine ground_fuel_consumption + + !***************************************************************** + subroutine fire_intensity ( currentSite ) + !***************************************************************** + !returns the updated currentPatch%FI value for each patch. + + !currentPatch%FI average fire intensity of flaming front during day. Backward ROS plays no role here. kJ/m/s or kW/m. + !currentPatch%ROS_front forward ROS (m/min) + !currentPatch%TFC_ROS total fuel consumed by flaming front (kgC/m2) + + use clm_varctl, only : use_ed_spit_fire + use SFParamsMod, only : SF_val_fdi_alpha,SF_val_fuel_energy, & + SF_val_max_durat, SF_val_durat_slope + + type(ed_site_type), intent(in), target :: currentSite + + type(ed_patch_type), pointer :: currentPatch + + real(r8) ROS !m/s + real(r8) W ! kgBiomass/m2 + real(r8) :: d_fdi !change in the NI on this day to give fire duration. + + currentPatch => currentSite%oldest_patch; + + do while(associated(currentPatch)) + ROS = currentPatch%ROS_front / 60.0_r8 !m/min to m/sec + W = currentPatch%TFC_ROS / 0.45_r8 !kgC/m2 to kgbiomass/m2 + currentPatch%FI = SF_val_fuel_energy * W * ROS !kj/m/s, or kW/m + if(write_sf == 1)then + if(masterproc) write(iulog,*) 'fire_intensity',currentPatch%fi,W,currentPatch%ROS_front + endif + !'decide_fire' subroutine shortened and put in here... + if (currentPatch%FI >= fire_threshold) then ! 50kW/m is the threshold for a self-sustaining fire + currentPatch%fire = 1 ! Fire... :D + + ! This is like but not identical to equation 7 in Thonicke et al. 2010. WHY? + d_FDI = 1.0_r8 - exp(-SF_val_fdi_alpha*currentSite%acc_NI) !follows Venevsky et al GCB 2002 + ! Equation 14 in Thonicke et al. 2010 + currentPatch%FD = SF_val_max_durat / (1.0_r8 + SF_val_max_durat * exp(SF_val_durat_slope*d_FDI)) + if(write_SF == 1)then + if (masterproc) write(iulog,*) 'fire duration minutes',currentPatch%fd + endif + !equation 15 in Arora and Boer CTEM model.Average fire is 1 day long. + !currentPatch%FD = 60.0_r8 * 24.0_r8 !no minutes in a day + else + currentPatch%fire = 0 ! No fire... :-/ + currentPatch%FD = 0.0_r8 + endif + ! FIX(SPM,032414) needs a refactor + ! FIX(RF,032414) : should happen outside of SF loop - doing all spitfire code is inefficient otherwise. + if(.not. use_ed_spit_fire)then + currentPatch%fire = 0 !fudge to turn fire off + endif + + currentPatch => currentPatch%younger; + enddo !end patch loop + + end subroutine fire_intensity + + + !***************************************************************** + subroutine area_burnt ( currentSite ) + !***************************************************************** + !currentPatch%AB daily area burnt (m2) + !currentPatch%NF !Daily number of ignitions (lightning and human-caused), adjusted for size of patch. + + use domainMod, only : ldomain + use EDParamsMod, only : ED_val_nfires + + type(ed_site_type), intent(inout), target :: currentSite + + type(ed_patch_type), pointer :: currentPatch + + real lb !length to breadth ratio of fire ellipse + real df !distance fire has travelled forward + real db !distance fire has travelled backward + real(r8) gridarea + real(r8) size_of_fire + integer g + + currentSite%frac_burnt = 0.0_r8 + + currentPatch => currentSite%oldest_patch; + do while(associated(currentPatch)) + currentPatch%AB = 0.0_r8 + currentPatch%frac_burnt = 0.0_r8 + lb = 0.0_r8; db = 0.0_r8; df = 0.0_r8 + + if (currentPatch%fire == 1) then + ! The feedback between vegetation structure and ellipse size if turned off for now, + ! to reduce the positive feedback in the syste, + ! This will also be investigated by William Hoffmans proposal. + ! if (currentPatch%effect_wspeed < 16.67_r8) then !16.67m/min = 1km/hr + lb = 1.0_r8 + ! else + !FIX(RF,032414) FOR NO GRASS + ! lb = currentPatch%total_canopy_area/currentPatch%area*(1.0_r8)+(8.729_r8 * & + ! ((1.0_r8 -(exp(-0.03_r8 * 0.06_r8 * currentPatch%effect_wspeed)))**2.155_r8)) !& + !& +currentPatch%fpc_grass*(1.1_r8+((0.06_r8*currentPatch%effect_wspeed)**0.0464)) + + ! endif + + ! if (lb > 8.0_r8)then + ! lb = 8.0_r8 !Constraint Canadian Fire Behaviour System + ! endif + ! ---- calculate length of major axis--- + db = currentPatch%ROS_back * currentPatch%FD !m + df = currentPatch%ROS_front * currentPatch%FD !m + + ! --- calculate area burnt--- + if(lb > 0.0_r8) then + g = currentSite%clmgcell + gridarea = ldomain%area(g) *1000000.0_r8 !convert from km2 into m2 + currentPatch%NF = ldomain%area(g) * ED_val_nfires * currentPatch%area/area /365 + ! If there are 15 lightening strickes per year, per km2. (approx from NASA product) + ! then there are 15/365 s/km2 each day. + + ! Equation 1 in Thonicke et al. 2010 + ! To Do: Connect here with the Li & Levis GDP fire suppression algorithm. + ! Equation 16 in arora and boer model. + !currentPatch%ab = currentPatch%ab *3.0_r8 + size_of_fire = ((3.1416_r8/(4.0_r8*lb))*((df+db)**2.0_r8)) + currentPatch%AB = size_of_fire * currentPatch%nf + if (currentPatch%AB > gridarea*currentPatch%area/area) then !all of patch burnt. + + if (masterproc) write(iulog,*) 'burnt all of patch',currentPatch%patchno, & + currentPatch%area/area,currentPatch%ab,currentPatch%area/area*gridarea + if (masterproc) write(iulog,*) 'ros',currentPatch%ROS_front,currentPatch%FD, & + currentPatch%NF,currentPatch%FI,size_of_fire + + if (masterproc) write(iulog,*) 'litter',currentPatch%sum_fuel,currentPatch%CWD_AG,currentPatch%leaf_litter + ! turn km2 into m2. work out total area burnt. + currentPatch%AB = currentPatch%area * gridarea/AREA + endif + currentPatch%frac_burnt = currentPatch%AB / (gridarea*currentPatch%area/area) + if(write_SF == 1)then + if (masterproc) write(iulog,*) 'frac_burnt',currentPatch%frac_burnt + endif + endif + endif! fire + currentSite%frac_burnt = currentSite%frac_burnt + currentPatch%frac_burnt + + currentPatch => currentPatch%younger; + + enddo !end patch loop + + end subroutine area_burnt + + !***************************************************************** + subroutine crown_scorching ( currentSite ) + !***************************************************************** + !currentPatch%SH !average scorch height for the patch(m) + !currentPatch%FI average fire intensity of flaming front during day. kW/m. + + use SFParamsMod, only : SF_val_alpha_SH + use EDParamsMod, only : ED_val_ag_biomass + + type(ed_site_type), intent(in), target :: currentSite + + type(ed_patch_type), pointer :: currentPatch + type(ed_cohort_type), pointer :: currentCohort + + real f_ag_bmass !fraction of a tree cohort's above-ground biomass as a proportion of total patch ag tree biomass. + real tree_ag_biomass !total amount of above-ground tree biomass in patch. kgC/m2 + + currentPatch => currentSite%oldest_patch; + do while(associated(currentPatch)) + + tree_ag_biomass = 0.0_r8 + f_ag_bmass = 0.0_r8 + if (currentPatch%fire == 1) then + currentCohort => currentPatch%tallest; + do while(associated(currentCohort)) + if (pftcon%woody(currentCohort%pft) == 1) then !trees only + tree_ag_biomass = tree_ag_biomass+(currentCohort%bl+ED_val_ag_biomass* & + (currentCohort%bsw + currentCohort%bdead))*currentCohort%n + endif !trees only + + currentCohort=>currentCohort%shorter; + + enddo !end cohort loop + + !This loop weights the scorch height for the contribution of each cohort to the overall biomass. + currentPatch%SH = 0.0_r8 + currentCohort => currentPatch%tallest; + do while(associated(currentCohort)) + if (pftcon%woody(currentCohort%pft) == 1.and.(tree_ag_biomass > 0.0_r8)) then !trees only + f_ag_bmass = ((currentCohort%bl+ED_val_ag_biomass*(currentCohort%bsw + & + currentCohort%bdead))*currentCohort%n)/tree_ag_biomass + !equation 16 in Thonicke et al. 2010 + if(write_SF == 1)then + if (masterproc) write(iulog,*) 'currentPatch%SH',currentPatch%SH,f_ag_bmass + endif + !2/3 Byram (1959) + currentPatch%SH = currentPatch%SH + f_ag_bmass * SF_val_alpha_SH * (currentPatch%FI**0.667_r8) + endif !trees only + currentCohort=>currentCohort%shorter; + enddo !end cohort loop + endif !fire + + currentPatch => currentPatch%younger; + enddo !end patch loop + + end subroutine crown_scorching + + !***************************************************************** + subroutine crown_damage ( currentSite ) + !***************************************************************** + + !returns the updated currentCohort%cfa value for each tree cohort within each patch. + !currentCohort%cfa proportion of crown affected by fire + + type(ed_site_type), intent(in), target :: currentSite + + type(ed_patch_type) , pointer :: currentPatch + type(ed_cohort_type), pointer :: currentCohort + + currentPatch => currentSite%oldest_patch + + do while(associated(currentPatch)) + if (currentPatch%fire == 1) then + + currentCohort=>currentPatch%tallest + + do while(associated(currentCohort)) + currentCohort%cfa = 0.0_r8 + if (pftcon%woody(currentCohort%pft) == 1) then !trees only + ! Flames lower than bottom of canopy. + ! c%hite is height of cohort + if (currentPatch%SH < (currentCohort%hite-currentCohort%hite*EDecophyscon%crown(currentCohort%pft))) then + currentCohort%cfa = 0.0_r8 + else + ! Flames part of way up canopy. + ! Equation 17 in Thonicke et al. 2010. + ! flames over bottom of canopy but not over top. + if ((currentCohort%hite > 0.0_r8).and.(currentPatch%SH >= & + (currentCohort%hite-currentCohort%hite*EDecophyscon%crown(currentCohort%pft)))) then + + currentCohort%cfa = (currentPatch%SH-currentCohort%hite* & + EDecophyscon%crown(currentCohort%pft))/(currentCohort%hite-currentCohort%hite* & + EDecophyscon%crown(currentCohort%pft)) + + else + ! Flames over top of canopy. + currentCohort%cfa = 1.0_r8 + endif + + endif + ! Check for strange values. + currentCohort%cfa = min(1.0_r8, max(0.0_r8,currentCohort%cfa)) + endif !trees only + !shrink canopy to account for burnt section. + !currentCohort%canopy_trim = min(currentCohort%canopy_trim,(1.0_r8-currentCohort%cfa)) + + currentCohort => currentCohort%shorter; + + enddo !end cohort loop + endif !fire? + + currentPatch => currentPatch%younger; + + enddo !end patch loop + + end subroutine crown_damage + + !***************************************************************** + subroutine cambial_damage_kill ( currentSite ) + !***************************************************************** + ! routine description. + ! returns the probability that trees dies due to cambial char + ! currentPatch%tau_l = duration of lethal stem heating (min). Calculated at patch level. + + type(ed_site_type), intent(in), target :: currentSite + + type(ed_patch_type) , pointer :: currentPatch + type(ed_cohort_type), pointer :: currentCohort + + real(r8) :: tau_c !critical time taken to kill cambium (minutes) + real(r8) :: bt !bark thickness in cm. + + currentPatch => currentSite%oldest_patch; + + do while(associated(currentPatch)) + + if (currentPatch%fire == 1) then + currentCohort => currentPatch%tallest; + do while(associated(currentCohort)) + if (pftcon%woody(currentCohort%pft) == 1) then !trees only + ! Equation 21 in Thonicke et al 2010 + bt = EDecophyscon%bark_scaler(currentCohort%pft)*currentCohort%dbh ! bark thickness. + ! Equation 20 in Thonicke et al. 2010. + tau_c = 2.9_r8*bt**2.0_r8 !calculate time it takes to kill cambium (min) + ! Equation 19 in Thonicke et al. 2010 + if ((currentPatch%tau_l/tau_c) >= 2.0_r8) then + currentCohort%cambial_mort = 1.0_r8 + else + if ((currentPatch%tau_l/tau_c) > 0.22_r8) then + currentCohort%cambial_mort = (0.563_r8*(currentPatch%tau_l/tau_c)) - 0.125_r8 + else + currentCohort%cambial_mort = 0.0_r8 + endif + endif + endif !trees + + currentCohort => currentCohort%shorter; + + enddo !end cohort loop + endif !fire? + + currentPatch=>currentPatch%younger; + + enddo !end patch loop + + end subroutine cambial_damage_kill + + !***************************************************************** + subroutine post_fire_mortality ( currentSite ) + !***************************************************************** + + ! returns the updated currentCohort%fire_mort value for each tree cohort within each patch. + ! currentCohort%cfa proportion of crown affected by fire + ! currentCohort%crownfire_mort probability of tree post-fire mortality due to crown scorch + ! currentCohort%cambial_mort probability of tree post-fire mortality due to cambial char + ! currentCohort%fire_mort post-fire mortality from cambial and crown damage assuming two are independent. + + type(ed_site_type), intent(in), target :: currentSite + + type(ed_patch_type), pointer :: currentPatch + type(ed_cohort_type), pointer :: currentCohort + + currentPatch => currentSite%oldest_patch + + do while(associated(currentPatch)) + + if (currentPatch%fire == 1) then + currentCohort => currentPatch%tallest + do while(associated(currentCohort)) + currentCohort%fire_mort = 0.0_r8 + currentCohort%crownfire_mort = 0.0_r8 + if (pftcon%woody(currentCohort%pft) == 1) then + ! Equation 22 in Thonicke et al. 2010. + currentCohort%crownfire_mort = EDecophyscon%crown_kill(currentCohort%pft)*currentCohort%cfa**3.0_r8 + ! Equation 18 in Thonicke et al. 2010. + currentCohort%fire_mort = currentCohort%crownfire_mort+currentCohort%cambial_mort- & + (currentCohort%crownfire_mort*currentCohort%cambial_mort) !joint prob. + else + currentCohort%fire_mort = 0.0_r8 !I have changed this to zero and made the mode of death removal of leaves... + endif !trees + + currentCohort => currentCohort%shorter + + enddo !end cohort loop + endif !fire? + + currentPatch => currentPatch%younger + + enddo !end patch loop + + end subroutine post_fire_mortality + + ! ============================================================================ +end module SFMainMod diff --git a/fire/SFParamsMod.F90 b/fire/SFParamsMod.F90 new file mode 100644 index 0000000000..3caa526a01 --- /dev/null +++ b/fire/SFParamsMod.F90 @@ -0,0 +1,212 @@ +module SFParamsMod + ! + ! module that deals with reading the SF parameter file + ! + use shr_kind_mod , only: r8 => shr_kind_r8 + use EDtypesMod , only: NLSC,NFSC,NCWD + + implicit none + save + ! private - if we allow this module to be private, it does not allow the protected values below to be + ! seen outside of this module. + + ! + ! this is what the user can use for the actual values + ! + real(r8),protected :: SF_val_fdi_a + real(r8),protected :: SF_val_fdi_b + real(r8),protected :: SF_val_fdi_alpha + real(r8),protected :: SF_val_miner_total + real(r8),protected :: SF_val_fuel_energy + real(r8),protected :: SF_val_part_dens + real(r8),protected :: SF_val_miner_damp + real(r8),protected :: SF_val_max_durat + real(r8),protected :: SF_val_durat_slope + real(r8),protected :: SF_val_alpha_SH + real(r8),protected :: SF_val_alpha_FMC(NLSC) + real(r8),protected :: SF_val_CWD_frac(NCWD) + real(r8),protected :: SF_val_max_decomp(NLSC) + real(r8),protected :: SF_val_SAV(NFSC) + real(r8),protected :: SF_val_FBD(NFSC) + real(r8),protected :: SF_val_min_moisture(NFSC) + real(r8),protected :: SF_val_mid_moisture(NFSC) + real(r8),protected :: SF_val_low_moisture_C(NFSC) + real(r8),protected :: SF_val_low_moisture_S(NFSC) + real(r8),protected :: SF_val_mid_moisture_C(NFSC) + real(r8),protected :: SF_val_mid_moisture_S(NFSC) + + character(len=20),parameter :: SF_name_fdi_a = "fdi_a" + character(len=20),parameter :: SF_name_fdi_b = "fdi_b" + character(len=20),parameter :: SF_name_fdi_alpha = "fdi_alpha" + character(len=20),parameter :: SF_name_miner_total = "miner_total" + character(len=20),parameter :: SF_name_fuel_energy = "fuel_energy" + character(len=20),parameter :: SF_name_part_dens = "part_dens" + character(len=20),parameter :: SF_name_miner_damp = "miner_damp" + character(len=20),parameter :: SF_name_max_durat = "max_durat" + character(len=20),parameter :: SF_name_durat_slope = "durat_slope" + character(len=20),parameter :: SF_name_alpha_SH = "alpha_SH" + character(len=20),parameter :: SF_name_alpha_FMC = "alpha_FMC" + character(len=20),parameter :: SF_name_CWD_frac = "CWD_frac" + character(len=20),parameter :: SF_name_max_decomp = "max_decomp" + character(len=20),parameter :: SF_name_SAV = "SAV" + character(len=20),parameter :: SF_name_FBD = "FBD" + character(len=20),parameter :: SF_name_min_moisture = "min_moisture" + character(len=20),parameter :: SF_name_mid_moisture = "mid_moisture" + character(len=20),parameter :: SF_name_low_moisture_C = "low_moisture_C" + character(len=20),parameter :: SF_name_low_moisture_S = "low_moisture_S" + character(len=20),parameter :: SF_name_mid_moisture_C = "mid_moisture_C" + character(len=20),parameter :: SF_name_mid_moisture_S = "mid_moisture_S" + + public :: SFParamsRead + +contains + !----------------------------------------------------------------------- + ! + !----------------------------------------------------------------------- + subroutine SFParamsRead(ncid) + ! + ! calls to initialize parameter instance and do ncdio read + ! + use ncdio_pio , only : file_desc_t + + implicit none + + ! arguments + type(file_desc_t),intent(inout) :: ncid ! pio netCDF file id + + call SFParamsReadLocal(ncid) + + end subroutine SFParamsRead + !----------------------------------------------------------------------- + + !----------------------------------------------------------------------- + ! + !----------------------------------------------------------------------- + subroutine SFParamsReadLocal(ncid) + ! + ! read the netcdf file and populate internalInstScalar + ! + use ncdio_pio , only : file_desc_t + use paramUtilMod , only : readNcdio + + implicit none + + ! arguments + type(file_desc_t),intent(inout) :: ncid ! pio netCDF file id + + ! local vars + character(len=32) :: subname = 'SFParamsReadLocal::' + + ! + ! call read function + ! + + call readNcdio(ncid = ncid, & + varName=SF_name_fdi_a, & + callingName=subname, & + retVal=SF_val_fdi_a) + + call readNcdio(ncid = ncid, & + varName=SF_name_fdi_b, & + callingName=subname, & + retVal=SF_val_fdi_b) + + call readNcdio(ncid = ncid, & + varName=SF_name_fdi_alpha, & + callingName=subname, & + retVal=SF_val_fdi_alpha) + + call readNcdio(ncid = ncid, & + varName=SF_name_miner_total, & + callingName=subname, & + retVal=SF_val_miner_total) + + call readNcdio(ncid = ncid, & + varName=SF_name_fuel_energy, & + callingName=subname, & + retVal=SF_val_fuel_energy) + + call readNcdio(ncid = ncid, & + varName=SF_name_part_dens, & + callingName=subname, & + retVal=SF_val_part_dens) + + call readNcdio(ncid = ncid, & + varName=SF_name_miner_damp, & + callingName=subname, & + retVal=SF_val_miner_damp) + + call readNcdio(ncid = ncid, & + varName=SF_name_max_durat, & + callingName=subname, & + retVal=SF_val_max_durat) + + call readNcdio(ncid = ncid, & + varName=SF_name_durat_slope, & + callingName=subname, & + retVal=SF_val_durat_slope) + + call readNcdio(ncid = ncid, & + varName=SF_name_alpha_SH, & + callingName=subname, & + retVal=SF_val_alpha_SH) + + call readNcdio(ncid = ncid, & + varName=SF_name_alpha_FMC, & + callingName=subname, & + retVal=SF_val_alpha_FMC) + + call readNcdio(ncid = ncid, & + varName=SF_name_CWD_frac, & + callingName=subname, & + retVal=SF_val_CWD_frac) + + call readNcdio(ncid = ncid, & + varName=SF_name_max_decomp, & + callingName=subname, & + retVal=SF_val_max_decomp) + + call readNcdio(ncid = ncid, & + varName=SF_name_SAV, & + callingName=subname, & + retVal=SF_val_SAV) + + call readNcdio(ncid = ncid, & + varName=SF_name_FBD, & + callingName=subname, & + retVal=SF_val_FBD) + + call readNcdio(ncid = ncid, & + varName=SF_name_min_moisture, & + callingName=subname, & + retVal=SF_val_min_moisture) + + call readNcdio(ncid = ncid, & + varName=SF_name_mid_moisture, & + callingName=subname, & + retVal=SF_val_mid_moisture) + + call readNcdio(ncid = ncid, & + varName=SF_name_low_moisture_C, & + callingName=subname, & + retVal=SF_val_low_moisture_C) + + call readNcdio(ncid = ncid, & + varName=SF_name_low_moisture_S, & + callingName=subname, & + retVal=SF_val_low_moisture_S) + + call readNcdio(ncid = ncid, & + varName=SF_name_mid_moisture_C, & + callingName=subname, & + retVal=SF_val_mid_moisture_C) + + call readNcdio(ncid = ncid, & + varName=SF_name_mid_moisture_S, & + callingName=subname, & + retVal=SF_val_mid_moisture_S) + + end subroutine SFParamsReadLocal + !----------------------------------------------------------------------- + +end module SFParamsMod diff --git a/main/CMakeLists.txt b/main/CMakeLists.txt new file mode 100644 index 0000000000..28dbfa2d77 --- /dev/null +++ b/main/CMakeLists.txt @@ -0,0 +1,8 @@ +# Note that this is just used for unit testing; hence, we only need to add +# source files that are currently used in unit tests + +list(APPEND clm_sources + EDPftvarcon.F90 + ) + +sourcelist_to_parent(clm_sources) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 new file mode 100755 index 0000000000..5de402f35f --- /dev/null +++ b/main/EDCLMLinkMod.F90 @@ -0,0 +1,1427 @@ +module EDCLMLinkMod + + ! ============================================================================ + ! Modules to control the passing of infomation generated by ED into CLM to be used for either + ! diagnostics, or as input to the land surface components. + ! ============================================================================ + + use shr_kind_mod , only : r8 => shr_kind_r8; + use decompMod , only : bounds_type + use clm_varpar , only : nclmax, nlevcan_ed, numpft, numcft + use clm_varctl , only : iulog + use EDtypesMod , only : ed_site_type, ed_cohort_type, ed_patch_type + ! + implicit none + private + ! + logical :: DEBUG = .false. ! for debugging this module (EDCLMLinkMod.F90) + + type, public :: ed_clm_type + + real(r8), pointer, private :: trimming_patch (:) + real(r8), pointer, private :: area_plant_patch (:) + real(r8), pointer, private :: area_trees_patch (:) + real(r8), pointer, private :: canopy_spread_patch (:) + real(r8), pointer, private :: PFTbiomass_patch (:,:) ! total biomass of each patch + real(r8), pointer, private :: PFTleafbiomass_patch (:,:) ! total biomass of each patch + real(r8), pointer, private :: PFTstorebiomass_patch (:,:) ! total biomass of each patch + real(r8), pointer, private :: PFTnindivs_patch (:,:) ! total biomass of each patch + + real(r8), pointer, private :: nesterov_fire_danger_patch (:) ! total biomass of each patch + real(r8), pointer, private :: spitfire_ROS_patch (:) ! total biomass of each patch + real(r8), pointer, private :: effect_wspeed_patch (:) ! total biomass of each patch + real(r8), pointer, private :: TFC_ROS_patch (:) ! total biomass of each patch + real(r8), pointer, private :: fire_intensity_patch (:) ! total biomass of each patch + real(r8), pointer, private :: fire_area_patch (:) ! total biomass of each patch + real(r8), pointer, private :: scorch_height_patch (:) ! total biomass of each patch + real(r8), pointer, private :: fire_fuel_bulkd_patch (:) ! total biomass of each patch + real(r8), pointer, private :: fire_fuel_eff_moist_patch (:) ! total biomass of each patch + real(r8), pointer, private :: fire_fuel_sav_patch (:) ! total biomass of each patch + real(r8), pointer, private :: fire_fuel_mef_patch (:) ! total biomass of each patch + real(r8), pointer, private :: sum_fuel_patch (:) ! total biomass of each patch + + real(r8), pointer, private :: litter_in_patch (:) ! total biomass of each patch + real(r8), pointer, private :: litter_out_patch (:) ! total biomass of each patch + real(r8), pointer, private :: efpot_patch (:) ! potential transpiration + real(r8), pointer, private :: rb_patch (:) ! boundary layer conductance + + real(r8), pointer, private :: daily_temp_patch (:) ! daily temperature for fire and phenology models + real(r8), pointer, private :: daily_rh_patch (:) ! daily RH for fire model + real(r8), pointer, private :: daily_prec_patch (:) ! daily rain for fire and phenology models. + + !seed model. Aggregated to gridcell for now. + + real(r8), pointer, private :: seed_bank_patch (:) ! kGC/m2 Mass of seeds. + real(r8), pointer, private :: seeds_in_patch (:) ! kGC/m2/year Production of seed mass. + real(r8), pointer, private :: seed_decay_patch (:) ! kGC/m2/year Decay of seed mass. + real(r8), pointer, private :: seed_germination_patch (:) ! kGC/m2/year Germiantion rate of seed mass. + + real(r8), pointer, private :: ED_bstore_patch (:) ! kGC/m2 Total stored biomass. + real(r8), pointer, private :: ED_bdead_patch (:) ! kGC/m2 Total dead biomass. + real(r8), pointer, private :: ED_balive_patch (:) ! kGC/m2 Total alive biomass. + real(r8), pointer, private :: ED_bleaf_patch (:) ! kGC/m2 Total leaf biomass. + real(r8), pointer, private :: ED_biomass_patch (:) ! kGC/m2 Total biomass. + + real(r8), pointer, private :: storvegc_patch (:) ! (gC/m2) stored vegetation carbon, excluding cpool + real(r8), pointer, private :: dispvegc_patch (:) ! (gC/m2) displayed veg carbon, excluding storage and cpool + real(r8), pointer, private :: leafc_patch (:) ! (gC/m2) leaf C + real(r8), pointer, private :: livestemc_patch (:) ! (gC/m2) live stem C + real(r8), pointer, private :: deadstemc_patch (:) ! (gC/m2) dead stem C + real(r8), pointer, private :: livestemn_patch (:) ! (gN/m2) live stem N + real(r8), pointer, private :: npp_patch (:) ! (gC/m2/s) patch net primary production + real(r8), pointer, private :: gpp_patch (:) ! (gC/m2/s) patch gross primary production + + contains + + ! Public routines + procedure , public :: Init + procedure , public :: Restart + procedure , public :: SetValues + procedure , public :: ed_clm_link + + ! Private routines + procedure , private :: ed_clm_leaf_area_profile + procedure , private :: ed_update_history_variables + procedure , private :: InitAllocate + procedure , private :: InitHistory + procedure , private :: InitCold + + end type ed_clm_type + + ! 10/30/09: Created by Rosie Fisher + !----------------------------------------------------------------------- + +contains + + !------------------------------------------------------------------------ + subroutine Init(this, bounds) + ! + ! !DESCRIPTION: + ! Initialize module data structure instance + ! + ! !ARGUMENTS: + class(ed_clm_type) :: this + type(bounds_type), intent(in) :: bounds + !----------------------------------------------------------------------- + + call this%InitAllocate(bounds) + call this%InitHistory(bounds) + call this%InitCold(bounds) + + end subroutine Init + + !------------------------------------------------------------------------ + subroutine InitAllocate(this, bounds) + ! + ! !USES: + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + use clm_varpar , only : nlevgrnd + ! + ! !ARGUMENTS: + class (ed_clm_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: begp,endp + !------------------------------------------------------------------------ + + begp = bounds%begp; endp = bounds%endp + + allocate(this%trimming_patch (begp:endp)) ; this%trimming_patch (:) = 0.0_r8 + allocate(this%canopy_spread_patch (begp:endp)) ; this%canopy_spread_patch (:) = 0.0_r8 + allocate(this%area_plant_patch (begp:endp)) ; this%area_plant_patch (:) = 0.0_r8 + allocate(this%area_trees_patch (begp:endp)) ; this%area_trees_patch (:) = 0.0_r8 + allocate(this%PFTbiomass_patch (begp:endp,1:nlevgrnd)) ; this%PFTbiomass_patch (:,:) = 0.0_r8 + allocate(this%PFTleafbiomass_patch (begp:endp,1:nlevgrnd)) ; this%PFTleafbiomass_patch (:,:) = 0.0_r8 + allocate(this%PFTstorebiomass_patch (begp:endp,1:nlevgrnd)) ; this%PFTstorebiomass_patch (:,:) = 0.0_r8 + allocate(this%PFTnindivs_patch (begp:endp,1:nlevgrnd)) ; this%PFTnindivs_patch (:,:) = 0.0_r8 + allocate(this%nesterov_fire_danger_patch (begp:endp)) ; this%nesterov_fire_danger_patch (:) = 0.0_r8 + allocate(this%spitfire_ROS_patch (begp:endp)) ; this%spitfire_ROS_patch (:) = 0.0_r8 + allocate(this%effect_wspeed_patch (begp:endp)) ; this%effect_wspeed_patch (:) = 0.0_r8 + allocate(this%TFC_ROS_patch (begp:endp)) ; this%TFC_ROS_patch (:) = 0.0_r8 + allocate(this%fire_intensity_patch (begp:endp)) ; this%fire_intensity_patch (:) = 0.0_r8 + allocate(this%fire_area_patch (begp:endp)) ; this%fire_area_patch (:) = 0.0_r8 + allocate(this%scorch_height_patch (begp:endp)) ; this%scorch_height_patch (:) = 0.0_r8 + allocate(this%fire_fuel_bulkd_patch (begp:endp)) ; this%fire_fuel_bulkd_patch (:) = 0.0_r8 + allocate(this%fire_fuel_eff_moist_patch (begp:endp)) ; this%fire_fuel_eff_moist_patch (:) = 0.0_r8 + allocate(this%fire_fuel_sav_patch (begp:endp)) ; this%fire_fuel_sav_patch (:) = 0.0_r8 + allocate(this%fire_fuel_mef_patch (begp:endp)) ; this%fire_fuel_mef_patch (:) = 0.0_r8 + allocate(this%sum_fuel_patch (begp:endp)) ; this%sum_fuel_patch (:) = 0.0_r8 + allocate(this%litter_in_patch (begp:endp)) ; this%litter_in_patch (:) = 0.0_r8 + allocate(this%litter_out_patch (begp:endp)) ; this%litter_out_patch (:) = 0.0_r8 + allocate(this%efpot_patch (begp:endp)) ; this%efpot_patch (:) = 0.0_r8 + allocate(this%rb_patch (begp:endp)) ; this%rb_patch (:) = 0.0_r8 + allocate(this%seed_bank_patch (begp:endp)) ; this%seed_bank_patch (:) = 0.0_r8 + allocate(this%seed_decay_patch (begp:endp)) ; this%seed_decay_patch (:) = 0.0_r8 + allocate(this%seeds_in_patch (begp:endp)) ; this%seeds_in_patch (:) = 0.0_r8 + allocate(this%seed_germination_patch (begp:endp)) ; this%seed_germination_patch (:) = 0.0_r8 + allocate(this%ED_bstore_patch (begp:endp)) ; this%ED_bstore_patch (:) = 0.0_r8 + allocate(this%ED_bdead_patch (begp:endp)) ; this%ED_bdead_patch (:) = 0.0_r8 + allocate(this%ED_balive_patch (begp:endp)) ; this%ED_balive_patch (:) = 0.0_r8 + allocate(this%ED_bleaf_patch (begp:endp)) ; this%ED_bleaf_patch (:) = 0.0_r8 + allocate(this%ED_biomass_patch (begp:endp)) ; this%ED_biomass_patch (:) = 0.0_r8 + + allocate(this%storvegc_patch (begp:endp)) ; this%storvegc_patch (:) = nan + allocate(this%dispvegc_patch (begp:endp)) ; this%dispvegc_patch (:) = nan + allocate(this%leafc_patch (begp:endp)) ; this%leafc_patch (:) = nan + allocate(this%livestemc_patch (begp:endp)) ; this%livestemc_patch (:) = nan + allocate(this%deadstemc_patch (begp:endp)) ; this%deadstemc_patch (:) = nan + allocate(this%livestemn_patch (begp:endp)) ; this%livestemn_patch (:) = nan + + allocate(this%gpp_patch (begp:endp)) ; this%gpp_patch (:) = nan + allocate(this%npp_patch (begp:endp)) ; this%npp_patch (:) = nan + + end subroutine InitAllocate + + !------------------------------------------------------------------------ + subroutine InitHistory(this, bounds) + ! + ! !DESCRIPTION: + ! add history fields for all variables, always set as default='inactive' + ! + ! !USES: + use clm_varpar , only : ndecomp_cascade_transitions, ndecomp_pools + use clm_varpar , only : nlevdecomp, nlevdecomp_full, crop_prog + use clm_varcon , only : spval + use histFileMod, only : hist_addfld1d, hist_addfld2d, hist_addfld_decomp + ! + ! !ARGUMENTS: + class(ed_clm_type) :: this + type(bounds_type) , intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: k,l,ii,jj + character(8) :: vr_suffix + character(10) :: active + integer :: begp,endp + integer :: begc,endc + character(24) :: fieldname + character(100) :: longname + real(r8), pointer :: data1dptr(:) ! temp. pointer for slicing larger arrays + !--------------------------------------------------------------------- + + begp = bounds%begp; endp = bounds%endp + begc = bounds%begc; endc = bounds%endc + + call hist_addfld1d (fname='TRIMMING', units='none', & + avgflag='A', long_name='Degree to which canopy expansion is limited by leaf economics', & + ptr_patch=this%trimming_patch, set_lake=0._r8, set_urb=0._r8) + + call hist_addfld1d (fname='AREA_PLANT', units='m2', & + avgflag='A', long_name='area occupied by all plants', & + ptr_patch=this%area_plant_patch, set_lake=0._r8, set_urb=0._r8) + + call hist_addfld1d (fname='AREA_TREES', units='m2', & + avgflag='A', long_name='area occupied by woody plants', & + ptr_patch=this%area_trees_patch, set_lake=0._r8, set_urb=0._r8) + + call hist_addfld1d (fname='CANOPY_SPREAD', units='none', & + avgflag='A', long_name='Scaling factor between tree basal area and canopy area', & + ptr_patch=this%canopy_spread_patch, set_lake=0._r8, set_urb=0._r8) + + call hist_addfld2d (fname='PFTbiomass', units='kgC/m2', type2d='levgrnd', & + avgflag='A', long_name='total PFT level biomass', & + ptr_patch=this%PFTbiomass_patch, set_lake=0._r8, set_urb=0._r8) + + call hist_addfld2d (fname='PFTleafbiomass', units='kgC/m2', type2d='levgrnd', & + avgflag='A', long_name='total PFT level biomass', & + ptr_patch=this%PFTleafbiomass_patch, set_lake=0._r8, set_urb=0._r8) + + call hist_addfld2d (fname='PFTstorebiomass', units='kgC/m2', type2d='levgrnd', & + avgflag='A', long_name='total PFT level biomass', & + ptr_patch=this%PFTstorebiomass_patch, set_lake=0._r8, set_urb=0._r8) + + call hist_addfld2d (fname='PFTnindivs', units='kgC/m2', type2d='levgrnd', & + avgflag='A', long_name='total PFT level biomass', & + ptr_patch=this%PFTnindivs_patch, set_lake=0._r8, set_urb=0._r8) + + call hist_addfld1d (fname='FIRE_NESTEROV_INDEX', units='none', & + avgflag='A', long_name='nesterov_fire_danger index', & + ptr_patch=this%nesterov_fire_danger_patch, set_lake=0._r8, set_urb=0._r8) + + call hist_addfld1d (fname='FIRE_ROS', units='m/min', & + avgflag='A', long_name='fire rate of spread m/min', & + ptr_patch=this%spitfire_ROS_patch, set_lake=0._r8, set_urb=0._r8) + + call hist_addfld1d (fname='EFFECT_WSPEED', units='none', & + avgflag='A', long_name='effective windspeed for fire spread', & + ptr_patch=this%effect_wspeed_patch, set_lake=0._r8, set_urb=0._r8) + + call hist_addfld1d (fname='FIRE_TFC_ROS', units='none', & + avgflag='A', long_name='total fuel consumed', & + ptr_patch=this%TFC_ROS_patch, set_lake=0._r8, set_urb=0._r8) + + call hist_addfld1d (fname='FIRE_INTENSITY', units='kJ/m/s', & + avgflag='A', long_name='spitfire fire intensity: kJ/m/s', & + ptr_patch=this%fire_intensity_patch, set_lake=0._r8, set_urb=0._r8) + + call hist_addfld1d (fname='FIRE_AREA', units='fraction', & + avgflag='A', long_name='spitfire fire area:m2', & + ptr_patch=this%fire_area_patch, set_lake=0._r8, set_urb=0._r8) + + call hist_addfld1d (fname='SCORCH_HEIGHT', units='m', & + avgflag='A', long_name='spitfire fire area:m2', & + ptr_patch=this%scorch_height_patch, set_lake=0._r8, set_urb=0._r8) + + call hist_addfld1d (fname='fire_fuel_mef', units='m', & + avgflag='A', long_name='spitfire fuel moisture', & + ptr_patch=this%fire_fuel_mef_patch, set_lake=0._r8, set_urb=0._r8) + + call hist_addfld1d (fname='fire_fuel_bulkd', units='m', & + avgflag='A', long_name='spitfire fuel bulk density', & + ptr_patch=this%fire_fuel_bulkd_patch, set_lake=0._r8, set_urb=0._r8) + + call hist_addfld1d (fname='fire_fuel_eff_moist', units='m', & + avgflag='A', long_name='spitfire fuel moisture', & + ptr_patch=this%fire_fuel_eff_moist_patch, set_lake=0._r8, set_urb=0._r8) + + call hist_addfld1d (fname='fire_fuel_sav', units='m', & + avgflag='A', long_name='spitfire fuel surface/volume ', & + ptr_patch=this%fire_fuel_sav_patch, set_lake=0._r8, set_urb=0._r8) + + call hist_addfld1d (fname='TFC_ROS', units='m', & + avgflag='A', long_name='spitfire fuel surface/volume ', & + ptr_patch=this%TFC_ROS_patch, set_lake=0._r8, set_urb=0._r8) + + call hist_addfld1d (fname='SUM_FUEL', units=' KgC m-2 y-1', & + avgflag='A', long_name='Litter flux in leaves', & + ptr_patch=this%sum_fuel_patch, set_lake=0._r8, set_urb=0._r8) + + call hist_addfld1d (fname='LITTER_IN', units=' KgC m-2 y-1', & + avgflag='A', long_name='Litter flux in leaves', & + ptr_patch=this%litter_in_patch, set_lake=0._r8, set_urb=0._r8) + + call hist_addfld1d (fname='LITTER_OUT', units=' KgC m-2 y-1', & + avgflag='A', long_name='Litter flux out leaves', & + ptr_patch=this%litter_out_patch, set_lake=0._r8, set_urb=0._r8) + + call hist_addfld1d (fname='SEED_BANK', units=' KgC m-2', & + avgflag='A', long_name='Total Seed Mass of all PFTs', & + ptr_patch=this%seed_bank_patch, set_lake=0._r8, set_urb=0._r8) + + call hist_addfld1d (fname='SEEDS_IN', units=' KgC m-2 y-1', & + avgflag='A', long_name='Seed Production Rate', & + ptr_patch=this%seeds_in_patch, set_lake=0._r8, set_urb=0._r8) + + call hist_addfld1d (fname='SEED_GERMINATION', units=' KgC m-2 y-1', & + avgflag='A', long_name='Seed mass converted into new cohorts', & + ptr_patch=this%seed_germination_patch, set_lake=0._r8, set_urb=0._r8) + + call hist_addfld1d (fname='SEED_DECAY', units=' KgC m-2 y-1', & + avgflag='A', long_name='Seed mass decay', & + ptr_patch=this%seed_decay_patch, set_lake=0._r8, set_urb=0._r8) + + call hist_addfld1d (fname='ED_bstore', units=' KgC m-2', & + avgflag='A', long_name='ED stored biomass', & + ptr_patch=this%ED_bstore_patch, set_lake=0._r8, set_urb=0._r8) + + call hist_addfld1d (fname='ED_bdead', units=' KgC m-2', & + avgflag='A', long_name='ED dead biomass', & + ptr_patch=this%ED_bdead_patch, set_lake=0._r8, set_urb=0._r8) + + call hist_addfld1d (fname='ED_balive', units=' KgC m-2', & + avgflag='A', long_name='ED live biomass', & + ptr_patch=this%ED_balive_patch, set_lake=0._r8, set_urb=0._r8) + + call hist_addfld1d (fname='ED_bleaf', units=' KgC m-2', & + avgflag='A', long_name='ED leaf biomass', & + ptr_patch=this%ED_bleaf_patch, set_lake=0._r8, set_urb=0._r8) + + call hist_addfld1d (fname='ED_biomass', units=' KgC m-2', & + avgflag='A', long_name='ED total biomass', & + ptr_patch=this%ED_biomass_patch, set_lake=0._r8, set_urb=0._r8) + + call hist_addfld1d (fname='RB', units=' s m-1', & + avgflag='A', long_name='leaf boundary resistance', & + ptr_patch=this%rb_patch, set_lake=0._r8, set_urb=0._r8) + + call hist_addfld1d (fname='EFPOT', units='', & + avgflag='A', long_name='potential evap', & + ptr_patch=this%efpot_patch, set_lake=0._r8, set_urb=0._r8) + + this%dispvegc_patch(begp:endp) = spval + call hist_addfld1d (fname='DISPVEGC', units='gC/m^2', & + avgflag='A', long_name='displayed veg carbon, excluding storage and cpool', & + ptr_patch=this%dispvegc_patch) + + this%storvegc_patch(begp:endp) = spval + call hist_addfld1d (fname='STORVEGC', units='gC/m^2', & + avgflag='A', long_name='stored vegetation carbon, excluding cpool', & + ptr_patch=this%storvegc_patch) + + this%leafc_patch(begp:endp) = spval + call hist_addfld1d (fname='LEAFC', units='gC/m^2', & + avgflag='A', long_name='leaf C', & + ptr_patch=this%leafc_patch) + + this%livestemc_patch(begp:endp) = spval + call hist_addfld1d (fname='LIVESTEMC', units='gC/m^2', & + avgflag='A', long_name='live stem C', & + ptr_patch=this%livestemc_patch) + + this%deadstemc_patch(begp:endp) = spval + call hist_addfld1d (fname='DEADSTEMC', units='gC/m^2', & + avgflag='A', long_name='dead stem C', & + ptr_patch=this%deadstemc_patch) + + this%livestemn_patch(begp:endp) = spval + call hist_addfld1d (fname='LIVESTEMN', units='gN/m^2', & + avgflag='A', long_name='live stem N', & + ptr_patch=this%livestemn_patch) + + this%gpp_patch(begp:endp) = spval + call hist_addfld1d (fname='GPP', units='gC/m^2/s', & + avgflag='A', long_name='gross primary production', & + ptr_patch=this%gpp_patch) + + this%npp_patch(begp:endp) = spval + call hist_addfld1d (fname='NPP', units='gC/m^2/s', & + avgflag='A', long_name='net primary production', & + ptr_patch=this%npp_patch) + + end subroutine InitHistory + + !----------------------------------------------------------------------- + subroutine InitCold(this, bounds) + ! + ! !DESCRIPTION: + ! Initialize relevant time varying variables + ! + ! !ARGUMENTS: + class (ed_clm_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: p + !----------------------------------------------------------------------- + + do p = bounds%begp,bounds%endp + this%dispvegc_patch(p) = 0._r8 + this%storvegc_patch(p) = 0._r8 + end do + + end subroutine InitCold + + !----------------------------------------------------------------------- + subroutine Restart ( this, bounds, ncid, flag ) + ! + ! !DESCRIPTION: + ! Read/write restart data + ! + ! !USES: + use restUtilMod + use ncdio_pio + ! + ! !ARGUMENTS: + class (ed_clm_type) :: this + type(bounds_type) , intent(in) :: bounds + type(file_desc_t) , intent(inout) :: ncid + character(len=*) , intent(in) :: flag !'read' or 'write' or 'define' + ! + ! !LOCAL VARIABLES: + logical :: readvar + !------------------------------------------------------------------------ + + call restartvar(ncid=ncid, flag=flag, varname='leafc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%leafc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='livestemc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%livestemc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='deadstemc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%deadstemc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='livestemn', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%livestemn_patch) + + end subroutine Restart + + !----------------------------------------------------------------------- + subroutine SetValues( this, bounds, val) + ! + ! !ARGUMENTS: + class (ed_clm_type) :: this + type(bounds_type) , intent(in) :: bounds + real(r8) , intent(in) :: val + ! + ! !LOCAL VARIABLES: + integer :: fi,i,j,k,l ! loop index + !----------------------------------------------------------------------- + + ! + ! FIX(SPM,082714) - commenting these lines out while merging ED branch to CLM + ! trunk. Commented out by RF to work out science issues + ! + !this%trimming_patch (:) = val + !this%canopy_spread_patch (:) = val + !this%PFTbiomass_patch (:,:) = val + !this%PFTleafbiomass_patch (:,:) = val + !this%PFTstorebiomass_patch (:,:) = val + !this%PFTnindivs_patch (:,:) = val + this%efpot_patch (:) = val + this%rb_patch (:) = val + + end subroutine SetValues + + !----------------------------------------------------------------------- + subroutine ed_clm_link( this, bounds, ed_allsites_inst, ed_phenology_inst, & + waterstate_inst, canopystate_inst) + ! + ! !USES: + use landunit_varcon , only : istsoil + use EDGrowthFunctionsMod , only : tree_lai, c_area + use EDEcophysConType , only : EDecophyscon + use EDPhenologyType , only : ed_phenology_type + use EDtypesMod , only : area + use PatchType , only : clmpatch => patch + use ColumnType , only : col + use LandunitType , only : lun + use pftconMod , only : pftcon + use CanopyStateType , only : canopystate_type + use WaterStateType , only : waterstate_type + ! + ! !ARGUMENTS + class(ed_clm_type) :: this + type(bounds_type) , intent(in) :: bounds + type(ed_site_type) , intent(inout), target :: ed_allsites_inst( bounds%begg: ) + type(ed_phenology_type) , intent(inout) :: ed_phenology_inst + type(waterstate_type) , intent(inout) :: waterstate_inst + type(canopystate_type) , intent(inout) :: canopystate_inst + ! + ! !LOCAL VARIABLES: + type (ed_patch_type) , pointer :: currentPatch + type (ed_cohort_type) , pointer :: currentCohort + integer :: g,l,p,c + integer :: ft ! plant functional type + integer :: patchn ! identification number for each patch. + integer :: firstsoilpatch(bounds%begg:bounds%endg) ! the first patch in this gridcell that is soil and thus bare... + real(r8) :: total_bare_ground ! sum of the bare fraction in all pfts. + real(r8) :: total_patch_area + real(r8) :: coarse_wood_frac + real(r8) :: canopy_leaf_area ! total amount of leaf area in the vegetated area. m2. + integer :: sitecolumn(bounds%begg:bounds%endg) + logical :: istheresoil(bounds%begg:bounds%endg) + !---------------------------------------------------------------------- + + if (DEBUG) then + write(iulog,*) 'in ed_clm_link' + endif + + associate( & + tlai => canopystate_inst%tlai_patch , & + elai => canopystate_inst%elai_patch , & + tsai => canopystate_inst%tsai_patch , & + esai => canopystate_inst%esai_patch , & + htop => canopystate_inst%htop_patch , & + hbot => canopystate_inst%hbot_patch , & + begg => bounds%begg , & + endg => bounds%endg , & + begc => bounds%begc , & + endc => bounds%endc , & + begp => bounds%begp , & + endp => bounds%endp & + ) + + ! determine if gridcell is soil + + istheresoil(begg:endg) = .false. + do c = begc,endc + g = col%gridcell(c) + l = col%landunit(c) + + if (lun%itype(l) == istsoil .and. col%itype(c) == istsoil) then + istheresoil(g) = .true. + endif + ed_allsites_inst(g)%istheresoil = istheresoil(g) + enddo + + ! retrieve the first soil patch associated with each gridcell. + ! make sure we only get the first patch value for places which have soil. + + firstsoilpatch(begg:endg) = -999 + do c = begc,endc + g = col%gridcell(c) + l = col%landunit(c) + + if (lun%itype(l) == istsoil .and. col%itype(c) == istsoil) then + firstsoilpatch(g) = col%patchi(c) + sitecolumn(g) = c + endif + enddo + + ! ============================================================================ + ! Zero the whole variable so we dont have ghost values when patch number declines. + ! ============================================================================ + + clmpatch%is_veg(begp:endp) = .false. + clmpatch%is_bareground(begp:endp) = .false. + tlai(begp:endp) = 0.0_r8 + elai(firstsoilpatch(g)) = 0.0_r8 + tsai(firstsoilpatch(g)) = 0.0_r8 + esai(firstsoilpatch(g)) = 0.0_r8 + htop(begp:endp) = 0.0_r8 + hbot(begp:endp) = 0.0_r8 + + do g = begg,endg + + if(firstsoilpatch(g) >= 0.and.ed_allsites_inst(g)%istheresoil)then + ed_allsites_inst(g)%clmcolumn = sitecolumn(g) + + ! ============================================================================ + ! Zero the bare ground tile BGC variables. + ! ============================================================================ + + tlai(firstsoilpatch(g)) = 0.0_r8 + htop(firstsoilpatch(g)) = 0.0_r8 + hbot(firstsoilpatch(g)) = 0.0_r8 + + patchn = 0 + total_bare_ground = 0.0_r8 + total_patch_area = 0._r8 + + currentPatch => ed_allsites_inst(g)%oldest_patch + do while(associated(currentPatch)) + patchn = patchn + 1 + currentPatch%patchno = patchn + + if (patchn <= numpft - numcft)then !don't expand into crop patches. + + currentPatch%clm_pno = firstsoilpatch(g) + patchn !the first 'soil' patch is unvegetated... + p = currentPatch%clm_pno + c = clmpatch%column(p) + clmpatch%is_veg(p) = .true. !this .is. a tile filled with vegetation... + + call currentPatch%set_root_fraction() + + !zero cohort-summed variables. + currentPatch%total_canopy_area = 0.0_r8 + currentPatch%total_tree_area = 0.0_r8 + currentPatch%lai = 0.0_r8 + canopy_leaf_area = 0.0_r8 + + !update cohort quantitie s + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + ft = currentCohort%pft + currentCohort%livestemn = currentCohort%bsw / pftcon%leafcn(currentCohort%pft) + + if (pftcon%woody(ft) == 1) then + coarse_wood_frac = 0.5_r8 + else + coarse_wood_frac = 0.0_r8 + end if + + currentCohort%livecrootn = currentCohort%br * coarse_wood_frac / pftcon%leafcn(ft) + currentCohort%b = currentCohort%balive+currentCohort%bdead+currentCohort%bstore + currentCohort%treelai = tree_lai(currentCohort) + ! Why is currentCohort%c_area used and then reset in the + ! following line? + canopy_leaf_area = canopy_leaf_area + currentCohort%treelai *currentCohort%c_area + currentCohort%c_area = c_area(currentCohort) + + if(currentCohort%canopy_layer==1)then + currentPatch%total_canopy_area = currentPatch%total_canopy_area + currentCohort%c_area + if(pftcon%woody(ft)==1)then + currentPatch%total_tree_area = currentPatch%total_tree_area + currentCohort%c_area + endif + endif + + ! Check for erroneous zero values. + if(currentCohort%dbh <= 0._r8 .or. currentCohort%n == 0._r8)then + write(iulog,*) 'ED: dbh or n is zero in clmedlink', currentCohort%dbh,currentCohort%n + endif + if(currentCohort%pft == 0.or.currentCohort%canopy_trim <= 0._r8)then + write(iulog,*) 'ED: PFT or trim is zero in clmedlink',currentCohort%pft,currentCohort%canopy_trim + endif + if(currentCohort%balive <= 0._r8)then + write(iulog,*) 'ED: balive is zero in clmedlink',currentCohort%balive + endif + + currentCohort => currentCohort%taller + + enddo ! ends 'do while(associated(currentCohort)) + + if ( currentPatch%total_canopy_area-currentPatch%area > 0.000001_r8 ) then + write(iulog,*) 'canopy area bigger than area',currentPatch%total_canopy_area ,currentPatch%area + currentPatch%total_canopy_area = currentPatch%area + endif + + ! PASS BACK PATCH-LEVEL QUANTITIES THAT ARE NEEDED BY THE CLM CODE + if (associated(currentPatch%tallest)) then + htop(p) = currentPatch%tallest%hite + else + ! FIX(RF,040113) - should this be a parameter for the minimum possible vegetation height? + htop(p) = 0.1_r8 + endif + + hbot(p) = max(0._r8, min(0.2_r8, htop(p)- 1.0_r8)) + + ! leaf area index: of .only. the areas with some vegetation on them, as the non-vegetated areas + ! are merged into the bare ground fraction. This introduces a degree of unrealism, + ! which could be fixed if the surface albedo routine took account of the possibiltiy of bare + ! ground mixed with trees. + + if(currentPatch%total_canopy_area > 0)then; + tlai(p) = canopy_leaf_area/currentPatch%total_canopy_area + else + tlai(p) = 0.0_r8 + endif + + !write(iulog,*) 'tlai',tlai(p) + !write(iulog,*) 'htop',htop(p) + + ! 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. + + clmpatch%wt_ed(p) = min(1.0_r8,(currentPatch%total_canopy_area/currentPatch%area)) * (currentPatch%area/AREA) + currentPatch%bare_frac_area = (1.0_r8 - min(1.0_r8,currentPatch%total_canopy_area/currentPatch%area)) * & + (currentPatch%area/AREA) + ! write(iulog,*) 'bare frac',currentPatch%bare_frac_area + total_patch_area = total_patch_area + clmpatch%wt_ed(p) + currentPatch%bare_frac_area + total_bare_ground = total_bare_ground + currentPatch%bare_frac_area + currentCohort=> currentPatch%tallest + + else + write(iulog,*) 'ED: too many patches' + end if ! patchn<15 + + currentPatch => currentPatch%younger + end do !patch loop + + if((total_patch_area-1.0_r8)>1e-9)then + write(iulog,*) 'total area is wrong in CLMEDLINK',total_patch_area + endif + + !loop round all and zero the remaining empty vegetation patches + do p = firstsoilpatch(g)+patchn+1,firstsoilpatch(g)+numpft + clmpatch%wt_ed(p) = 0.0_r8 + enddo + + !set the area of the bare ground patch. + p = firstsoilpatch(g) + clmpatch%wt_ed(p) = total_bare_ground + clmpatch%is_bareground = .true. + endif ! are there any soil patches? + + call this%ed_clm_leaf_area_profile(ed_allsites_inst(g), waterstate_inst, canopystate_inst ) + + end do !grid loop + + call this%ed_update_history_variables( bounds, ed_allsites_inst(begg:endg), & + firstsoilpatch, ed_Phenology_inst, canopystate_inst) + + end associate + + end subroutine ed_clm_link + + !----------------------------------------------------------------------- + subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & + firstsoilpatch, ed_Phenology_inst, canopystate_inst) + ! + ! !USES: + use EDPhenologyType , only : ed_phenology_type + use CanopyStateType , only : canopystate_type + use PatchType , only : clmpatch => patch + ! + ! !ARGUMENTS: + class(ed_clm_type) :: this + type(bounds_type) , intent(in) :: bounds ! clump bounds + type(ed_site_type) , intent(inout), target :: ed_allsites_inst( bounds%begg: ) + type(ed_patch_type) , pointer :: currentPatch + type(ed_cohort_type) , pointer :: currentCohort + type(ed_phenology_type) , intent(inout) :: ed_phenology_inst + type(canopystate_type) , intent(inout) :: canopystate_inst + ! + ! !LOCAL VARIABLES: + integer :: G,p,ft + integer :: firstsoilpatch(bounds%begg:bounds%endg) + real(r8) :: n_density ! individual of cohort per m2. + !----------------------------------------------------------------------- + + associate( & + trimming => this%trimming_patch , & ! Output: + canopy_spread => this%canopy_spread_patch , & ! Output: + PFTbiomass => this%PFTbiomass_patch , & ! Output: + PFTleafbiomass => this%PFTleafbiomass_patch , & ! Output: + PFTstorebiomass => this%PFTstorebiomass_patch , & ! Output: + PFTnindivs => this%PFTnindivs_patch , & ! Output: + area_plant => this%area_plant_patch , & ! Output: + area_trees => this%area_trees_patch , & ! Output: + nesterov_fire_danger => this%nesterov_fire_danger_patch , & ! Output: + spitfire_ROS => this%spitfire_ROS_patch , & ! Output: + effect_wspeed => this%effect_wspeed_patch , & ! Output: + TFC_ROS => this%TFC_ROS_patch , & ! Output: + sum_fuel => this%sum_fuel_patch , & ! Output: + fire_intensity => this%fire_intensity_patch , & ! Output: + fire_area => this%fire_area_patch , & ! Output: + scorch_height => this%scorch_height_patch , & ! Output: + fire_fuel_bulkd => this%fire_fuel_bulkd_patch , & ! Output: + fire_fuel_eff_moist => this%fire_fuel_eff_moist_patch , & ! Output: + fire_fuel_sav => this%fire_fuel_sav_patch , & ! Output: + fire_fuel_mef => this%fire_fuel_mef_patch , & ! Output: + litter_in => this%litter_in_patch , & ! Output: + litter_out => this%litter_out_patch , & ! Output: + seed_bank => this%seed_bank_patch , & ! Output: + seeds_in => this%seeds_in_patch , & ! Output: + seed_decay => this%seed_decay_patch , & ! Output: + seed_germination => this%seed_germination_patch , & ! Output: + + ED_biomass => this%ED_biomass_patch , & ! InOut: + ED_bdead => this%ED_bdead_patch , & ! InOut: + ED_bleaf => this%ED_bleaf_patch , & ! InOut: + ED_balive => this%ED_balive_patch , & ! InOut: + ED_bstore => this%ED_bstore_patch , & ! InOut: + + phen_cd_status => ed_phenology_inst%phen_cd_status_patch , & ! InOut: + + gpp => this%gpp_patch , & ! Output: + npp => this%npp_patch , & ! Output: + + tlai => canopystate_inst%tlai_patch , & ! InOut: + elai => canopystate_inst%elai_patch , & ! InOut: + tsai => canopystate_inst%tsai_patch , & ! InOut: + esai => canopystate_inst%esai_patch , & ! InOut: + + begp => bounds%begp , & + endp => bounds%endp & + + ) + + ! ============================================================================ + ! Zero the whole variable so we dont have ghost values when patch number declines. + ! ============================================================================ + + trimming(:) = 1.0_r8 !the default value of this is 1.0, making it 0.0 means that the output is confusing. + canopy_spread(:) = 0.0_r8 + PFTbiomass(:,:) = 0.0_r8 + PFTleafbiomass(:,:) = 0.0_r8 + PFTstorebiomass(:,:) = 0.0_r8 + PFTnindivs(:,:) = 0.0_r8 + gpp(:) = 0.0_r8 + npp(:) = 0.0_r8 + area_plant(:) = 0.0_r8 + area_trees(:) = 0.0_r8 + nesterov_fire_danger(:) = 0.0_r8 + spitfire_ROS(:) = 0.0_r8 + effect_wspeed = 0.0_r8 + TFC_ROS(:) = 0.0_r8 + fire_intensity(:) = 0.0_r8 + fire_area(:) = 0.0_r8 + scorch_height(:) = 0.0_r8 + fire_fuel_bulkd(:) = 0.0_r8 + fire_fuel_eff_moist(:) = 0.0_r8 + fire_fuel_sav(:) = 0.0_r8 + fire_fuel_mef(:) = 0.0_r8 + litter_in(:) = 0.0_r8 + litter_out(:) = 0.0_r8 + seed_bank(:) = 0.0_r8 + seeds_in(:) = 0.0_r8 + seed_decay(:) = 0.0_r8 + seed_germination(:) = 0.0_r8 + ED_biomass(:) = 0.0_r8 + ED_bdead(:) = 0.0_r8 + ED_bleaf(:) = 0.0_r8 + ED_bstore(:) = 0.0_r8 + ED_balive(:) = 0.0_r8 + phen_cd_status(:) = 2 + + do g = bounds%begg,bounds%endg + + if (firstsoilpatch(g) >= 0 .and. ed_allsites_inst(g)%istheresoil) then + + ! ============================================================================ + ! Zero the bare ground tile BGC variables. + ! ============================================================================ + + trimming(firstsoilpatch(g)) = 1.0_r8 + canopy_spread(firstsoilpatch(g)) = 0.0_r8 + PFTbiomass(firstsoilpatch(g),:) = 0.0_r8 + PFTleafbiomass(firstsoilpatch(g),:) = 0.0_r8 + PFTstorebiomass(firstsoilpatch(g),:) = 0.0_r8 + PFTnindivs(firstsoilpatch(g),:) = 0.0_r8 + gpp(firstsoilpatch(g)) = 0.0_r8 + npp(firstsoilpatch(g)) = 0.0_r8 + area_plant(firstsoilpatch(g)) = 0.0_r8 + area_trees(firstsoilpatch(g)) = 0.0_r8 + nesterov_fire_danger(firstsoilpatch(g)) = 0.0_r8 + spitfire_ROS(firstsoilpatch(g)) = 0.0_r8 + TFC_ROS(firstsoilpatch(g)) = 0.0_r8 + effect_wspeed(firstsoilpatch(g)) = 0.0_r8 + fire_intensity(firstsoilpatch(g)) = 0.0_r8 + fire_area(firstsoilpatch(g)) = 0.0_r8 + scorch_height(firstsoilpatch(g)) = 0.0_r8 + fire_fuel_bulkd(firstsoilpatch(g)) = 0.0_r8 + fire_fuel_eff_moist(firstsoilpatch(g)) = 0.0_r8 + fire_fuel_sav(firstsoilpatch(g)) = 0.0_r8 + fire_fuel_mef(firstsoilpatch(g)) = 0.0_r8 + litter_in(firstsoilpatch(g)) = 0.0_r8 + litter_out(firstsoilpatch(g)) = 0.0_r8 + seed_bank(firstsoilpatch(g)) = 0.0_r8 + seeds_in(firstsoilpatch(g)) = 0.0_r8 + seed_decay(firstsoilpatch(g)) = 0.0_r8 + seed_germination(firstsoilpatch(g)) = 0.0_r8 + ED_biomass(firstsoilpatch(g)) = 0.0_r8 + ED_balive(firstsoilpatch(g)) = 0.0_r8 + ED_bdead(firstsoilpatch(g)) = 0.0_r8 + ED_bstore(firstsoilpatch(g)) = 0.0_r8 + ED_bleaf(firstsoilpatch(g)) = 0.0_r8 + elai(firstsoilpatch(g)) = 0.0_r8 + tlai(firstsoilpatch(g)) = 0.0_r8 + tsai(firstsoilpatch(g)) = 0.0_r8 + esai(firstsoilpatch(g)) = 0.0_r8 + ED_bleaf(firstsoilpatch(g)) = 0.0_r8 + sum_fuel(firstsoilpatch(g)) = 0.0_r8 + !this should probably be site level. + phen_cd_status(firstsoilpatch(g)) = ed_allsites_inst(g)%status + + currentPatch => ed_allsites_inst(g)%oldest_patch + do while(associated(currentPatch)) + + if(currentPatch%patchno <= numpft - numcft)then !don't expand into crop patches. + p = currentPatch%clm_pno + + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + !accumulate into history variables. + ft = currentCohort%pft + if(currentPatch%area>0._r8)then + n_density = currentCohort%n/currentPatch%area + else + n_density = 0.0_r8 + endif + ED_bleaf(p) = ED_bleaf(p) + n_density * currentCohort%bl + ED_bstore(p) = ED_bstore(p) + n_density * currentCohort%bstore + ED_biomass(p) = ED_biomass(p) + n_density * currentCohort%b + ED_bdead(p) = ED_bdead(p) + n_density * currentCohort%bdead + ED_balive(p) = ED_balive(p) + n_density * currentCohort%balive + npp(p) = npp(p) + n_density * currentCohort%npp + gpp(p) = gpp(p) + n_density * currentCohort%gpp + PFTbiomass(p,ft) = PFTbiomass(p,ft) + n_density * currentCohort%b + PFTleafbiomass(p,ft) = PFTleafbiomass(p,ft) + n_density * currentCohort%bl + PFTstorebiomass(p,ft) = PFTstorebiomass(p,ft) + n_density * currentCohort%bstore + PFTnindivs(p,ft) = PFTnindivs(p,ft) + currentCohort%n + currentCohort => currentCohort%taller + enddo ! cohort loop + + !Patch specific variables that are already calculated + + !These things are all duplicated. Should they all be converted to LL or array structures RF? + nesterov_fire_danger(p) = ed_allsites_inst(g)%acc_NI + spitfire_ROS(p) = currentPatch%ROS_front + TFC_ROS(p) = currentPatch%TFC_ROS + effect_wspeed(p) = currentPatch%effect_wspeed + fire_intensity(p) = currentPatch%FI + fire_area(p) = currentPatch%frac_burnt + scorch_height(p) = currentPatch%SH + fire_fuel_bulkd(p) = currentPatch%fuel_bulkd + fire_fuel_eff_moist(p) = currentPatch%fuel_eff_moist + fire_fuel_sav(p) = currentPatch%fuel_sav + fire_fuel_mef(p) = currentPatch%fuel_mef + sum_fuel(p) = currentPatch%sum_fuel + litter_in(p) = sum(currentPatch%CWD_AG_in) +sum(currentPatch%leaf_litter_in) + litter_out(p) = sum(currentPatch%CWD_AG_out)+sum(currentPatch%leaf_litter_out) + seed_bank(p) = sum(currentPatch%seed_bank) + seeds_in(p) = sum(currentPatch%seeds_in) + seed_decay(p) = sum(currentPatch%seed_decay) + seed_germination(p) = sum(currentPatch%seed_germination) + canopy_spread(p) = currentPatch%spread(1) + area_plant(p) = currentPatch%total_canopy_area /currentPatch%area + area_trees(p) = currentPatch%total_tree_area /currentPatch%area + phen_cd_status(p) = ed_allsites_inst(g)%status + if(associated(currentPatch%tallest))then + trimming(p) = currentPatch%tallest%canopy_trim + else + trimming(p) = 0.0_r8 + endif + + else + write(iulog,*) 'ED: too many patches' + end if ! patchn<15 + + currentPatch => currentPatch%younger + end do !patch loop + + endif ! are there any soil patches? + enddo !gridcell loop + + end associate + + end subroutine ed_update_history_variables + + !------------------------------------------------------------------------ + subroutine ed_clm_leaf_area_profile( this, currentSite, waterstate_inst, canopystate_inst ) + ! + ! !DESCRIPTION: + ! Load LAI in each layer into array to send to CLM + ! + ! !USES: + use EDGrowthFunctionsMod , only : tree_lai, tree_sai, c_area + use EDtypesMod , only : area, dinc_ed, hitemax, numpft_ed, n_hite_bins + use EDEcophysConType , only : EDecophyscon + use CanopyStateType , only : canopystate_type + use WaterStateType , only : waterstate_type + use PatchType , only : clmpatch => patch + ! + ! !ARGUMENTS + class(ed_clm_type) :: this + type(ed_site_type) , intent(inout) :: currentSite + type(waterstate_type) , intent(inout) :: waterstate_inst + type(canopystate_type) , intent(inout) :: canopystate_inst + ! + ! !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 + integer :: L ! Canopy layer index + integer :: P ! clm patch index + integer :: C ! column index + real(r8) :: tlai_temp ! calculation of tlai to check this method + real(r8) :: elai_temp ! make a new elai based on the layer-by-layer snow coverage. + real(r8) :: tsai_temp ! + real(r8) :: esai_temp ! + 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) + real(r8) :: layer_bottom_hite ! notional bottom height of this canopy layer (m) + integer :: smooth_leaf_distribution ! is the leaf distribution this option (1) or not (0) + real(r8) :: frac_canopy(N_HITE_BINS) ! amount of canopy in each height class + real(r8) :: minh(N_HITE_BINS) ! minimum height in height class (m) + real(r8) :: maxh(N_HITE_BINS) ! maximum height in height class (m) + real(r8) :: dh ! vertical detph of height class (m) + real(r8) :: min_chite ! bottom of cohort canopy (m) + real(r8) :: max_chite ! top of cohort canopy (m) + real(r8) :: lai ! summed lai for checking m2 m-2 + integer :: NC ! number of cohorts, for bug fixing. + !---------------------------------------------------------------------- + + smooth_leaf_distribution = 0 + + associate( & + snow_depth => waterstate_inst%snow_depth_col , & !Input: + frac_sno_eff => waterstate_inst%frac_sno_eff_col , & !Input: + snowdp => waterstate_inst%snowdp_col , & !Output: + + frac_veg_nosno_alb => canopystate_inst%frac_veg_nosno_alb_patch , & !Output: + tlai => canopystate_inst%tlai_patch , & !Output + elai => canopystate_inst%elai_patch , & !Output + tsai => canopystate_inst%tsai_patch , & !Output + esai => canopystate_inst%esai_patch & !Output + ) + + ! 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... + ! Each leaf is defined by how deep in the canopy it is, in terms of LAI units. (FIX(RF,032414), GB) + + if (currentSite%istheresoil)then + + currentPatch => currentSite%oldest_patch ! ed patch + p = currentPatch%clm_pno ! index for clm patch + + do while(associated(currentPatch)) + + !Calculate tree and canopy areas. + currentPatch%canopy_area = 0._r8 + currentPatch%canopy_layer_lai(:) = 0._r8 + NC = 0 + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + currentCohort%c_area = c_area(currentCohort) + currentPatch%canopy_area = currentPatch%canopy_area + currentCohort%c_area + NC = NC+1 + currentCohort => currentCohort%taller + enddo + ! if plants take up all the tile, then so does the canopy. + currentPatch%canopy_area = min(currentPatch%canopy_area,currentPatch%area) + + !calculate tree lai and sai. + currentPatch%ncan(:,:) = 0 + currentPatch%nrad(:,:) = 0 + currentPatch%lai = 0._r8 + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + currentCohort%treelai = tree_lai(currentCohort) + currentCohort%treesai = tree_sai(currentCohort) + currentCohort%lai = currentCohort%treelai *currentCohort%c_area/currentPatch%canopy_area + currentCohort%sai = currentCohort%treesai *currentCohort%c_area/currentPatch%canopy_area + !Calculate the LAI plus SAI in each canopy storey. + currentCohort%NV = CEILING((currentCohort%treelai+currentCohort%treesai)/dinc_ed) + + currentPatch%ncan(currentCohort%canopy_layer,currentCohort%pft) = & + max(currentPatch%ncan(currentCohort%canopy_layer,currentCohort%pft),currentCohort%NV) + currentPatch%lai = currentPatch%lai +currentCohort%lai + + do L = 1,nclmax-1 + if(currentCohort%canopy_layer == L)then + currentPatch%canopy_layer_lai(L) = currentPatch%canopy_layer_lai(L) + currentCohort%lai + & + currentCohort%sai + endif + enddo + + currentCohort => currentCohort%taller + + enddo !currentCohort + currentPatch%nrad = currentPatch%ncan + + 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 + currentPatch%tlai_profile = 0._r8 + currentPatch%tsai_profile = 0._r8 + currentPatch%elai_profile = 0._r8 + currentPatch%esai_profile = 0._r8 + + ! 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 + c = clmpatch%column(currentPatch%clm_pno) + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + ft = currentCohort%pft + min_chite = currentCohort%hite - currentCohort%hite * EDecophyscon%crown(ft) + max_chite = currentCohort%hite + do iv = 1,N_HITE_BINS + frac_canopy(iv) = 0.0_r8 + ! this layer is in the middle of the canopy + if(max_chite > maxh(iv).and.min_chite < minh(iv))then + frac_canopy(iv)= min(1.0_r8,dh / (currentCohort%hite*EDecophyscon%crown(ft))) + ! this is the layer with the bottom of the canopy in it. + elseif(min_chite < maxh(iv).and.min_chite > minh(iv).and.max_chite > maxh(iv))then + frac_canopy(iv) = (maxh(iv) -min_chite ) / (currentCohort%hite*EDecophyscon%crown(ft)) + ! this is the layer with the top of the canopy in it. + elseif(max_chite > minh(iv).and.max_chite < maxh(iv).and.min_chite < minh(iv))then + frac_canopy(iv) = (max_chite - minh(iv)) / (currentCohort%hite*EDecophyscon%crown(ft)) + 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 + fraction_exposed = 1.0_r8 !default. + + snowdp(c) = snow_depth(c) * frac_sno_eff(c) + if(snowdp(c) > maxh(iv))then + fraction_exposed = 0._r8 + endif + if(snowdp(c) < minh(iv))then + fraction_exposed = 1._r8 + endif + if(snowdp(c) >= minh(iv).and.snowdp(c) <= maxh(iv))then !only partly hidden... + fraction_exposed = max(0._r8,(min(1.0_r8,(snowdp(c)-minh(iv))/dh))) + endif + + ! no m2 of leaf per m2 of ground in each height class + ! FIX(SPM,032414) these should be uncommented this and double check + !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 + + enddo ! (iv) hite bins + + currentCohort => currentCohort%taller + + enddo !currentCohort + + !check + currentPatch%lai = 0._r8 + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + currentPatch%lai = currentPatch%lai +currentCohort%lai + currentCohort => currentCohort%taller + enddo !currentCohort + lai = 0.0_r8 + do ft = 1,numpft_ed + lai = lai+ sum(currentPatch%tlai_profile(1,ft,:)) + enddo + + if(lai > currentPatch%lai)then + write(iulog,*) 'problem with lai assignments' + endif + + + else ! smooth leaf distribution + !Go through all cohorts and add their leaf area and canopy area to the accumulators. + currentPatch%tlai_profile = 0._r8 + currentPatch%tsai_profile = 0._r8 + currentPatch%elai_profile = 0._r8 + currentPatch%esai_profile = 0._r8 + currentPatch%canopy_area_profile(:,:,:) = 0._r8 + currentPatch%ncan(:,:) = 0 + currentPatch%nrad(:,:) = 0 + currentCohort => currentPatch%shortest + + do while(associated(currentCohort)) + L = currentCohort%canopy_layer + ft = currentCohort%pft + !Calculate the number of layers of thickness dlai, including the last one. + currentCohort%NV = CEILING((currentCohort%treelai+currentCohort%treesai)/dinc_ed) + !how much of each tree is stem area index? Assuming that there is + if(currentCohort%treelai+currentCohort%treesai > 0._r8)then + fleaf = currentCohort%lai / (currentCohort%lai + currentCohort%sai) + else + fleaf = 0._r8 + write(iulog,*) 'no stem or leaf area' ,currentCohort%pft,currentCohort%bl, & + currentCohort%balive,currentCohort%treelai,currentCohort%treesai,currentCohort%dbh, & + currentCohort%n,currentCohort%status_coh + endif + currentPatch%ncan(L,ft) = max(currentPatch%ncan(L,ft),currentCohort%NV) + currentPatch%nrad(L,ft) = currentPatch%ncan(L,ft) !fudge - this needs to be altered for snow burial + if(currentCohort%NV > currentPatch%nrad(L,ft))then + write(iulog,*) 'CF: issue with NV',currentCohort%NV,currentCohort%pft,currentCohort%canopy_layer + endif + c = clmpatch%column(currentPatch%clm_pno) + + !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. FIX(RF,032414)- for debugging jan 2012 + do iv = 1,currentCohort%NV-1 + + currentPatch%tlai_profile(L,ft,iv) = currentPatch%tlai_profile(L,ft,iv)+ dinc_ed * fleaf * & + currentCohort%c_area/currentPatch%total_canopy_area + currentPatch%tsai_profile(L,ft,iv) = currentPatch%tsai_profile(L,ft,iv)+ dinc_ed * (1._r8 - fleaf) * & + currentCohort%c_area/currentPatch%total_canopy_area + currentPatch%canopy_area_profile(L,ft,iv) = min(1.0_r8,currentPatch%canopy_area_profile(L,ft,iv) + & + currentCohort%c_area/currentPatch%total_canopy_area) + + ! what is the height of this layer? (for snow burial purposes...) + ! pftcon%vertical_canopy_frac(ft))! fudge - this should be pft specific but i cant get it to compile. + layer_top_hite = currentCohort%hite-((iv/currentCohort%NV) * currentCohort%hite * & + EDecophyscon%crown(currentCohort%pft) ) + layer_bottom_hite = currentCohort%hite-(((iv+1)/currentCohort%NV) * currentCohort%hite * & + EDecophyscon%crown(currentCohort%pft)) ! pftcon%vertical_canopy_frac(ft)) + fraction_exposed = 1.0_r8 !default. + snowdp(c) = snow_depth(c) * frac_sno_eff(c) + if(snowdp(c) > layer_top_hite)then + fraction_exposed = 0._r8 + endif + if(snowdp(c) <= layer_bottom_hite)then + fraction_exposed = 1._r8 + endif + if(snowdp(c) > layer_bottom_hite.and.snowdp(c) <= layer_top_hite)then !only partly hidden... + fraction_exposed = max(0._r8,(min(1.0_r8,(snowdp(c)-layer_bottom_hite)/ & + (layer_top_hite-layer_bottom_hite )))) + endif + + currentPatch%elai_profile(L,ft,iv) = currentPatch%tlai_profile(L,ft,iv) *fraction_exposed + !here we are assuming that the stem and leaf area indices have the same profile... + currentPatch%esai_profile(L,ft,iv) = currentPatch%tsai_profile(L,ft,iv) *fraction_exposed + end do + + !Bottom layer + iv = currentCohort%NV + ! pftcon%vertical_canopy_frac(ft))! fudge - this should be pft specific but i cant get it to compile. + layer_top_hite = currentCohort%hite-((iv/currentCohort%NV) * currentCohort%hite * & + EDecophyscon%crown(currentCohort%pft) ) + ! pftcon%vertical_canopy_frac(ft)) + layer_bottom_hite = currentCohort%hite-(((iv+1)/currentCohort%NV) * currentCohort%hite * & + EDecophyscon%crown(currentCohort%pft)) + fraction_exposed = 1.0_r8 !default. + + fraction_exposed = 1.0_r8 !default. + if(snowdp(c) > layer_top_hite)then + fraction_exposed = 0._r8 + endif + if(snowdp(c) <= layer_bottom_hite)then + fraction_exposed = 1._r8 + endif + if(snowdp(c) > layer_bottom_hite.and.snowdp(c) <= layer_top_hite)then !only partly hidden... + fraction_exposed = max(0._r8,(min(1.0_r8,(snowdp(c)-layer_bottom_hite) / & + (layer_top_hite-layer_bottom_hite )))) + endif + + remainder = (currentCohort%treelai + currentCohort%treesai) - (dinc_ed*(currentCohort%NV-1)) + if(remainder > 1.0_r8)then + write(iulog,*)'issue with remainder',currentCohort%treelai,currentCohort%treesai,dinc_ed, & + currentCohort%NV + endif + !assumes that fleaf is unchanging FIX(RF,032414) + + currentPatch%tlai_profile(L,ft,iv) = currentPatch%tlai_profile(L,ft,iv)+ remainder * fleaf * & + currentCohort%c_area/currentPatch%total_canopy_area + + !assumes that fleaf is unchanging FIX(RF,032414) + + currentPatch%tsai_profile(L,ft,iv) = currentPatch%tsai_profile(L,ft,iv)+ remainder * & + (1.0_r8-fleaf) * currentCohort%c_area/currentPatch%total_canopy_area + currentPatch%elai_profile(L,ft,iv) = currentPatch%tlai_profile(L,ft,iv) *fraction_exposed + currentPatch%esai_profile(L,ft,iv) = currentPatch%tsai_profile(L,ft,iv) *fraction_exposed + currentPatch%canopy_area_profile(L,ft,iv) = min(1.0_r8,currentPatch%canopy_area_profile(L,ft,iv) + & + currentCohort%c_area/currentPatch%total_canopy_area) + + if(currentCohort%dbh <= 0._r8.or.currentCohort%n == 0._r8)then + write(iulog,*) 'ED: dbh or n is zero in clmedlink', currentCohort%dbh,currentCohort%n + endif + if(currentCohort%pft == 0.or.currentCohort%canopy_trim <= 0._r8)then + write(iulog,*) 'ED: PFT or trim is zero in clmedlink',currentCohort%pft,currentCohort%canopy_trim + endif + if(currentCohort%balive <= 0._r8.or.currentCohort%bl < 0._r8)then + write(iulog,*) 'ED: balive is zero in clmedlink',currentCohort%balive,currentCohort%bl + endif + + currentCohort => currentCohort%taller + + enddo !cohort + + do L = 1,currentPatch%NCL_p + do ft = 1,numpft_ed + do iv = 1,currentPatch%nrad(L,ft) + !account for total canopy area + currentPatch%tlai_profile(L,ft,iv) = currentPatch%tlai_profile(L,ft,iv) / & + currentPatch%canopy_area_profile(L,ft,iv) + currentPatch%tsai_profile(L,ft,iv) = currentPatch%tsai_profile(L,ft,iv) / & + currentPatch%canopy_area_profile(L,ft,iv) + currentPatch%elai_profile(L,ft,iv) = currentPatch%elai_profile(L,ft,iv) / & + currentPatch%canopy_area_profile(L,ft,iv) + currentPatch%esai_profile(L,ft,iv) = currentPatch%esai_profile(L,ft,iv) / & + currentPatch%canopy_area_profile(L,ft,iv) + enddo + + currentPatch%tlai_profile(L,ft,currentPatch%nrad(L,ft)+1: nlevcan_ed) = 0._r8 + currentPatch%tsai_profile(L,ft,currentPatch%nrad(L,ft)+1: nlevcan_ed) = 0._r8 + currentPatch%elai_profile(L,ft,currentPatch%nrad(L,ft)+1: nlevcan_ed) = 0._r8 + currentPatch%esai_profile(L,ft,currentPatch%nrad(L,ft)+1: nlevcan_ed) = 0._r8 + + enddo + enddo + + !what is the resultant leaf area? + + tlai_temp = 0._r8 + elai_temp = 0._r8 + tsai_temp = 0._r8 + esai_temp = 0._r8 + + do L = 1,currentPatch%NCL_p + do ft = 1,numpft_ed + + tlai_temp = tlai_temp + sum(currentPatch%canopy_area_profile(L,ft,1:currentPatch%nrad(L,ft)) * & + currentPatch%tlai_profile(L,ft,1:currentPatch%nrad(L,ft))) + elai_temp = elai_temp + sum(currentPatch%canopy_area_profile(L,ft,1:currentPatch%nrad(L,ft)) * & + currentPatch%elai_profile(L,ft,1:currentPatch%nrad(L,ft))) + tsai_temp = tsai_temp + sum(currentPatch%canopy_area_profile(L,ft,1:currentPatch%nrad(L,ft)) * & + currentPatch%tsai_profile(L,ft,1:currentPatch%nrad(L,ft))) + esai_temp = esai_temp + sum(currentPatch%canopy_area_profile(L,ft,1:currentPatch%nrad(L,ft)) * & + currentPatch%esai_profile(L,ft,1:currentPatch%nrad(L,ft))) + enddo + enddo + + p = currentPatch%clm_pno + if(abs(tlai(p)-tlai_temp) > 0.0001_r8) then + + write(iulog,*) 'error with tlai calcs',& + NC,currentSite%clmgcell, abs(tlai(p)-tlai_temp), tlai_temp,tlai(p) + + do L = 1,currentPatch%NCL_p + write(iulog,*) 'carea profile',L,currentPatch%canopy_area_profile(L,1,1:currentPatch%nrad(L,1)) + write(iulog,*) 'tlai profile',L,currentPatch%tlai_profile(L,1,1:currentPatch%nrad(L,1)) + end do + + endif + + elai(p) = max(0.1_r8,elai_temp) + tlai(p) = max(0.1_r8,tlai_temp) + esai(p) = max(0.1_r8,esai_temp) + tsai(p) = max(0.1_r8,tsai_temp) + + ! write(iulog,*) 'elai',elai(p),tlai(p),tlai_temp,elai_temp + ! write(iulog,*) 'esai',esai(p),tsai(p) + ! write(iulog,*) 'TLAI_prof',currentPatch%tlai_profile(1,:,:) + + ! Fraction of vegetation free of snow. What does this do? Is it right? + if ((elai(p) + esai(p)) > 0._r8) then + frac_veg_nosno_alb(p) = 1.0_r8 + else + frac_veg_nosno_alb(p) = 0.0_r8 + end if + ! write(iulog,*) 'frac nosno',frac_veg_nosno_alb(p) + + currentPatch%nrad = currentPatch%ncan + do L = 1,currentPatch%NCL_p + do ft = 1,numpft_ed + if(currentPatch%nrad(L,ft) > 30)then + write(iulog,*) 'ED: issue w/ nrad' + endif + currentPatch%present(L,ft) = 0 + do iv = 1, currentPatch%nrad(L,ft); + if(currentPatch%canopy_area_profile(L,ft,iv) > 0._r8)then + currentPatch%present(L,ft) = 1 + endif + end do !iv + enddo !ft + + if ( L == 1 .and. abs(sum(currentPatch%canopy_area_profile(1,1:numpft_ed,1))) < 0.99999 & + .and. currentPatch%NCL_p > 1 ) then + write(iulog,*) 'canopy area too small',sum(currentPatch%canopy_area_profile(1,1:numpft_ed,1)) + write(iulog,*) 'cohort areas', currentPatch%canopy_area_profile(1,1:numpft_ed,:) + endif + + if (L == 1 .and. currentPatch%NCL_p > 1 .and. & + abs(sum(currentPatch%canopy_area_profile(1,1:numpft_ed,1))) < 0.99999) then + write(iulog,*) 'not enough area in the top canopy', & + sum(currentPatch%canopy_area_profile(L,1:numpft_ed,1)), & + currentPatch%canopy_area_profile(L,1:numpft_ed,1) + endif + + if(abs(sum(currentPatch%canopy_area_profile(L,1:numpft_ed,1))) > 1.00001)then + write(iulog,*) 'canopy-area-profile wrong',sum(currentPatch%canopy_area_profile(L,1:numpft_ed,1)), & + currentSite%clmgcell,currentPatch%patchno,L + write(iulog,*) 'areas',currentPatch%canopy_area_profile(L,1:2,1),currentPatch%patchno + + currentCohort => currentPatch%shortest + + do while(associated(currentCohort)) + + if(currentCohort%canopy_layer==1)then + write(iulog,*) 'cohorts',currentCohort%dbh,currentCohort%c_area, & + currentPatch%total_canopy_area,currentPatch%area,currentPatch%canopy_area + write(iulog,*) 'fracarea',currentCohort%pft, currentCohort%c_area/currentPatch%total_canopy_area + endif + + currentCohort => currentCohort%taller + + enddo !currentCohort + endif + enddo ! loop over L + + do L = 1,currentPatch%NCL_p + do ft = 1,numpft_ed + if(currentPatch%present(L,FT) > 1)then + write(iulog,*) 'present issue',currentPatch%clm_pno,L,ft,currentPatch%present(L,FT) + currentPatch%present(L,ft) = 1 + endif + enddo + enddo + + endif !leaf distribution + + currentPatch => currentPatch%younger + + enddo !patch + + endif !is there soil? + + end associate + + end subroutine ed_clm_leaf_area_profile + +end module EDCLMLinkMod diff --git a/main/EDEcophysConType.F90 b/main/EDEcophysConType.F90 new file mode 100644 index 0000000000..e305510f0a --- /dev/null +++ b/main/EDEcophysConType.F90 @@ -0,0 +1,110 @@ +module EDEcophysConType + + !---------------------------------------------------- + ! ED ecophysiological constants + !---------------------------------------------------- + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + ! + implicit none + save + private + ! + ! !PUBLIC MEMBER FUNCTIONS: + public :: EDecophysconInit + ! + ! !PUBLIC TYPES: + type, public :: EDecophyscon_type + real(r8), pointer :: max_dbh (:) ! maximum dbh at which height growth ceases... + real(r8), pointer :: freezetol (:) ! minimum temperature tolerance... + real(r8), pointer :: wood_density (:) ! wood density g cm^-3 ... + real(r8), pointer :: alpha_stem (:) ! live stem turnover rate. y-1 + real(r8), pointer :: hgt_min (:) ! sapling height m + real(r8), pointer :: cushion (:) ! labile carbon storage target as multiple of leaf pool. + real(r8), pointer :: leaf_stor_priority (:) ! leaf turnover vs labile carbon use prioritisation. ! (1=lose leaves, 0=use store). + real(r8), pointer :: leafwatermax (:) ! amount of water allowed on leaf surfaces + real(r8), pointer :: rootresist (:) + real(r8), pointer :: soilbeta (:) + real(r8), pointer :: crown (:) ! fraction of the height of the plant that is occupied by crown. For fire model. + real(r8), pointer :: bark_scaler (:) ! scaler from dbh to bark thickness. For fire model. + real(r8), pointer :: crown_kill (:) ! scaler on fire death. For fire model. + real(r8), pointer :: initd (:) ! initial seedling density + real(r8), pointer :: sd_mort (:) ! rate of death of seeds produced from reproduction. + real(r8), pointer :: seed_rain (:) ! seeds that come from outside the gridbox. + real(r8), pointer :: BB_slope (:) ! ball berry slope parameter + real(r8), pointer :: root_long (:) ! root longevity (yrs) + real(r8), pointer :: clone_alloc (:) ! fraction of carbon balance allocated to clonal reproduction. + real(r8), pointer :: seed_alloc (:) ! fraction of carbon balance allocated to seeds. + real(r8), pointer :: sapwood_ratio (:) ! amount of sapwood per unit leaf carbon and m height + end type EDecophyscon_type + + type(EDecophyscon_type), public :: EDecophyscon ! ED ecophysiological constants structure + !------------------------------------------------------------------------ + +contains + + !------------------------------------------------------------------------ + subroutine EDecophysconInit(EDpftvarcon_inst, numpft) + ! + ! !USES: + use EDPftvarcon, only : EDPftvarcon_type + ! + ! !ARGUMENTS: + type(EDpftVarCon_type) , intent(in) :: EDpftvarcon_inst + integer , intent(in) :: numpft + ! + ! !LOCAL VARIABLES: + integer :: m, ib + !------------------------------------------------------------------------ + + allocate( EDecophyscon%max_dbh (0:numpft)); EDecophyscon%max_dbh (:) = nan + allocate( EDecophyscon%freezetol (0:numpft)); EDecophyscon%freezetol (:) = nan + allocate( EDecophyscon%wood_density (0:numpft)); EDecophyscon%wood_density (:) = nan + allocate( EDecophyscon%alpha_stem (0:numpft)); EDecophyscon%alpha_stem (:) = nan + allocate( EDecophyscon%hgt_min (0:numpft)); EDecophyscon%hgt_min (:) = nan + allocate( EDecophyscon%cushion (0:numpft)); EDecophyscon%cushion (:) = nan + allocate( EDecophyscon%leaf_stor_priority (0:numpft)); EDecophyscon%leaf_stor_priority (:) = nan + allocate( EDecophyscon%leafwatermax (0:numpft)); EDecophyscon%leafwatermax (:) = nan + allocate( EDecophyscon%rootresist (0:numpft)); EDecophyscon%rootresist (:) = nan + allocate( EDecophyscon%soilbeta (0:numpft)); EDecophyscon%soilbeta (:) = nan + allocate( EDecophyscon%crown (0:numpft)); EDecophyscon%crown (:) = nan + allocate( EDecophyscon%bark_scaler (0:numpft)); EDecophyscon%bark_scaler (:) = nan + allocate( EDecophyscon%crown_kill (0:numpft)); EDecophyscon%crown_kill (:) = nan + allocate( EDecophyscon%initd (0:numpft)); EDecophyscon%initd (:) = nan + allocate( EDecophyscon%sd_mort (0:numpft)); EDecophyscon%sd_mort (:) = nan + allocate( EDecophyscon%seed_rain (0:numpft)); EDecophyscon%seed_rain (:) = nan + allocate( EDecophyscon%BB_slope (0:numpft)); EDecophyscon%BB_slope (:) = nan + allocate( EDecophyscon%root_long (0:numpft)); EDecophyscon%root_long (:) = nan + allocate( EDecophyscon%seed_alloc (0:numpft)); EDecophyscon%seed_alloc (:) = nan + allocate( EDecophyscon%clone_alloc (0:numpft)); EDecophyscon%clone_alloc (:) = nan + allocate( EDecophyscon%sapwood_ratio (0:numpft)); EDecophyscon%sapwood_ratio (:) = nan + + do m = 0,numpft + EDecophyscon%max_dbh(m) = EDPftvarcon_inst%max_dbh(m) + EDecophyscon%freezetol(m) = EDPftvarcon_inst%freezetol(m) + EDecophyscon%wood_density(m) = EDPftvarcon_inst%wood_density(m) + EDecophyscon%alpha_stem(m) = EDPftvarcon_inst%alpha_stem(m) + EDecophyscon%hgt_min(m) = EDPftvarcon_inst%hgt_min(m) + EDecophyscon%cushion(m) = EDPftvarcon_inst%cushion(m) + EDecophyscon%leaf_stor_priority(m) = EDPftvarcon_inst%leaf_stor_priority(m) + EDecophyscon%leafwatermax(m) = EDPftvarcon_inst%leafwatermax(m) + EDecophyscon%rootresist(m) = EDPftvarcon_inst%rootresist(m) + EDecophyscon%soilbeta(m) = EDPftvarcon_inst%soilbeta(m) + EDecophyscon%crown(m) = EDPftvarcon_inst%crown(m) + EDecophyscon%bark_scaler(m) = EDPftvarcon_inst%bark_scaler(m) + EDecophyscon%crown_kill(m) = EDPftvarcon_inst%crown_kill(m) + EDecophyscon%initd(m) = EDPftvarcon_inst%initd(m) + EDecophyscon%sd_mort(m) = EDPftvarcon_inst%sd_mort(m) + EDecophyscon%seed_rain(m) = EDPftvarcon_inst%seed_rain(m) + EDecophyscon%bb_slope(m) = EDPftvarcon_inst%bb_slope(m) + EDecophyscon%root_long(m) = EDPftvarcon_inst%root_long(m) + EDecophyscon%seed_alloc(m) = EDPftvarcon_inst%seed_alloc(m) + EDecophyscon%clone_alloc(m) = EDPftvarcon_inst%clone_alloc(m) + EDecophyscon%sapwood_ratio(m) = EDPftvarcon_inst%sapwood_ratio(m) + end do + + end subroutine EDecophysconInit + +end module EDEcophysConType diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 new file mode 100755 index 0000000000..3390053c3f --- /dev/null +++ b/main/EDInitMod.F90 @@ -0,0 +1,388 @@ +module EDInitMod + + ! ============================================================================ + ! Contains all modules to set up the ED structure. + ! ============================================================================ + + use shr_kind_mod , only : r8 => shr_kind_r8; + use spmdMod , only : masterproc + use decompMod , only : bounds_type + use abortutils , only : endrun + use clm_varpar , only : nclmax + use clm_varctl , only : iulog, use_ed_spit_fire + use clm_time_manager , only : is_restart + use CanopyStateType , only : canopystate_type + use WaterStateType , only : waterstate_type + use GridcellType , only : grc + use pftconMod , only : pftcon + use EDPhenologyType , only : ed_phenology_type + use EDEcophysConType , only : EDecophyscon + use EDGrowthFunctionsMod , only : bdead, bleaf, dbh + use EDCohortDynamicsMod , only : create_cohort, fuse_cohorts, sort_cohorts + use EDPatchDynamicsMod , only : create_patch + use EDMainMod , only : ed_update_site + use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type, area + use EDTypesMod , only : cohorts_per_gcell, ncwd, numpft_ed, udata + use EDCLMLinkMod , only : ed_clm_type + + implicit none + private + + public :: ed_init + public :: ed_init_sites + public :: zero_site + + private :: set_site_properties + private :: init_patches + private :: init_cohorts + ! ============================================================================ + +contains + + ! ============================================================================ + subroutine ed_init( bounds, ed_allsites_inst, ed_clm_inst, & + ed_phenology_inst, waterstate_inst, canopystate_inst) + ! + ! !DESCRIPTION: + ! use ed_allsites_inst at the top level, then pass it through arg. list. then we can + ! actually use intents + ! + ! !USES: + ! + ! !ARGUMENTS + type(bounds_type) , intent(in) :: bounds ! clump bounds + type(ed_site_type) , intent(inout), target :: ed_allsites_inst( bounds%begg: ) + type(ed_clm_type) , intent(inout) :: ed_clm_inst + type(ed_phenology_type) , intent(inout) :: ed_phenology_inst + type(waterstate_type) , intent(inout) :: waterstate_inst + type(canopystate_type) , intent(inout) :: canopystate_inst + ! + ! !LOCAL VARIABLES: + integer :: g + !---------------------------------------------------------------------- + + if (masterproc) then + write(iulog,*) 'ED: restart ? = ' ,is_restart() ! FIX(SPM,032414) debug + write(iulog,*) 'ED_Mod.F90 :: SPITFIRE_SWITCH (use_ed_spit_fire) ',use_ed_spit_fire ! FIX(SPM,032414) debug + write(iulog,*) 'ED_Mod.F90 :: cohorts_per_gcell ',cohorts_per_gcell ! FIX(SPM,032414) debug + end if + + if ( .not. is_restart() ) then + call ed_init_sites( bounds, ed_allsites_inst(bounds%begg:bounds%endg)) + + do g = bounds%begg,bounds%endg + if (ed_allsites_inst(g)%istheresoil) then + call ed_update_site(ed_allsites_inst(g)) + end if + end do + + call ed_clm_inst%ed_clm_link( bounds, ed_allsites_inst(bounds%begg:bounds%endg), & + ed_phenology_inst, waterstate_inst, canopystate_inst) + endif + + end subroutine ed_init + + ! ============================================================================ + subroutine ed_init_sites( bounds, ed_allsites_inst ) + ! + ! !DESCRIPTION: + ! Intialize all ED sites + ! + ! !USES: + use ColumnType , only : col + use landunit_varcon , only : istsoil + ! + ! !ARGUMENTS + type(bounds_type) , intent(in) :: bounds + type(ed_site_type) , intent(inout), target :: ed_allsites_inst( bounds%begg: ) + ! + ! !LOCAL VARIABLES: + integer :: g,l,c + logical :: istheresoil(bounds%begg:bounds%endg) + !---------------------------------------------------------------------- + + ! INITIALISE THE SITE STRUCTURES + udata%cohort_number = 0 !Makes unique cohort identifiers. Needs zeroing at beginning of run. + + do g = bounds%begg,bounds%endg + ! zero the site + call zero_site(ed_allsites_inst(g)) + + !create clm mapping to ED structure + ed_allsites_inst(g)%clmgcell = g + ed_allsites_inst(g)%lat = grc%latdeg(g) + ed_allsites_inst(g)%lon = grc%londeg(g) + enddo + + istheresoil(bounds%begg:bounds%endg) = .false. + do c = bounds%begc,bounds%endc + g = col%gridcell(c) + if (col%itype(c) == istsoil) then + istheresoil(g) = .true. + endif + ed_allsites_inst(g)%istheresoil = istheresoil(g) + enddo + + call set_site_properties( bounds, ed_allsites_inst(bounds%begg:bounds%endg) ) + + ! on restart, this functionality is handled in EDRestVectorMod::createPatchCohortStructure + if (.not. is_restart() ) then + call init_patches( bounds, ed_allsites_inst(bounds%begg:bounds%endg) ) + endif + + end subroutine ed_init_sites + + ! ============================================================================ + subroutine zero_site( site_in ) + ! + ! !DESCRIPTION: + ! + ! !USES: + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + ! + ! !ARGUMENTS + type(ed_site_type), intent(inout) :: site_in + ! + ! !LOCAL VARIABLES: + !---------------------------------------------------------------------- + + site_in%oldest_patch => null() ! pointer to oldest patch at the site + site_in%youngest_patch => null() ! pointer to yngest patch at the site + + ! INDICES + site_in%lat = nan + site_in%lon = nan + site_in%clmgcell = 0 + site_in%clmcolumn = 0 + site_in%istheresoil = .false. + + ! DISTURBANCE + site_in%disturbance_rate = 0._r8 ! site level disturbance rates from mortality and fire. + site_in%dist_type = 0 ! disturbance dist_type id. + + ! PHENOLOGY + site_in%status = 0 ! are leaves in this pixel on or off? + site_in%dstatus = 0 + site_in%gdd = nan ! growing degree days + site_in%ncd = nan ! no chilling days + site_in%last_n_days(:) = 999 ! record of last 10 days temperature for senescence model. + site_in%leafondate = 999 ! doy of leaf on + site_in%leafoffdate = 999 ! doy of leaf off + site_in%dleafondate = 999 ! doy of leaf on drought + site_in%dleafoffdate = 999 ! doy of leaf on drought + site_in%water_memory(:) = nan + + ! FIRE + site_in%acc_ni = 0.0_r8 ! daily nesterov index accumulating over time. time unlimited theoretically. + site_in%frac_burnt = 0.0_r8 ! burn area read in from external file + + end subroutine zero_site + + ! ============================================================================ + subroutine set_site_properties( bounds, ed_allsites_inst ) + ! + ! !DESCRIPTION: + ! + ! !USES: + ! + ! !ARGUMENTS + type(bounds_type) , intent(in) :: bounds + type(ed_site_type) , intent(inout), target :: ed_allsites_inst( bounds%begg: ) + ! + ! !LOCAL VARIABLES: + integer :: i,g !beginning and end of these data clumps. + real(r8) :: leafon (bounds%begg:bounds%endg) + real(r8) :: leafoff (bounds%begg:bounds%endg) + real(r8) :: stat (bounds%begg:bounds%endg) + real(r8) :: NCD (bounds%begg:bounds%endg) + real(r8) :: GDD (bounds%begg:bounds%endg) + real(r8) :: dstat (bounds%begg:bounds%endg) + real(r8) :: acc_NI (bounds%begg:bounds%endg) + real(r8) :: watermem (bounds%begg:bounds%endg) + integer :: dleafoff (bounds%begg:bounds%endg) + integer :: dleafon (bounds%begg:bounds%endg) + !---------------------------------------------------------------------- + + if ( .not. is_restart() ) then + !initial guess numbers for site condition. + do i = bounds%begg,bounds%endg + NCD(i) = 0.0_r8 + GDD(i) = 30.0_r8 + leafon(i) = 100.0_r8 + leafoff(i) = 300.0_r8 + stat(i) = 2 + acc_NI(i) = 0.0_r8 + dstat(i) = 2 + dleafoff(i) = 300 + dleafon(i) = 100 + watermem(i) = 0.5_r8 + enddo + else ! assignements for restarts + do i = bounds%begg,bounds%endg + NCD(i) = 1.0_r8 ! NCD should be 1 on restart + !GDD(i) = 0.0_r8 + leafon(i) = 0.0_r8 + leafoff(i) = 0.0_r8 + stat(i) = 1 + acc_NI(i) = 0.0_r8 + dstat(i) = 2 + dleafoff(i) = 300 + dleafon(i) = 100 + watermem(i) = 0.5_r8 + enddo + endif + + do g = bounds%begg,bounds%endg + ed_allsites_inst(g)%gdd = GDD(g) + ed_allsites_inst(g)%ncd = NCD(g) + ed_allsites_inst(g)%leafondate = leafon(g) + ed_allsites_inst(g)%leafoffdate = leafoff(g) + ed_allsites_inst(g)%dleafoffdate = dleafoff(g) + ed_allsites_inst(g)%dleafondate = dleafon(g) + + if ( .not. is_restart() ) then + ed_allsites_inst(g)%water_memory(1:10) = watermem(g) + end if + + ed_allsites_inst(g)%status = stat(g) + !start off with leaves off to initialise + ed_allsites_inst(g)%dstatus= dstat(g) + + ed_allsites_inst(g)%acc_NI = acc_NI(g) + ed_allsites_inst(g)%frac_burnt = 0.0_r8 + ed_allsites_inst(g)%old_stock = 0.0_r8 + enddo + + end subroutine set_site_properties + + ! ============================================================================ + subroutine init_patches( bounds, ed_allsites_inst ) + ! + ! !DESCRIPTION: + !initialize patches on new ground + ! + ! !USES: + use EDParamsMod , only : ED_val_maxspread + ! + ! !ARGUMENTS + type(bounds_type) , intent(in) :: bounds + type(ed_site_type) , intent(inout), target :: ed_allsites_inst( bounds%begg: ) + ! + ! !LOCAL VARIABLES: + integer :: g + real(r8) :: cwd_ag_local(ncwd) + real(r8) :: cwd_bg_local(ncwd) + real(r8) :: spread_local(nclmax) + real(r8) :: leaf_litter_local(numpft_ed) + real(r8) :: root_litter_local(numpft_ed) + real(r8) :: seed_bank_local(numpft_ed) + real(r8) :: age !notional age of this patch + type(ed_patch_type), pointer :: newp + !---------------------------------------------------------------------- + + cwd_ag_local(:) = 0.0_r8 !ED_val_init_litter -- arbitrary value for litter pools. kgC m-2 + cwd_bg_local(:) = 0.0_r8 !ED_val_init_litter + leaf_litter_local(:) = 0.0_r8 + root_litter_local(:) = 0.0_r8 + spread_local(:) = ED_val_maxspread + seed_bank_local(:) = 0.0_r8 !Note (mv,11-04-2014, this is a bug fix - this line was missing) + age = 0.0_r8 + + !FIX(SPM,032414) clean this up...inits out of this loop + do g = bounds%begg,bounds%endg + + allocate(newp) +! call zero_patch(newp) !Note (mv,11-04-2014, this is a bug fix - this line was missing) + + newp%patchno = 1 + newp%younger => null() + newp%older => null() + + ed_allsites_inst(g)%youngest_patch => newp + ed_allsites_inst(g)%youngest_patch => newp + ed_allsites_inst(g)%oldest_patch => newp + + ! make new patch... + call create_patch(ed_allsites_inst(g), newp, age, AREA, & + spread_local, cwd_ag_local, cwd_bg_local, leaf_litter_local, & + root_litter_local, seed_bank_local) + + call init_cohorts(newp) + + enddo !gridcells + + end subroutine init_patches + + ! ============================================================================ + subroutine init_cohorts( patch_in ) + ! + ! !DESCRIPTION: + ! initialize new cohorts on bare ground + ! + ! !USES: + ! + ! !ARGUMENTS + type(ed_patch_type), intent(inout), pointer :: patch_in + ! + ! !LOCAL VARIABLES: + type(ed_cohort_type),pointer :: temp_cohort + integer :: cstatus + integer :: pft + !---------------------------------------------------------------------- + + patch_in%tallest => null() + patch_in%shortest => null() + + do pft = 1,numpft_ed !FIX(RF,032414) - turning off veg dynamics + + allocate(temp_cohort) ! temporary cohort + + temp_cohort%pft = pft + temp_cohort%n = EDecophyscon%initd(pft) * patch_in%area + temp_cohort%hite = EDecophyscon%hgt_min(pft) + temp_cohort%dbh = Dbh(temp_cohort) ! FIX(RF, 090314) - comment out addition of ' + 0.0001_r8*pft ' - seperate out PFTs a little bit... + temp_cohort%canopy_trim = 1.0_r8 + temp_cohort%bdead = Bdead(temp_cohort) + temp_cohort%balive = Bleaf(temp_cohort)*(1.0_r8 + pftcon%froot_leaf(pft) & + + EDecophyscon%sapwood_ratio(temp_cohort%pft)*temp_cohort%hite) + temp_cohort%b = temp_cohort%balive + temp_cohort%bdead + + if( pftcon%evergreen(pft) == 1) then + temp_cohort%bstore = Bleaf(temp_cohort) * EDecophyscon%cushion(pft) + temp_cohort%laimemory = 0._r8 + cstatus = 2 + endif + + if( pftcon%season_decid(pft) == 1 ) then !for dorment places + temp_cohort%bstore = Bleaf(temp_cohort) * EDecophyscon%cushion(pft) !stored carbon in new seedlings. + if(patch_in%siteptr%status == 2)then + temp_cohort%laimemory = 0.0_r8 + else + temp_cohort%laimemory = Bleaf(temp_cohort) + endif + ! reduce biomass according to size of store, this will be recovered when elaves com on. + temp_cohort%balive = temp_cohort%balive - temp_cohort%laimemory + cstatus = patch_in%siteptr%status + endif + + if ( pftcon%stress_decid(pft) == 1 ) then + temp_cohort%bstore = Bleaf(temp_cohort) * EDecophyscon%cushion(pft) + temp_cohort%laimemory = Bleaf(temp_cohort) + temp_cohort%balive = temp_cohort%balive - temp_cohort%laimemory + cstatus = patch_in%siteptr%dstatus + endif + + call create_cohort(patch_in, pft, temp_cohort%n, temp_cohort%hite, temp_cohort%dbh, & + temp_cohort%balive, temp_cohort%bdead, temp_cohort%bstore, & + temp_cohort%laimemory, cstatus, temp_cohort%canopy_trim, 1) + + deallocate(temp_cohort) ! get rid of temporary cohort + + enddo !numpft + + call fuse_cohorts(patch_in) + call sort_cohorts(patch_in) + + end subroutine init_cohorts + +end module EDInitMod diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 new file mode 100755 index 0000000000..ccabb1baed --- /dev/null +++ b/main/EDMainMod.F90 @@ -0,0 +1,492 @@ +module EDMainMod + + ! =========================================================================== + ! Main ED module. + ! ============================================================================ + + use shr_kind_mod , only : r8 => shr_kind_r8 + use decompMod , only : bounds_type + use clm_varctl , only : iulog + use atm2lndType , only : atm2lnd_type + use SoilStateType , only : soilstate_type + use TemperatureType , only : temperature_type + use WaterStateType , only : waterstate_type + use EDCohortDynamicsMod , only : allocate_live_biomass, terminate_cohorts, fuse_cohorts, sort_cohorts, count_cohorts + use EDPatchDynamicsMod , only : disturbance_rates, fuse_patches, spawn_patches, terminate_patches + use EDPhysiologyMod , only : canopy_derivs, non_canopy_derivs, phenology, recruitment, trim_canopy + use SFMainMod , only : fire_model + use EDtypesMod , only : ncwd, n_sub, numpft_ed, udata + use EDtypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type + use EDPhenologyType , only : ed_phenology_type + use EDCLMLinkMod , only : ed_clm_type + + implicit none + private + + ! + ! !PUBLIC MEMBER FUNCTIONS: + public :: ed_driver + public :: ed_update_site + ! + ! !PRIVATE MEMBER FUNCTIONS: + private :: ed_ecosystem_dynamics + private :: ed_integrate_state_variables + private :: ed_total_balance_check + + logical :: DEBUG_main = .false. + ! + ! 10/30/09: Created by Rosie Fisher + !----------------------------------------------------------------------- + +contains + + !----------------------------------------------------------------------- + subroutine ed_driver( bounds, ed_allsites_inst, ed_clm_inst, ed_phenology_inst, & + atm2lnd_inst, soilstate_inst, temperature_inst, waterstate_inst, canopystate_inst) + ! + ! !DESCRIPTION: + ! Main ed model routine containing gridcell loop + ! + ! !USES: + use clm_time_manager , only : get_days_per_year, get_curr_date + use clm_time_manager , only : get_ref_date, timemgr_datediff + use CanopySTateType , only : canopystate_type + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + type(ed_site_type) , intent(inout), target :: ed_allsites_inst( bounds%begg: ) + type(ed_clm_type) , intent(inout) :: ed_clm_inst + type(ed_phenology_type) , intent(inout) :: ed_phenology_inst + type(atm2lnd_type) , intent(in) :: atm2lnd_inst + type(soilstate_type) , intent(in) :: soilstate_inst + type(temperature_type) , intent(in) :: temperature_inst + type(waterstate_type) , intent(inout) :: waterstate_inst + type(canopystate_type) , intent(inout) :: canopystate_inst + ! + ! !LOCAL VARIABLES: + type(ed_site_type), pointer :: currentSite + real(r8) :: dayDiff ! day of run + integer :: dayDiffInt ! integer of day of run + integer :: g ! gridcell + integer :: yr ! year (0, ...) + integer :: mon ! month (1, ..., 12) + integer :: day ! day of month (1, ..., 31) + integer :: sec ! seconds of the day + integer :: ncdate ! current date + integer :: nbdate ! base date (reference date) + !----------------------------------------------------------------------- + + call ed_clm_inst%SetValues( bounds, 0._r8 ) + + ! timing statements. + n_sub = get_days_per_year() + udata%deltat = 1.0_r8/n_sub !for working out age of patches in years + if(udata%time_period == 0)then + udata%time_period = n_sub + endif + + call get_curr_date(yr, mon, day, sec) + ncdate = yr*10000 + mon*100 + day + call get_ref_date(yr, mon, day, sec) + nbdate = yr*10000 + mon*100 + day + + call timemgr_datediff(nbdate, 0, ncdate, sec, dayDiff) + + dayDiffInt = floor(dayDiff) + udata%time_period = mod( dayDiffInt , n_sub ) + + ! where most things happen + do g = bounds%begg,bounds%endg + if (ed_allsites_inst(g)%istheresoil) then + currentSite => ed_allsites_inst(g) + call ed_ecosystem_dynamics(currentSite, & + ed_clm_inst, ed_phenology_inst, atm2lnd_inst, & + soilstate_inst, temperature_inst, waterstate_inst) + + call ed_update_site( ed_allsites_inst(g)) + endif + enddo + + ! updates site & patch information + + ! link to CLM structures + call ed_clm_inst%ed_clm_link( bounds, ed_allsites_inst(bounds%begg:bounds%endg), & + ed_phenology_inst, waterstate_inst, canopystate_inst) + + write(iulog,*) 'leaving ed model',bounds%begg,bounds%endg,dayDiffInt + + end subroutine ed_driver + + !-------------------------------------------------------------------------------! + subroutine ed_ecosystem_dynamics(currentSite, & + ed_clm_inst, ed_phenology_inst, atm2lnd_inst, & + soilstate_inst, temperature_inst, waterstate_inst) + ! + ! !DESCRIPTION: + ! Core of ed model, calling all subsequent vegetation dynamics routines + ! + ! !ARGUMENTS: + type(ed_site_type) , intent(inout), pointer :: currentSite + type(ed_phenology_type) , intent(in) :: ed_phenology_inst + type(ed_clm_type) , intent(in) :: ed_clm_inst + type(atm2lnd_type) , intent(in) :: atm2lnd_inst + type(soilstate_type) , intent(in) :: soilstate_inst + type(temperature_type) , intent(in) :: temperature_inst + type(waterstate_type) , intent(in) :: waterstate_inst + ! + ! !LOCAL VARIABLES: + type(ed_patch_type), pointer :: currentPatch + !----------------------------------------------------------------------- + + !************************************************************************** + ! 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 + + call ed_total_balance_check(currentSite, 0) + + call phenology(currentSite, ed_phenology_inst, temperature_inst, waterstate_inst) + + call fire_model(currentSite, atm2lnd_inst, temperature_inst) + + ! Calculate disturbance and mortality based on previous timestep vegetation. + call disturbance_rates(currentSite) + + ! Integrate state variables from annual rates to daily timestep + call ed_integrate_state_variables(currentSite, soilstate_inst, temperature_inst, waterstate_inst) + + !****************************************************************************** + ! Reproduction, Recruitment and Cohort Dynamics : controls cohort organisation + !****************************************************************************** + + currentPatch => currentSite%oldest_patch + do while (associated(currentPatch)) + + ! adds small cohort of each PFT + call recruitment(0,currentPatch) + + currentPatch => currentPatch%younger + enddo + + call ed_total_balance_check(currentSite,1) + + currentPatch => currentSite%oldest_patch + do while (associated(currentPatch)) + + ! kills cohorts that are too small + call terminate_cohorts(currentPatch) + + ! puts cohorts in right order + call sort_cohorts(currentPatch) + + ! fuses similar cohorts + call fuse_cohorts(currentPatch) + + currentPatch => currentPatch%younger + enddo + + call ed_total_balance_check(currentSite,2) + + !********************************************************************************* + ! Patch dynamics sub-routines: fusion, new patch creation (spwaning), termination. + !********************************************************************************* + + ! make new patches from disturbed land + call spawn_patches(currentSite) + + call ed_total_balance_check(currentSite,3) + + ! fuse on the spawned patches. + call fuse_patches(currentSite) + + call ed_total_balance_check(currentSite,4) + + ! kill patches that are too small + call terminate_patches(currentSite) + + call ed_total_balance_check(currentSite,5) + + end subroutine ed_ecosystem_dynamics + + !-------------------------------------------------------------------------------! + subroutine ed_integrate_state_variables(currentSite, soilstate_inst, temperature_inst, waterstate_inst) + ! + ! !DESCRIPTION: + ! FIX(SPM,032414) refactor so everything goes through interface + ! + ! !USES: + ! + ! !ARGUMENTS: + type(ed_site_type) , intent(in) :: currentSite + type(soilstate_type) , intent(in) :: soilstate_inst + type(temperature_type) , intent(in) :: temperature_inst + type(waterstate_type) , intent(in) :: waterstate_inst + ! + ! !LOCAL VARIABLES: + type(ed_patch_type) , pointer :: currentPatch + type(ed_cohort_type) , pointer :: currentCohort + + integer :: c ! Counter for litter size class + integer :: p ! Counter for PFT + real(r8) :: small_no ! to circumvent numerical errors that cause negative values of things that can't be negative + real(r8) :: cohort_biomass_store ! remembers the biomass in the cohort for balance checking + !----------------------------------------------------------------------- + + small_no = 0.0000000000_r8 ! Obviously, this is arbitrary. RF - changed to zero + + currentPatch => currentSite%youngest_patch + + do while(associated(currentPatch)) + + currentPatch%age = currentPatch%age + udata%deltat + ! FIX(SPM,032414) valgrind 'Conditional jump or move depends on uninitialised value' + if( currentPatch%age < 0._r8 )then + write(iulog,*) 'negative patch age?',currentSite%clmgcell, currentPatch%age, & + currentPatch%patchno,currentPatch%area + endif + + ! Find the derivatives of the growth and litter processes. + call canopy_derivs(currentPatch) + + ! Update Canopy Biomass Pools + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + + cohort_biomass_store = (currentCohort%balive+currentCohort%bdead+currentCohort%bstore) + currentCohort%dbh = max(small_no,currentCohort%dbh + currentCohort%ddbhdt * udata%deltat ) + currentCohort%balive = currentCohort%balive + currentCohort%dbalivedt * udata%deltat + currentCohort%bdead = max(small_no,currentCohort%bdead + currentCohort%dbdeaddt * udata%deltat ) + currentCohort%bstore = currentCohort%bstore + currentCohort%dbstoredt * udata%deltat + + if( (currentCohort%balive+currentCohort%bdead+currentCohort%bstore)*currentCohort%n<0._r8)then + write(iulog,*) 'biomass is negative', currentCohort%n,currentCohort%balive, & + currentCohort%bdead,currentCohort%bstore + endif + + if(abs((currentCohort%balive+currentCohort%bdead+currentCohort%bstore+udata%deltat*(currentCohort%md+ & + currentCohort%seed_prod)-cohort_biomass_store)-currentCohort%npp_acc) > 1e-8_r8)then + write(iulog,*) 'issue with c balance in integration', abs(currentCohort%balive+currentCohort%bdead+ & + currentCohort%bstore+udata%deltat* & + (currentCohort%md+currentCohort%seed_prod)-cohort_biomass_store-currentCohort%npp_acc) + endif + !do we need these any more? + currentCohort%npp_acc = 0.0_r8 + currentCohort%gpp_acc = 0.0_r8 + currentCohort%resp_acc = 0.0_r8 + + call allocate_live_biomass(currentCohort) + + currentCohort => currentCohort%taller + + enddo + + write(6,*)'DEBUG18: calling non_canopy_derivs with pno= ',currentPatch%clm_pno + call non_canopy_derivs( currentPatch, temperature_inst, soilstate_inst, waterstate_inst ) + + !update state variables simultaneously according to derivatives for this time period. + do p = 1,numpft_ed + currentPatch%seed_bank(p) = currentPatch%seed_bank(p) + currentPatch%dseed_dt(p)*udata%deltat + enddo + + do c = 1,ncwd + currentPatch%cwd_ag(c) = currentPatch%cwd_ag(c) + currentPatch%dcwd_ag_dt(c)* udata%deltat + currentPatch%cwd_bg(c) = currentPatch%cwd_bg(c) + currentPatch%dcwd_bg_dt(c)* udata%deltat + enddo + + do p = 1,numpft_ed + currentPatch%leaf_litter(p) = currentPatch%leaf_litter(p) + currentPatch%dleaf_litter_dt(p)* udata%deltat + currentPatch%root_litter(p) = currentPatch%root_litter(p) + currentPatch%droot_litter_dt(p)* udata%deltat + enddo + + ! Check for negative values. Write out warning to show carbon balance. + do p = 1,numpft_ed + if(currentPatch%seed_bank(p) currentPatch%shortest + do while(associated(currentCohort)) + currentCohort%n = max(small_no,currentCohort%n + currentCohort%dndt * udata%deltat ) + currentCohort => currentCohort%taller + enddo + + currentPatch => currentPatch%older + + enddo + + end subroutine ed_integrate_state_variables + + !-------------------------------------------------------------------------------! + subroutine ed_update_site( currentSite ) + ! + ! !DESCRIPTION: + ! 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. + ! + ! !USES: + use EDCanopyStructureMod , only : canopy_spread, canopy_structure + ! + ! !ARGUMENTS: + type(ed_site_type) , intent(inout), target :: currentSite + ! + ! !LOCAL VARIABLES: + type (ed_patch_type) , pointer :: currentPatch + integer :: cohort_number ! To print out the number of cohorts. + integer :: g ! Counter for sites + !----------------------------------------------------------------------- + + call canopy_spread(currentSite) + + call ed_total_balance_check(currentSite,6) + + call canopy_structure(currentSite) + + call ed_total_balance_check(currentSite,7) + + currentPatch => currentSite%oldest_patch + do while(associated(currentPatch)) + + call terminate_cohorts(currentPatch) + + ! FIX(SPM,040314) why is this needed for BFB restarts? Look into this at some point + cohort_number = count_cohorts(currentPatch) + if (DEBUG_main) then + write(iulog,*) 'tempCount ',cohort_number + endif + ! Note (RF) + ! This breaks the balance check, but if we leave it out, then + ! the first new patch that isn't fused has no cohorts at the end of the spawn process + ! and so there are radiation errors instead. + ! Fixing this would likely require a re-work of how seed germination works which would be tricky. + if(currentPatch%countcohorts < 1)then + !write(iulog,*) 'ED: calling recruitment for no cohorts',currentPatch%siteptr%clmgcell,currentPatch%patchno + !call recruitment(1,currentPatch) + ! write(iulog,*) 'patch empty',currentPatch%area,currentPatch%age + endif + + currentPatch => currentPatch%younger + + enddo + + ! FIX(RF,032414). This needs to be monthly, not annual + if((udata%time_period == N_SUB-1))then + write(iulog,*) 'calling trim canopy' + call trim_canopy(currentSite) + endif + + end subroutine ed_update_site + + !-------------------------------------------------------------------------------! + subroutine ed_total_balance_check (currentSite, call_index ) + ! + ! !DESCRIPTION: + ! This routine looks at the carbon in and out of the ED model and compares it to + ! the change in total carbon stocks. + ! Fluxes in are NPP. Fluxes out are decay of CWD and litter into SOM pools. + ! ed_allsites_inst%flux_out and ed_allsites_inst%flux_in are set where they occur + ! in the code. + ! + ! !ARGUMENTS: + type(ed_site_type) , intent(inout) :: currentSite + integer , intent(in) :: call_index + ! + ! !LOCAL VARIABLES: + real(r8) :: biomass_stock ! total biomass in KgC/site + real(r8) :: litter_stock ! total litter in KgC/site + real(r8) :: seed_stock ! total seed mass in KgC/site + real(r8) :: total_stock ! total ED carbon in KgC/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) :: net_flux ! Difference between recorded fluxes in and out. KgC/site + + ! 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 + !----------------------------------------------------------------------- + + change_in_stock = 0.0_r8 + biomass_stock = 0.0_r8 + litter_stock = 0.0_r8 + seed_stock = 0.0_r8 + + if (currentSite%istheresoil) then + currentPatch => currentSite%oldest_patch + do while(associated(currentPatch)) + + litter_stock = litter_stock + currentPatch%area * (sum(currentPatch%cwd_ag)+ & + sum(currentPatch%cwd_bg)+sum(currentPatch%leaf_litter)+sum(currentPatch%root_litter)) + seed_stock = seed_stock + currentPatch%area * sum(currentPatch%seed_bank) + currentCohort => currentPatch%tallest; + + do while(associated(currentCohort)) + + biomass_stock = biomass_stock + (currentCohort%bdead + currentCohort%balive + & + currentCohort%bstore) * currentCohort%n + currentCohort => currentCohort%shorter; + + enddo !end cohort loop + + currentPatch => currentPatch%younger + + enddo !end patch loop + + endif + + total_stock = biomass_stock + seed_stock +litter_stock + change_in_stock = total_stock - currentSite%old_stock + net_flux = currentSite%flux_in - currentSite%flux_out + error = abs(net_flux - change_in_stock) + + if ( abs(error) > 10e-6 ) then + write(iulog,*) 'total error:in,out,net,dstock,error',call_index, currentSite%flux_in, & + currentSite%flux_out,net_flux,change_in_stock,error + write(iulog,*) 'biomass,litter,seeds', biomass_stock,litter_stock,seed_stock + write(iulog,*) 'lat lon',currentSite%lat,currentSite%lon + endif + + currentSite%flux_in = 0.0_r8 + currentSite%flux_out = 0.0_r8 + currentSite%old_stock = total_stock + + end subroutine ed_total_balance_check + +end module EDMainMod diff --git a/main/EDParamsMod.F90 b/main/EDParamsMod.F90 new file mode 100644 index 0000000000..cf851430a1 --- /dev/null +++ b/main/EDParamsMod.F90 @@ -0,0 +1,149 @@ +module EDParamsMod + ! + ! module that deals with reading the ED parameter file + ! + use shr_kind_mod , only: r8 => shr_kind_r8 + + implicit none + save + ! private - if we allow this module to be private, it does not allow the protected values below to be + ! seen outside of this module. + + ! + ! this is what the user can use for the actual values + ! + real(r8),protected :: ED_val_grass_spread + real(r8),protected :: ED_val_comp_excln + real(r8),protected :: ED_val_stress_mort + real(r8),protected :: ED_val_dispersal + real(r8),protected :: ED_val_grperc + real(r8),protected :: ED_val_maxspread + real(r8),protected :: ED_val_minspread + real(r8),protected :: ED_val_init_litter + real(r8),protected :: ED_val_nfires + real(r8),protected :: ED_val_understorey_death + real(r8),protected :: ED_val_profile_tol + real(r8),protected :: ED_val_ag_biomass + + character(len=20),parameter :: ED_name_grass_spread = "grass_spread" + character(len=20),parameter :: ED_name_comp_excln = "comp_excln" + character(len=20),parameter :: ED_name_stress_mort = "stress_mort" + character(len=20),parameter :: ED_name_dispersal = "dispersal" + character(len=20),parameter :: ED_name_grperc = "grperc" + character(len=20),parameter :: ED_name_maxspread = "maxspread" + character(len=20),parameter :: ED_name_minspread = "minspread" + character(len=20),parameter :: ED_name_init_litter = "init_litter" + character(len=20),parameter :: ED_name_nfires = "nfires" + character(len=20),parameter :: ED_name_understorey_death = "understorey_death" + character(len=20),parameter :: ED_name_profile_tol = "profile_tol" + character(len=20),parameter :: ED_name_ag_biomass= "ag_biomass" + + public :: EDParamsRead + +contains + + !----------------------------------------------------------------------- + ! + !----------------------------------------------------------------------- + subroutine EDParamsRead(ncid) + ! + ! calls to initialize parameter instance and do ncdio read + ! + use ncdio_pio , only : file_desc_t + + implicit none + + ! arguments + type(file_desc_t),intent(inout) :: ncid ! pio netCDF file id + + call EDParamsReadLocal(ncid) + + end subroutine EDParamsRead + !----------------------------------------------------------------------- + + !----------------------------------------------------------------------- + ! + !----------------------------------------------------------------------- + subroutine EDParamsReadLocal(ncid) + ! + ! read the netcdf file and populate internalInstScalar + ! + use ncdio_pio , only : file_desc_t + use paramUtilMod , only : readNcdio + + implicit none + + ! arguments + type(file_desc_t),intent(inout) :: ncid ! pio netCDF file id + + ! local vars + character(len=32) :: subname = 'EDParamsReadLocal::' + + ! + ! call read function + ! + + call readNcdio(ncid = ncid, & + varName=ED_name_grass_spread, & + callingName=subname, & + retVal=ED_val_grass_spread) + + call readNcdio(ncid = ncid, & + varName=ED_name_comp_excln, & + callingName=subname, & + retVal=ED_val_comp_excln) + + call readNcdio(ncid = ncid, & + varName=ED_name_stress_mort, & + callingName=subname, & + retVal=ED_val_stress_mort) + + call readNcdio(ncid = ncid, & + varName=ED_name_dispersal, & + callingName=subname, & + retVal=ED_val_dispersal) + + call readNcdio(ncid = ncid, & + varName=ED_name_grperc, & + callingName=subname, & + retVal=ED_val_grperc) + + call readNcdio(ncid = ncid, & + varName=ED_name_maxspread, & + callingName=subname, & + retVal=ED_val_maxspread) + + call readNcdio(ncid = ncid, & + varName=ED_name_minspread, & + callingName=subname, & + retVal=ED_val_minspread) + + call readNcdio(ncid = ncid, & + varName=ED_name_init_litter, & + callingName=subname, & + retVal=ED_val_init_litter) + + call readNcdio(ncid = ncid, & + varName=ED_name_nfires, & + callingName=subname, & + retVal=ED_val_nfires) + + call readNcdio(ncid = ncid, & + varName=ED_name_understorey_death, & + callingName=subname, & + retVal=ED_val_understorey_death) + + call readNcdio(ncid = ncid, & + varName=ED_name_profile_tol, & + callingName=subname, & + retVal=ED_val_profile_tol) + + call readNcdio(ncid = ncid, & + varName=ED_name_ag_biomass, & + callingName=subname, & + retVal=ED_val_ag_biomass) + + end subroutine EDParamsReadLocal + !----------------------------------------------------------------------- + +end module EDParamsMod diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 new file mode 100644 index 0000000000..421828a6ba --- /dev/null +++ b/main/EDPftvarcon.F90 @@ -0,0 +1,138 @@ +module EDPftvarcon + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Module containing vegetation constants and method to + ! read and initialize vegetation (PFT) constants. + ! + ! !USES: + use clm_varpar , only : mxpft + use shr_kind_mod, only : r8 => shr_kind_r8 + + ! + ! !PUBLIC TYPES: + implicit none + save + private + + !ED specific variables. + type, public :: EDPftvarcon_type + real(r8) :: max_dbh (0:mxpft) ! maximum dbh at which height growth ceases... + real(r8) :: freezetol (0:mxpft) ! minimum temperature tolerance... + real(r8) :: wood_density (0:mxpft) ! wood density g cm^-3 ... + real(r8) :: alpha_stem (0:mxpft) ! live stem turnover rate. y-1 + real(r8) :: hgt_min (0:mxpft) ! sapling height m + real(r8) :: cushion (0:mxpft) ! labile carbon storage target as multiple of leaf pool. + real(r8) :: leaf_stor_priority (0:mxpft) ! leaf turnover vs labile carbon use prioritisation. (1 = lose leaves, 0 = use store). + real(r8) :: leafwatermax (0:mxpft) ! degree to which respiration is limited by btran if btran = 0 + real(r8) :: rootresist (0:mxpft) + real(r8) :: soilbeta (0:mxpft) + real(r8) :: crown (0:mxpft) + real(r8) :: bark_scaler (0:mxpft) + real(r8) :: crown_kill (0:mxpft) + real(r8) :: initd (0:mxpft) + real(r8) :: sd_mort (0:mxpft) + real(r8) :: seed_rain (0:mxpft) + real(r8) :: BB_slope (0:mxpft) + real(r8) :: root_long (0:mxpft) ! root longevity (yrs) + real(r8) :: clone_alloc (0:mxpft) ! fraction of carbon balance allocated to clonal reproduction. + real(r8) :: seed_alloc (0:mxpft) ! fraction of carbon balance allocated to seeds. + real(r8) :: sapwood_ratio (0:mxpft) ! amount of sapwood per unit leaf carbon and m of height. gC/gC/m + end type EDPftvarcon_type + + type(EDPftvarcon_type), public :: EDPftvarcon_inst + + ! + ! !PUBLIC MEMBER FUNCTIONS: + public :: EDpftconrd ! Read and initialize vegetation (PFT) constants + !----------------------------------------------------------------------- + +contains + + !----------------------------------------------------------------------- + subroutine EDpftconrd( ncid ) + ! + ! !DESCRIPTION: + ! Read and initialize vegetation (PFT) constants + ! + ! !USES: + use ncdio_pio , only : file_desc_t, ncd_io + use abortutils , only : endrun + ! + ! !ARGUMENTS: + implicit none + ! + type(file_desc_t), intent(inout) :: ncid ! pio netCDF file id + + ! !LOCAL VARIABLES: + + logical :: readv ! read variable in or not + character(len=32) :: subname = 'EDpftconrd' ! subroutine name + + call ncd_io('max_dbh',EDPftvarcon_inst%max_dbh, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun( trim(subname)//' ERROR: error in reading in pft data' ) + + call ncd_io('freezetol',EDPftvarcon_inst%freezetol, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun( trim(subname)//' ERROR: error in reading in pft data' ) + + call ncd_io('wood_density',EDPftvarcon_inst%wood_density, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun( trim(subname)//' ERROR: error in reading in pft data' ) + + call ncd_io('alpha_stem',EDPftvarcon_inst%alpha_stem, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun( trim(subname)//' ERROR: error in reading in pft data' ) + + call ncd_io('hgt_min',EDPftvarcon_inst%hgt_min, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun( trim(subname)//' ERROR: error in reading in pft data' ) + + call ncd_io('cushion',EDPftvarcon_inst%cushion, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun( trim(subname)//' ERROR: error in reading in pft data' ) + + call ncd_io('leaf_stor_priority',EDPftvarcon_inst%leaf_stor_priority, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun( trim(subname)//' ERROR: error in reading in pft data' ) + + call ncd_io('leafwatermax',EDPftvarcon_inst%leafwatermax, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun( trim(subname)//' ERROR: error in reading in pft data' ) + + call ncd_io('rootresist',EDPftvarcon_inst%rootresist,'read', ncid, readvar=readv) + if ( .not. readv ) call endrun( trim(subname)//' ERROR: error in reading in pft data' ) + + call ncd_io('soilbeta',EDPftvarcon_inst%soilbeta,'read', ncid, readvar=readv) + if ( .not. readv) call endrun(trim(subname)// ' ERROR : error in reading in pft data') + + call ncd_io('crown',EDPftvarcon_inst%crown,'read', ncid, readvar=readv) + if ( .not. readv) call endrun(trim(subname)// ' ERROR : error in reading in pft data') + + call ncd_io('bark_scaler',EDPftvarcon_inst%bark_scaler,'read', ncid, readvar=readv) + if ( .not. readv) call endrun(trim(subname)// ' ERROR : error in reading in pft data') + + call ncd_io('crown_kill',EDPftvarcon_inst%crown_kill,'read', ncid, readvar=readv) + if ( .not. readv) call endrun(trim(subname)// ' ERROR : error in reading in pft data') + + call ncd_io('initd',EDPftvarcon_inst%initd,'read', ncid, readvar=readv) + if ( .not. readv) call endrun(trim(subname)// ' ERROR : error in reading in pft data') + + call ncd_io('sd_mort',EDPftvarcon_inst%sd_mort,'read', ncid, readvar=readv) + if ( .not. readv) call endrun(trim(subname)// ' ERROR : error in reading in pft data') + + call ncd_io('seed_rain',EDPftvarcon_inst%seed_rain,'read', ncid, readvar=readv) + if ( .not. readv) call endrun(trim(subname)// ' ERROR : error in reading in pft data') + + call ncd_io('BB_slope',EDPftvarcon_inst%BB_slope,'read', ncid, readvar=readv) + if ( .not. readv) call endrun(trim(subname)// ' ERROR : error in reading in pft data') + + call ncd_io('root_long',EDPftvarcon_inst%root_long, 'read', ncid, readvar=readv) + if ( .not. readv) call endrun(trim(subname)// ' ERROR : error in reading in pft data') + + call ncd_io('seed_alloc',EDPftvarcon_inst%seed_alloc, 'read', ncid, readvar=readv) + if ( .not. readv) call endrun(trim(subname)// ' ERROR : error in reading in pft data') + + call ncd_io('clone_alloc',EDPftvarcon_inst%clone_alloc, 'read', ncid, readvar=readv) + if ( .not. readv) call endrun(trim(subname)// ' ERROR : error in reading in pft data') + + call ncd_io('sapwood_ratio',EDPftvarcon_inst%sapwood_ratio, 'read', ncid, readvar=readv) + if ( .not. readv) call endrun(trim(subname)// ' ERROR : error in reading in pft data') + + end subroutine EDpftconrd + +end module EDPftvarcon + diff --git a/main/EDRestVectorMod.F90 b/main/EDRestVectorMod.F90 new file mode 100755 index 0000000000..4481e42e63 --- /dev/null +++ b/main/EDRestVectorMod.F90 @@ -0,0 +1,1618 @@ +module EDRestVectorMod + +#include "shr_assert.h" + + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_log_mod , only : errMsg => shr_log_errMsg + use shr_sys_mod , only : shr_sys_abort + use clm_varctl , only : iulog + use decompMod , only : bounds_type, get_clmlevel_gsmap + use CanopyStateType , only : canopystate_type + use WaterStateType , only : waterstate_type + use pftconMod , only : pftcon + use EDTypesMod , only : area, cohorts_per_gcell, numpft_ed, numWaterMem, nclmax, numCohortsPerPatch + use EDTypesMod , only : ncwd, invalidValue + use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type + use EDPhenologyType , only : ed_phenology_type + ! + implicit none + private + ! + ! ED cohort data as a type of vectors + ! + type, public :: EDRestartVectorClass + ! + ! for vector start and stop, equivalent to begCohort and endCohort + ! + integer :: vectorLengthStart + integer :: vectorLengthStop + + logical :: DEBUG = .false. + ! + ! add ED vectors that need to be written for Restarts + ! + + ! required to map cohorts and patches to/fro + ! vectors/LinkedLists + integer, pointer :: cellWithPatch(:) + integer, pointer :: numPatchesPerCell(:) + integer, pointer :: cohortsPerPatch(:) + ! + ! cohort data + ! + real(r8), pointer :: balive(:) + real(r8), pointer :: bdead(:) + real(r8), pointer :: bl(:) + real(r8), pointer :: br(:) + real(r8), pointer :: bstore(:) + real(r8), pointer :: canopy_layer(:) + real(r8), pointer :: canopy_trim(:) + real(r8), pointer :: dbh(:) + real(r8), pointer :: hite(:) + real(r8), pointer :: laimemory(:) + real(r8), pointer :: leaf_md(:) ! this can probably be removed + real(r8), pointer :: root_md(:) ! this can probably be removed + real(r8), pointer :: n(:) + real(r8), pointer :: gpp_acc(:) + real(r8), pointer :: npp_acc(:) + real(r8), pointer :: resp_clm(:) + integer, pointer :: pft(:) + integer, pointer :: status_coh(:) + ! + ! patch level restart vars + ! indexed by ncwd + ! + real(r8), pointer :: cwd_ag(:) + real(r8), pointer :: cwd_bg(:) + ! + ! indexed by pft + ! + real(r8), pointer :: leaf_litter(:) + real(r8), pointer :: root_litter(:) + real(r8), pointer :: leaf_litter_in(:) + real(r8), pointer :: root_litter_in(:) + real(r8), pointer :: seed_bank(:) + ! + ! indext by nclmax + ! + real(r8), pointer :: spread(:) + ! + ! one per patch + ! + real(r8), pointer :: livegrass(:) ! this can probably be removed + real(r8), pointer :: age(:) + real(r8), pointer :: areaRestart(:) + ! + ! site level restart vars + ! + real(r8), pointer :: water_memory(:) + real(r8), pointer :: old_stock(:) + contains + ! + ! implement getVector and setVector + ! + procedure :: setVectors + procedure :: getVectors + ! + ! restart calls + ! + procedure :: doVectorIO + ! + ! clean up pointer arrays + ! + procedure :: deleteEDRestartVectorClass + ! + ! utility routines + ! + procedure :: convertCohortListToVector + procedure :: createPatchCohortStructure + procedure :: convertCohortVectorToList + procedure :: printIoInfoLL + procedure :: printDataInfoLL + procedure :: printDataInfoVector + + end type EDRestartVectorClass + + ! Fortran way of getting a user-defined ctor + interface EDRestartVectorClass + module procedure newEDRestartVectorClass + end interface EDRestartVectorClass + + ! + ! non type-bound procedures + ! + public :: EDRest + !-------------------------------------------------------------------------------! + +contains + + !--------------------------------------------! + ! Type-Bound Procedures Here: + !--------------------------------------------! + + !-------------------------------------------------------------------------------! + subroutine deleteEDRestartVectorClass( this ) + ! + ! !DESCRIPTION: + ! provide clean-up routine of allocated pointer arrays + ! + ! !USES: + ! + ! !ARGUMENTS: + class(EDRestartVectorClass), intent(inout) :: this + ! + ! !LOCAL VARIABLES: + deallocate(this%cellWithPatch ) + deallocate(this%numPatchesPerCell ) + deallocate(this%cohortsPerPatch ) + deallocate(this%balive ) + deallocate(this%bdead ) + deallocate(this%bl ) + deallocate(this%br ) + deallocate(this%bstore ) + deallocate(this%canopy_layer ) + deallocate(this%canopy_trim ) + deallocate(this%dbh ) + deallocate(this%hite ) + deallocate(this%laimemory ) + deallocate(this%leaf_md ) + deallocate(this%root_md ) + deallocate(this%n ) + deallocate(this%gpp_acc ) + deallocate(this%npp_acc ) + deallocate(this%resp_clm ) + deallocate(this%pft ) + deallocate(this%status_coh ) + deallocate(this%cwd_ag ) + deallocate(this%cwd_bg ) + deallocate(this%leaf_litter ) + deallocate(this%root_litter ) + deallocate(this%leaf_litter_in ) + deallocate(this%root_litter_in ) + deallocate(this%seed_bank ) + deallocate(this%spread ) + deallocate(this%livegrass ) + deallocate(this%age ) + deallocate(this%areaRestart ) + deallocate(this%water_memory ) + deallocate(this%old_stock ) + + end subroutine deleteEDRestartVectorClass + + !-------------------------------------------------------------------------------! + function newEDRestartVectorClass( bounds ) + ! + ! !DESCRIPTION: + ! provide user-defined ctor, with array length argument + ! allocate memory for vector to write + ! + ! !USES: + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds ! bounds + ! + ! !LOCAL VARIABLES: + type(EDRestartVectorClass) :: newEDRestartVectorClass + integer :: retVal = 99 + integer, parameter :: allocOK = 0 + !----------------------------------------------------------------------- + + associate( new => newEDRestartVectorClass) + + ! set class variables + new%vectorLengthStart = bounds%begCohort + new%vectorLengthStop = bounds%endCohort + + ! + ! cohort level variables that are required on restart + ! + + allocate(new%cellWithPatch & + (bounds%begg:bounds%endg), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%cellWithPatch(:) = 0 + + allocate(new%numPatchesPerCell & + (bounds%begg:bounds%endg), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%numPatchesPerCell(:) = invalidValue + + allocate(new%cohortsPerPatch & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%cohortsPerPatch(:) = invalidValue + + allocate(new%balive & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%balive(:) = 0.0_r8 + + allocate(new%bdead & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%bdead(:) = 0.0_r8 + + allocate(new%bl & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%bl(:) = 0.0_r8 + + allocate(new%br & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%br(:) = 0.0_r8 + + allocate(new%bstore & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%bstore(:) = 0.0_r8 + + allocate(new%canopy_layer & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%canopy_layer(:) = 0.0_r8 + + allocate(new%canopy_trim & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%canopy_trim(:) = 0.0_r8 + + allocate(new%dbh & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%dbh(:) = 0.0_r8 + + allocate(new%hite & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%hite(:) = 0.0_r8 + + allocate(new%laimemory & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%laimemory(:) = 0.0_r8 + + allocate(new%leaf_md & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%leaf_md(:) = 0.0_r8 + + allocate(new%root_md & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%root_md(:) = 0.0_r8 + + allocate(new%n & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%n(:) = 0.0_r8 + + allocate(new%gpp_acc & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%gpp_acc(:) = 0.0_r8 + + allocate(new%npp_acc & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%npp_acc(:) = 0.0_r8 + + allocate(new%resp_clm & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%resp_clm(:) = 0.0_r8 + + allocate(new%pft & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%pft(:) = 0 + + allocate(new%status_coh & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%status_coh(:) = 0 + + ! + ! some patch level variables that are required on restart + ! + allocate(new%cwd_ag & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%cwd_ag(:) = 0.0_r8 + + allocate(new%cwd_bg & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%cwd_bg(:) = 0.0_r8 + + allocate(new%leaf_litter & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%leaf_litter(:) = 0.0_r8 + + allocate(new%root_litter & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%root_litter(:) = 0.0_r8 + + allocate(new%leaf_litter_in & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%leaf_litter_in(:) = 0.0_r8 + + allocate(new%root_litter_in & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%root_litter_in(:) = 0.0_r8 + + allocate(new%seed_bank & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%seed_bank(:) = 0.0_r8 + + allocate(new%spread & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%spread(:) = 0.0_r8 + + allocate(new%livegrass & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%livegrass(:) = 0.0_r8 + + allocate(new%age & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%age(:) = 0.0_r8 + + allocate(new%areaRestart & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%areaRestart(:) = 0.0_r8 + + ! + ! site level variable + ! + + allocate(new%water_memory & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%water_memory(:) = 0.0_r8 + + allocate(new%old_stock & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%old_stock(:) = 0.0_r8 + + end associate + + end function newEDRestartVectorClass + + !-------------------------------------------------------------------------------! + subroutine setVectors( this, bounds, ed_allsites_inst ) + ! + ! !DESCRIPTION: + ! implement setVectors + ! + ! !USES: + use clm_time_manager , only : get_nstep + ! + ! !ARGUMENTS: + class(EDRestartVectorClass) , intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + type(ed_site_type) , intent(in), target :: ed_allsites_inst( bounds%begg: ) + ! + ! !LOCAL VARIABLES: + !----------------------------------------------------------------------- + + write(iulog,*) 'edtime setVectors ',get_nstep() + + if (this%DEBUG) then + call this%printIoInfoLL ( bounds, ed_allsites_inst(bounds%begg:bounds%endg) ) + call this%printDataInfoLL ( bounds, ed_allsites_inst(bounds%begg:bounds%endg) ) + end if + + call this%convertCohortListToVector ( bounds, ed_allsites_inst(bounds%begg:bounds%endg) ) + + if (this%DEBUG) then + call this%printDataInfoVector ( ) + end if + + end subroutine setVectors + + !-------------------------------------------------------------------------------! + subroutine getVectors( this, bounds, ed_allsites_inst, ed_clm_inst, & + ed_phenology_inst, waterstate_inst, canopystate_inst) + ! + ! !DESCRIPTION: + ! implement getVectors + ! + ! !USES: + use clm_time_manager , only : get_nstep + use EDCLMLinkMod , only : ed_clm_type + use EDInitMod , only : ed_init_sites + use EDMainMod , only : ed_update_site + ! + ! !ARGUMENTS: + class(EDRestartVectorClass) , intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + type(ed_site_type) , intent(inout), target :: ed_allsites_inst( bounds%begg: ) + type(ed_clm_type) , intent(inout) :: ed_clm_inst + type(ed_phenology_type) , intent(inout) :: ed_phenology_inst + type(waterstate_type) , intent(inout) :: waterstate_inst + type(canopystate_type) , intent(inout) :: canopystate_inst + ! + ! !LOCAL VARIABLES: + integer :: g + !----------------------------------------------------------------------- + + if (this%DEBUG) then + write(iulog,*) 'edtime getVectors ',get_nstep() + call this%printDataInfoVector ( ) + end if + + call this%createPatchCohortStructure ( bounds, ed_allsites_inst(bounds%begg:bounds%endg) ) + + call this%convertCohortVectorToList ( bounds, ed_allsites_inst(bounds%begg:bounds%endg) ) + + do g = bounds%begg,bounds%endg + if (ed_allsites_inst(g)%istheresoil) then + call ed_update_site( ed_allsites_inst(g) ) + end if + end do + + call ed_clm_inst%ed_clm_link( bounds, ed_allsites_inst(bounds%begg:bounds%endg), & + ed_phenology_inst, waterstate_inst, canopystate_inst) + + if (this%DEBUG) then + call this%printIoInfoLL ( bounds, ed_allsites_inst(bounds%begg:bounds%endg) ) + call this%printDataInfoLL ( bounds, ed_allsites_inst(bounds%begg:bounds%endg) ) + end if + + end subroutine getVectors + + !-------------------------------------------------------------------------------! + subroutine doVectorIO( this, ncid, flag ) + ! + ! !DESCRIPTION: + ! implement VectorIO + ! + ! !USES: + use ncdio_pio , only : file_desc_t, ncd_int, ncd_double + use restUtilMod, only : restartvar + use clm_varcon, only : nameg, nameCohort + use spmdMod, only : iam + use mct_mod, only : mct_gsMap, mct_gsmap_OP + ! + ! !ARGUMENTS: + class(EDRestartVectorClass), intent(inout) :: this + type(file_desc_t), intent(inout) :: ncid ! netcdf id + character(len=*) , intent(in) :: flag !'read' or 'write' + ! + ! !LOCAL VARIABLES: + logical :: readvar + character(len=16) :: dimName = trim(nameCohort) + type(mct_gsMap),pointer :: gsmap ! global seg map + integer, pointer,dimension(:) :: gsmOP ! gsmap ordered points + !----------------------------------------------------------------------- + + ! TODO(wjs, 2014-11-25) gsmap and gsmOP are computed here, but never used. Are these + ! place-holders that are intended to be used at some point, or can they be removed? + call get_clmlevel_gsmap(clmlevel='cohort', gsmap=gsmap) + call mct_gsmap_OP(gsmap, iam, gsmOP) + + ! + ! cohort level vars + ! + call restartvar(ncid=ncid, flag=flag, varname='ed_io_cellWithPatch', xtype=ncd_int, & + dim1name=nameg, & + long_name='1 if a gridcell has a patch', units='1=true,0=false', & + interpinic_flag='interp', data=this%cellWithPatch, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_io_numPatchesPerCell', xtype=ncd_int, & + dim1name=nameg, & + long_name='works with ed_cellWithPatch. num patches per gridcell', units='unitless', & + interpinic_flag='interp', data=this%numPatchesPerCell, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_io_cohortsPerPatch', xtype=ncd_int, & + dim1name=dimName, & + long_name='list of cohorts per patch. indexed by numPatchesPerCell', units='unitless', & + interpinic_flag='interp', data=this%cohortsPerPatch, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_balive', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed cohort ed_balive', units='unitless', & + interpinic_flag='interp', data=this%balive, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_bdead', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed cohort - bdead', units='unitless', & + interpinic_flag='interp', data=this%bdead, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_bl', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed cohort - bl', units='unitless', & + interpinic_flag='interp', data=this%bl, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_br', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed cohort - br', units='unitless', & + interpinic_flag='interp', data=this%br, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_bstore', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed cohort - bstore', units='unitless', & + interpinic_flag='interp', data=this%bstore, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_canopy_layer', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed cohort - canopy_layer', units='unitless', & + interpinic_flag='interp', data=this%canopy_layer, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_canopy_trim', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed cohort - canopy_trim', units='unitless', & + interpinic_flag='interp', data=this%canopy_trim, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_dbh', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed cohort - dbh', units='unitless', & + interpinic_flag='interp', data=this%dbh, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_hite', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed cohort - hite', units='unitless', & + interpinic_flag='interp', data=this%hite, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_laimemory', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed cohort - laimemory', units='unitless', & + interpinic_flag='interp', data=this%laimemory, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_leaf_md', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed cohort - leaf_md', units='unitless', & + interpinic_flag='interp', data=this%leaf_md, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_root_md', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed cohort - root_md', units='unitless', & + interpinic_flag='interp', data=this%root_md, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_n', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed cohort - n', units='unitless', & + interpinic_flag='interp', data=this%n, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_gpp_acc', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed cohort - gpp_acc', units='unitless', & + interpinic_flag='interp', data=this%gpp_acc, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_npp_acc', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed cohort - npp_acc', units='unitless', & + interpinic_flag='interp', data=this%npp_acc, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_resp_clm', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed cohort - resp_clm', units='unitless', & + interpinic_flag='interp', data=this%resp_clm, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_pft', xtype=ncd_int, & + dim1name=dimName, & + long_name='ed cohort - pft', units='unitless', & + interpinic_flag='interp', data=this%pft, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_status_coh', xtype=ncd_int, & + dim1name=dimName, & + long_name='ed cohort - status_coh', units='unitless', & + interpinic_flag='interp', data=this%status_coh, & + readvar=readvar) + + ! + ! patch level vars + ! + + call restartvar(ncid=ncid, flag=flag, varname='ed_cwd_ag', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed cohort - cwd_ag', units='unitless', & + interpinic_flag='interp', data=this%cwd_ag, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_cwd_bg', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed cohort - cwd_bg', units='unitless', & + interpinic_flag='interp', data=this%cwd_bg, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_leaf_litter', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed cohort - leaf_litter', units='unitless', & + interpinic_flag='interp', data=this%leaf_litter, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_root_litter', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed cohort - root_litter', units='unitless', & + interpinic_flag='interp', data=this%root_litter, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_leaf_litter_in', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed cohort - leaf_litter_in', units='unitless', & + interpinic_flag='interp', data=this%leaf_litter_in, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_root_litter_in', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed cohort - root_litter_in', units='unitless', & + interpinic_flag='interp', data=this%root_litter_in, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_seed_bank', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed cohort - seed_bank', units='unitless', & + interpinic_flag='interp', data=this%seed_bank, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_spread', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed cohort - spread', units='unitless', & + interpinic_flag='interp', data=this%spread, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_livegrass', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed cohort - livegrass', units='unitless', & + interpinic_flag='interp', data=this%livegrass, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_age', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed cohort - age', units='unitless', & + interpinic_flag='interp', data=this%age, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_area', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed cohort - area', units='unitless', & + interpinic_flag='interp', data=this%areaRestart, & + readvar=readvar) + + ! + ! site level vars + ! + + call restartvar(ncid=ncid, flag=flag, varname='ed_water_memory', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed cohort - water_memory', units='unitless', & + interpinic_flag='interp', data=this%water_memory, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_old_stock', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed cohort - old_stock', units='unitless', & + interpinic_flag='interp', data=this%old_stock, & + readvar=readvar) + + deallocate(gsmOP) + + end subroutine doVectorIO + + !-------------------------------------------------------------------------------! + subroutine printDataInfoVector( this ) + ! + ! !DESCRIPTION: + ! + ! !USES: + ! + ! !ARGUMENTS: + class(EDRestartVectorClass), intent(inout) :: this + ! + ! !LOCAL VARIABLES: + character(len=32) :: methodName = 'PDIV ' + integer :: iSta, iSto + !----------------------------------------------------------------------- + + iSta = this%vectorLengthStart + iSto = iSta + 1 + + write(iulog,*) trim(methodName)//' :: this%vectorLengthStart ', & + this%vectorLengthStart + write(iulog,*) trim(methodName)//' :: this%vectorLengthStop ', & + this%vectorLengthStop + + write(iulog,*) ' PDIV chk ',iSta,iSto + write(iulog,*) trim(methodName)//' :: balive ', & + this%balive(iSta:iSto) + write(iulog,*) trim(methodName)//' :: bdead ', & + this%bdead(iSta:iSto) + write(iulog,*) trim(methodName)//' :: bl ', & + this%bl(iSta:iSto) + write(iulog,*) trim(methodName)//' :: br ', & + this%br(iSta:iSto) + write(iulog,*) trim(methodName)//' :: bstore ', & + this%bstore(iSta:iSto) + + write(iulog,*) trim(methodName)//' :: canopy_layer ', & + this%canopy_layer(iSta:iSto) + write(iulog,*) trim(methodName)//' :: canopy_trim ', & + this%canopy_trim(iSta:iSto) + write(iulog,*) trim(methodName)//' :: dbh ', & + this%dbh(iSta:iSto) + + write(iulog,*) trim(methodName)//' :: hite ', & + this%hite(iSta:iSto) + write(iulog,*) trim(methodName)//' :: laimemory ', & + this%laimemory(iSta:iSto) + write(iulog,*) trim(methodName)//' :: leaf_md ', & + this%leaf_md(iSta:iSto) + write(iulog,*) trim(methodName)//' :: root_md ', & + this%root_md(iSta:iSto) + write(iulog,*) trim(methodName)//' :: n ', & + this%n(iSta:iSto) + write(iulog,*) trim(methodName)//' :: gpp_acc ', & + this%gpp_acc(iSta:iSto) + write(iulog,*) trim(methodName)//' :: npp_acc ', & + this%npp_acc(iSta:iSto) + write(iulog,*) trim(methodName)//' :: resp_clm ', & + this%resp_clm(iSta:iSto) + + write(iulog,*) trim(methodName)//' :: pft ', & + this%pft(iSta:iSto) + write(iulog,*) trim(methodName)//' :: status_coh ', & + this%status_coh(iSta:iSto) + + write(iulog,*) trim(methodName)//' :: cwd_ag ', & + this%cwd_ag(iSta:iSto) + write(iulog,*) trim(methodName)//' :: cwd_bg ', & + this%cwd_bg(iSta:iSto) + write(iulog,*) trim(methodName)//' :: leaf_litter ', & + this%leaf_litter(iSta:iSto) + write(iulog,*) trim(methodName)//' :: root_litter ', & + this%root_litter(iSta:iSto) + write(iulog,*) trim(methodName)//' :: leaf_litter_in ', & + this%leaf_litter_in(iSta:iSto) + write(iulog,*) trim(methodName)//' :: root_litter_in ', & + this%root_litter_in(iSta:iSto) + write(iulog,*) trim(methodName)//' :: seed_bank ', & + this%seed_bank(iSta:iSto) + write(iulog,*) trim(methodName)//' :: spread ', & + this%spread(iSta:iSto) + write(iulog,*) trim(methodName)//' :: livegrass ', & + this%livegrass(iSta:iSto) + write(iulog,*) trim(methodName)//' :: age ', & + this%age(iSta:iSto) + write(iulog,*) trim(methodName)//' :: area ', & + this%areaRestart(iSta:iSto) + write(iulog,*) trim(methodName)//' :: water_memory ', & + this%water_memory(iSta:iSto) + write(iulog,*) trim(methodName)//' :: old_stock ', & + this%old_stock(iSta:iSto) + + end subroutine printDataInfoVector + + !-------------------------------------------------------------------------------! + subroutine printDataInfoLL( this, bounds, ed_allsites_inst ) + ! + ! !DESCRIPTION: + ! counts the total number of cohorts over all p levels (ed_patch_type) so we + ! can allocate vectors, copy from LL -> vector and read/write restarts. + ! + ! !USES: + ! + ! !ARGUMENTS: + class(EDRestartVectorClass) , intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + type(ed_site_type) , intent(in), target :: ed_allsites_inst( bounds%begg: ) + ! + ! !LOCAL VARIABLES: + type (ed_patch_type), pointer :: currentPatch + type (ed_cohort_type), pointer :: currentCohort + integer :: g + integer :: totalCohorts + integer :: numCohort + integer :: numPatches,totPatchCount + character(len=32) :: methodName = 'printDataInfoLL ' + !----------------------------------------------------------------------- + + totalCohorts = 0 + totPatchCount = 1 + + write(iulog,*) 'vecLenStart ',this%vectorLengthStart + + g = bounds%begg + do while(g <= bounds%endg) + + if (ed_allsites_inst(g)%istheresoil) then + currentPatch => ed_allsites_inst(g)%oldest_patch + + numPatches = 1 + + do while(associated(currentPatch)) + currentCohort => currentPatch%shortest + + write(iulog,*) trim(methodName)//':: found gcell with patch(s) ',g + + numCohort = 0 + + do while(associated(currentCohort)) + + totalCohorts = totalCohorts + 1 + + write(iulog,*) trim(methodName)//' balive ' ,totalCohorts,currentCohort%balive + write(iulog,*) trim(methodName)//' bdead ' ,totalCohorts,currentCohort%bdead + write(iulog,*) trim(methodName)//' bl ' ,totalCohorts,currentCohort%bl + write(iulog,*) trim(methodName)//' br ' ,totalCohorts,currentCohort%br + write(iulog,*) trim(methodName)//' bstore ' ,totalCohorts,currentCohort%bstore + write(iulog,*) trim(methodName)//' canopy_layer ' ,totalCohorts,currentCohort%canopy_layer + write(iulog,*) trim(methodName)//' canopy_trim ' ,totalCohorts,currentCohort%canopy_trim + write(iulog,*) trim(methodName)//' dbh ' ,totalCohorts,currentCohort%dbh + write(iulog,*) trim(methodName)//' hite ' ,totalCohorts,currentCohort%hite + write(iulog,*) trim(methodName)//' laimemory ' ,totalCohorts,currentCohort%laimemory + write(iulog,*) trim(methodName)//' leaf_md ' ,totalCohorts,currentCohort%leaf_md + write(iulog,*) trim(methodName)//' root_md ' ,totalCohorts,currentCohort%root_md + write(iulog,*) trim(methodName)//' n ' ,totalCohorts,currentCohort%n + write(iulog,*) trim(methodName)//' gpp_acc ' ,totalCohorts,currentCohort%gpp_acc + write(iulog,*) trim(methodName)//' npp_acc ' ,totalCohorts,currentCohort%npp_acc + write(iulog,*) trim(methodName)//' resp_clm ' ,totalCohorts,currentCohort%resp_clm + write(iulog,*) trim(methodName)//' pft ' ,totalCohorts,currentCohort%pft + write(iulog,*) trim(methodName)//' status_coh ' ,totalCohorts,currentCohort%status_coh + + numCohort = numCohort + 1 + + currentCohort => currentCohort%taller + enddo ! currentCohort do while + + write(iulog,*) trim(methodName)//': numpatches for gcell ',& + ed_allsites_inst(g)%clmgcell, numPatches + + write(iulog,*) trim(methodName)//': patches and cohorts ',& + totPatchCount,numCohort + + write(iulog,*) trim(methodName)//' cwd_ag ' ,currentPatch%cwd_ag + write(iulog,*) trim(methodName)//' cwd_bg ' ,currentPatch%cwd_bg + write(iulog,*) trim(methodName)//' leaf_litter ' ,currentPatch%leaf_litter + write(iulog,*) trim(methodName)//' root_litter ' ,currentPatch%root_litter + write(iulog,*) trim(methodName)//' leaf_litter_in ' ,currentPatch%leaf_litter_in + write(iulog,*) trim(methodName)//' root_litter_in ' ,currentPatch%root_litter_in + write(iulog,*) trim(methodName)//' seed_bank ' ,currentPatch%seed_bank + write(iulog,*) trim(methodName)//' spread ' ,currentPatch%spread + write(iulog,*) trim(methodName)//' livegrass ' ,currentPatch%livegrass + write(iulog,*) trim(methodName)//' age ' ,currentPatch%age + write(iulog,*) trim(methodName)//' area ' ,currentPatch%area + write(iulog,*) trim(methodName)//' old_stock ' ,ed_allsites_inst(g)%old_stock + + currentPatch => currentPatch%younger + + totPatchCount = totPatchCount + 1 + numPatches = numPatches + 1 + enddo ! currentPatch do while + endif + g = g + 1 + + write(iulog,*) trim(methodName)//' water_memory ',ed_allsites_inst(g)%water_memory(1) + + enddo + + write(iulog,*) trim(methodName)//': total cohorts ',totalCohorts + + end subroutine printDataInfoLL + + !-------------------------------------------------------------------------------! + subroutine printIoInfoLL( this, bounds, ed_allsites_inst ) + ! + ! !DESCRIPTION: + ! for debugging. prints some IO info regarding cohorts/patches + ! currently prints cohort level variables + ! + ! !USES: + ! + ! !ARGUMENTS: + class(EDRestartVectorClass) , intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + type(ed_site_type) , intent(in), target :: ed_allsites_inst( bounds%begg: ) + ! + ! !LOCAL VARIABLES: + type (ed_patch_type), pointer :: currentPatch + type (ed_cohort_type), pointer :: currentCohort + integer g + integer totalCohorts + integer numCohort + integer numPatches,totPatchCount + character(len=32) :: methodName = 'printIoInfoLL ' + !----------------------------------------------------------------------- + + totalCohorts = 0 + totPatchCount = 1 + + write(iulog,*) 'vecLenStart ',this%vectorLengthStart + + g = bounds%begg + do while(g <= bounds%endg) + + if (ed_allsites_inst(g)%istheresoil) then + currentPatch => ed_allsites_inst(g)%oldest_patch + + numPatches = 1 + + do while(associated(currentPatch)) + currentCohort => currentPatch%shortest + + write(iulog,*) trim(methodName)//': found gcell with patch(s) ',g + + numCohort = 0 + + do while(associated(currentCohort)) + + totalCohorts = totalCohorts + 1 + numCohort = numCohort + 1 + + write(iulog,*) trim(methodName)//' balive ',numCohort,currentCohort%balive + write(iulog,*) trim(methodName)//' bdead ',currentCohort%bdead + write(iulog,*) trim(methodName)//' bl ',currentCohort%bl + write(iulog,*) trim(methodName)//' br ',currentCohort%br + write(iulog,*) trim(methodName)//' bstore ',currentCohort%bstore + write(iulog,*) trim(methodName)//' canopy_layer ',currentCohort%canopy_layer + write(iulog,*) trim(methodName)//' canopy_trim ',currentCohort%canopy_trim + write(iulog,*) trim(methodName)//' dbh ',currentCohort%dbh + write(iulog,*) trim(methodName)//' hite ',currentCohort%hite + write(iulog,*) trim(methodName)//' laimemory ',currentCohort%laimemory + write(iulog,*) trim(methodName)//' leaf_md ',currentCohort%leaf_md + write(iulog,*) trim(methodName)//' root_md ',currentCohort%root_md + write(iulog,*) trim(methodName)//' n ',currentCohort%n + write(iulog,*) trim(methodName)//' gpp_acc ',currentCohort%gpp_acc + write(iulog,*) trim(methodName)//' npp_acc ',currentCohort%npp_acc + write(iulog,*) trim(methodName)//' resp_clm ',currentCohort%resp_clm + write(iulog,*) trim(methodName)//' pft ',currentCohort%pft + write(iulog,*) trim(methodName)//' status_coh ',currentCohort%status_coh + + currentCohort => currentCohort%taller + enddo ! currentCohort do while + + write(iulog,*) trim(methodName)//': numpatches for gcell ',ed_allsites_inst(g)%clmgcell, numPatches + write(iulog,*) trim(methodName)//': patches and cohorts ',totPatchCount,numCohort + + currentPatch => currentPatch%younger + + totPatchCount = totPatchCount + 1 + numPatches = numPatches + 1 + enddo ! currentPatch do while + endif + g = g + 1 + enddo + + end subroutine printIoInfoLL + + !-------------------------------------------------------------------------------! + subroutine convertCohortListToVector( this, bounds, ed_allsites_inst ) + ! + ! !DESCRIPTION: + ! counts the total number of cohorts over all p levels (ed_patch_type) so we + ! can allocate vectors, copy from LL -> vector and read/write restarts. + ! + ! !USES: + use clm_varpar, only : nclmax + ! + ! !ARGUMENTS: + class(EDRestartVectorClass) , intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + type(ed_site_type) , intent(in), target :: ed_allsites_inst( bounds%begg: ) + ! + ! !LOCAL VARIABLES: + type (ed_patch_type), pointer :: currentPatch + type (ed_cohort_type), pointer :: currentCohort + integer :: g + integer :: totalCohorts ! number of cohorts starting from 1 + integer :: countCohort ! number of cohorts starting from + ! vectorLengthStart + integer :: numCohort + integer :: numPatches + integer :: totPatchCount, offsetTotPatchCount + integer :: countPft + integer :: countNcwd + integer :: countWaterMem + integer :: countNclmax + integer :: i, incrementOffset + !----------------------------------------------------------------------- + + totalCohorts = 0 + + incrementOffset = this%vectorLengthStart + countCohort = this%vectorLengthStart + countPft = this%vectorLengthStart + countNcwd = this%vectorLengthStart + countNclmax = this%vectorLengthStart + countWaterMem = this%vectorLengthStart + + g = bounds%begg + do while(g <= bounds%endg) + + if (ed_allsites_inst(g)%istheresoil)then + + currentPatch => ed_allsites_inst(g)%oldest_patch + + ! new grid cell, reset num patches + numPatches = 0 + + do while(associated(currentPatch)) + + ! found patch, increment + numPatches = numPatches + 1 + + currentCohort => currentPatch%shortest + + ! new patch, reset num cohorts + numCohort = 0 + + do while(associated(currentCohort)) + + ! found cohort, increment + numCohort = numCohort + 1 + totalCohorts = totalCohorts + 1 + + if (this%DEBUG) then + write(iulog,*) 'countCohort ',countCohort, this%vectorLengthStart, this%vectorLengthStop + endif + + this%balive(countCohort) = currentCohort%balive + this%bdead(countCohort) = currentCohort%bdead + this%bl(countCohort) = currentCohort%bl + this%br(countCohort) = currentCohort%br + this%bstore(countCohort) = currentCohort%bstore + this%canopy_layer(countCohort) = currentCohort%canopy_layer + this%canopy_trim(countCohort) = currentCohort%canopy_trim + this%dbh(countCohort) = currentCohort%dbh + this%hite(countCohort) = currentCohort%hite + this%laimemory(countCohort) = currentCohort%laimemory + this%leaf_md(countCohort) = currentCohort%leaf_md + this%root_md(countCohort) = currentCohort%root_md + this%n(countCohort) = currentCohort%n + this%gpp_acc(countCohort) = currentCohort%gpp_acc + this%npp_acc(countCohort) = currentCohort%npp_acc + this%resp_clm(countCohort) = currentCohort%resp_clm + this%pft(countCohort) = currentCohort%pft + this%status_coh(countCohort) = currentCohort%status_coh + + if (this%DEBUG) then + write(iulog,*) 'offsetNumCohorts II ',countCohort, & + numCohort + endif + + countCohort = countCohort + 1 + + currentCohort => currentCohort%taller + + enddo ! currentCohort do while + + if ( numCohort > numCohortsPerPatch ) then + write(iulog,*) 'offsetNumCohorts, numCohortsPerPatch ',countCohort, numCohortsPerPatch + call shr_sys_abort( 'error in convertCohortListToVector :: '//& + 'overrun of number of total cohorts in one patch. Try increasing cohorts for '//& + 'IO '//errMsg(__FILE__, __LINE__)) + endif + + ! + ! deal with patch level fields here + ! + this%livegrass(incrementOffset) = currentPatch%livegrass + this%age(incrementOffset) = currentPatch%age + this%areaRestart(incrementOffset) = currentPatch%area + this%old_stock(incrementOffset) = ed_allsites_inst(g)%old_stock + ! set cohorts per patch for IO + this%cohortsPerPatch( incrementOffset ) = numCohort + + if (this%DEBUG) then + write(iulog,*) 'offsetNumCohorts III ' & + ,countCohort,cohorts_per_gcell, numCohort + endif + ! + ! deal with patch level fields of arrays here + ! + ! these are arrays of length numpft_ed, each patch contains one + ! vector so we increment + do i = 1,numpft_ed ! numpft_ed currently 2 + this%leaf_litter(countPft) = currentPatch%leaf_litter(i) + this%root_litter(countPft) = currentPatch%root_litter(i) + this%leaf_litter_in(countPft) = currentPatch%leaf_litter_in(i) + this%root_litter_in(countPft) = currentPatch%root_litter_in(i) + this%seed_bank(countPft) = currentPatch%seed_bank(i) + countPft = countPft + 1 + end do + + do i = 1,ncwd ! ncwd currently 4 + this%cwd_ag(countNcwd) = currentPatch%cwd_ag(i) + this%cwd_bg(countNcwd) = currentPatch%cwd_bg(i) + countNcwd = countNcwd + 1 + end do + + do i = 1,nclmax ! nclmax currently 2 + this%spread(countNclmax) = currentPatch%spread(i) + countNclmax = countNclmax + 1 + end do + + ! set numpatches for this gcell + this%numPatchesPerCell( ed_allsites_inst(g)%clmgcell ) = numPatches + + incrementOffset = incrementOffset + numCohortsPerPatch + ! reset counters so that they are all advanced evenly. Currently + ! the offset is 10, the max of numpft_ed, ncwd, nclmax, + ! countWaterMem and the number of allowed cohorts per patch + countPft = incrementOffset + countNcwd = incrementOffset + countNclmax = incrementOffset + countCohort = incrementOffset + + write(iulog,*) 'incrementOffset, cohorts_per_gcell, numCohort, totalCohorts ', & + incrementOffset, cohorts_per_gcell, numCohort, totalCohorts + + currentPatch => currentPatch%younger + + enddo ! currentPatch do while + + ! set which gridcells have patches/cohorts + this%cellWithPatch( ed_allsites_inst(g)%clmgcell ) = 1 + + do i = 1,numWaterMem ! numWaterMem currently 10 + this%water_memory( countWaterMem ) = ed_allsites_inst(g)%water_memory(i) + countWaterMem = countWaterMem + 1 + end do + + if ( incrementOffset > cohorts_per_gcell ) then + write(iulog,*) 'incrementOffset, cohorts_per_gcell, numCohort, totalCohorts ', & + incrementOffset, cohorts_per_gcell, numCohort, totalCohorts + call shr_sys_abort( 'error in convertCohortListToVector :: '//& + 'overrun of number of total cohorts in this gcell. Try increasing cohorts for '//& + 'IO '//errMsg(__FILE__, __LINE__)) + endif + + countWaterMem = incrementOffset + + endif ! is there soil check + + g = g + 1 + + enddo + + if (this%DEBUG) then + write(iulog,*) 'total cohorts ',totalCohorts + end if + + end subroutine convertCohortListToVector + + !-------------------------------------------------------------------------------! + subroutine createPatchCohortStructure( this, bounds, ed_allsites_inst ) + ! + ! !DESCRIPTION: + ! counts the total number of cohorts over all p levels (ed_patch_type) so we + ! can allocate vectors, copy from LL -> vector and read/write restarts. + ! + ! !USES: + use EDPatchDynamicsMod , only : zero_patch + use EDGrowthFunctionsMod, only : Dbh + use EDCohortDynamicsMod, only : create_cohort + use EDInitMod , only : zero_site + use EDParamsMod , only : ED_val_maxspread + use EDPatchDynamicsMod , only : create_patch + use GridcellType , only : grc + ! + ! !ARGUMENTS: + class(EDRestartVectorClass) , intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + type(ed_site_type) , intent(inout), target :: ed_allsites_inst( bounds%begg: ) + ! + ! !LOCAL VARIABLES: + type (ed_patch_type) , pointer :: newp + type(ed_cohort_type), allocatable :: temp_cohort + real(r8) :: cwd_ag_local(ncwd),cwd_bg_local(ncwd),spread_local(nclmax) + real(r8) :: leaf_litter_local(numpft_ed),root_litter_local(numpft_ed) + real(r8) :: seed_bank_local(numpft_ed) + real(r8) :: age !notional age of this patch + integer :: cohortstatus + integer :: g,patchIdx,currIdx, fto, ft + !----------------------------------------------------------------------- + + currIdx = this%vectorLengthStart + + cwd_ag_local = 0.0_r8 !ED_val_init_litter !arbitrary value for litter pools. kgC m-2 ! + cwd_bg_local = 0.0_r8 !ED_val_init_litter + leaf_litter_local = 0.0_r8 + root_litter_local = 0.0_r8 + age = 0.0_r8 + spread_local = ED_val_maxspread + + ! + ! loop over model grid cells and create patch/cohort structure based on + ! restart data + ! + do g = bounds%begg, bounds%endg + + if (this%DEBUG) then + write(iulog,*) 'cellWithPatch ',this%cellWithPatch(g),this%numPatchesPerCell(g) + end if + + call zero_site( ed_allsites_inst(g) ) + ! + ! set a few items that are necessary on restart for ED but not on the + ! restart file + ! + ed_allsites_inst(g)%istheresoil = .true. ! if we are dealing with ED data there will always be soil + ed_allsites_inst(g)%lat = grc%latdeg(g) + ed_allsites_inst(g)%lon = grc%londeg(g) + ed_allsites_inst(g)%gdd = 0.0_r8 + ed_allsites_inst(g)%ncd = 0.0_r8 + + ! then this site has soil and should be set here + do patchIdx = 1,this%numPatchesPerCell(g) + + if (this%DEBUG) then + write(iulog,*) 'create patch ',patchIdx + write(iulog,*) 'patchIdx 1-numCohorts : ',this%cohortsPerPatch(currIdx) + end if + + ! create patch + allocate(newp) + call zero_patch(newp) + + ! make new patch + call create_patch(ed_allsites_inst(g), newp, age, AREA, & + spread_local, cwd_ag_local, cwd_bg_local, & + leaf_litter_local, root_litter_local, seed_bank_local) + + newp%siteptr => ed_allsites_inst(g) + + ! give this patch a unique patch number + newp%patchno = patchIdx + + do fto = 1, this%cohortsPerPatch(currIdx) + + allocate(temp_cohort) + + temp_cohort%n = 700.0_r8 + temp_cohort%balive = 0.0_r8 + temp_cohort%bdead = 0.0_r8 + temp_cohort%bstore = 0.0_r8 + temp_cohort%laimemory = 0.0_r8 + temp_cohort%canopy_trim = 0.0_r8 + temp_cohort%canopy_layer = 1.0_r8 + + ! set the pft (only 2 used in ed) based on odd/even cohort + ! number + ft=2 + if ((mod(fto, 2) == 0 )) then + ft=1 + endif + + cohortstatus = newp%siteptr%status + + if(pftcon%stress_decid(ft) == 1)then !drought decidous, override status. + cohortstatus = newp%siteptr%dstatus + endif + + temp_cohort%hite = 1.25_r8 + ! the dbh function should only take as an argument, the one + ! item it needs, not the entire cohort...refactor + temp_cohort%dbh = Dbh(temp_cohort) + 0.0001_r8*ft + + call create_cohort(newp, ft, temp_cohort%n, temp_cohort%hite, temp_cohort%dbh, & + temp_cohort%balive, temp_cohort%bdead, temp_cohort%bstore, & + temp_cohort%laimemory, cohortstatus, temp_cohort%canopy_trim, newp%NCL_p) + + deallocate(temp_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 (patchIdx == 1) then ! nothing associated yet. first patch is pointed to by youngest and oldest + + if (this%DEBUG) write(iulog,*) 'patchIdx ',patchIdx + + ed_allsites_inst(g)%youngest_patch => newp + ed_allsites_inst(g)%oldest_patch => newp + ed_allsites_inst(g)%youngest_patch%younger => null() + ed_allsites_inst(g)%youngest_patch%older => null() + ed_allsites_inst(g)%oldest_patch%younger => null() + ed_allsites_inst(g)%oldest_patch%older => null() + + else if (patchIdx == 2) then ! add second patch to list + + if (this%DEBUG) write(iulog,*) 'patchIdx ',patchIdx + + ed_allsites_inst(g)%youngest_patch => newp + ed_allsites_inst(g)%youngest_patch%younger => null() + ed_allsites_inst(g)%youngest_patch%older => ed_allsites_inst(g)%oldest_patch + ed_allsites_inst(g)%oldest_patch%younger => ed_allsites_inst(g)%youngest_patch + ed_allsites_inst(g)%oldest_patch%older => null() + + else ! more than 2 patches, insert patch into youngest slot + + if (this%DEBUG) write(iulog,*) 'patchIdx ',patchIdx + + newp%older => ed_allsites_inst(g)%youngest_patch + ed_allsites_inst(g)%youngest_patch%younger => newp + newp%younger => null() + ed_allsites_inst(g)%youngest_patch => newp + + endif + + currIdx = currIdx + numCohortsPerPatch + + enddo ! ends loop over patchIdx + + enddo ! ends loop over g + + end subroutine createPatchCohortStructure + + !-------------------------------------------------------------------------------! + subroutine convertCohortVectorToList( this, bounds, ed_allsites_inst ) + ! + ! !DESCRIPTION: + ! counts the total number of cohorts over all p levels (ed_patch_type) so we + ! can allocate vectors, copy from LL -> vector and read/write restarts. + ! + ! !USES: + use clm_varpar, only : nclmax + ! + ! !ARGUMENTS: + class(EDRestartVectorClass) , intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + type(ed_site_type) , intent(inout), target :: ed_allsites_inst( bounds%begg: ) + ! + ! !LOCAL VARIABLES: + type (ed_patch_type), pointer :: currentPatch + type (ed_cohort_type),pointer :: currentCohort + integer :: g + integer :: totalCohorts ! number of cohorts starting from 0 + integer :: countCohort ! number of cohorts starting from + ! vectorLengthStart + integer :: numCohort + integer :: numPatches + integer :: countPft + integer :: countNcwd + integer :: countWaterMem + integer :: countNclmax + integer :: i, incrementOffset + !----------------------------------------------------------------------- + + totalCohorts = 0 + + incrementOffset = this%vectorLengthStart + countCohort = this%vectorLengthStart + countPft = this%vectorLengthStart + countNcwd = this%vectorLengthStart + countNclmax = this%vectorLengthStart + countWaterMem = this%vectorLengthStart + + g = bounds%begg + do while(g <= bounds%endg) + + if (ed_allsites_inst(g)%istheresoil) then + currentPatch => ed_allsites_inst(g)%oldest_patch + + ! new grid cell, reset num patches + numPatches = 0 + + ed_allsites_inst(g)%clmgcell = g + + do while(associated(currentPatch)) + + ! found patch, increment + numPatches = numPatches + 1 + + currentCohort => currentPatch%shortest + + ! new patch, reset num cohorts + numCohort = 0 + + do while(associated(currentCohort)) + + ! found cohort, increment + numCohort = numCohort + 1 + totalCohorts = totalCohorts + 1 + + if (this%DEBUG) then + write(iulog,*) 'CVTL countCohort ',countCohort, this%vectorLengthStart, this%vectorLengthStop + endif + + currentCohort%balive = this%balive(countCohort) + currentCohort%bdead = this%bdead(countCohort) + currentCohort%bl = this%bl(countCohort) + currentCohort%br = this%br(countCohort) + currentCohort%bstore = this%bstore(countCohort) + currentCohort%canopy_layer = this%canopy_layer(countCohort) + currentCohort%canopy_trim = this%canopy_trim(countCohort) + currentCohort%dbh = this%dbh(countCohort) + currentCohort%hite = this%hite(countCohort) + currentCohort%laimemory = this%laimemory(countCohort) + currentCohort%leaf_md = this%leaf_md(countCohort) + currentCohort%root_md = this%root_md(countCohort) + currentCohort%n = this%n(countCohort) + currentCohort%gpp_acc = this%gpp_acc(countCohort) + currentCohort%npp_acc = this%npp_acc(countCohort) + currentCohort%resp_clm = this%resp_clm(countCohort) + currentCohort%pft = this%pft(countCohort) + currentCohort%status_coh = this%status_coh(countCohort) + + if (this%DEBUG) then + write(iulog,*) 'CVTL II ',countCohort, & + numCohort + endif + + countCohort = countCohort + 1 + + currentCohort => currentCohort%taller + + enddo ! currentPatch do while + + if ( numCohort > numCohortsPerPatch ) then + write(iulog,*) 'CVTL offsetNumCohorts, numCohortsPerPatch ',countCohort, numCohortsPerPatch + call shr_sys_abort( 'error in convertCohortListToVector :: '//& + 'overrun of number of total cohorts in one patch. Try increasing cohorts for '//& + 'IO '//errMsg(__FILE__, __LINE__)) + endif + + ! FIX(SPM,032414) move to init if you can...or make a new init function + currentPatch%leaf_litter(:) = 0.0_r8 + currentPatch%root_litter(:) = 0.0_r8 + currentPatch%leaf_litter_in(:) = 0.0_r8 + currentPatch%root_litter_in(:) = 0.0_r8 + currentPatch%seed_bank(:) = 0.0_r8 + currentPatch%spread(:) = 0.0_r8 + + ! + ! deal with patch level fields here + ! + currentPatch%livegrass = this%livegrass(incrementOffset) + currentPatch%age = this%age(incrementOffset) + currentPatch%area = this%areaRestart(incrementOffset) + ed_allsites_inst(g)%old_stock = this%old_stock(incrementOffset) + ! set cohorts per patch for IO + + if (this%DEBUG) then + write(iulog,*) 'CVTL III ' & + ,countCohort,cohorts_per_gcell, numCohort + endif + ! + ! deal with patch level fields of arrays here + ! + ! these are arrays of length numpft_ed, each patch contains one + ! vector so we increment + do i = 1,numpft_ed ! numpft_ed currently 2 + currentPatch%leaf_litter(i) = this%leaf_litter(countPft) + currentPatch%root_litter(i) = this%root_litter(countPft) + currentPatch%leaf_litter_in(i) = this%leaf_litter_in(countPft) + currentPatch%root_litter_in(i) = this%root_litter_in(countPft) + currentPatch%seed_bank(i) = this%seed_bank(countPft) + countPft = countPft + 1 + end do + + do i = 1,ncwd ! ncwd currently 4 + currentPatch%cwd_ag(i) = this%cwd_ag(countNcwd) + currentPatch%cwd_bg(i) = this%cwd_bg(countNcwd) + countNcwd = countNcwd + 1 + end do + + do i = 1,nclmax ! nclmax currently 2 + currentPatch%spread(i) = this%spread(countNclmax) + countNclmax = countNclmax + 1 + end do + + incrementOffset = incrementOffset + numCohortsPerPatch + ! reset counters so that they are all advanced evenly. Currently + ! the offset is 10, the max of numpft_ed, ncwd, nclmax, + ! countWaterMem and the number of allowed cohorts per patch + countPft = incrementOffset + countNcwd = incrementOffset + countNclmax = incrementOffset + countCohort = incrementOffset + + if (this%DEBUG) then + write(iulog,*) 'CVTL incrementOffset, cohorts_per_gcell, numCohort, totalCohorts ', & + incrementOffset, cohorts_per_gcell, numCohort, totalCohorts + endif + + currentPatch => currentPatch%younger + + enddo ! currentPatch do while + + do i = 1,numWaterMem + ed_allsites_inst(g)%water_memory(i) = this%water_memory( countWaterMem ) + countWaterMem = countWaterMem + 1 + end do + + if ( incrementOffset > cohorts_per_gcell ) then + write(iulog,*) 'CVTL incrementOffset, cohorts_per_gcell, numCohort, totalCohorts ', & + incrementOffset, cohorts_per_gcell, numCohort, totalCohorts + call shr_sys_abort( 'error in convertCohortListToVector :: '//& + 'overrun of number of total cohorts in this gcell. Try increasing cohorts for '//& + 'IO '//errMsg(__FILE__, __LINE__)) + endif + + countWaterMem = incrementOffset + + endif ! is there soil check + + g = g + 1 + + enddo + + if (this%DEBUG) then + write(iulog,*) 'CVTL total cohorts ',totalCohorts + end if + + end subroutine convertCohortVectorToList + + !--------------------------------------------! + ! Non Type-Bound Procedures Here: + !--------------------------------------------! + + !-------------------------------------------------------------------------------! + subroutine EDRest ( bounds, ncid, flag, ed_allsites_inst, ed_clm_inst, ed_phenology_inst, & + waterstate_inst, canopystate_inst ) + ! + ! !DESCRIPTION: + ! Read/write ED restart data + ! EDRest called from restFileMod.F90 + ! + ! !USES: + use ncdio_pio , only : file_desc_t + use EDCLMLinkMod , only : ed_clm_type + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds ! bounds + type(file_desc_t) , intent(inout) :: ncid ! netcdf id + character(len=*) , intent(in) :: flag !'read' or 'write' + type(ed_site_type) , intent(inout), target :: ed_allsites_inst( bounds%begg: ) + type(ed_clm_type) , intent(inout) :: ed_clm_inst + type(ed_phenology_type) , intent(inout) :: ed_phenology_inst + type(waterstate_type) , intent(inout) :: waterstate_inst + type(canopystate_type) , intent(inout) :: canopystate_inst + ! + ! !LOCAL VARIABLES: + type(EDRestartVectorClass) :: ervc + !----------------------------------------------------------------------- + ! + ! Note: ed_allsites_inst already exists and is allocated in clm_instInit + ! + ervc = newEDRestartVectorClass( bounds ) + + if ( flag == 'write' ) then + call ervc%setVectors( bounds, ed_allsites_inst(bounds%begg:bounds%endg) ) + endif + + call ervc%doVectorIO( ncid, flag ) + + if ( flag == 'read' ) then + call ervc%getVectors( bounds, ed_allsites_inst(bounds%begg:bounds%endg), ed_clm_inst, & + ed_phenology_inst, waterstate_inst, canopystate_inst) + endif + + call ervc%deleteEDRestartVectorClass () + + end subroutine EDRest + +end module EDRestVectorMod diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 new file mode 100755 index 0000000000..1362b0480a --- /dev/null +++ b/main/EDTypesMod.F90 @@ -0,0 +1,457 @@ +module EDTypesMod + + use shr_kind_mod , only : r8 => shr_kind_r8; + use decompMod , only : bounds_type + use clm_varpar , only : nlevcan_ed, nclmax, numrad, nlevgrnd + use domainMod , only : domain_type + use shr_sys_mod , only : shr_sys_flush + + implicit none + save + + !SWITCHES THAT ARE READ IN + integer RESTART ! restart flag, 1= read initial system state 0 = bare ground + + ! MODEL PARAMETERS + real(r8) :: timestep_secs ! subdaily timestep in seconds (e.g. 1800 or 3600) + integer :: n_sub ! num of substeps in year + real(r8), parameter :: AREA = 10000.0_r8 ! Notional area of simulated forest m2 + integer doy + + integer, parameter :: invalidValue = -9999 ! invalid value for gcells, + ! cohorts, and patches + + ! for setting number of patches per gridcell and number of cohorts per patch + ! for I/O and converting to a vector + integer, parameter :: numPatchesPerGridCell = 4 ! + integer, parameter :: numCohortsPerPatch = 20 ! + integer, parameter :: cohorts_per_gcell = 80 ! should be numPatchesPerGridCell*numCohortsPerPatch + integer, parameter :: numWaterMem = 10 ! watermemory saved as site level var + + ! BIOLOGY/BIOGEOCHEMISTRY + integer , parameter :: INTERNAL_RECRUITMENT = 1 ! internal recruitment fla 1=yes + integer , parameter :: EXTERNAL_RECRUITMENT = 0 ! external recruitment flag 1=yes + integer , parameter :: SENES = 10 ! Window of time over which we track temp for cold sensecence (days) + real(r8), parameter :: DINC_ED = 1.0_r8 ! size of LAI bins. + integer , parameter :: N_DIST_TYPES = 2 ! number of disturbance types (mortality, fire) + integer , parameter :: numpft_ed = 2 ! number of PFTs used in ED. + + ! SPITFIRE + integer , parameter :: NLSC = 5 ! number carbon compartments in above ground litter array + integer , parameter :: NFSC = 6 ! number fuel size classes + integer , parameter :: N_EF = 7 ! number of emission factors. One per trace gas or aerosol species. + integer, parameter :: NCWD = 4 ! number of coarse woody debris pools + integer, parameter :: lg_sf = 6 ! array index of live grass pool for spitfire + integer, parameter :: dg_sf = 1 ! array index of dead grass pool for spitfire + integer, parameter :: tr_sf = 5 ! array index of dead trunk pool for spitfire + integer, parameter :: lb_sf = 4 ! array index of lrge branch pool for spitfire + real(r8), parameter :: fire_threshold = 35.0_r8 ! threshold for fires that spread or go out. KWm-2 + + ! COHORT FUSION + real(r8), parameter :: FUSETOL = 0.6_r8 ! min fractional difference in dbh between cohorts + + ! PATCH FUSION + real(r8), parameter :: NTOL = 0.05_r8 ! min plant density for hgt bin to be used in height profile comparisons + real(r8), parameter :: HITEMAX = 30.0_r8 ! max dbh value used in hgt profile comparison + real(r8), parameter :: DBHMAX = 150.0_r8 ! max dbh value used in hgt profile comparison + integer , parameter :: N_HITE_BINS = 60 ! no. of hite bins used to distribute LAI + integer , parameter :: N_DBH_BINS = 5 ! no. of dbh bins used when comparing patches + + character*4 yearchar + + !************************************ + !** COHORT type structure ** + !************************************ + type ed_cohort_type + + ! POINTERS + type (ed_cohort_type) , pointer :: taller => null() ! pointer to next tallest cohort + type (ed_cohort_type) , pointer :: shorter => null() ! pointer to next shorter cohort + type (ed_patch_type) , pointer :: patchptr => null() ! pointer to patch that cohort is in + type (ed_site_type) , pointer :: siteptr => null() ! pointer to site that cohort is in + + ! VEGETATION STRUCTURE + integer :: pft ! pft number + real(r8) :: n ! number of individuals in cohort per 'area' (10000m2 default) + real(r8) :: dbh ! dbh: cm + real(r8) :: hite ! height: meters + integer :: indexnumber ! unique number for each cohort. (within clump?) + real(r8) :: balive ! total living biomass: kGC per indiv + real(r8) :: bdead ! dead biomass: kGC per indiv + real(r8) :: bstore ! stored carbon: kGC per indiv + real(r8) :: laimemory ! target leaf biomass- set from previous year: kGC per indiv + integer :: canopy_layer ! canopy status of cohort (1 = canopy, 2 = understorey, etc.) + real(r8) :: b ! total biomass: kGC per indiv + real(r8) :: bsw ! sapwood in stem and roots: kGC per indiv + real(r8) :: bl ! leaf biomass: kGC per indiv + real(r8) :: br ! fine root biomass: kGC per indiv + real(r8) :: lai ! leaf area index of cohort m2/m2 + real(r8) :: sai ! stem area index of cohort m2/m2 + real(r8) :: gscan ! Stomatal resistance of cohort. + real(r8) :: canopy_trim ! What is the fraction of the maximum leaf biomass that we are targeting? :- + real(r8) :: leaf_cost ! How much does it cost to maintain leaves: kgC/m2/year-1 + real(r8) :: excl_weight ! How much of this cohort is demoted each year, as a proportion of all cohorts:- + real(r8) :: prom_weight ! How much of this cohort is promoted each year, as a proportion of all cohorts:- + integer :: nv ! Number of leaf layers: - + integer :: status_coh ! growth status of plant (2 = leaves on , 1 = leaves off) + real(r8) :: c_area ! areal extent of canopy (m2) + real(r8) :: treelai ! lai of tree (total leaf area (m2) / canopy area (m2) + real(r8) :: treesai ! stem area index of tree (total stem area (m2) / canopy area (m2) + + ! CARBON FLUXES + real(r8) :: gpp ! GPP: kgC/indiv/year + real(r8) :: gpp_acc ! GPP: kgC/indiv/day + real(r8) :: gpp_clm ! GPP: kgC/indiv/timestep + real(r8) :: npp ! NPP: kgC/indiv/year + real(r8) :: npp_acc ! NPP: kgC/indiv/day + real(r8) :: npp_clm ! NPP: kgC/indiv/timestep + real(r8) :: resp ! Resp: kgC/indiv/year + real(r8) :: resp_acc ! Resp: kgC/indiv/day + real(r8) :: resp_clm ! Resp: kgC/indiv/timestep + + real(r8) :: ts_net_uptake(nlevcan_ed) ! Net uptake of leaf layers: kgC/m2/s + real(r8) :: year_net_uptake(nlevcan_ed) ! Net uptake of leaf layers: kgC/m2/year + + ! RESPIRATION COMPONENTS + real(r8) :: rd ! Dark respiration: umol/indiv/s + real(r8) :: resp_g ! Growth respiration: kgC/indiv/timestep + real(r8) :: resp_m ! Maintenance respiration: kgC/indiv/timestep + real(r8) :: livestem_mr ! Live stem maintenance respiration: kgC/indiv/s + real(r8) :: livecroot_mr ! Live coarse root maintenance respiration: kgC/indiv/s + real(r8) :: froot_mr ! Live fine root maintenance respiration: kgC/indiv/s + + ! ALLOCATION + real(r8) :: md ! plant maintenance demand: kgC/indiv/year + real(r8) :: leaf_md ! leaf maintenance demand: kgC/indiv/year + real(r8) :: root_md ! root maintenance demand: kgC/indiv/year + real(r8) :: carbon_balance ! carbon remaining for growth and storage: kg/indiv/year + real(r8) :: seed_prod ! reproduction seed and clonal: KgC/indiv/year + real(r8) :: leaf_litter ! leaf litter from phenology: KgC/m2 + real(r8) :: woody_turnover ! amount of wood lost each day: kgC/indiv/year. Currently set to zero. + + !MORTALITY + real(r8) :: dmort ! proportional mortality rate. (year-1) + + ! NITROGEN POOLS + real(r8) :: livestemn ! live stem nitrogen : KgN/invid + real(r8) :: livecrootn ! live coarse root nitrogen: KgN/invid + real(r8) :: frootn ! fine root nitrogen : KgN/invid + + ! GROWTH DERIVIATIVES + real(r8) :: dndt ! time derivative of cohort size : n/year + real(r8) :: dhdt ! time derivative of height : m/year + real(r8) :: ddbhdt ! time derivative of dbh : cm/year + real(r8) :: dbalivedt ! time derivative of total living biomass : KgC/year + real(r8) :: dbdeaddt ! time derivative of dead biomass : KgC/year + real(r8) :: dbstoredt ! time derivative of stored biomass : KgC/year + real(r8) :: storage_flux ! flux from npp into bstore : KgC/year + + ! FIRE + real(r8) :: cfa ! proportion of crown affected by fire:- + real(r8) :: cambial_mort ! probability that trees dies due to cambial char:- + real(r8) :: crownfire_mort ! probability of tree post-fire mortality due to crown scorch:- + real(r8) :: fire_mort ! post-fire mortality from cambial and crown damage assuming two are independent:- + + end type ed_cohort_type + + !************************************ + !** Patch type structure ** + !************************************ + + type ed_patch_type + + ! POINTERS + type (ed_cohort_type), pointer :: tallest => null() ! pointer to patch's tallest cohort + type (ed_cohort_type), pointer :: shortest => null() ! pointer to patch's shortest cohort + type (ed_patch_type), pointer :: older => null() ! pointer to next older patch + type (ed_patch_type), pointer :: younger => null() ! pointer to next younger patch + type (ed_site_type), pointer :: siteptr => null() ! pointer to the site that the patch is in + + !INDICES + integer :: patchno ! unique number given to each new patch created for tracking + integer :: clm_pno ! clm patch number (index of p vector) + + ! PATCH INFO + real(r8) :: age ! average patch age: years + real(r8) :: area ! patch area: m2 + integer :: countcohorts ! Number of cohorts in patch + integer :: ncl_p ! Number of occupied canopy layers + + ! LEAF ORGANIZATION + real(r8) :: spread(nclmax) ! dynamic ratio of dbh to canopy area: cm/m2 + real(r8) :: pft_agb_profile(numpft_ed,n_dbh_bins) ! binned above ground biomass, for patch fusion: KgC/m2 + real(r8) :: canopy_layer_lai(nclmax) ! lai that is shading this canopy layer: m2/m2 + real(r8) :: total_canopy_area ! area that is covered by vegetation : m2 + real(r8) :: total_tree_area ! area that is covered by woody vegetation : m2 + real(r8) :: canopy_area ! area that is covered by vegetation : m2 (is this different to total_canopy_area? + real(r8) :: bare_frac_area ! bare soil in this patch expressed as a fraction of the total soil surface. + real(r8) :: lai ! leaf area index of patch + + real(r8) :: tlai_profile(nclmax,numpft_ed,nlevcan_ed) ! total leaf area in each canopy layer, pft, and leaf layer. m2/m2 + real(r8) :: elai_profile(nclmax,numpft_ed,nlevcan_ed) ! exposed leaf area in each canopy layer, pft, and leaf layer. m2/m2 + real(r8) :: tsai_profile(nclmax,numpft_ed,nlevcan_ed) ! total stem area in each canopy layer, pft, and leaf layer. m2/m2 + real(r8) :: esai_profile(nclmax,numpft_ed,nlevcan_ed) ! exposed stem area in each canopy layer, pft, and leaf layer. m2/m2 + + real(r8) :: canopy_area_profile(nclmax,numpft_ed,nlevcan_ed) ! fraction of canopy in each canopy + ! layer, pft, and leaf layer:- + integer :: present(nclmax,numpft_ed) ! is there any of this pft in this canopy layer? + integer :: nrad(nclmax,numpft_ed) ! number of exposed leaf layers for each canopy layer and pft + integer :: ncan(nclmax,numpft_ed) ! number of total leaf layers for each canopy layer and pft + + !RADIATION FLUXES + real(r8) :: fabd_sun_z(nclmax,numpft_ed,nlevcan_ed) ! sun fraction of direct light absorbed by each canopy + ! layer, pft, and leaf layer:- + real(r8) :: fabd_sha_z(nclmax,numpft_ed,nlevcan_ed) ! shade fraction of direct light absorbed by each canopy + ! layer, pft, and leaf layer:- + real(r8) :: fabi_sun_z(nclmax,numpft_ed,nlevcan_ed) ! sun fraction of indirect light absorbed by each canopy + ! layer, pft, and leaf layer:- + real(r8) :: fabi_sha_z(nclmax,numpft_ed,nlevcan_ed) ! shade fraction of indirect light absorbed by each canopy + ! layer, pft, and leaf layer:- + + real(r8) :: ed_laisun_z(nclmax,numpft_ed,nlevcan_ed) ! amount of LAI in the sun in each canopy layer, + ! pft, and leaf layer. m2/m2 + real(r8) :: ed_laisha_z(nclmax,numpft_ed,nlevcan_ed) ! amount of LAI in the shade in each canopy layer, + real(r8) :: ed_parsun_z(nclmax,numpft_ed,nlevcan_ed) ! PAR absorbed in the sun in each canopy layer, + real(r8) :: ed_parsha_z(nclmax,numpft_ed,nlevcan_ed) ! PAR absorbed in the shade in each canopy layer, + real(r8) :: f_sun(nclmax,numpft_ed,nlevcan_ed) ! fraction of leaves in the sun in each canopy layer, pft, + ! and leaf layer. m2/m2 + real(r8) :: tr_soil_dir(numrad) ! fraction of incoming direct radiation that + ! is transmitted to the soil as direct + real(r8) :: tr_soil_dif(numrad) ! fraction of incoming diffuse radiation that + ! is transmitted to the soil as diffuse + real(r8) :: tr_soil_dir_dif(numrad) ! fraction of incoming direct radiation that + ! is transmitted to the soil as diffuse + real(r8) :: fab(numrad) ! fraction of incoming total radiation that is absorbed by the canopy + real(r8) :: fabd(numrad) ! fraction of incoming direct radiation that is absorbed by the canopy + real(r8) :: fabi(numrad) ! fraction of incoming diffuse radiation that is absorbed by the canopy + real(r8) :: sabs_dir(numrad) ! fraction of incoming direct radiation that is absorbed by the canopy + real(r8) :: sabs_dif(numrad) ! fraction of incoming diffuse radiation that is absorbed by the canopy + + + !SEED BANK + real(r8) :: seed_bank(numpft_ed) ! seed pool in KgC/m2/year + real(r8) :: seeds_in(numpft_ed) ! seed production KgC/m2/year + real(r8) :: seed_decay(numpft_ed) ! seed decay in KgC/m2/year + real(r8) :: seed_germination(numpft_ed) ! germination rate of seed pool in KgC/m2/year + real(r8) :: dseed_dt(numpft_ed) + + ! PHOTOSYNTHESIS + real(r8) :: psn_z(nclmax,numpft_ed,nlevcan_ed) ! carbon assimilation in each canopy layer, pft, and leaf layer. umolC/m2/s + real(r8) :: gpp ! total patch gpp: KgC/m2/year + real(r8) :: npp ! total patch npp: KgC/m2/year + + ! ROOTS + real(r8), allocatable :: rootfr_ft(:,:) ! root fraction of each PFT in each soil layer:- + real(r8), allocatable :: rootr_ft(:,:) ! fraction of water taken from each PFT and soil layer:- + real(r8) :: btran_ft(numpft_ed) ! btran calculated seperately for each PFT:- + + ! DISTURBANCE + real(r8) :: disturbance_rates(n_dist_types) ! disturbance rate from 1) mortality and 2) fire: fraction/day + real(r8) :: disturbance_rate ! larger effective disturbance rate: fraction/day + + ! LITTER AND COARSE WOODY DEBRIS + ! Pools of litter (non respiring) + real(r8) :: cwd_ag(ncwd) ! above ground coarse wood debris litter that does not respire. KgC/m2 + real(r8) :: cwd_bg(ncwd) ! below ground coarse wood debris litter that does not respire. KgC/m2 + real(r8) :: leaf_litter(numpft_ed) ! above ground leaf litter that does not respire. KgC/m2 + real(r8) :: root_litter(numpft_ed) ! below ground fine root litter that does not respire. KgC/m2 + + ! Fluxes of litter (non respiring) + real(r8) :: fragmentation_scaler ! Scale rate of litter fragmentation. 0 to 1. + real(r8) :: cwd_ag_in(ncwd) ! Flux into CWD_AG from turnover and mortality KgC/m2/y + real(r8) :: cwd_bg_in(ncwd) ! Flux into cwd_bg from root turnover and mortality KgC/m2/y + real(r8) :: cwd_ag_out(ncwd) ! Flux out of AG CWD into AG litter KgC/m2/y + real(r8) :: cwd_bg_out(ncwd) ! Flux out of BG CWD into BG litter KgC/m2/ + + + real(r8) :: leaf_litter_in(numpft_ed) ! Flux in to AG leaf litter from leaf turnover and mortality KgC/m2/y + real(r8) :: leaf_litter_out(numpft_ed) ! Flux out of AG leaf litter from fragmentation KgC/m2/y + real(r8) :: root_litter_in(numpft_ed) ! Flux in to BG root litter from leaf turnover and mortality KgC/m2/y + real(r8) :: root_litter_out(numpft_ed) ! Flux out of BG root from fragmentation KgC/m2/y + + ! Derivatives of litter (non respiring) + real(r8) :: dcwd_AG_dt(ncwd) ! rate of change of above ground CWD in each size class: KgC/m2/year. + real(r8) :: dcwd_BG_dt(ncwd) ! rate of change of below ground CWD in each size class: KgC/m2/year. + real(r8) :: dleaf_litter_dt(numpft_ed) ! rate of change of leaf litter in each size class: KgC/m2/year. + real(r8) :: droot_litter_dt(numpft_ed) ! rate of change of root litter in each size class: KgC/m2/year. + + real(r8) :: canopy_mortality_woody_litter ! flux of wood litter in to litter pool: KgC/m2/year + real(r8) :: canopy_mortality_leaf_litter(numpft_ed) ! flux in to leaf litter from tree death: KgC/m2/year + real(r8) :: canopy_mortality_root_litter(numpft_ed) ! flux in to froot litter from tree death: KgC/m2/year + + real(r8) :: repro(numpft_ed) ! allocation to reproduction per PFT : KgC/m2 + + !FUEL CHARECTERISTICS + real(r8) :: sum_fuel ! total ground fuel related to ros (omits 1000hr fuels): KgC/m2 + real(r8) :: fuel_frac(ncwd+2) ! fraction of each litter class in the ros_fuel:-. + real(r8) :: livegrass ! total aboveground grass biomass in patch. KgC/m2 + real(r8) :: fuel_bulkd ! average fuel bulk density of the ground fuel + ! (incl. live grasses. omits 1000hr fuels). KgC/m3 + real(r8) :: fuel_sav ! average surface area to volume ratio of the ground fuel + ! (incl. live grasses. omits 1000hr fuels). + real(r8) :: fuel_mef ! average moisture of extinction factor + ! of the ground fuel (incl. live grasses. omits 1000hr fuels). + real(r8) :: fuel_eff_moist ! effective avearage fuel moisture content of the ground fuel + ! (incl. live grasses. omits 1000hr fuels) + real(r8) :: litter_moisture(ncwd+2) + + ! FIRE SPREAD + real(r8) :: ros_front ! rate of forward spread of fire: m/min + real(r8) :: ros_back ! rate of backward spread of fire: m/min + real(r8) :: effect_wspeed ! windspeed modified by fraction of relative grass and tree cover: m/min + real(r8) :: tau_l ! Duration of lethal heating: mins + real(r8) :: fi ! average fire intensity of flaming front: kj/m/s or kw/m + integer :: fire ! Is there a fire? 1=yes 0=no + real(r8) :: fd ! fire duration: mins + real(r8) :: nf ! number of fires initiated daily: n/gridcell/day + real(r8) :: sh ! average scorch height: m + + ! FIRE EFFECTS + real(r8) :: ab ! area burnt: m2/day + real(r8) :: frac_burnt ! fraction burnt: frac gridcell/day + real(r8) :: tfc_ros ! total fuel consumed - no trunks. KgC/m2/day + real(r8) :: burnt_frac_litter(nfsc) ! fraction of each litter pool burned:- + + contains + + procedure, public :: set_root_fraction + + end type ed_patch_type + + !************************************ + !** Site type structure ** + !************************************ + + type ed_site_type + + ! POINTERS + type (ed_patch_type), pointer :: oldest_patch => null() ! pointer to oldest patch at the site + type (ed_patch_type), pointer :: youngest_patch => null() ! pointer to yngest patch at the site + + ! INDICES + real(r8) :: lat ! latitude: degrees + real(r8) :: lon ! longitude: degrees + integer :: clmgcell ! gridcell index + integer :: clmcolumn ! column index (assuming there is only one soil column in each gcell. + logical :: istheresoil ! are there any soil columns, or is this all ice/rocks/lakes? + + ! CARBON BALANCE + real(r8) :: flux_in ! for carbon balance purpose. C coming into biomass pool: KgC/site + real(r8) :: flux_out ! for carbon balance purpose. C leaving ED pools KgC/site + real(r8) :: old_stock ! for accounting purposes, remember biomass stock from last time: KgC/site + + ! DISTURBANCE + real(r8) :: disturbance_mortality ! site level disturbance rates from mortality. + real(r8) :: disturbance_fire ! site level disturbance rates from fire. + integer :: dist_type ! disturbance dist_type id. + real(r8) :: disturbance_rate ! site total dist rate + + ! PHENOLOGY + integer :: status ! are leaves in this pixel on or off for cold decid + integer :: dstatus ! are leaves in this pixel on or off for drought decid + real(r8) :: gdd ! growing degree days: deg C. + real(r8) :: ncd ! no chilling days:- + real(r8) :: last_n_days(senes) ! record of last 10 days temperature for senescence model. deg C + integer :: leafondate ! doy of leaf on:- + integer :: leafoffdate ! doy of leaf off:- + integer :: dleafondate ! doy of leaf on drought:- + integer :: dleafoffdate ! doy of leaf on drought:- + real(r8) :: water_memory(10) ! last 10 days of soil moisture memory... + real(r8) :: cwd_ag_burned(ncwd) + real(r8) :: leaf_litter_burned(numpft_ed) + + ! FIRE + real(r8) :: acc_ni ! daily nesterov index accumulating over time. + real(r8) :: ab ! daily burnt area: m2 + real(r8) :: frac_burnt ! fraction of soil burnt in this day. + + end type ed_site_type + + !************************************ + !** Userdata type structure ** + !************************************ + + type userdata + integer :: cohort_number ! Counts up the number of cohorts which have been made. + real(r8) :: deltat ! fraction of year used for each timestep (1/N_SUB) + integer :: time_period ! Within year timestep (1:N_SUB) day of year + integer :: restart_year ! Which year of simulation are we starting in? + end type userdata + + type(userdata), public, target :: udata + !-------------------------------------------------------------------------------------! + +contains + + !-------------------------------------------------------------------------------------! + function map_clmpatch_to_edpatch(site, clmpatch_number) result(edpatch_pointer) + ! + ! !ARGUMENTS + type(ed_site_type), intent(in), target :: site + integer, intent(in) :: clmpatch_number + ! + ! !LOCAL VARIABLES: + type(ed_patch_type), pointer :: edpatch_pointer + !---------------------------------------------------------------------- + + ! There is a one-to-one mapping between edpatches and clmpatches. To obtain + ! this mapping - the following is computed elsewhere in the code base + ! (1) what is the weight respective to the column of clmpatch? + ! dynEDMod determines this via the following logic + ! if (clm_patch%is_veg(p) .or. clm_patch%is_bareground(p)) then + ! clm_patch%wtcol(p) = clm_patch%wt_ed(p) + ! else + ! clm_patch%wtcol(p) = 0.0_r8 + ! end if + ! (2) is the clmpatch active? + ! subgridWeightsMod uses the following logic (in routine is_active_p) to determine if + ! clmpatch_number is active ( this is a shortened version of the logic to capture + ! only the essential parts relevent here) + ! if (clmpatch%wtcol(p) > 0._r8) is_active_p = .true. + + edpatch_pointer => site%oldest_patch + do while ( clmpatch_number /= edpatch_pointer%clm_pno ) + edpatch_pointer => edpatch_pointer%younger + end do + + end function map_clmpatch_to_edpatch + + !-------------------------------------------------------------------------------------! + subroutine set_root_fraction( this ) + ! + ! !DESCRIPTION: + ! Calculates the fractions of the root biomass in each layer for each pft. + ! + ! !USES: + use PatchType , only : clmpatch => patch + use ColumnType , only : col + use clm_varpar , only : nlevsoi + use pftconMod , only : pftcon + ! + ! !ARGUMENTS + class(ed_patch_type) :: this + ! + ! !LOCAL VARIABLES: + integer :: lev,p,c,ft + !---------------------------------------------------------------------- + + p = this%clm_pno + c = clmpatch%column(p) + + do ft = 1,numpft_ed + do lev = 1, nlevgrnd + this%rootfr_ft(ft,lev) = 0._r8 + enddo + + do lev = 1, nlevsoi-1 + this%rootfr_ft(ft,lev) = .5_r8*( & + exp(-pftcon%roota_par(ft) * col%zi(c,lev-1)) & + + exp(-pftcon%rootb_par(ft) * col%zi(c,lev-1)) & + - exp(-pftcon%roota_par(ft) * col%zi(c,lev)) & + - exp(-pftcon%rootb_par(ft) * col%zi(c,lev))) + end do + end do + + end subroutine set_root_fraction + +end module EDTypesMod diff --git a/main/EDVecCohortType.F90 b/main/EDVecCohortType.F90 new file mode 100644 index 0000000000..96dc04e9b7 --- /dev/null +++ b/main/EDVecCohortType.F90 @@ -0,0 +1,42 @@ +module EDVecCohortType + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! cohortype. mimics CLM vector subgrid types. For now this holds ED data that is + ! necessary in the rest of CLM + ! + ! !USES: + + ! !PUBLIC TYPES: + implicit none + public + ! + type, public :: ed_vec_cohort_type + integer :: cohorts_per_gridcell + integer , pointer :: gridcell(:) !index into gridcell level quantities + contains + procedure, public :: Init + end type ed_vec_cohort_type + + type(ed_vec_cohort_type), public :: ed_vec_cohort + !------------------------------------------------------------------------ + +contains + + !------------------------------------------------------------------------ + subroutine Init(this, beg, end) + ! + ! !USES: + ! + ! !ARGUMENTS: + class(ed_vec_cohort_type) :: this + integer, intent(in) :: beg, end + !------------------------------------------------------------------------ + + ! FIX(SPM,032414) pull this out and put in own ED source + + allocate(this%gridcell(beg:end)) + + end subroutine Init + +end module EDVecCohortType