From 10b40a6265191ddaa03627c6ac368dd9d3bc7d70 Mon Sep 17 00:00:00 2001 From: Ben Andre Date: Wed, 9 Dec 2015 15:12:01 -0700 Subject: [PATCH 001/437] pull clm4_5_1_r120 tags from svn --- LICENSE.txt | 34 + 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 + 24 files changed, 13154 insertions(+) create mode 100644 LICENSE.txt 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/LICENSE.txt b/LICENSE.txt new file mode 100644 index 00000000..6c74023f --- /dev/null +++ b/LICENSE.txt @@ -0,0 +1,34 @@ +Copyright (c) 2013-2015, University Corporation for Atmospheric Research (UCAR) +All rights reserved. + +Developed by: + University Corporation for Atmospheric Research - National Center for Atmospheric Research + https://www2.cesm.ucar.edu/working-groups/sewg + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the "Software"), +to deal with the Software without restriction, including without limitation +the rights to use, copy, modify, merge, publish, distribute, sublicense, +and/or sell copies of the Software, and to permit persons to whom +the Software is furnished to do so, subject to the following conditions: + + - Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimers. + - Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimers in the documentation + and/or other materials provided with the distribution. + - Neither the names of UCAR, or NCAR, + nor the names of its contributors may be used to endorse or promote + products derived from this Software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 new file mode 100755 index 00000000..133639fc --- /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 00000000..7fe96b45 --- /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 00000000..a497df20 --- /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 00000000..826e7a60 --- /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 00000000..f948fc70 --- /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 00000000..ab543045 --- /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 00000000..a51fbb5f --- /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 00000000..29312bb3 --- /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 00000000..5cfb93c7 --- /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 00000000..889c9054 --- /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 00000000..868bd984 --- /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 00000000..60194c17 --- /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 00000000..3caa526a --- /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 00000000..28dbfa2d --- /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 00000000..5de402f3 --- /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 00000000..e305510f --- /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 00000000..3390053c --- /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 00000000..ccabb1ba --- /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 00000000..cf851430 --- /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 00000000..421828a6 --- /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 00000000..4481e42e --- /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 00000000..1362b048 --- /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 00000000..96dc04e9 --- /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 From ec4f58f38c411748ce6a7f7750d1b9c2e524fd82 Mon Sep 17 00:00:00 2001 From: Ben Andre Date: Wed, 9 Dec 2015 16:03:36 -0700 Subject: [PATCH 002/437] 'pull clm4_5_6_r155 tags from svn' --- fire/SFMainMod.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index 60194c17..29679323 100755 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -755,6 +755,8 @@ subroutine crown_scorching ( currentSite ) enddo !end cohort loop !This loop weights the scorch height for the contribution of each cohort to the overall biomass. + + ! does this do anything? I think it might be redundant? RF. currentPatch%SH = 0.0_r8 currentCohort => currentPatch%tallest; do while(associated(currentCohort)) From e336366e471c730769f9637965ee4ece9811b5db Mon Sep 17 00:00:00 2001 From: Ben Andre Date: Mon, 14 Dec 2015 17:00:00 -0700 Subject: [PATCH 003/437] 'pull ed4x5fix_n06_r120 tags from svn' --- biogeochem/EDCohortDynamicsMod.F90 | 105 +++++++++--- biogeochem/EDPatchDynamicsMod.F90 | 9 ++ biogeochem/EDPhenologyType.F90 | 15 +- biogeochem/EDPhysiologyMod.F90 | 82 ++++++++-- biogeophys/EDAccumulateFluxesMod.F90 | 11 ++ biogeophys/EDPhotosynthesisMod.F90 | 76 +++++++-- biogeophys/EDSurfaceAlbedoMod.F90 | 25 ++- main/EDCLMLinkMod.F90 | 76 +++++---- main/EDInitMod.F90 | 27 +++- main/EDMainMod.F90 | 17 +- main/EDRestVectorMod.F90 | 228 +++++++++++++++++++-------- main/EDTypesMod.F90 | 8 +- 12 files changed, 511 insertions(+), 168 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 7fe96b45..7903d4f1 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -28,6 +28,8 @@ module EDCohortDynamicsMod public :: countCohorts public :: allocate_live_biomass + logical, parameter :: DEBUG = .true. ! local debug flag + ! 10/30/09: Created by Rosie Fisher !-------------------------------------------------------------------------------------! @@ -62,7 +64,7 @@ subroutine create_cohort(patchptr, pft, nn, hite, dbh, & 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. @@ -88,15 +90,20 @@ subroutine create_cohort(patchptr, pft, nn, hite, dbh, & new_cohort%balive = balive new_cohort%bstore = bstore + if ( DEBUG ) write(iulog,*) 'EDCohortDyn I ',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 + 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 + + 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 + + if (new_cohort%siteptr%dstatus==2 .and. pftcon%stress_decid(pft) == 1) then new_cohort%laimemory = 0.0_r8 endif @@ -187,12 +194,11 @@ subroutine allocate_live_biomass(cc_p) 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 + !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 @@ -203,12 +209,13 @@ subroutine allocate_live_biomass(cc_p) ratio_balive = currentcohort%balive / ideal_balive currentcohort%br = currentcohort%br * ratio_balive currentcohort%bsw = currentcohort%bsw * ratio_balive - endif + 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,*) 'issue with carbon allocation in create_cohort,allocate_live_biomass',& + 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 @@ -413,29 +420,44 @@ subroutine terminate_cohorts( patchptr ) 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 + + if ( DEBUG ) then + write(iulog,*) 'terminating cohorts 1',currentCohort%n/currentPatch%area,currentCohort%dbh + endif + endif ! In the third canopy layer if (currentCohort%canopy_layer > NCLMAX) then terminate = 1 - ! write(iulog,*) 'terminating cohorts 2', currentCohort%canopy_layer + + if ( DEBUG ) then + write(iulog,*) 'terminating cohorts 2', currentCohort%canopy_layer + endif + 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 + + if ( DEBUG ) then + write(iulog,*) 'terminating cohorts 3', currentCohort%balive,currentCohort%bstore + endif + 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 ( DEBUG ) then + write(iulog,*) 'terminating cohorts 4', currentCohort%balive, currentCohort%bstore, currentCohort%bdead, & + currentCohort%balive+currentCohort%bdead+& + currentCohort%bstore, currentCohort%n + endif + + endif if (terminate == 1) then if (.not. associated(currentCohort%taller)) then @@ -536,13 +558,20 @@ subroutine fuse_cohorts(patchptr) if (currentCohort%pft == nextc%pft) then ! check cohorts in same c. layer. before fusing - if (currentCohort%canopy_layer == nextc%canopy_layer) then + 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 + + if ( DEBUG ) write(iulog,*) 'EDcohortDyn I ',currentCohort%bstore + currentCohort%bstore = (currentCohort%n*currentCohort%bstore + nextc%n*nextc%bstore)/newn + + if ( DEBUG ) write(iulog,*) 'EDcohortDyn II ',currentCohort%bstore + 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 @@ -551,18 +580,34 @@ subroutine fuse_cohorts(patchptr) 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 + + if ( DEBUG ) write(iulog,*) 'EDcohortDyn 569 ',currentCohort%br + if ( DEBUG ) write(iulog,*) 'EDcohortDyn 570 ',currentCohort%n + if ( DEBUG ) write(iulog,*) 'EDcohortDyn 571 ',nextc%br + if ( DEBUG ) write(iulog,*) 'EDcohortDyn 572 ',nextc%n + 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 + + if ( DEBUG ) write(iulog,*) 'EDcohortDyn III ',currentCohort%npp_acc + if ( DEBUG ) write(iulog,*) 'EDcohortDyn IV ',currentCohort%resp_acc + 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 + + if ( DEBUG ) write(iulog,*) 'EDcohortDyn V ',currentCohort%npp_acc + if ( DEBUG ) write(iulog,*) 'EDcohortDyn VI ',currentCohort%resp_acc + 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 @@ -588,9 +633,11 @@ subroutine fuse_cohorts(patchptr) else nextnextc%taller => nextc%taller endif + if (associated(nextc)) then deallocate(nextc) endif + endif !canopy layer endif !pft endif !index no. @@ -601,6 +648,7 @@ subroutine fuse_cohorts(patchptr) else nextc => nextnextc !if we have removed next endif + enddo !end checking nextc cohort loop if (associated (currentCohort%shorter)) then @@ -620,11 +668,13 @@ subroutine fuse_cohorts(patchptr) 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 ! !---------------------------------------------------------------------! + dynamic_fusion_tolerance = dynamic_fusion_tolerance * 1.1_r8 + + write(iulog,*) 'maxcohorts exceeded',dynamic_fusion_tolerance + else iterate = 0 endif @@ -855,6 +905,10 @@ subroutine copy_cohort( currentCohort,copyc ) n%gpp_clm = o%gpp_clm n%npp = o%npp n%npp_clm = o%npp_clm + + if ( DEBUG ) write(iulog,*) 'EDcohortDyn Ia ',o%npp_acc + if ( DEBUG ) write(iulog,*) 'EDcohortDyn Ib ',o%resp_acc + n%npp_acc = o%npp_acc n%resp_clm = o%resp_clm n%resp_acc = o%resp_acc @@ -895,6 +949,9 @@ subroutine copy_cohort( currentCohort,copyc ) n%dbalivedt = o%dbalivedt n%dbdeaddt = o%dbdeaddt n%dbstoredt = o%dbstoredt + + if ( DEBUG ) write(iulog,*) 'EDCohortDyn dpstoredt ',o%dbstoredt + n%storage_flux = o%storage_flux ! FIRE diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 826e7a60..ff55b8db 100755 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -743,6 +743,9 @@ subroutine create_patch(currentSite, new_patch, age, areap, spread_local,cwd_ag_ new_patch%cwd_ag_in(:) = 0._r8 new_patch%cwd_bg_in(:) = 0._r8 + new_patch%cwd_ag_out(:) = 0._r8 + new_patch%cwd_bg_out(:) = 0._r8 + new_patch%f_sun = 0._r8 new_patch%ed_laisun_z(:,:,:) = 0._r8 new_patch%ed_laisha_z(:,:,:) = 0._r8 @@ -761,6 +764,9 @@ subroutine create_patch(currentSite, new_patch, age, areap, spread_local,cwd_ag_ new_patch%total_tree_area = 0.0_r8 new_patch%NCL_p = 1 + new_patch%leaf_litter_in(:) = 0._r8 + new_patch%leaf_litter_out(:) = 0._r8 + allocate(new_patch%rootfr_ft(numpft_ed,nlevgrnd)) allocate(new_patch%rootr_ft(numpft_ed,nlevgrnd)) @@ -847,6 +853,9 @@ subroutine zero_patch(cp_p) currentPatch%root_litter(:) = 0.0_r8 currentPatch%leaf_litter(:) = 0.0_r8 + currentPatch%leaf_litter_in(:) = 0.0_r8 + currentPatch%leaf_litter_out(:) = 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) diff --git a/biogeochem/EDPhenologyType.F90 b/biogeochem/EDPhenologyType.F90 index f948fc70..dc0f7ec8 100644 --- a/biogeochem/EDPhenologyType.F90 +++ b/biogeochem/EDPhenologyType.F90 @@ -15,18 +15,22 @@ module EDPhenologyType 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 + use clm_time_manager , only : get_nstep, get_step_size, is_restart ! ! !USES: implicit none private ! type, public :: ed_phenology_type + + logical :: DEBUG = .false. + ! ! 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' @@ -126,6 +130,13 @@ subroutine accumulateAndExtract( this, bounds, & call update_accum_field ( trim(this%accString), rbufslp, get_nstep() ) call extract_accum_field ( trim(this%accstring), this%ED_GDD_patch, get_nstep() ) + if (is_restart()) then + if (this%DEBUG) write(iulog,*) 'EDPhenologyType.F90 130 ' + this%ED_GDD_patch(:) = 0.0_r8 + end if + + if (this%DEBUG) write(iulog,*) 'ED_GDD accumAndExtract ', this%ED_GDD_patch + deallocate(rbufslp) end subroutine accumulateAndExtract @@ -270,6 +281,8 @@ subroutine initAccVars(this, bounds) call extract_accum_field (this%accString, rbufslp, get_nstep()) this%ED_GDD_patch(bounds%begp:bounds%endp) = rbufslp(bounds%begp:bounds%endp) + write(iulog,*) 'ED_GDD initAccVars ',this%ED_GDD_patch(bounds%begp:bounds%endp) + deallocate(rbufslp) end subroutine initAccVars diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index ab543045..ef719afc 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -35,6 +35,9 @@ module EDPhysiologyMod public :: seeds_in public :: seed_decay public :: seed_germination + + logical, parameter :: DEBUG = .true. ! local debug flag + ! ============================================================================ contains @@ -85,6 +88,8 @@ subroutine non_canopy_derivs( currentPatch, temperature_inst, soilstate_inst, wa currentPatch%leaf_litter_in(:) = 0.0_r8 currentPatch%root_litter_in(:) = 0.0_r8 + currentPatch%dleaf_litter_dt(:) = 0.0_r8 + currentPatch%droot_litter_dt(:) = 0.0_r8 currentPatch%leaf_litter_out(:) = 0.0_r8 currentPatch%root_litter_out(:) = 0.0_r8 currentPatch%cwd_AG_in(:) = 0.0_r8 @@ -122,6 +127,7 @@ subroutine non_canopy_derivs( currentPatch, temperature_inst, soilstate_inst, wa 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 @@ -190,7 +196,11 @@ subroutine trim_canopy( currentSite ) 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 + + if ( DEBUG ) then + write(iulog,*) 'trimming leaves',currentCohort%canopy_trim,currentCohort%leaf_cost + endif + ! 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 @@ -212,7 +222,10 @@ subroutine trim_canopy( currentSite ) 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 + + if ( DEBUG ) then + write(iulog,*) 'trimming',currentCohort%canopy_trim + endif ! currentCohort%canopy_trim = 1.0_r8 !FIX(RF,032414) this turns off ctrim for now. currentCohort => currentCohort%shorter @@ -325,12 +338,12 @@ subroutine phenology( currentSite, ed_phenology_inst, temperature_inst, watersta !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 + 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 + if ( DEBUG ) write(iulog,*) 'leaves on' + endif !ncd endif !status endif !GDD @@ -351,7 +364,7 @@ subroutine phenology( currentSite, ed_phenology_inst, temperature_inst, watersta 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' + if ( DEBUG ) write(iulog,*) 'leaves off' endif endif endif @@ -361,7 +374,7 @@ subroutine phenology( currentSite, ed_phenology_inst, temperature_inst, watersta 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' + if ( DEBUG ) write(iulog,*) 'leaves off' endif endif @@ -492,12 +505,23 @@ subroutine phenology_leafonoff(currentSite) 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 + ! 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 + currentCohort%bl = currentCohort%bstore endif - currentCohort%balive = currentCohort%balive + currentCohort%bl ! Add deployed carbon to alive biomass pool + + ! Add deployed carbon to alive biomass pool + currentCohort%balive = currentCohort%balive + currentCohort%bl + + if ( DEBUG ) write(iulog,*) 'EDPhysMod 1 ',currentCohort%bstore + currentCohort%bstore = currentCohort%bstore - currentCohort%bl ! Drain store + + if ( DEBUG ) write(iulog,*) 'EDPhysMod 2 ',currentCohort%bstore + currentCohort%laimemory = 0.0_r8 + endif !pft phenology endif ! growing season @@ -528,8 +552,15 @@ subroutine phenology_leafonoff(currentSite) 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 + + if ( DEBUG ) write(iulog,*) 'EDPhysMod 3 ',currentCohort%bstore + currentCohort%bstore = currentCohort%bstore - currentCohort%bl ! empty store + + if ( DEBUG ) write(iulog,*) 'EDPhysMod 4 ',currentCohort%bstore + currentCohort%laimemory = 0.0_r8 + endif !currentCohort status again? endif !currentSite status @@ -706,6 +737,8 @@ subroutine Growth_Derivatives( currentCohort) endif ! NPP + if ( DEBUG ) write(iulog,*) 'EDphys 716 ',currentCohort%npp_acc + 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 @@ -750,10 +783,15 @@ subroutine Growth_Derivatives( currentCohort) ! Calculate carbon balance ! this is the fraction of maintenance demand we -have- to do... + if ( DEBUG ) write(iulog,*) 'EDphys 760 ',currentCohort%npp, currentCohort%md, & + EDecophyscon%leaf_stor_priority(currentCohort%pft) + currentCohort%carbon_balance = currentCohort%npp - currentCohort%md * EDecophyscon%leaf_stor_priority(currentCohort%pft) if (Bleaf(currentCohort) > 0._r8)then + if ( DEBUG ) write(iulog,*) 'EDphys A ',currentCohort%carbon_balance + if (currentCohort%carbon_balance > 0._r8)then !spend C on growing and storing !what fraction of the target storage do we have? @@ -763,6 +801,9 @@ subroutine Growth_Derivatives( currentCohort) !what fraction of allocation do we divert to storage? !what is the flux into the store? currentCohort%storage_flux = currentCohort%carbon_balance * f_store + + if ( DEBUG ) write(iulog,*) 'EDphys B ',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. @@ -829,6 +870,9 @@ subroutine Growth_Derivatives( currentCohort) currentCohort%dbalivedt = gr_fract * va * currentCohort%carbon_balance - balive_loss currentCohort%dbdeaddt = gr_fract * vs * currentCohort%carbon_balance currentCohort%dbstoredt = currentCohort%storage_flux + + if ( DEBUG ) write(iulog,*) 'EDPhys dbstoredt I ',currentCohort%dbstoredt + 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 @@ -847,6 +891,9 @@ subroutine Growth_Derivatives( currentCohort) write(iulog,*) 'using non-neg leaf mass cap',currentCohort%balive , currentCohort%dbalivedt,currentCohort%dbstoredt, & currentCohort%carbon_balance currentCohort%dbstoredt = currentCohort%dbstoredt + currentCohort%dbalivedt + + if ( DEBUG ) write(iulog,*) 'EDPhys dbstoredt II ',currentCohort%dbstoredt + currentCohort%dbalivedt = 0._r8 endif @@ -916,10 +963,15 @@ subroutine recruitment( t, currentPatch ) endif if (temp_cohort%n > 0.0_r8)then + + if ( DEBUG ) write(iulog,*) 'EDPhysiologyMod.F90 call create_cohort ' + 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 @@ -1104,8 +1156,8 @@ subroutine cwd_out( currentPatch, temperature_inst, soilstate_inst, waterstate_i !---------------------------------------------------------------------- currentSite => currentPatch%siteptr - currentPatch%root_litter_out = 0.0_r8 - currentPatch%leaf_litter_out = 0.0_r8 + currentPatch%root_litter_out(:) = 0.0_r8 + currentPatch%leaf_litter_out(:) = 0.0_r8 call fragmentation_scaler(currentPatch, temperature_inst) diff --git a/biogeophys/EDAccumulateFluxesMod.F90 b/biogeophys/EDAccumulateFluxesMod.F90 index 29312bb3..6247cae0 100644 --- a/biogeophys/EDAccumulateFluxesMod.F90 +++ b/biogeophys/EDAccumulateFluxesMod.F90 @@ -10,8 +10,11 @@ module EDAccumulateFluxesMod ! ! !USES: implicit none + private ! public :: AccumulateFluxes_ED + + logical :: DEBUG = .true. ! for debugging this module !------------------------------------------------------------------------------ contains @@ -25,6 +28,7 @@ subroutine AccumulateFluxes_ED(bounds, p, ed_allsites_inst, photosyns_inst) ! !USES: use shr_kind_mod , only : r8 => shr_kind_r8 use decompMod , only : bounds_type + use clm_varctl , only : iulog 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 @@ -60,6 +64,13 @@ subroutine AccumulateFluxes_ED(bounds, p, ed_allsites_inst, photosyns_inst) ! Accumulate fluxes from hourly to daily values. ! _clm fluxes are KgC/indiv/timestep _acc are KgC/indiv/day + if ( DEBUG ) then + write(iulog,*) 'EDAccumFlux 64 ',currentCohort%npp_acc, & + currentCohort%npp_clm + write(iulog,*) 'EDAccumFlux 66 ',currentCohort%gpp_clm + write(iulog,*) 'EDAccumFlux 67 ',currentCohort%resp_clm + endif + 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 diff --git a/biogeophys/EDPhotosynthesisMod.F90 b/biogeophys/EDPhotosynthesisMod.F90 index 889c9054..c80b886d 100644 --- a/biogeophys/EDPhotosynthesisMod.F90 +++ b/biogeophys/EDPhotosynthesisMod.F90 @@ -75,6 +75,9 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & type (ed_cohort_type), pointer :: currentCohort ! integer , parameter :: psn_type = 2 !c3 or c4. + + logical :: DEBUG = .true. + ! ! Leaf photosynthesis parameters real(r8) :: vcmax_z(nclmax,mxpft,nlevcan_ed) ! maximum rate of carboxylation (umol co2/m**2/s) @@ -433,13 +436,11 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & ! 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) - - + !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 @@ -581,7 +582,9 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & 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 ( DEBUG ) write(iulog,*) 'EDphoto 581 ',currentPatch%ed_parsun_z(CL,ft,iv) if (currentPatch%ed_parsun_z(CL,FT,iv) <= 0._r8) then ! night time + ac = 0._r8 aj = 0._r8 ap = 0._r8 @@ -591,10 +594,16 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & 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 ( DEBUG ) write(iulog,*) 'EDphot 594 ',currentPatch%ed_laisun_z(CL,ft,iv) + if ( DEBUG ) write(iulog,*) 'EDphot 595 ',currentPatch%ed_laisha_z(CL,ft,iv) + if(currentPatch%ed_laisun_z(CL,ft,iv)+currentPatch%ed_laisha_z(cl,ft,iv) > 0._r8)then + + if ( DEBUG ) write(iulog,*) '600 in laisun, laisha loop ' + !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. @@ -736,6 +745,10 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & ! Convert gs_mol (umol H2O/m**2/s) to gs (m/s) and then to rs (s/m) gs = gs_mol / cf + if ( DEBUG ) write(iulog,*) 'EDPhoto 737 ', currentPatch%psn_z(cl,ft,iv) + if ( DEBUG ) write(iulog,*) 'EDPhoto 738 ', ag(cl,ft,iv) + if ( DEBUG ) write(iulog,*) 'EDPhoto 739 ', currentPatch%f_sun(cl,ft,iv) + !accumulate total photosynthesis umol/m2 ground/s-1. weight per unit sun and sha leaves. if(sunsha == 1)then !sunlit @@ -757,6 +770,10 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & end if + if ( DEBUG ) write(iulog,*) 'EDPhoto 758 ', currentPatch%psn_z(cl,ft,iv) + if ( DEBUG ) write(iulog,*) 'EDPhoto 759 ', ag(cl,ft,iv) + if ( DEBUG ) write(iulog,*) 'EDPhoto 760 ', currentPatch%f_sun(cl,ft,iv) + ! Make sure iterative solution is correct if (gs_mol < 0._r8) then write (iulog,*)'Negative stomatal conductance:' @@ -800,8 +817,11 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & call t_startf('edfluxunpack1') if(currentCohort%n > 0._r8)then ! Zero cohort flux accumulators. - currentCohort%npp_clm = 0._r8 - currentCohort%resp_clm = 0._r8 + currentCohort%npp_clm = 0.0_r8 + currentCohort%resp_clm = 0.0_r8 + currentCohort%gpp_clm = 0.0_r8 + currentCohort%rd = 0.0_r8 + currentCohort%resp_m = 0.0_r8 ! Select canopy layer and PFT. FT = currentCohort%pft !are we going to have ftindex? @@ -811,10 +831,19 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & !------------------------------------------------------------------------------ ! Convert from umolC/m2leaf/s to umolC/indiv/s ( x canopy area x 1m2 leaf area). tree_area = currentCohort%c_area/currentCohort%n + + if ( DEBUG ) write(iulog,*) 'EDPhoto 816 ', currentCohort%gpp_clm + if ( DEBUG ) write(iulog,*) 'EDPhoto 817 ', currentPatch%psn_z(cl,ft,1:currentCohort%nv-1) + if ( DEBUG ) write(iulog,*) 'EDPhoto 818 ', cl + if ( DEBUG ) write(iulog,*) 'EDPhoto 819 ', ft + if ( DEBUG ) write(iulog,*) 'EDPhoto 820 ', currentCohort%nv + if ( DEBUG ) write(iulog,*) 'EDPhoto 821 ', currentPatch%elai_profile(cl,ft,1:currentCohort%nv-1) + 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 @@ -824,12 +853,14 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & else currentCohort%gpp_clm = 0.0_r8 - currentCohort%rd = 0._r8 - currentCohort%gscan = 0._r8 - currentCohort%ts_net_uptake(:) = 0._r8 + currentCohort%rd = 0.0_r8 + currentCohort%gscan = 0.0_r8 + currentCohort%ts_net_uptake(:) = 0.0_r8 end if + if ( DEBUG ) write(iulog,*) 'EDPhoto 832 ', currentCohort%gpp_clm + 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 @@ -837,6 +868,9 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & currentCohort%gpp_clm = currentCohort%gpp_clm + currentPatch%psn_z(cl,ft,currentCohort%nv) * & currentPatch%elai_profile(cl,ft,currentCohort%nv) * laifrac * tree_area + + if ( DEBUG ) write(iulog,*) 'EDPhoto 843 ', currentCohort%rd + currentCohort%rd = currentCohort%rd + lmr_z(cl,ft,currentCohort%nv) * & currentPatch%elai_profile(cl,ft,currentCohort%nv) * laifrac * tree_area @@ -864,6 +898,10 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & currentCohort%livestem_mr = 0._r8 currentCohort%livecroot_mr = 0._r8 + + if ( DEBUG ) write(iulog,*) 'EDPhoto 874 ', currentCohort%livecroot_mr + if ( DEBUG ) write(iulog,*) 'EDPhoto 875 ', currentCohort%livecrootn + 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) @@ -900,6 +938,13 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & 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 + + if ( DEBUG ) write(iulog,*) 'EDPhoto 904 ', currentCohort%resp_m + if ( DEBUG ) write(iulog,*) 'EDPhoto 905 ', currentCohort%rd + if ( DEBUG ) write(iulog,*) 'EDPhoto 906 ', currentCohort%livestem_mr + if ( DEBUG ) write(iulog,*) 'EDPhoto 907 ', currentCohort%livecroot_mr + if ( DEBUG ) write(iulog,*) 'EDPhoto 908 ', currentCohort%froot_mr + 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 @@ -909,6 +954,11 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & ! convert from kgC/indiv/s to kgC/indiv/timestep currentCohort%resp_m = currentCohort%resp_m * dtime currentCohort%gpp_clm = currentCohort%gpp_clm * dtime + + if ( DEBUG ) write(iulog,*) 'EDPhoto 911 ', currentCohort%gpp_clm + if ( DEBUG ) write(iulog,*) 'EDPhoto 912 ', currentCohort%resp_clm + if ( DEBUG ) write(iulog,*) 'EDPhoto 913 ', currentCohort%resp_m + 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 diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index 868bd984..9c300edf 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -23,6 +23,8 @@ module EDSurfaceAlbedoMod ! 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. + logical :: DEBUG = .true. ! for debugging this module + real(r8), public :: albice(numrad) = & ! albedo land ice by waveband (1=vis, 2=nir) (/ 0.80_r8, 0.55_r8 /) ! @@ -727,6 +729,12 @@ subroutine ED_Norman_Radiation (bounds, & !it is absorbed? do iv = 1, currentPatch%nrad(L,ft) if (radtype==1)then + + if ( DEBUG ) then + write(iulog,*) 'EDsurfAlb 730 ',Abs_dif_z(ft,iv),currentPatch%f_sun(L,ft,iv) + write(iulog,*) 'EDsurfAlb 731 ',currentPatch%fabd_sha_z(L,ft,iv),currentPatch%fabd_sun_z(L,ft,iv) + endif + currentPatch%fabd_sha_z(L,ft,iv) = Abs_dif_z(ft,iv) * (1._r8 - currentPatch%f_sun(L,ft,iv)) currentPatch%fabd_sun_z(L,ft,iv) = Abs_dif_z(ft,iv) * currentPatch%f_sun(L,ft,iv) + & Abs_dir_z(ft,iv) @@ -734,6 +742,11 @@ subroutine ED_Norman_Radiation (bounds, & 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 + + if ( DEBUG ) then + write(iulog,*) 'EDsurfAlb 740 ',currentPatch%fabd_sha_z(L,ft,iv),currentPatch%fabd_sun_z(L,ft,iv) + endif + end do !==============================================================================! @@ -850,24 +863,22 @@ subroutine ED_Norman_Radiation (bounds, & 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 + ! NO-OP ! 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 + ! NO-OP ! 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 + ! NO-OP ! 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 @@ -891,8 +902,6 @@ subroutine ED_Norman_Radiation (bounds, & 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 diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 5de402f3..935300e7 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -14,7 +14,7 @@ module EDCLMLinkMod implicit none private ! - logical :: DEBUG = .false. ! for debugging this module (EDCLMLinkMod.F90) + logical :: DEBUG = .true. ! for debugging this module (EDCLMLinkMod.F90) type, public :: ed_clm_type @@ -69,7 +69,7 @@ module EDCLMLinkMod 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 + real(r8), pointer, public :: gpp_patch (:) ! (gC/m2/s) patch gross primary production contains @@ -507,7 +507,7 @@ subroutine ed_clm_link( this, bounds, ed_allsites_inst, ed_phenology_inst, & logical :: istheresoil(bounds%begg:bounds%endg) !---------------------------------------------------------------------- - if (DEBUG) then + if ( DEBUG ) then write(iulog,*) 'in ed_clm_link' endif @@ -615,7 +615,17 @@ subroutine ed_clm_link( this, bounds, ed_allsites_inst, ed_phenology_inst, & coarse_wood_frac = 0.0_r8 end if + if ( DEBUG ) then + write(iulog,*) 'EDCLMLink 618 ',currentCohort%livecrootn + write(iulog,*) 'EDCLMLink 619 ',currentCohort%br + write(iulog,*) 'EDCLMLink 620 ',coarse_wood_frac + write(iulog,*) 'EDCLMLink 621 ',pftcon%leafcn(ft) + endif + currentCohort%livecrootn = currentCohort%br * coarse_wood_frac / pftcon%leafcn(ft) + + if ( DEBUG ) write(iulog,*) 'EDCLMLink 625 ',currentCohort%livecrootn + currentCohort%b = currentCohort%balive+currentCohort%bdead+currentCohort%bstore currentCohort%treelai = tree_lai(currentCohort) ! Why is currentCohort%c_area used and then reset in the @@ -646,7 +656,7 @@ subroutine ed_clm_link( this, bounds, ed_allsites_inst, ed_phenology_inst, & 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 + write(iulog,*) 'ED: canopy area bigger than area',currentPatch%total_canopy_area ,currentPatch%area currentPatch%total_canopy_area = currentPatch%area endif @@ -671,8 +681,10 @@ subroutine ed_clm_link( this, bounds, ed_allsites_inst, ed_phenology_inst, & tlai(p) = 0.0_r8 endif - !write(iulog,*) 'tlai',tlai(p) - !write(iulog,*) 'htop',htop(p) + if ( DEBUG ) then + write(iulog,*) 'tlai',tlai(p) + write(iulog,*) 'htop',htop(p) + endif ! 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. @@ -680,10 +692,13 @@ subroutine ed_clm_link( this, bounds, ed_allsites_inst, ed_phenology_inst, & ! 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) + 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 + + if ( DEBUG ) 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 @@ -896,6 +911,12 @@ subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & else n_density = 0.0_r8 endif + + if ( DEBUG ) then + write(iulog,*) 'EDCLMLinkMod I ',currentCohort%bstore + write(iulog,*) 'EDCLMLinkMod II ',p,ED_bstore(p) + 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 @@ -1156,7 +1177,7 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, waterstate_inst, canopys enddo if(lai > currentPatch%lai)then - write(iulog,*) 'problem with lai assignments' + write(iulog,*) 'ED: problem with lai assignments' endif @@ -1181,14 +1202,14 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, waterstate_inst, canopys fleaf = currentCohort%lai / (currentCohort%lai + currentCohort%sai) else fleaf = 0._r8 - write(iulog,*) 'no stem or leaf area' ,currentCohort%pft,currentCohort%bl, & + write(iulog,*) 'ED: 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 + write(iulog,*) 'ED: issue with NV',currentCohort%NV,currentCohort%pft,currentCohort%canopy_layer endif c = clmpatch%column(currentPatch%clm_pno) @@ -1251,7 +1272,7 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, waterstate_inst, canopys 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, & + write(iulog,*)'ED: issue with remainder',currentCohort%treelai,currentCohort%treesai,dinc_ed, & currentCohort%NV endif !assumes that fleaf is unchanging FIX(RF,032414) @@ -1328,12 +1349,12 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, waterstate_inst, canopys p = currentPatch%clm_pno if(abs(tlai(p)-tlai_temp) > 0.0001_r8) then - write(iulog,*) 'error with tlai calcs',& + write(iulog,*) 'ED: 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)) + write(iulog,*) 'ED: carea profile',L,currentPatch%canopy_area_profile(L,1,1:currentPatch%nrad(L,1)) + write(iulog,*) 'ED: tlai profile',L,currentPatch%tlai_profile(L,1,1:currentPatch%nrad(L,1)) end do endif @@ -1343,9 +1364,11 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, waterstate_inst, canopys 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,:,:) + if ( DEBUG ) then + 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,:,:) + endif ! Fraction of vegetation free of snow. What does this do? Is it right? if ((elai(p) + esai(p)) > 0._r8) then @@ -1353,7 +1376,6 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, waterstate_inst, canopys 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 @@ -1371,30 +1393,30 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, waterstate_inst, canopys 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,:) + write(iulog,*) 'ED: canopy area too small',sum(currentPatch%canopy_area_profile(1,1:numpft_ed,1)) + write(iulog,*) 'ED: 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', & + write(iulog,*) 'ED: not enough area in the top canopy', & sum(currentPatch%canopy_area_profile(L,1:numpft_ed,1)), & currentPatch%canopy_area_profile(L,1:numpft_ed,1) 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)), & + write(iulog,*) 'ED: 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 + write(iulog,*) 'ED: 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, & + write(iulog,*) 'ED: 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 + write(iulog,*) 'ED: fracarea',currentCohort%pft, currentCohort%c_area/currentPatch%total_canopy_area endif currentCohort => currentCohort%taller @@ -1406,7 +1428,7 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, waterstate_inst, canopys 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) + write(iulog,*) 'ED: present issue',currentPatch%clm_pno,L,ft,currentPatch%present(L,FT) currentPatch%present(L,ft) = 1 endif enddo diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 3390053c..4b44b85a 100755 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -28,6 +28,8 @@ module EDInitMod implicit none private + logical :: DEBUG = .true. + public :: ed_init public :: ed_init_sites public :: zero_site @@ -62,11 +64,17 @@ subroutine ed_init( bounds, ed_allsites_inst, ed_clm_inst, & !---------------------------------------------------------------------- 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 + if (DEBUG) then + write(iulog,*) 'ED: restart ? = ' ,is_restart() + write(iulog,*) 'ED_Mod.F90 :: SPITFIRE_SWITCH (use_ed_spit_fire) ', & + use_ed_spit_fire + write(iulog,*) 'ED_Mod.F90 :: cohorts_per_gcell ',cohorts_per_gcell + end if end if + ! + ! don't call this if we are restarting + ! if ( .not. is_restart() ) then call ed_init_sites( bounds, ed_allsites_inst(bounds%begg:bounds%endg)) @@ -101,8 +109,11 @@ subroutine ed_init_sites( bounds, ed_allsites_inst ) logical :: istheresoil(bounds%begg:bounds%endg) !---------------------------------------------------------------------- + ! ! INITIALISE THE SITE STRUCTURES - udata%cohort_number = 0 !Makes unique cohort identifiers. Needs zeroing at beginning of run. + ! + ! Makes unique cohort identifiers. Needs zeroing at beginning of run. + udata%cohort_number = 0 do g = bounds%begg,bounds%endg ! zero the site @@ -126,9 +137,9 @@ subroutine ed_init_sites( bounds, ed_allsites_inst ) 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 + !if (.not. is_restart() ) then + call init_patches( bounds, ed_allsites_inst(bounds%begg:bounds%endg) ) + !endif end subroutine ed_init_sites @@ -372,6 +383,8 @@ subroutine init_cohorts( patch_in ) cstatus = patch_in%siteptr%dstatus endif + write(iulog,*) 'EDInitMod.F90 call create_cohort ' + 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) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index ccabb1ba..fd656c0b 100755 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -5,6 +5,7 @@ module EDMainMod ! ============================================================================ use shr_kind_mod , only : r8 => shr_kind_r8 + use spmdMod , only : masterproc use decompMod , only : bounds_type use clm_varctl , only : iulog use atm2lndType , only : atm2lnd_type @@ -33,7 +34,7 @@ module EDMainMod private :: ed_integrate_state_variables private :: ed_total_balance_check - logical :: DEBUG_main = .false. + logical :: DEBUG_main = .true. ! ! 10/30/09: Created by Rosie Fisher !----------------------------------------------------------------------- @@ -107,13 +108,13 @@ subroutine ed_driver( bounds, ed_allsites_inst, ed_clm_inst, ed_phenology_inst, 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 + if (masterproc) then + write(iulog,*) 'leaving ed model',bounds%begg,bounds%endg,dayDiffInt + end if end subroutine ed_driver @@ -258,7 +259,11 @@ subroutine ed_integrate_state_variables(currentSite, soilstate_inst, temperature 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 ) + !write(iulog,*) 'EDMainMod dbstoredt I ',currentCohort%bstore, & + !currentCohort%dbstoredt,udata%deltat currentCohort%bstore = currentCohort%bstore + currentCohort%dbstoredt * udata%deltat + !write(iulog,*) 'EDMainMod dbstoredt II ',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, & @@ -282,7 +287,9 @@ subroutine ed_integrate_state_variables(currentSite, soilstate_inst, temperature enddo - write(6,*)'DEBUG18: calling non_canopy_derivs with pno= ',currentPatch%clm_pno + if (DEBUG_main) then + write(6,*)'DEBUG18: calling non_canopy_derivs with pno= ',currentPatch%clm_pno + endif call non_canopy_derivs( currentPatch, temperature_inst, soilstate_inst, waterstate_inst ) !update state variables simultaneously according to derivatives for this time period. diff --git a/main/EDRestVectorMod.F90 b/main/EDRestVectorMod.F90 index 4481e42e..2e480f44 100755 --- a/main/EDRestVectorMod.F90 +++ b/main/EDRestVectorMod.F90 @@ -6,12 +6,13 @@ module EDRestVectorMod 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 spmdMod , only : masterproc + use decompMod , only : bounds_type 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 : ncwd, invalidValue, nlevcan_ed use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type use EDPhenologyType , only : ed_phenology_type ! @@ -82,6 +83,10 @@ module EDRestVectorMod real(r8), pointer :: livegrass(:) ! this can probably be removed real(r8), pointer :: age(:) real(r8), pointer :: areaRestart(:) + real(r8), pointer :: fabd_sun_z(:) + real(r8), pointer :: fabi_sun_z(:) + real(r8), pointer :: fabd_sha_z(:) + real(r8), pointer :: fabi_sha_z(:) ! ! site level restart vars ! @@ -174,6 +179,10 @@ subroutine deleteEDRestartVectorClass( this ) deallocate(this%livegrass ) deallocate(this%age ) deallocate(this%areaRestart ) + deallocate(this%fabd_sun_z ) + deallocate(this%fabi_sun_z ) + deallocate(this%fabd_sha_z ) + deallocate(this%fabi_sha_z ) deallocate(this%water_memory ) deallocate(this%old_stock ) @@ -370,6 +379,26 @@ function newEDRestartVectorClass( bounds ) SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) new%areaRestart(:) = 0.0_r8 + allocate(new%fabd_sun_z & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%fabd_sun_z(:) = 0.0_r8 + + allocate(new%fabi_sun_z & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%fabi_sun_z(:) = 0.0_r8 + + allocate(new%fabd_sha_z & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%fabd_sha_z(:) = 0.0_r8 + + allocate(new%fabi_sha_z & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%fabi_sha_z(:) = 0.0_r8 + ! ! site level variable ! @@ -405,16 +434,18 @@ subroutine setVectors( this, bounds, ed_allsites_inst ) ! !LOCAL VARIABLES: !----------------------------------------------------------------------- - write(iulog,*) 'edtime setVectors ',get_nstep() + if ( masterproc ) 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 + !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%printIoInfoLL ( bounds, ed_allsites_inst(bounds%begg:bounds%endg) ) + call this%printDataInfoLL ( bounds, ed_allsites_inst(bounds%begg:bounds%endg) ) call this%printDataInfoVector ( ) end if @@ -448,7 +479,6 @@ subroutine getVectors( this, bounds, ed_allsites_inst, ed_clm_inst, & 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) ) @@ -467,6 +497,7 @@ subroutine getVectors( this, bounds, ed_allsites_inst, ed_clm_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) ) + call this%printDataInfoVector ( ) end if end subroutine getVectors @@ -482,7 +513,6 @@ subroutine doVectorIO( this, ncid, flag ) 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 @@ -492,15 +522,8 @@ subroutine doVectorIO( this, ncid, flag ) ! !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 ! @@ -636,70 +659,93 @@ subroutine doVectorIO( this, ncid, flag ) call restartvar(ncid=ncid, flag=flag, varname='ed_cwd_ag', xtype=ncd_double, & dim1name=dimName, & - long_name='ed cohort - cwd_ag', units='unitless', & + long_name='ed patch - 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', & + long_name='ed patch - 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', & + long_name='ed patch - 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', & + long_name='ed patch - 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', & + long_name='ed patch - 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', & + long_name='ed patch - 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', & + long_name='ed patch - 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', & + long_name='ed patch - 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', & + long_name='ed patch - 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', & + long_name='ed patch - 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', & + long_name='ed patch - area', units='unitless', & interpinic_flag='interp', data=this%areaRestart, & readvar=readvar) + call restartvar(ncid=ncid, flag=flag, varname='ed_fabd_sun_z', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed patch - fabd_sun_z', units='unitless', & + interpinic_flag='interp', data=this%fabd_sun_z, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_fabi_sun_z', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed patch - fabi_sun_z', units='unitless', & + interpinic_flag='interp', data=this%fabi_sun_z, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_fabd_sha_z', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed patch - fabd_sha_z', units='unitless', & + interpinic_flag='interp', data=this%fabd_sha_z, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_fabi_sha_z', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed patch - fabi_sha_z', units='unitless', & + interpinic_flag='interp', data=this%fabi_sha_z, & + readvar=readvar) ! ! site level vars ! @@ -716,8 +762,6 @@ subroutine doVectorIO( this, ncid, flag ) interpinic_flag='interp', data=this%old_stock, & readvar=readvar) - deallocate(gsmOP) - end subroutine doVectorIO !-------------------------------------------------------------------------------! @@ -806,6 +850,14 @@ subroutine printDataInfoVector( this ) this%age(iSta:iSto) write(iulog,*) trim(methodName)//' :: area ', & this%areaRestart(iSta:iSto) + write(iulog,*) trim(methodName)//' :: fabd_sun_z ', & + this%fabd_sun_z(iSta:iSto) + write(iulog,*) trim(methodName)//' :: fabi_sun_z ', & + this%fabi_sun_z(iSta:iSto) + write(iulog,*) trim(methodName)//' :: fabd_sha_z ', & + this%fabd_sha_z(iSta:iSto) + write(iulog,*) trim(methodName)//' :: fabi_sha_z ', & + this%fabi_sha_z(iSta:iSto) write(iulog,*) trim(methodName)//' :: water_memory ', & this%water_memory(iSta:iSto) write(iulog,*) trim(methodName)//' :: old_stock ', & @@ -902,6 +954,10 @@ subroutine printDataInfoLL( this, bounds, ed_allsites_inst ) 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)//' fabd_sun_z (sum) ' ,sum(currentPatch%fabd_sun_z) + write(iulog,*) trim(methodName)//' fabi_sun_z (sum) ' ,sum(currentPatch%fabi_sun_z) + write(iulog,*) trim(methodName)//' fabd_sha_z (sum) ' ,sum(currentPatch%fabd_sha_z) + write(iulog,*) trim(methodName)//' fabi_sha_z (sum) ' ,sum(currentPatch%fabi_sha_z) write(iulog,*) trim(methodName)//' old_stock ' ,ed_allsites_inst(g)%old_stock currentPatch => currentPatch%younger @@ -910,9 +966,9 @@ subroutine printDataInfoLL( this, bounds, ed_allsites_inst ) numPatches = numPatches + 1 enddo ! currentPatch do while endif - g = g + 1 write(iulog,*) trim(methodName)//' water_memory ',ed_allsites_inst(g)%water_memory(1) + g = g + 1 enddo @@ -922,7 +978,7 @@ 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 @@ -1034,7 +1090,9 @@ subroutine convertCohortListToVector( this, bounds, ed_allsites_inst ) integer :: countNcwd integer :: countWaterMem integer :: countNclmax - integer :: i, incrementOffset + integer :: countSunZ + integer :: i,j,k + integer :: incrementOffset !----------------------------------------------------------------------- totalCohorts = 0 @@ -1045,6 +1103,7 @@ subroutine convertCohortListToVector( this, bounds, ed_allsites_inst ) countNcwd = this%vectorLengthStart countNclmax = this%vectorLengthStart countWaterMem = this%vectorLengthStart + countSunZ = this%vectorLengthStart g = bounds%begg do while(g <= bounds%endg) @@ -1073,7 +1132,9 @@ subroutine convertCohortListToVector( this, bounds, ed_allsites_inst ) totalCohorts = totalCohorts + 1 if (this%DEBUG) then - write(iulog,*) 'countCohort ',countCohort, this%vectorLengthStart, this%vectorLengthStop + write(iulog,*) 'CLTV countCohort ', countCohort + write(iulog,*) 'CLTV vecLenStart ', this%vectorLengthStart + write(iulog,*) 'CLTV vecLenStop ', this%vectorLengthStop endif this%balive(countCohort) = currentCohort%balive @@ -1096,7 +1157,7 @@ subroutine convertCohortListToVector( this, bounds, ed_allsites_inst ) this%status_coh(countCohort) = currentCohort%status_coh if (this%DEBUG) then - write(iulog,*) 'offsetNumCohorts II ',countCohort, & + write(iulog,*) 'CLTV offsetNumCohorts II ',countCohort, & numCohort endif @@ -1152,10 +1213,28 @@ subroutine convertCohortListToVector( this, bounds, ed_allsites_inst ) countNclmax = countNclmax + 1 end do + if (this%DEBUG) write(iulog,*) 'CLTV countSunZ 1 ',countSunZ + + if (this%DEBUG) write(iulog,*) 'CLTV 1186 ',nlevcan_ed,numpft_ed,nclmax + + do k = 1,nlevcan_ed ! nlevcan_ed currently 40 + do j = 1,numpft_ed ! numpft_ed currently 2 + do i = 1,nclmax ! nclmax currently 2 + this%fabd_sun_z(countSunZ) = currentPatch%fabd_sun_z(i,j,k) + this%fabi_sun_z(countSunZ) = currentPatch%fabi_sun_z(i,j,k) + this%fabd_sha_z(countSunZ) = currentPatch%fabd_sha_z(i,j,k) + this%fabi_sha_z(countSunZ) = currentPatch%fabi_sha_z(i,j,k) + countSunZ = countSunZ + 1 + end do + end do + end do + + if (this%DEBUG) write(iulog,*) 'CLTV countSunZ 2 ',countSunZ + ! set numpatches for this gcell this%numPatchesPerCell( ed_allsites_inst(g)%clmgcell ) = numPatches - incrementOffset = incrementOffset + numCohortsPerPatch + incrementOffset = incrementOffset + cohorts_per_gcell ! 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 @@ -1163,9 +1242,14 @@ subroutine convertCohortListToVector( this, bounds, ed_allsites_inst ) countNcwd = incrementOffset countNclmax = incrementOffset countCohort = incrementOffset + countSunZ = incrementOffset - write(iulog,*) 'incrementOffset, cohorts_per_gcell, numCohort, totalCohorts ', & - incrementOffset, cohorts_per_gcell, numCohort, totalCohorts + if (this%DEBUG) then + write(iulog,*) 'CLTV incrementOffset ', incrementOffset + write(iulog,*) 'CLTV cohorts_per_gcell ', cohorts_per_gcell + write(iulog,*) 'CLTV numCohort ', numCohort + write(iulog,*) 'CLTV totalCohorts ', totalCohorts + end if currentPatch => currentPatch%younger @@ -1179,14 +1263,6 @@ subroutine convertCohortListToVector( this, bounds, ed_allsites_inst ) 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 @@ -1196,7 +1272,7 @@ subroutine convertCohortListToVector( this, bounds, ed_allsites_inst ) enddo if (this%DEBUG) then - write(iulog,*) 'total cohorts ',totalCohorts + write(iulog,*) 'CLTV total cohorts ',totalCohorts end if end subroutine convertCohortListToVector @@ -1276,7 +1352,7 @@ subroutine createPatchCohortStructure( this, bounds, ed_allsites_inst ) call zero_patch(newp) ! make new patch - call create_patch(ed_allsites_inst(g), newp, age, AREA, & + 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) @@ -1315,6 +1391,8 @@ subroutine createPatchCohortStructure( this, bounds, ed_allsites_inst ) ! item it needs, not the entire cohort...refactor temp_cohort%dbh = Dbh(temp_cohort) + 0.0001_r8*ft + write(iulog,*) 'EDRestVectorMod.F90::createPatchCohortStructure call create_cohort ' + 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) @@ -1329,7 +1407,7 @@ subroutine createPatchCohortStructure( this, bounds, ed_allsites_inst ) ! if (patchIdx == 1) then ! nothing associated yet. first patch is pointed to by youngest and oldest - if (this%DEBUG) write(iulog,*) 'patchIdx ',patchIdx + if (this%DEBUG) write(iulog,*) 'patchIdx = 1 ',patchIdx ed_allsites_inst(g)%youngest_patch => newp ed_allsites_inst(g)%oldest_patch => newp @@ -1340,7 +1418,7 @@ subroutine createPatchCohortStructure( this, bounds, ed_allsites_inst ) else if (patchIdx == 2) then ! add second patch to list - if (this%DEBUG) write(iulog,*) 'patchIdx ',patchIdx + if (this%DEBUG) write(iulog,*) 'patchIdx = 2 ',patchIdx ed_allsites_inst(g)%youngest_patch => newp ed_allsites_inst(g)%youngest_patch%younger => null() @@ -1350,7 +1428,7 @@ subroutine createPatchCohortStructure( this, bounds, ed_allsites_inst ) else ! more than 2 patches, insert patch into youngest slot - if (this%DEBUG) write(iulog,*) 'patchIdx ',patchIdx + if (this%DEBUG) write(iulog,*) 'patchIdx > 2 ',patchIdx newp%older => ed_allsites_inst(g)%youngest_patch ed_allsites_inst(g)%youngest_patch%younger => newp @@ -1359,7 +1437,7 @@ subroutine createPatchCohortStructure( this, bounds, ed_allsites_inst ) endif - currIdx = currIdx + numCohortsPerPatch + currIdx = currIdx + cohorts_per_gcell enddo ! ends loop over patchIdx @@ -1395,7 +1473,9 @@ subroutine convertCohortVectorToList( this, bounds, ed_allsites_inst ) integer :: countNcwd integer :: countWaterMem integer :: countNclmax - integer :: i, incrementOffset + integer :: countSunZ + integer :: i,j,k + integer :: incrementOffset !----------------------------------------------------------------------- totalCohorts = 0 @@ -1406,6 +1486,7 @@ subroutine convertCohortVectorToList( this, bounds, ed_allsites_inst ) countNcwd = this%vectorLengthStart countNclmax = this%vectorLengthStart countWaterMem = this%vectorLengthStart + countSunZ = this%vectorLengthStart g = bounds%begg do while(g <= bounds%endg) @@ -1521,19 +1602,38 @@ subroutine convertCohortVectorToList( this, bounds, ed_allsites_inst ) countNclmax = countNclmax + 1 end do - incrementOffset = incrementOffset + numCohortsPerPatch + if (this%DEBUG) write(iulog,*) 'CVTL countSunZ 1 ',countSunZ + + do k = 1,nlevcan_ed ! nlevcan_ed currently 40 + do j = 1,numpft_ed ! numpft_ed currently 2 + do i = 1,nclmax ! nclmax currently 2 + currentPatch%fabd_sun_z(i,j,k) = this%fabd_sun_z(countSunZ) + currentPatch%fabi_sun_z(i,j,k) = this%fabi_sun_z(countSunZ) + currentPatch%fabd_sha_z(i,j,k) = this%fabd_sha_z(countSunZ) + currentPatch%fabi_sha_z(i,j,k) = this%fabi_sha_z(countSunZ) + countSunZ = countSunZ + 1 + end do + end do + end do + + if (this%DEBUG) write(iulog,*) 'CVTL countSunZ 2 ',countSunZ + + incrementOffset = incrementOffset + cohorts_per_gcell ! 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 + ! the offset must be > 160, nlevcan_ed*numpft_ed*nclmax + ! and the number of allowed cohorts per patch (currently 200) countPft = incrementOffset countNcwd = incrementOffset countNclmax = incrementOffset countCohort = incrementOffset + countSunZ = incrementOffset if (this%DEBUG) then - write(iulog,*) 'CVTL incrementOffset, cohorts_per_gcell, numCohort, totalCohorts ', & - incrementOffset, cohorts_per_gcell, numCohort, totalCohorts - endif + write(iulog,*) 'CVTL incrementOffset ', incrementOffset + write(iulog,*) 'CVTL cohorts_per_gcell ', cohorts_per_gcell + write(iulog,*) 'CVTL numCohort ', numCohort + write(iulog,*) 'CVTL totalCohorts ', totalCohorts + end if currentPatch => currentPatch%younger @@ -1544,14 +1644,6 @@ subroutine convertCohortVectorToList( this, bounds, ed_allsites_inst ) 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 @@ -1600,6 +1692,10 @@ subroutine EDRest ( bounds, ncid, flag, ed_allsites_inst, ed_clm_inst, ed_phenol ! ervc = newEDRestartVectorClass( bounds ) + if (ervc%DEBUG) then + write(iulog,*) 'EDRestVectorMod:EDRest flag ',flag + end if + if ( flag == 'write' ) then call ervc%setVectors( bounds, ed_allsites_inst(bounds%begg:bounds%endg) ) endif diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 1362b048..f9b44cd4 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -24,8 +24,12 @@ module EDTypesMod ! 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 :: numCohortsPerPatch = 200 ! + integer, parameter :: cohorts_per_gcell = 800 ! This is the max number of individual items one can store per + ! each grid cell and effects the striding in the ED restart + ! data as some fields are arrays where each array is + ! associated with one cohort + integer, parameter :: numWaterMem = 10 ! watermemory saved as site level var ! BIOLOGY/BIOGEOCHEMISTRY From c38dc6f917386d8ab34423633b3d38a8a4ba1129 Mon Sep 17 00:00:00 2001 From: Ben Andre Date: Mon, 14 Dec 2015 17:07:02 -0700 Subject: [PATCH 004/437] 'pull ed4x5fix_n07_r120 tags from svn' --- main/EDCLMLinkMod.F90 | 14 ++------------ 1 file changed, 2 insertions(+), 12 deletions(-) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 935300e7..99d33b5b 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -609,6 +609,8 @@ subroutine ed_clm_link( this, bounds, ed_allsites_inst, ed_phenology_inst, & ft = currentCohort%pft currentCohort%livestemn = currentCohort%bsw / pftcon%leafcn(currentCohort%pft) + currentCohort%livecrootn = 0.0_r8 + if (pftcon%woody(ft) == 1) then coarse_wood_frac = 0.5_r8 else @@ -681,10 +683,6 @@ subroutine ed_clm_link( this, bounds, ed_allsites_inst, ed_phenology_inst, & tlai(p) = 0.0_r8 endif - if ( DEBUG ) then - write(iulog,*) 'tlai',tlai(p) - write(iulog,*) 'htop',htop(p) - endif ! 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. @@ -696,9 +694,6 @@ subroutine ed_clm_link( this, bounds, ed_allsites_inst, ed_phenology_inst, & (currentPatch%area/AREA) currentPatch%bare_frac_area = (1.0_r8 - min(1.0_r8,currentPatch%total_canopy_area/currentPatch%area)) * & (currentPatch%area/AREA) - - if ( DEBUG ) 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 @@ -1364,11 +1359,6 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, waterstate_inst, canopys esai(p) = max(0.1_r8,esai_temp) tsai(p) = max(0.1_r8,tsai_temp) - if ( DEBUG ) then - 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,:,:) - endif ! Fraction of vegetation free of snow. What does this do? Is it right? if ((elai(p) + esai(p)) > 0._r8) then From a46704e93e327d9b9f6210cdbc7ae88e888877a6 Mon Sep 17 00:00:00 2001 From: Ben Andre Date: Mon, 14 Dec 2015 18:51:49 -0700 Subject: [PATCH 005/437] Import ed_v0.1.0 changes into a branch from r120. Created patch file between clm4_5_1_r097 and ed_v010_21_clm4_5_1_r097 tags with the command: svn diff \ https://svn-ccsm-models.cgd.ucar.edu/clm2/trunk_tags/clm4_5_1_r097/ \ https://svn-ccsm-models.cgd.ucar.edu/clm2/branch_tags/ed_v0.1.0_tags/ed_v010_21_clm4_5_1_r097 > \ ed_v0.1.0-21_r097.patch Manually edit patch file to remove property changes. Manually edit patch file to change 'models/lnd' to 'components' in patch file paths. There are some failed hunks in SVN_EXTERNAL_DIRECTORIES that failed to apply and were ignored. It looks like most of these are irrelevent because of cime changes, but one may need to be revisited: https://svn-ccsm-models.cgd.ucar.edu/scripts/branch_tags/refKovenMuszala_tags/rkm_01_scripts4_141023 Testing: Branch has not been compiled or tested. --- biogeochem/EDCohortDynamicsMod.F90 | 1 + biogeochem/EDGrowthFunctionsMod.F90 | 14 +- biogeochem/EDPatchDynamicsMod.F90 | 6 +- biogeochem/EDPhenologyType.F90 | 41 +++++- biogeochem/EDPhysiologyMod.F90 | 66 +++++++--- biogeophys/EDPhotosynthesisMod.F90 | 12 +- biogeophys/EDSurfaceAlbedoMod.F90 | 35 ++--- main/CMakeLists.txt | 1 + main/EDCLMLinkMod.F90 | 6 +- main/EDMainMod.F90 | 10 +- main/EDRestVectorMod.F90 | 190 +++++++++++++++++++++++----- 11 files changed, 296 insertions(+), 86 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 7fe96b45..ef3817dc 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -211,6 +211,7 @@ subroutine allocate_live_biomass(cc_p) 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 + write(iulog,*) 'pft',ft,pftcon%evergreen(ft),pftcon%season_decid(ft),leaves_off_switch endif currentCohort%b = currentCohort%bdead + currentCohort%balive diff --git a/biogeochem/EDGrowthFunctionsMod.F90 b/biogeochem/EDGrowthFunctionsMod.F90 index a497df20..086d0f77 100755 --- a/biogeochem/EDGrowthFunctionsMod.F90 +++ b/biogeochem/EDGrowthFunctionsMod.F90 @@ -103,6 +103,7 @@ real(r8) function Bleaf( cohort_in ) ! ============================================================================ type(ed_cohort_type), intent(in) :: cohort_in + real(r8) :: slascaler ! changes the target biomass according to the SLA 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 @@ -111,12 +112,17 @@ real(r8) function Bleaf( cohort_in ) 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 - + bleaf = 0.0419_r8 * (EDecophyscon%max_dbh(cohort_in%pft)**1.56) * EDecophyscon%wood_density(cohort_in%pft)**0.55_r8 + endif + slascaler = 0.03_r8/pftcon%slatop(cohort_in%pft) + bleaf = bleaf * slascaler + + !write(*,*) 'bleaf',bleaf, slascaler,cohort_in%pft + !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 + + bleaf = bleaf * cohort_in%canopy_trim return end function Bleaf diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 826e7a60..397606ce 100755 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -1096,7 +1096,11 @@ subroutine fuse_2_patches(dp, rp) 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%dleaf_litter_dt(:) = (dp%dleaf_litter_dt(:)*dp%area + rp%dleaf_litter_dt(:)*rp%area)/(dp%area+rp%area) + rp%leaf_litter_in(:) = (dp%leaf_litter_in(:)*dp%area + rp%leaf_litter_in(:)*rp%area)/(dp%area+rp%area) + rp%leaf_litter_out(:) = (dp%leaf_litter_out(:)*dp%area + rp%leaf_litter_out(:)*rp%area)/(dp%area+rp%area) + + rp%area = rp%area + dp%area !THIS MUST COME AT THE END! !insert donor cohorts into recipient patch diff --git a/biogeochem/EDPhenologyType.F90 b/biogeochem/EDPhenologyType.F90 index f948fc70..00bcff77 100644 --- a/biogeochem/EDPhenologyType.F90 +++ b/biogeochem/EDPhenologyType.F90 @@ -37,6 +37,7 @@ module EDPhenologyType ! Public procedures procedure, public :: accumulateAndExtract procedure, public :: init + procedure, public :: restart procedure, public :: initAccVars procedure, public :: initAccBuffer procedure, public :: clean @@ -51,6 +52,40 @@ module EDPhenologyType contains !------------------------------------------------------------------------------ + + !------------------------------------------------------------------------ + subroutine Restart(this, bounds, ncid, flag) + ! + ! !DESCRIPTION: + ! Read/Write module information to/from restart file. + ! + ! !USES: + use shr_log_mod , only : errMsg => shr_log_errMsg + use spmdMod , only : masterproc + use abortutils , only : endrun + use ncdio_pio , only : file_desc_t, ncd_double + use restUtilMod + ! + ! !ARGUMENTS: + class(ed_phenology_type) :: this + type(bounds_type), intent(in) :: bounds + type(file_desc_t), intent(inout) :: ncid + character(len=*) , intent(in) :: flag + + ! + ! !LOCAL VARIABLES: + integer :: j,c ! indices + logical :: readvar ! determine if variable is on initial file + !----------------------------------------------------------------------- + + call restartvar(ncid=ncid, flag=flag, varname='ED_GDD', xtype=ncd_double, & + dim1name='pft', & + long_name='growing degree days for ED', units='ddays', & + interpinic_flag='interp', readvar=readvar, data=this%ED_GDD_patch) + + + end subroutine restart + subroutine accumulateAndExtract( this, bounds, & t_ref2m_patch, & gridcell, latdeg, & @@ -78,6 +113,7 @@ subroutine accumulateAndExtract( this, bounds, & ! 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 @@ -91,7 +127,7 @@ subroutine accumulateAndExtract( this, bounds, & ! Accumulate and extract GDD0 for ED do p = bounds%begp,bounds%endp - + g = gridcell(p) if (latdeg(g) >= 0._r8) then @@ -120,11 +156,10 @@ subroutine accumulateAndExtract( this, bounds, & 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() ) + call extract_accum_field ( trim(this%accString), this%ED_GDD_patch, get_nstep() ) deallocate(rbufslp) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index ab543045..969f8481 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -8,6 +8,7 @@ module EDPhysiologyMod use shr_kind_mod , only : r8 => shr_kind_r8 use clm_varctl , only : iulog + use spmdMod , only : masterproc use TemperatureType , only : temperature_type use SoilStateType , only : soilstate_type use WaterstateType , only : waterstate_type @@ -85,6 +86,7 @@ subroutine non_canopy_derivs( currentPatch, temperature_inst, soilstate_inst, wa currentPatch%leaf_litter_in(:) = 0.0_r8 currentPatch%root_litter_in(:) = 0.0_r8 + currentPatch%dleaf_litter_dt(:) = 0.0_r8 currentPatch%leaf_litter_out(:) = 0.0_r8 currentPatch%root_litter_out(:) = 0.0_r8 currentPatch%cwd_AG_in(:) = 0.0_r8 @@ -230,6 +232,8 @@ subroutine phenology( currentSite, ed_phenology_inst, temperature_inst, watersta ! ! !USES: use clm_varcon, only : tfrz + use clm_time_manager, only : get_days_per_year, get_curr_date + use clm_time_manager, only : get_ref_date, timemgr_datediff use EDTypesMod, only : udata ! ! !ARGUMENTS: @@ -247,6 +251,14 @@ subroutine phenology( currentSite, ed_phenology_inst, temperature_inst, watersta integer :: ncolddayslim ! critical no days underneath the threshold for leaf drop integer :: i integer :: timesincedleafon,timesincedleafoff,timesinceleafon,timesinceleafoff + integer :: refdate + integer :: curdate + + integer :: yr ! year (0, ...) + integer :: mon ! month (1, ..., 12) + integer :: day ! day of month (1, ..., 31) + integer :: sec ! seconds of the day + 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 @@ -256,13 +268,26 @@ subroutine phenology( currentSite, ed_phenology_inst, temperature_inst, watersta 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 + real(r8) :: modelday + !------------------------------------------------------------------------ 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 + + call get_curr_date(yr, mon, day, sec) + curdate = yr*10000 + mon*100 + day + + call get_ref_date(yr, mon, day, sec) + refdate = yr*10000 + mon*100 + day + + call timemgr_datediff(refdate, 0, curdate, sec, modelday) + if ( masterproc ) write(iulog,*) 'modelday',modelday + ! 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 @@ -315,11 +340,7 @@ subroutine phenology( currentSite, ed_phenology_inst, temperature_inst, watersta endif enddo - timesinceleafoff = t - currentSite%leafoffdate - if (t < currentSite%leafoffdate)then - timesinceleafoff = t +(365-currentSite%leafoffdate) - endif - + timesinceleafoff = modelday - currentSite%leafoffdate !LEAF ON: COLD DECIDUOUS. Needs to !1) have exceeded the growing degree day threshold !2) The leaves should not be on already @@ -327,17 +348,15 @@ subroutine phenology( currentSite, ed_phenology_inst, temperature_inst, watersta 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' + 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 + timesinceleafon = modelday - currentSite%leafondate + !LEAF OFF: COLD THRESHOLD !Needs to: @@ -350,18 +369,18 @@ subroutine phenology( currentSite, ed_phenology_inst, temperature_inst, watersta 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' + currentSite%leafoffdate = modelday !record leaf off date + write(iulog,*) 'leaves off cold' 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 + if(timesinceleafoff > 400)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' + currentSite%leafoffdate = modelday !record leaf off date + write(iulog,*) 'leaves off time' endif endif @@ -476,10 +495,15 @@ subroutine phenology_leafonoff(currentSite) ! !LOCAL VARIABLES: type(ed_patch_type) , pointer :: currentPatch type(ed_cohort_type), pointer :: currentCohort + + real(r8) :: store_output ! the amount of the store to put into leaves - is a barrier against negative storage and C starvation. + !------------------------------------------------------------------------ currentPatch => CurrentSite%oldest_patch + store_output = 0.5_r8 + do while(associated(currentPatch)) currentCohort => currentPatch%tallest do while(associated(currentCohort)) @@ -492,7 +516,7 @@ subroutine phenology_leafonoff(currentSite) 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... + currentCohort%bl = currentCohort%bstore * store_output !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 @@ -525,8 +549,8 @@ subroutine phenology_leafonoff(currentSite) 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%bl = currentCohort%bstore * store_output !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 diff --git a/biogeophys/EDPhotosynthesisMod.F90 b/biogeophys/EDPhotosynthesisMod.F90 index 889c9054..93767f0a 100644 --- a/biogeophys/EDPhotosynthesisMod.F90 +++ b/biogeophys/EDPhotosynthesisMod.F90 @@ -435,7 +435,7 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & !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) + jmax25top(FT) = 1.67_r8 * vcmax25top(FT) tpu25top(FT) = 0.167_r8 * vcmax25top(FT) kp25top(FT) = 20000._r8 * vcmax25top(FT) @@ -776,7 +776,13 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & 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) + else !No leaf area. This layer is present only because of stems. (leaves are off, or have reduced to 0 + currentPatch%psn_z(cl,ft,iv) = 0._r8 + rs_z(CL,FT,iv) = min(rsmax0, 1._r8/bbb(FT) * cf) + end if !is there leaf area? + + end if ! night or day end do ! iv canopy layer end if ! present(L,ft) ? rd_array @@ -811,8 +817,8 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & !------------------------------------------------------------------------------ ! 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 - + if (currentCohort%nv > 1) then !is there canopy, and are the leaves on? + 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) * & diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index 868bd984..a061c5c2 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -149,8 +149,6 @@ subroutine ED_Norman_Radiation (bounds, & 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 @@ -281,7 +279,7 @@ subroutine ED_Norman_Radiation (bounds, & 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 + chil(p) = 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. @@ -725,16 +723,23 @@ subroutine ED_Norman_Radiation (bounds, & ! 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 + + if (ib == 1) then ! only set the absorbed PAR for the visible light band. + 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) + endif + end do + endif ! ib !==============================================================================! ! Sum fluxes @@ -886,7 +891,7 @@ subroutine ED_Norman_Radiation (bounds, & write(iulog,*) 'cp',currentPatch%area, currentPatch%patchno write(iulog,*) 'albgrd(c,ib)',albgrd(c,ib) - ! albd(p,ib) = albd(p,ib) + error + albd(p,ib) = albd(p,ib) + error end if else @@ -910,7 +915,7 @@ subroutine ED_Norman_Radiation (bounds, & write(iulog,*) 'CAP',currentPatch%canopy_area_profile(1,1:2,1) - ! albi(p,ib) = albi(p,ib) + error + albi(p,ib) = albi(p,ib) + error end if diff --git a/main/CMakeLists.txt b/main/CMakeLists.txt index 28dbfa2d..5f8dbdcf 100644 --- a/main/CMakeLists.txt +++ b/main/CMakeLists.txt @@ -6,3 +6,4 @@ list(APPEND clm_sources ) sourcelist_to_parent(clm_sources) + diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 5de402f3..b0b559e9 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -606,6 +606,7 @@ subroutine ed_clm_link( this, bounds, ed_allsites_inst, ed_phenology_inst, & !update cohort quantitie s currentCohort => currentPatch%shortest do while(associated(currentCohort)) + ft = currentCohort%pft currentCohort%livestemn = currentCohort%bsw / pftcon%leafcn(currentCohort%pft) @@ -680,9 +681,11 @@ subroutine ed_clm_link( this, bounds, ed_allsites_inst, ed_phenology_inst, & ! 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) + 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 @@ -791,7 +794,6 @@ subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & begp => bounds%begp , & endp => bounds%endp & - ) ! ============================================================================ diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index ccabb1ba..66e929a3 100755 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -5,6 +5,7 @@ module EDMainMod ! ============================================================================ use shr_kind_mod , only : r8 => shr_kind_r8 + use spmdMod , only : masterproc use decompMod , only : bounds_type use clm_varctl , only : iulog use atm2lndType , only : atm2lnd_type @@ -113,7 +114,9 @@ subroutine ed_driver( bounds, ed_allsites_inst, ed_clm_inst, ed_phenology_inst, 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 + if (masterproc) then + write(iulog,*) 'leaving ed model',bounds%begg,bounds%endg,dayDiffInt + end if end subroutine ed_driver @@ -321,11 +324,12 @@ subroutine ed_integrate_state_variables(currentSite, soilstate_inst, temperature do p = 1,numpft_ed if(currentPatch%leaf_litter(p) shr_log_errMsg use shr_sys_mod , only : shr_sys_abort use clm_varctl , only : iulog + use spmdMod , only : masterproc use decompMod , only : bounds_type, get_clmlevel_gsmap use CanopyStateType , only : canopystate_type use WaterStateType , only : waterstate_type @@ -87,6 +88,16 @@ module EDRestVectorMod ! real(r8), pointer :: water_memory(:) real(r8), pointer :: old_stock(:) + real(r8), pointer :: cd_status(:) + real(r8), pointer :: dd_status(:) + real(r8), pointer :: ncd(:) + real(r8), pointer :: leafondate(:) + real(r8), pointer :: leafoffdate(:) + real(r8), pointer :: dleafondate(:) + real(r8), pointer :: dleafoffdate(:) + real(r8), pointer :: acc_NI(:) + + contains ! ! implement getVector and setVector @@ -176,6 +187,14 @@ subroutine deleteEDRestartVectorClass( this ) deallocate(this%areaRestart ) deallocate(this%water_memory ) deallocate(this%old_stock ) + deallocate(this%cd_status ) + deallocate(this%dd_status ) + deallocate(this%ncd ) + deallocate(this%leafondate ) + deallocate(this%leafoffdate ) + deallocate(this%dleafondate ) + deallocate(this%dleafoffdate ) + deallocate(this%acc_NI ) end subroutine deleteEDRestartVectorClass @@ -384,6 +403,46 @@ function newEDRestartVectorClass( bounds ) SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) new%old_stock(:) = 0.0_r8 + allocate(new%cd_status & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%cd_status(:) = 0_r8 + + allocate(new%dd_status & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%dd_status(:) = 0_r8 + + allocate(new%ncd & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%ncd(:) = 0_r8 + + allocate(new%leafondate & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%leafondate(:) = 0_r8 + + allocate(new%leafoffdate & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%leafoffdate(:) = 0_r8 + + allocate(new%dleafondate & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%dleafondate(:) = 0_r8 + + allocate(new%dleafoffdate & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%dleafoffdate(:) = 0_r8 + + allocate(new%acc_NI & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%acc_NI(:) = 0_r8 + end associate end function newEDRestartVectorClass @@ -405,7 +464,7 @@ subroutine setVectors( this, bounds, ed_allsites_inst ) ! !LOCAL VARIABLES: !----------------------------------------------------------------------- - write(iulog,*) 'edtime setVectors ',get_nstep() + if ( masterproc ) write(iulog,*) 'edtime setVectors ',get_nstep() if (this%DEBUG) then call this%printIoInfoLL ( bounds, ed_allsites_inst(bounds%begg:bounds%endg) ) @@ -718,6 +777,56 @@ subroutine doVectorIO( this, ncid, flag ) deallocate(gsmOP) + call restartvar(ncid=ncid, flag=flag, varname='ed_cd_status', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed cold dec status', units='unitless', & + interpinic_flag='interp', data=this%cd_status, & + readvar=readvar) + + + call restartvar(ncid=ncid, flag=flag, varname='ed_dd_status', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed drought dec status', units='unitless', & + interpinic_flag='interp', data=this%dd_status, & + readvar=readvar) + + + call restartvar(ncid=ncid, flag=flag, varname='ed_chilling days', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed chilling day counter', units='unitless', & + interpinic_flag='interp', data=this%ncd, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_leafondate', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed leafondate', units='unitless', & + interpinic_flag='interp', data=this%leafondate, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_leafoffdate', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed leafoffdate', units='unitless', & + interpinic_flag='interp', data=this%leafoffdate, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_dleafondate', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed dleafondate', units='unitless', & + interpinic_flag='interp', data=this%dleafondate, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_dleafoffdate', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed dleafoffdate', units='unitless', & + interpinic_flag='interp', data=this%dleafoffdate, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_acc_NI', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed nesterov index', units='unitless', & + interpinic_flag='interp', data=this%acc_NI, & + readvar=readvar) + end subroutine doVectorIO !-------------------------------------------------------------------------------! @@ -810,7 +919,23 @@ subroutine printDataInfoVector( this ) this%water_memory(iSta:iSto) write(iulog,*) trim(methodName)//' :: old_stock ', & this%old_stock(iSta:iSto) - + write(iulog,*) trim(methodName)//' :: cd_status', & + this%cd_status(iSta:iSto) + write(iulog,*) trim(methodName)//' :: dd_status', & + this%cd_status(iSta:iSto) + write(iulog,*) trim(methodName)//' :: ncd', & + this%ncd(iSta:iSto) + write(iulog,*) trim(methodName)//' :: leafondate', & + this%leafondate(iSta:iSto) + write(iulog,*) trim(methodName)//' :: leafoffdate', & + this%leafoffdate(iSta:iSto) + write(iulog,*) trim(methodName)//' :: dleafondate', & + this%dleafondate(iSta:iSto) + write(iulog,*) trim(methodName)//' :: dleafoffdate', & + this%dleafoffdate(iSta:iSto) + write(iulog,*) trim(methodName)//' :: acc_NI', & + this%acc_NI(iSta:iSto) + end subroutine printDataInfoVector !-------------------------------------------------------------------------------! @@ -903,6 +1028,15 @@ subroutine printDataInfoLL( this, bounds, ed_allsites_inst ) 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 + write(iulog,*) trim(methodName)//' cd_status ' ,ed_allsites_inst(g)%status + write(iulog,*) trim(methodName)//' dd_status ' ,ed_allsites_inst(g)%dstatus + write(iulog,*) trim(methodName)//' ncd ' ,ed_allsites_inst(g)%ncd + write(iulog,*) trim(methodName)//' leafondate ' ,ed_allsites_inst(g)%leafondate + write(iulog,*) trim(methodName)//' leafoffdate ' ,ed_allsites_inst(g)%leafoffdate + write(iulog,*) trim(methodName)//' dleafondate ' ,ed_allsites_inst(g)%dleafondate + write(iulog,*) trim(methodName)//' dleafoffdate ' ,ed_allsites_inst(g)%dleafoffdate + write(iulog,*) trim(methodName)//' acc_NI' ,ed_allsites_inst(g)%acc_NI + currentPatch => currentPatch%younger @@ -910,9 +1044,9 @@ subroutine printDataInfoLL( this, bounds, ed_allsites_inst ) numPatches = numPatches + 1 enddo ! currentPatch do while endif - g = g + 1 write(iulog,*) trim(methodName)//' water_memory ',ed_allsites_inst(g)%water_memory(1) + g = g + 1 enddo @@ -1106,12 +1240,6 @@ subroutine convertCohortListToVector( this, bounds, ed_allsites_inst ) 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 @@ -1120,6 +1248,16 @@ subroutine convertCohortListToVector( this, bounds, ed_allsites_inst ) this%age(incrementOffset) = currentPatch%age this%areaRestart(incrementOffset) = currentPatch%area this%old_stock(incrementOffset) = ed_allsites_inst(g)%old_stock + this%cd_status(incrementOffset) = ed_allsites_inst(g)%status + this%dd_status(incrementOffset) = ed_allsites_inst(g)%dstatus + this%ncd(incrementOffset) = ed_allsites_inst(g)%ncd + this%leafondate(incrementOffset) = ed_allsites_inst(g)%leafondate + this%leafoffdate(incrementOffset) = ed_allsites_inst(g)%leafoffdate + this%dleafondate(incrementOffset) = ed_allsites_inst(g)%dleafondate + this%dleafoffdate(incrementOffset)= ed_allsites_inst(g)%dleafoffdate + this%acc_NI(incrementOffset) = ed_allsites_inst(g)%acc_NI + + ! set cohorts per patch for IO this%cohortsPerPatch( incrementOffset ) = numCohort @@ -1164,9 +1302,6 @@ subroutine convertCohortListToVector( this, bounds, ed_allsites_inst ) 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 @@ -1179,14 +1314,6 @@ subroutine convertCohortListToVector( this, bounds, ed_allsites_inst ) 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 @@ -1468,12 +1595,6 @@ subroutine convertCohortVectorToList( this, bounds, ed_allsites_inst ) 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 @@ -1490,6 +1611,15 @@ subroutine convertCohortVectorToList( this, bounds, ed_allsites_inst ) currentPatch%age = this%age(incrementOffset) currentPatch%area = this%areaRestart(incrementOffset) ed_allsites_inst(g)%old_stock = this%old_stock(incrementOffset) + ed_allsites_inst(g)%status = this%cd_status(incrementOffset) + ed_allsites_inst(g)%dstatus = this%dd_status(incrementOffset) + ed_allsites_inst(g)%ncd = this%ncd(incrementOffset) + ed_allsites_inst(g)%leafondate = this%leafondate(incrementOffset) + ed_allsites_inst(g)%leafoffdate = this%leafoffdate(incrementOffset) + ed_allsites_inst(g)%dleafondate = this%dleafondate(incrementOffset) + ed_allsites_inst(g)%dleafoffdate = this%dleafoffdate(incrementOffset) + ed_allsites_inst(g)%acc_NI = this%acc_NI(incrementOffset) + ! set cohorts per patch for IO if (this%DEBUG) then @@ -1544,14 +1674,6 @@ subroutine convertCohortVectorToList( this, bounds, ed_allsites_inst ) 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 From 3ec641fd9fd504519f436c390f7a439da5b08f74 Mon Sep 17 00:00:00 2001 From: Ben Andre Date: Mon, 14 Dec 2015 19:02:06 -0700 Subject: [PATCH 006/437] Import ed_v0.1.0 unstable science changes. Created a patch file of changes Rosie considered unstable science from the ed_v0.1.0 branch: svn diff -r68491:r72748 \ https://svn-ccsm-models.cgd.ucar.edu/clm2/branches/ed_v0.1.0/ > \ ed_v0.1.0-buggy-science.patch Patch applied cleanly. Testing: Branch has not been compiled or tested. --- biogeochem/EDBGCDynMod.F90 | 355 ++++++++++++++++++++++++++ biogeochem/EDPatchDynamicsMod.F90 | 2 +- biogeochem/EDPhysiologyMod.F90 | 18 +- biogeophys/EDSurfaceAlbedoMod.F90 | 4 +- main/EDCLMLinkMod.F90 | 406 +++++++++++++++++++++++++++++- main/EDMainMod.F90 | 2 +- 6 files changed, 771 insertions(+), 16 deletions(-) create mode 100644 biogeochem/EDBGCDynMod.F90 diff --git a/biogeochem/EDBGCDynMod.F90 b/biogeochem/EDBGCDynMod.F90 new file mode 100644 index 00000000..6ba670fb --- /dev/null +++ b/biogeochem/EDBGCDynMod.F90 @@ -0,0 +1,355 @@ +module EDBGCDynMod + +! Interface from ED calls to CLM belowground biogeochemistry module + + use shr_kind_mod , only : r8 => shr_kind_r8 + use clm_varctl , only : use_c13, use_c14, use_ed + use decompMod , only : bounds_type + use perf_mod , only : t_startf, t_stopf + use clm_varctl , only : use_century_decomp, use_nitrif_denitrif + use CNVegStateType , only : cnveg_state_type + use CNVegCarbonStateType , only : cnveg_carbonstate_type + use CNVegCarbonFluxType , only : cnveg_carbonflux_type + use CNVegNitrogenStateType , only : cnveg_nitrogenstate_type + use CNVegNitrogenFluxType , only : cnveg_nitrogenflux_type + use SoilBiogeochemStateType , only : soilbiogeochem_state_type + use SoilBiogeochemCarbonStateType , only : soilbiogeochem_carbonstate_type + use SoilBiogeochemCarbonFluxType , only : soilbiogeochem_carbonflux_type + use SoilBiogeochemNitrogenStateType , only : soilbiogeochem_nitrogenstate_type + use SoilBiogeochemNitrogenFluxType , only : soilbiogeochem_nitrogenflux_type + use EDCLMLinkMod , only : ed_clm_type + use CanopyStateType , only : canopystate_type + use SoilStateType , only : soilstate_type + use SoilHydrologyType , only : soilhydrology_type + use TemperatureType , only : temperature_type + use WaterstateType , only : waterstate_type + use WaterfluxType , only : waterflux_type + use atm2lndType , only : atm2lnd_type + use SoilStateType , only : soilstate_type + use ch4Mod , only : ch4_type + + + ! public :: EDBGCDynInit ! BGC dynamics: initialization + public :: EDBGCDyn ! BGC Dynamics + public :: EDBGCDynSummary ! BGC dynamics: summary + +contains + + + !----------------------------------------------------------------------- + subroutine EDBGCDyn(bounds, & + num_soilc, filter_soilc, num_soilp, filter_soilp, num_pcropp, filter_pcropp, doalb, & + cnveg_state_inst, & + cnveg_carbonflux_inst, cnveg_carbonstate_inst, & + ed_clm_inst, & + soilbiogeochem_carbonflux_inst, soilbiogeochem_carbonstate_inst, & + soilbiogeochem_state_inst, & + soilbiogeochem_nitrogenflux_inst, soilbiogeochem_nitrogenstate_inst, & + c13_soilbiogeochem_carbonstate_inst, c13_soilbiogeochem_carbonflux_inst, & + c14_soilbiogeochem_carbonstate_inst, c14_soilbiogeochem_carbonflux_inst, & + atm2lnd_inst, waterstate_inst, waterflux_inst, & + canopystate_inst, soilstate_inst, temperature_inst, crop_inst, ch4_inst) + ! + ! !DESCRIPTION: + + ! + ! !USES: + use clm_varpar , only: crop_prog, nlevgrnd, nlevdecomp_full + use clm_varpar , only: nlevdecomp, ndecomp_cascade_transitions, ndecomp_pools + use subgridAveMod , only: p2c + use CropType , only: crop_type + use CNNDynamicsMod , only: CNNDeposition,CNNFixation, CNNFert, CNSoyfix + use CNMRespMod , only: CNMResp + use CNPhenologyMod , only: CNPhenology + use CNGRespMod , only: CNGResp + use CNFireMod , only: CNFireArea, CNFireFluxes + use CNCIsoFluxMod , only: CIsoFlux1, CIsoFlux2, CIsoFlux2h, CIsoFlux3 + use CNC14DecayMod , only: C14Decay + use CNWoodProductsMod , only: CNWoodProducts + use CNCStateUpdate1Mod , only: CStateUpdate1,CStateUpdate0 + use CNCStateUpdate2Mod , only: CStateUpdate2, CStateUpdate2h + use CNCStateUpdate3Mod , only: CStateUpdate3 + use CNNStateUpdate1Mod , only: NStateUpdate1 + use CNNStateUpdate2Mod , only: NStateUpdate2, NStateUpdate2h + use CNGapMortalityMod , only: CNGapMortality + use dynHarvestMod , only: CNHarvest + use SoilBiogeochemDecompCascadeBGCMod , only: decomp_rate_constants_bgc + use SoilBiogeochemDecompCascadeCNMod , only: decomp_rate_constants_cn + use SoilBiogeochemCompetitionMod , only: SoilBiogeochemCompetition + use SoilBiogeochemDecompMod , only: SoilBiogeochemDecomp + use SoilBiogeochemLittVertTranspMod , only: SoilBiogeochemLittVertTransp + use SoilBiogeochemPotentialMod , only: SoilBiogeochemPotential + use SoilBiogeochemVerticalProfileMod , only: SoilBiogeochemVerticalProfile + use SoilBiogeochemNitrifDenitrifMod , only: SoilBiogeochemNitrifDenitrif + use SoilBiogeochemNStateUpdate1Mod , only: SoilBiogeochemNStateUpdate1 + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + integer , intent(in) :: num_pcropp ! number of prog. crop patches in filter + integer , intent(in) :: filter_pcropp(:) ! filter for prognostic crop patches + logical , intent(in) :: doalb ! true = surface albedo calculation time step + type(cnveg_state_type) , intent(inout) :: cnveg_state_inst + type(cnveg_carbonflux_type) , intent(inout) :: cnveg_carbonflux_inst + type(cnveg_carbonstate_type) , intent(inout) :: cnveg_carbonstate_inst + type(ed_clm_type) , intent(inout) :: ed_clm_inst + type(soilbiogeochem_state_type) , intent(inout) :: soilbiogeochem_state_inst + type(soilbiogeochem_carbonflux_type) , intent(inout) :: soilbiogeochem_carbonflux_inst + type(soilbiogeochem_carbonstate_type) , intent(inout) :: soilbiogeochem_carbonstate_inst + type(soilbiogeochem_carbonflux_type) , intent(inout) :: c13_soilbiogeochem_carbonflux_inst + type(soilbiogeochem_carbonstate_type) , intent(inout) :: c13_soilbiogeochem_carbonstate_inst + type(soilbiogeochem_carbonflux_type) , intent(inout) :: c14_soilbiogeochem_carbonflux_inst + type(soilbiogeochem_carbonstate_type) , intent(inout) :: c14_soilbiogeochem_carbonstate_inst + type(soilbiogeochem_nitrogenflux_type) , intent(inout) :: soilbiogeochem_nitrogenflux_inst + type(soilbiogeochem_nitrogenstate_type) , intent(inout) :: soilbiogeochem_nitrogenstate_inst + type(atm2lnd_type) , intent(in) :: atm2lnd_inst + type(waterstate_type) , intent(in) :: waterstate_inst + type(waterflux_type) , intent(in) :: waterflux_inst + type(canopystate_type) , intent(in) :: canopystate_inst + type(soilstate_type) , intent(in) :: soilstate_inst + type(temperature_type) , intent(inout) :: temperature_inst + type(crop_type) , intent(in) :: crop_inst + type(ch4_type) , intent(in) :: ch4_inst + ! + ! !LOCAL VARIABLES: + real(r8):: cn_decomp_pools(bounds%begc:bounds%endc,1:nlevdecomp,1:ndecomp_pools) + real(r8):: p_decomp_cpool_loss(bounds%begc:bounds%endc,1:nlevdecomp,1:ndecomp_cascade_transitions) !potential C loss from one pool to another + real(r8):: pmnf_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,1:ndecomp_cascade_transitions) !potential mineral N flux, from one pool to another + real(r8):: arepr(bounds%begp:bounds%endp) ! reproduction allocation coefficient (only used for crop_prog) + real(r8):: aroot(bounds%begp:bounds%endp) ! root allocation coefficient (only used for crop_prog) + integer :: begp,endp + integer :: begc,endc + !----------------------------------------------------------------------- + + begp = bounds%begp; endp = bounds%endp + begc = bounds%begc; endc = bounds%endc + + !real(r8) , intent(in) :: rootfr_patch(bounds%begp:, 1:) + !integer , intent(in) :: altmax_lastyear_indx_col(bounds%begc:) ! frost table depth (m) + + associate( & + rootfr_patch => soilstate_inst%rootfr_patch , & ! fraction of roots in each soil layer (nlevgrnd) + altmax_lastyear_indx_col => canopystate_inst%altmax_lastyear_indx_col , & ! frost table depth (m) + laisun => canopystate_inst%laisun_patch , & ! Input: [real(r8) (:) ] sunlit projected leaf area index + laisha => canopystate_inst%laisha_patch , & ! Input: [real(r8) (:) ] shaded projected leaf area index + frac_veg_nosno => canopystate_inst%frac_veg_nosno_patch , & ! Input: [integer (:) ] fraction of vegetation not covered by snow (0 OR 1) [-] + frac_veg_nosno_alb => canopystate_inst%frac_veg_nosno_alb_patch , & ! Output: [integer (:) ] frac of vegetation not covered by snow [-] + tlai => canopystate_inst%tlai_patch , & ! Input: [real(r8) (:) ] one-sided leaf area index, no burying by snow + tsai => canopystate_inst%tsai_patch , & ! Input: [real(r8) (:) ] one-sided stem area index, no burying by snow + elai => canopystate_inst%elai_patch , & ! Output: [real(r8) (:) ] one-sided leaf area index with burying by snow + esai => canopystate_inst%esai_patch , & ! Output: [real(r8) (:) ] one-sided stem area index with burying by snow + htop => canopystate_inst%htop_patch , & ! Output: [real(r8) (:) ] canopy top (m) + hbot => canopystate_inst%hbot_patch & ! Output: [real(r8) (:) ] canopy bottom (m) + ) + + ! -------------------------------------------------- + ! zero the column-level C and N fluxes + ! -------------------------------------------------- + + call t_startf('BGCZero') + + call soilbiogeochem_carbonflux_inst%SetValues( & + num_soilc, filter_soilc, 0._r8) + if ( use_c13 ) then + call c13_soilbiogeochem_carbonflux_inst%SetValues( & + num_soilc, filter_soilc, 0._r8) + end if + if ( use_c14 ) then + call c14_soilbiogeochem_carbonflux_inst%SetValues( & + num_soilc, filter_soilc, 0._r8) + end if + + call t_stopf('BGCZero') + + ! -------------------------------------------------- + ! Nitrogen Deposition, Fixation and Respiration + ! -------------------------------------------------- + + ! call t_startf('CNDeposition') + ! call CNNDeposition(bounds, & + ! atm2lnd_inst, soilbiogeochem_nitrogenflux_inst) + ! call t_stopf('CNDeposition') + + + ! if (crop_prog) then + ! call CNNFert(bounds, num_soilc,filter_soilc, & + ! cnveg_nitrogenflux_inst, soilbiogeochem_nitrogenflux_inst) + + ! call CNSoyfix (bounds, num_soilc, filter_soilc, num_soilp, filter_soilp, & + ! waterstate_inst, crop_inst, cnveg_state_inst, cnveg_nitrogenflux_inst , & + ! soilbiogeochem_state_inst, soilbiogeochem_nitrogenstate_inst, soilbiogeochem_nitrogenflux_inst) + ! end if + + !-------------------------------------------- + ! Soil Biogeochemistry + !-------------------------------------------- + + if (use_century_decomp) then + call decomp_rate_constants_bgc(bounds, num_soilc, filter_soilc, & + canopystate_inst, soilstate_inst, temperature_inst, ch4_inst, soilbiogeochem_carbonflux_inst) + else + call decomp_rate_constants_cn(bounds, num_soilc, filter_soilc, & + canopystate_inst, soilstate_inst, temperature_inst, ch4_inst, soilbiogeochem_carbonflux_inst) + end if + + ! calculate potential decomp rates and total immobilization demand (previously inlined in CNDecompAlloc) + call SoilBiogeochemPotential (bounds, num_soilc, filter_soilc, & + soilbiogeochem_state_inst, soilbiogeochem_carbonstate_inst, soilbiogeochem_carbonflux_inst, & + soilbiogeochem_nitrogenstate_inst, soilbiogeochem_nitrogenflux_inst, & + cn_decomp_pools=cn_decomp_pools(begc:endc,1:nlevdecomp,1:ndecomp_pools), & + p_decomp_cpool_loss=p_decomp_cpool_loss(begc:endc,1:nlevdecomp,1:ndecomp_cascade_transitions), & + pmnf_decomp_cascade=pmnf_decomp_cascade(begc:endc,1:nlevdecomp,1:ndecomp_cascade_transitions)) + + + !-------------------------------------------- + ! Resolve the competition between plants and soil heterotrophs + ! for available soil mineral N resource + !-------------------------------------------- + ! will add this back in when integrtating hte nutirent cycles + + + !-------------------------------------------- + ! Calculate litter and soil decomposition rate + !-------------------------------------------- + + ! Calculation of actual immobilization and decomp rates, following + ! resolution of plant/heterotroph competition for mineral N (previously inlined in CNDecompAllocation in CNDecompMod) + + call t_startf('SoilBiogeochemDecomp') + + call SoilBiogeochemDecomp (bounds, num_soilc, filter_soilc, & + soilbiogeochem_state_inst, soilbiogeochem_carbonstate_inst, soilbiogeochem_carbonflux_inst, & + soilbiogeochem_nitrogenstate_inst, soilbiogeochem_nitrogenflux_inst, & + cn_decomp_pools=cn_decomp_pools(begc:endc,1:nlevdecomp,1:ndecomp_pools), & + p_decomp_cpool_loss=p_decomp_cpool_loss(begc:endc,1:nlevdecomp,1:ndecomp_cascade_transitions), & + pmnf_decomp_cascade=pmnf_decomp_cascade(begc:endc,1:nlevdecomp,1:ndecomp_cascade_transitions)) + + call t_stopf('SoilBiogeochemDecomp') + + + !-------------------------------------------- + ! Update1 + !-------------------------------------------- + + call t_startf('BNGCUpdate1') + + + ! Update all prognostic carbon state variables (except for gap-phase mortality and fire fluxes) + call CStateUpdate1( num_soilc, filter_soilc, num_soilp, filter_soilp, & + cnveg_state_inst, cnveg_carbonflux_inst, cnveg_carbonstate_inst, & + ed_clm_inst, & + soilbiogeochem_carbonflux_inst) + + call t_stopf('BNGCUpdate1') + + !-------------------------------------------- + ! Calculate vertical mixing of soil and litter pools + !-------------------------------------------- + + call t_startf('SoilBiogeochemLittVertTransp') + + call SoilBiogeochemLittVertTransp(bounds, num_soilc, filter_soilc, & + canopystate_inst, soilbiogeochem_state_inst, & + soilbiogeochem_carbonstate_inst, soilbiogeochem_carbonflux_inst, & + c13_soilbiogeochem_carbonstate_inst, c13_soilbiogeochem_carbonflux_inst, & + c14_soilbiogeochem_carbonstate_inst, c14_soilbiogeochem_carbonflux_inst, & + soilbiogeochem_nitrogenstate_inst, soilbiogeochem_nitrogenflux_inst) + + call t_stopf('SoilBiogeochemLittVertTransp') + + end associate + + end subroutine EDBGCDyn + + + !----------------------------------------------------------------------- + subroutine EDBGCDynSummary(bounds, num_soilc, filter_soilc, num_soilp, filter_soilp, & + soilbiogeochem_carbonflux_inst, soilbiogeochem_carbonstate_inst, & + c13_soilbiogeochem_carbonflux_inst, c13_soilbiogeochem_carbonstate_inst, & + c14_soilbiogeochem_carbonflux_inst, c14_soilbiogeochem_carbonstate_inst, & + soilbiogeochem_nitrogenflux_inst, soilbiogeochem_nitrogenstate_inst) + ! + ! !DESCRIPTION: + ! Call to all CN and SoilBiogeochem summary routines + ! + ! !USES: + use clm_varpar , only: ndecomp_cascade_transitions + use CNPrecisionControlMod , only: CNPrecisionControl + use SoilBiogeochemPrecisionControlMod , only: SoilBiogeochemPrecisionControl + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + type(soilbiogeochem_carbonflux_type) , intent(inout) :: soilbiogeochem_carbonflux_inst + type(soilbiogeochem_carbonstate_type) , intent(inout) :: soilbiogeochem_carbonstate_inst + type(soilbiogeochem_carbonflux_type) , intent(inout) :: c13_soilbiogeochem_carbonflux_inst + type(soilbiogeochem_carbonstate_type) , intent(inout) :: c13_soilbiogeochem_carbonstate_inst + type(soilbiogeochem_carbonflux_type) , intent(inout) :: c14_soilbiogeochem_carbonflux_inst + type(soilbiogeochem_carbonstate_type) , intent(inout) :: c14_soilbiogeochem_carbonstate_inst + type(soilbiogeochem_nitrogenflux_type) , intent(inout) :: soilbiogeochem_nitrogenflux_inst + type(soilbiogeochem_nitrogenstate_type) , intent(inout) :: soilbiogeochem_nitrogenstate_inst + ! + ! !LOCAL VARIABLES: + integer :: begc,endc + !----------------------------------------------------------------------- + + begc = bounds%begc; endc= bounds%endc + + ! Call to all summary routines + + call t_startf('BGCsum') + + ! Set controls on very low values in critical state variables + + call SoilBiogeochemPrecisionControl(num_soilc, filter_soilc, & + soilbiogeochem_carbonstate_inst, c13_soilbiogeochem_carbonstate_inst, & + c14_soilbiogeochem_carbonstate_inst,soilbiogeochem_nitrogenstate_inst) + + ! Note - all summary updates to cnveg_carbonstate_inst and cnveg_carbonflux_inst are done in + ! soilbiogeochem_carbonstate_inst%summary and CNVeg_carbonstate_inst%summary + + ! ---------------------------------------------- + ! soilbiogeochem carbon/nitrogen state summary + ! ---------------------------------------------- + + call soilbiogeochem_carbonstate_inst%summary(bounds, num_soilc, filter_soilc) + if ( use_c13 ) then + call c13_soilbiogeochem_carbonstate_inst%summary(bounds, num_soilc, filter_soilc) + end if + if ( use_c14 ) then + call c14_soilbiogeochem_carbonstate_inst%summary(bounds, num_soilc, filter_soilc) + end if + ! call soilbiogeochem_nitrogenstate_inst%summary(bounds, num_soilc, filter_soilc) + + ! ---------------------------------------------- + ! soilbiogeochem carbon/nitrogen flux summary + ! ---------------------------------------------- + + call soilbiogeochem_carbonflux_inst%Summary(bounds, num_soilc, filter_soilc) + if ( use_c13 ) then + call c13_soilbiogeochem_carbonflux_inst%Summary(bounds, num_soilc, filter_soilc) + end if + if ( use_c14 ) then + call c14_soilbiogeochem_carbonflux_inst%Summary(bounds, num_soilc, filter_soilc) + end if + ! call soilbiogeochem_nitrogenflux_inst%Summary(bounds, num_soilc, filter_soilc) + + ! ---------------------------------------------- + ! ed veg carbon state summary + ! ---------------------------------------------- + + ! ---------------------------------------------- + ! ed veg carbon/nitrogen flux summary + ! ---------------------------------------------- + + call t_stopf('BGCsum') + + end subroutine EDBGCDynSummary + +end module EDBGCDynMod diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 397606ce..d5ed6bc1 100755 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -1020,7 +1020,7 @@ subroutine fuse_patches( csite ) 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 ! !---------------------------------------------------------------------! diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 969f8481..4277ab17 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -120,14 +120,14 @@ subroutine non_canopy_derivs( currentPatch, temperature_inst, soilstate_inst, wa 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 + ! 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 @@ -1174,4 +1174,6 @@ subroutine cwd_out( currentPatch, temperature_inst, soilstate_inst, waterstate_i end subroutine cwd_out + + end module EDPhysiologyMod diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index a061c5c2..e6c007ea 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -849,10 +849,10 @@ subroutine ED_Norman_Radiation (bounds, & 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) +! 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) +! 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) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index b0b559e9..bc0c3e0f 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -9,12 +9,19 @@ module EDCLMLinkMod 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 + use EDtypesMod , only : ed_site_type, ed_cohort_type, ed_patch_type, ncwd + use CanopyStateType , only : canopystate_type + use clm_varctl , only : use_vertsoilc + ! implicit none private ! logical :: DEBUG = .false. ! for debugging this module (EDCLMLinkMod.F90) + + ! !PUBLIC DATA MEMBERS + real(r8), public :: cwd_fcel_ed + real(r8), public :: cwd_flig_ed type, public :: ed_clm_type @@ -71,6 +78,16 @@ module EDCLMLinkMod 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 + ! litterfall fluxes of C from ED patches to BGC columns + + real(r8), pointer, public :: ED_c_to_litr_lab_c_col(:,:) !total labile litter coming from ED. gC/m3/s + real(r8), pointer, public :: ED_c_to_litr_cel_c_col(:,:) !total cellulose litter coming from ED. gC/m3/s + real(r8), pointer, public :: ED_c_to_litr_lig_c_col(:,:) !total lignin litter coming from ED. gC/m3/s + real(r8), pointer, private :: leaf_prof_col(:,:) !(1/m) profile of leaves + real(r8), pointer, private :: froot_prof_col(:,:,:) !(1/m) profile of fine roots + real(r8), pointer, private :: croot_prof_col(:,:) !(1/m) profile of coarse roots + real(r8), pointer, private :: stem_prof_col(:,:) !(1/m) profile of leaves + contains ! Public routines @@ -84,7 +101,8 @@ module EDCLMLinkMod procedure , private :: ed_update_history_variables procedure , private :: InitAllocate procedure , private :: InitHistory - procedure , private :: InitCold + procedure , private :: InitCold + procedure , private :: flux_into_litter_pools end type ed_clm_type @@ -115,7 +133,8 @@ subroutine InitAllocate(this, bounds) ! ! !USES: use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) - use clm_varpar , only : nlevgrnd + use clm_varpar , only : nlevgrnd, nlevdecomp_full + use EDtypesMod , only : numpft_ed ! ! !ARGUMENTS: class (ed_clm_type) :: this @@ -123,9 +142,12 @@ subroutine InitAllocate(this, bounds) ! ! !LOCAL VARIABLES: integer :: begp,endp + integer :: begc,endc !bounds !------------------------------------------------------------------------ begp = bounds%begp; endp = bounds%endp + begc = bounds%begc; endc = bounds%endc + 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 @@ -171,6 +193,15 @@ subroutine InitAllocate(this, bounds) allocate(this%gpp_patch (begp:endp)) ; this%gpp_patch (:) = nan allocate(this%npp_patch (begp:endp)) ; this%npp_patch (:) = nan + allocate(this%ED_c_to_litr_lab_c_col (begc:endc,1:nlevdecomp_full)) ; this%ED_c_to_litr_lab_c_col (:,:) = nan + allocate(this%ED_c_to_litr_cel_c_col (begc:endc,1:nlevdecomp_full)) ; this%ED_c_to_litr_cel_c_col (:,:) = nan + allocate(this%ED_c_to_litr_lig_c_col (begc:endc,1:nlevdecomp_full)) ; this%ED_c_to_litr_lig_c_col (:,:) = nan + + allocate(this%leaf_prof_col (begc:endc,1:nlevdecomp_full)) ; this%leaf_prof_col (:,:) = nan + allocate(this%froot_prof_col (begc:endc,1:numpft_ed,1:nlevdecomp_full)); this%froot_prof_col (:,:,:) = nan + allocate(this%croot_prof_col (begc:endc,1:nlevdecomp_full)) ; this%croot_prof_col (:,:) = nan + allocate(this%stem_prof_col (begc:endc,1:nlevdecomp_full)) ; this%stem_prof_col (:,:) = nan + end subroutine InitAllocate !------------------------------------------------------------------------ @@ -379,6 +410,32 @@ subroutine InitHistory(this, bounds) avgflag='A', long_name='net primary production', & ptr_patch=this%npp_patch) + call hist_addfld_decomp (fname='ED_c_to_litr_lab_c', units='gC/m^2/s', type2d='levdcmp', & + avgflag='A', long_name='ED_c_to_litr_lab_c', & + ptr_col=this%ED_c_to_litr_lab_c_col) + + call hist_addfld_decomp (fname='ED_c_to_litr_cel_c', units='gC/m^2/s', type2d='levdcmp', & + avgflag='A', long_name='ED_c_to_litr_cel_c', & + ptr_col=this%ED_c_to_litr_cel_c_col) + + call hist_addfld_decomp (fname='ED_c_to_litr_lig_c', units='gC/m^2/s', type2d='levdcmp', & + avgflag='A', long_name='ED_c_to_litr_lig_c', & + ptr_col=this%ED_c_to_litr_lig_c_col) + + call hist_addfld_decomp (fname='leaf_prof', units='1/m', type2d='levdcmp', & + avgflag='A', long_name='leaf_prof', & + ptr_col=this%leaf_prof_col) + + call hist_addfld_decomp (fname='croot_prof', units='1/m', type2d='levdcmp', & + avgflag='A', long_name='croot_prof', & + ptr_col=this%croot_prof_col) + + call hist_addfld_decomp (fname='stem_prof', units='1/m', type2d='levdcmp', & + avgflag='A', long_name='stem_prof', & + ptr_col=this%stem_prof_col) + + + end subroutine InitHistory !----------------------------------------------------------------------- @@ -717,7 +774,10 @@ subroutine ed_clm_link( this, bounds, ed_allsites_inst, ed_phenology_inst, & end do !grid loop - call this%ed_update_history_variables( bounds, ed_allsites_inst(begg:endg), & + call this%flux_into_litter_pools(bounds, ed_allsites_inst(begg:endg), firstsoilpatch, & + canopystate_inst) + + call this%ed_update_history_variables(bounds, ed_allsites_inst(begg:endg), & firstsoilpatch, ed_Phenology_inst, canopystate_inst) end associate @@ -1426,4 +1486,342 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, waterstate_inst, canopys end subroutine ed_clm_leaf_area_profile + + subroutine flux_into_litter_pools(this, bounds, ed_allsites_inst, firstsoilpatch, canopystate_inst) + ! Created by Charlie Koven and Rosie Fisher, 2014-2015 + ! take the flux out of the fragmenting litter pools and port into the decomposing litter pools. + ! in this implementation, decomposing pools are assumed to be humus and non-flammable, whereas fragmenting pools + ! are assumed to be physically fragmenting but not respiring. This is a simplification, but allows us to + ! a) reconcile the need to track both chemical fractions (lignin, cellulose, labile) and size fractions (trunk, branch, etc.) + ! b) to impose a realistic delay on the surge of nutrients into the litter pools when large CWD is added to the system via mortality + + ! because of the different subgrid structure, this subroutine includes the functionality that in the big-leaf BGC model, is calculated in SoilBiogeochemVerticalProfileMod + + ! The ED code is resolved at a daily timestep, but all of the CN-BGC fluxes are passed in as derivatives per second, + ! and then accumulated in the CNStateUpdate routines. One way of doing this is to pass back the CN fluxes per second, + ! and keep them constant for the whole day (making sure they are not overwritten. + ! This means that the carbon gets passed back and forth between the photosynthesis code (fast timestepping) to the ED code (slow timestepping), back to the BGC code (fast timestepping). + ! This means that the state update for the litter pools and for the CWD pools occurs at different timescales. + + use SFParamsMod, only: SF_val_max_decomp + use clm_varpar, only : mxpft,nlevdecomp, nlevdecomp_full + use EDTypesMod, only : AREA, numpft_ed + use SoilBiogeochemVerticalProfileMod, only: exponential_rooting_profile, pftspecific_rootingprofile, rootprof_exp, surfprof_exp + use pftconMod, only : pftcon + use shr_const_mod, only: SHR_CONST_CDAY + use clm_varcon, only : zisoi, dzsoi_decomp, zsoi + use ColumnType , only : col + use abortutils , only : endrun + use shr_log_mod , only : errMsg => shr_log_errMsg + use EDParamsMod, only : ED_val_ag_biomass + ! + implicit none + ! + ! !ARGUMENTS + class(ed_clm_type) :: this + type(bounds_type) , intent(in) :: bounds + type(ed_site_type) , intent(inout), target :: ed_allsites_inst( bounds%begg: ) + integer :: firstsoilpatch(bounds%begg:bounds%endg) ! the first patch in this gridcell that is soil and thus bare... + type(canopystate_type) , intent(inout) :: canopystate_inst + ! + ! !LOCAL VARIABLES: + type (ed_patch_type) , pointer :: currentPatch + type (ed_cohort_type) , pointer :: currentCohort + type(ed_site_type), pointer :: cs + integer c,p,cc,j,g + real(r8) time_convert ! from year to seconds + real(r8) mass_convert ! ED uses kg, CLM uses g + integer :: begp,endp + integer :: begc,endc !bounds + !------------------------------------------------------------------------ + real(r8) :: cinput_rootfr(bounds%begc:bounds%endc, 1:numpft_ed, 1:nlevdecomp_full) ! column by pft root fraction used for calculating inputs + real(r8) :: croot_prof_perpatch(1:nlevdecomp_full) + real(r8) :: surface_prof(1:nlevdecomp_full) + integer :: ft, lev + real(r8) :: rootfr_tot(1:numpft_ed), biomass_bg_ft(1:numpft_ed) + real(r8) :: surface_prof_tot, leaf_prof_sum, stem_prof_sum, froot_prof_sum, biomass_bg_tot + real(r8) :: delta + + begp = bounds%begp; endp = bounds%endp + begc = bounds%begc; endc = bounds%endc + delta = 0.001_r8 + !no of seconds in a year. + time_convert = 365.0_r8*SHR_CONST_CDAY + + ! number of grams in a kilogram + mass_convert = 1000._r8 + + associate( & + ED_c_to_litr_lab_c => this%ED_c_to_litr_lab_c_col , & ! Output: total labile litter coming from ED. gC/m3/s + ED_c_to_litr_cel_c => this%ED_c_to_litr_cel_c_col , & ! Output: total cellulose litter coming from ED. gC/m3/s + ED_c_to_litr_lig_c => this%ED_c_to_litr_lig_c_col , & ! Output: total lignin litter coming from ED. gC/m3/s + leaf_prof => this%leaf_prof_col , & ! Output: (1/m) profile of leaves + froot_prof => this%froot_prof_col , & ! Output: (1/m) profile of fine roots + croot_prof => this%croot_prof_col , & ! Output: (1/m) profile of coarse roots + stem_prof => this%stem_prof_col , & ! Output: (1/m) profile of leaves + altmax_lastyear_indx => canopystate_inst%altmax_lastyear_indx_col & ! Input: [integer (:) ]frost table depth (m) + ) + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! first calculate vertical profiles + ! define two types of profiles: + ! (1) a surface profile, for leaves and stem inputs, which is the same for each pft but differs from one column to the next to avoid inputting any C into permafrost + ! (2) a fine root profile, which is indexed by both column and pft, differs for each pft and also from one column to the next to avoid inputting any C into permafrost + ! (3) a coarse root profile, which is the root-biomass=weighted average of the fine root profiles + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + if (use_vertsoilc) then + + ! define a single shallow surface profile for surface additions (leaves, stems, and N deposition) + surface_prof(:) = 0._r8 + do j = 1, nlevdecomp + surface_prof(j) = exp(-surfprof_exp * zsoi(j)) / dzsoi_decomp(j) + end do + + ! initialize profiles to zero + leaf_prof(begc:endc, :) = 0._r8 + froot_prof(begc:endc, 1:numpft_ed, :) = 0._r8 + croot_prof(begc:endc, :) = 0._r8 + stem_prof(begc:endc, :) = 0._r8 + + cinput_rootfr(begc:endc, 1:numpft_ed, :) = 0._r8 + + do c = bounds%begc,bounds%endc + + ! calculate pft-specific rooting profiles in the absence of permafrost limitations + if ( exponential_rooting_profile ) then + if ( .not. pftspecific_rootingprofile ) then + ! define rooting profile from exponential parameters + do ft = 1, numpft_ed + do j = 1, nlevdecomp + cinput_rootfr(c,ft,j) = exp(-rootprof_exp * zsoi(j)) / dzsoi_decomp(j) + end do + end do + else + ! use beta distribution parameter from Jackson et al., 1996 + do ft = 1, numpft_ed + do j = 1, nlevdecomp + cinput_rootfr(c,ft,j) = ( pftcon%rootprof_beta(ft) ** (zisoi(j-1)*100._r8) - & + pftcon%rootprof_beta(ft) ** (zisoi(j)*100._r8) ) & + / dzsoi_decomp(j) + end do + end do + endif + else + do ft = 1,numpft_ed + do j = 1, nlevdecomp + ! use standard CLM root fraction profiles; + cinput_rootfr(c,ft,j) = ( .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)))) / dzsoi_decomp(j) + end do + end do + endif + ! + ! + ! now add permafrost constraint: integrate rootfr over active layer of soil column, + ! truncate below permafrost table where present, and rescale so that integral = 1 + do ft = 1,numpft_ed + rootfr_tot(ft) = 0._r8 + end do + surface_prof_tot = 0._r8 + ! + do j = 1, min(max(altmax_lastyear_indx(c), 1), nlevdecomp) + surface_prof_tot = surface_prof_tot + surface_prof(j) * dzsoi_decomp(j) + end do + do ft = 1,numpft_ed + do j = 1, min(max(altmax_lastyear_indx(c), 1), nlevdecomp) + rootfr_tot(ft) = rootfr_tot(ft) + cinput_rootfr(c,ft,j) * dzsoi_decomp(j) + end do + end do + ! + ! rescale the fine root profile + do ft = 1,numpft_ed + if ( (altmax_lastyear_indx(c) > 0) .and. (rootfr_tot(ft) > 0._r8) ) then + ! where there is not permafrost extending to the surface, integrate the profiles over the active layer + ! this is equivalent to integrating over all soil layers outside of permafrost regions + do j = 1, min(max(altmax_lastyear_indx(c), 1), nlevdecomp) + froot_prof(c,ft,j) = cinput_rootfr(c,ft,j) / rootfr_tot(ft) + end do + else + ! if fully frozen, or no roots, put everything in the top layer + froot_prof(c,ft,1) = 1./dzsoi_decomp(1) + endif + end do + ! + ! rescale the shallow profiles + if ( (altmax_lastyear_indx(c) > 0) .and. (surface_prof_tot > 0._r8) ) then + ! where there is not permafrost extending to the surface, integrate the profiles over the active layer + ! this is equivalent to integrating over all soil layers outside of permafrost regions + do j = 1, min(max(altmax_lastyear_indx(c), 1), nlevdecomp) + ! set all surface processes to shallower profile + leaf_prof(c,j) = surface_prof(j)/ surface_prof_tot + stem_prof(c,j) = surface_prof(j)/ surface_prof_tot + end do + else + ! if fully frozen, or no roots, put everything in the top layer + leaf_prof(c,1) = 1./dzsoi_decomp(1) + stem_prof(c,1) = 1./dzsoi_decomp(1) + endif + end do + + else + + ! for one layer decomposition model, set profiles to unity + leaf_prof(bounds%begc:bounds%endc, :) = 1._r8 + froot_prof(bounds%begc:bounds%endc, 1:numpft_ed, :) = 1._r8 + stem_prof(bounds%begc:bounds%endc, :) = 1._r8 + + end if + + ! sanity check to ensure they integrate to 1 + do c = bounds%begc,bounds%endc + ! check the leaf and stem profiles + leaf_prof_sum = 0._r8 + stem_prof_sum = 0._r8 + do j = 1, nlevdecomp + leaf_prof_sum = leaf_prof_sum + leaf_prof(c,j) * dzsoi_decomp(j) + stem_prof_sum = stem_prof_sum + stem_prof(c,j) * dzsoi_decomp(j) + end do + if ( ( abs(stem_prof_sum - 1._r8) > delta ) .or. ( abs(leaf_prof_sum - 1._r8) > delta ) ) then + write(iulog, *) 'profile sums: ', leaf_prof_sum, stem_prof_sum + write(iulog, *) 'surface_prof: ', surface_prof + write(iulog, *) 'surface_prof_tot: ', surface_prof_tot + write(iulog, *) 'leaf_prof: ', leaf_prof(c,:) + write(iulog, *) 'stem_prof: ', stem_prof(c,:) + write(iulog, *) 'altmax_lastyear_indx: ', altmax_lastyear_indx(c) + write(iulog, *) 'dzsoi_decomp: ', dzsoi_decomp + call endrun(msg=' ERROR: sum-1 > delta'//errMsg(__FILE__, __LINE__)) + endif + ! now check each fine root profile + do ft = 1,numpft_ed + froot_prof_sum = 0._r8 + do j = 1, nlevdecomp + froot_prof_sum = froot_prof_sum + froot_prof(c,ft,j) * dzsoi_decomp(j) + end do + if ( ( abs(froot_prof_sum - 1._r8) > delta ) ) then + write(iulog, *) 'profile sums: ', froot_prof_sum + call endrun(msg=' ERROR: sum-1 > delta'//errMsg(__FILE__, __LINE__)) + endif + end do + end do + + ! zero the column-level C input variables + do c = bounds%begc,bounds%endc + do j = 1, nlevdecomp + ED_c_to_litr_lab_c(c,j) = 0._r8 + ED_c_to_litr_cel_c(c,j) = 0._r8 + ED_c_to_litr_lig_c(c,j) = 0._r8 + croot_prof(c,j) = 0._r8 + end do + end do + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! now disaggregate the inputs vertically, using the vertical profiles + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + do g = bounds%begg,bounds%endg + if (firstsoilpatch(g) >= 0 .and. ed_allsites_inst(g)%istheresoil) then + currentPatch => ed_allsites_inst(g)%oldest_patch + + do while(associated(currentPatch)) + + cs => currentpatch%siteptr + cc = cs%clmcolumn + + ! the CWD pools lose information about which PFT they came from; for the stems this doesn't matter as they all have the same profile, + ! however for the coarse roots they may have different profiles. to approximately recover this information, loop over all cohorts in patch + ! to calculate the total root biomass in that patch of each pft, and then rescale the croot_prof as the weighted average of the froot_prof + biomass_bg_ft(1:numpft_ed) = 0._r8 + currentCohort => currentPatch%tallest + do while(associated(currentCohort)) + biomass_bg_ft(currentCohort%pft) = biomass_bg_ft(currentCohort%pft) + currentCohort%b * (currentCohort%n / currentPatch%area) * (1.0_r8-ED_val_ag_biomass) + currentCohort => currentCohort%shorter + enddo !currentCohort + ! + biomass_bg_tot = 0._r8 + do ft = 1,numpft_ed + biomass_bg_tot = biomass_bg_tot + biomass_bg_ft(ft) + end do + ! + do j = 1, nlevdecomp + ! zero this for each patch + croot_prof_perpatch(j) = 0._r8 + end do + ! + if ( biomass_bg_tot .gt. 0._r8) then + do ft = 1,numpft_ed + do j = 1, nlevdecomp + croot_prof_perpatch(j) = croot_prof_perpatch(j) + froot_prof(cc,ft,j) * biomass_bg_ft(ft) / biomass_bg_tot + end do + end do + else ! no biomass + croot_prof_perpatch(1) = 1./dzsoi_decomp(1) + end if + ! + ! add croot_prof as weighted average (weighted by patch area) of croot_prof_perpatch + do j = 1, nlevdecomp + croot_prof(cc, j) = croot_prof(cc, j) + croot_prof_perpatch(j) * currentPatch%area / AREA + end do + ! + ! now disaggregate, vertically and by decomposition substrate type, the actual fluxes from CWD and litter pools + ! + ! do c = 1, ncwd + ! write(iulog,*)'cdk CWD_AG_out', c, currentpatch%CWD_AG_out(c), cwd_fcel_ed, currentpatch%area/AREA + ! write(iulog,*)'cdk CWD_BG_out', c, currentpatch%CWD_BG_out(c), cwd_fcel_ed, currentpatch%area/AREA + ! end do + ! do ft = 1,numpft_ed + ! write(iulog,*)'cdk leaf_litter_out', ft, currentpatch%leaf_litter_out(ft), cwd_fcel_ed, currentpatch%area/AREA + ! write(iulog,*)'cdk root_litter_out', ft, currentpatch%root_litter_out(ft), cwd_fcel_ed, currentpatch%area/AREA + ! end do + ! ! + ! CWD pools fragmenting into decomposing litter pools. + do c = 1, ncwd + do j = 1, nlevdecomp + ED_c_to_litr_cel_c(cc,j) = ED_c_to_litr_cel_c(cc,j) + currentpatch%CWD_AG_out(c) * cwd_fcel_ed * currentpatch%area/AREA * stem_prof(cc,j) + ED_c_to_litr_lig_c(cc,j) = ED_c_to_litr_lig_c(cc,j) + currentpatch%CWD_AG_out(c) * cwd_flig_ed * currentpatch%area/AREA * stem_prof(cc,j) + ! + ED_c_to_litr_cel_c(cc,j) = ED_c_to_litr_cel_c(cc,j) + currentpatch%CWD_BG_out(c) * cwd_fcel_ed * currentpatch%area/AREA * croot_prof_perpatch(j) + ED_c_to_litr_lig_c(cc,j) = ED_c_to_litr_lig_c(cc,j) + currentpatch%CWD_BG_out(c) * cwd_flig_ed * currentpatch%area/AREA * croot_prof_perpatch(j) + end do + end do + + ! leaf and fine root pools. + do ft = 1,numpft_ed + do j = 1, nlevdecomp + ED_c_to_litr_lab_c(cc,j) = ED_c_to_litr_lab_c(cc,j) + currentpatch%leaf_litter_out(ft) * pftcon%lf_flab(ft) * currentpatch%area/AREA * leaf_prof(cc,j) + ED_c_to_litr_cel_c(cc,j) = ED_c_to_litr_cel_c(cc,j) + currentpatch%leaf_litter_out(ft) * pftcon%lf_fcel(ft) * currentpatch%area/AREA * leaf_prof(cc,j) + ED_c_to_litr_lig_c(cc,j) = ED_c_to_litr_lig_c(cc,j) + currentpatch%leaf_litter_out(ft) * pftcon%lf_flig(ft) * currentpatch%area/AREA * leaf_prof(cc,j) + ! + ED_c_to_litr_lab_c(cc,j) = ED_c_to_litr_lab_c(cc,j) + currentpatch%root_litter_out(ft) * pftcon%fr_flab(ft) * currentpatch%area/AREA * froot_prof(cc,ft,j) + ED_c_to_litr_cel_c(cc,j) = ED_c_to_litr_cel_c(cc,j) + currentpatch%root_litter_out(ft) * pftcon%fr_fcel(ft) * currentpatch%area/AREA * froot_prof(cc,ft,j) + ED_c_to_litr_lig_c(cc,j) = ED_c_to_litr_lig_c(cc,j) + currentpatch%root_litter_out(ft) * pftcon%fr_flig(ft) * currentpatch%area/AREA * froot_prof(cc,ft,j) + enddo + end do + + currentPatch => currentPatch%younger + end do !currentPatch + end if + end do + + do cc = bounds%begc,bounds%endc + do j = 1, nlevdecomp + ! time unit conversion + ED_c_to_litr_lab_c(cc,j)=ED_c_to_litr_lab_c(cc,j) * mass_convert / time_convert + ED_c_to_litr_cel_c(cc,j)=ED_c_to_litr_cel_c(cc,j) * mass_convert / time_convert + ED_c_to_litr_lig_c(cc,j)=ED_c_to_litr_lig_c(cc,j) * mass_convert / time_convert + + end do + end do + + ! write(iulog,*)'cdk ED_c_to_litr_lab_c: ', ED_c_to_litr_lab_c + ! write(iulog,*)'cdk ED_c_to_litr_cel_c: ', ED_c_to_litr_cel_c + ! write(iulog,*)'cdk ED_c_to_litr_lig_c: ', ED_c_to_litr_lig_c + + end associate + end subroutine flux_into_litter_pools + + + end module EDCLMLinkMod diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 66e929a3..ace3cfd7 100755 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -285,7 +285,7 @@ subroutine ed_integrate_state_variables(currentSite, soilstate_inst, temperature 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. From 5f06f48c47ec2162257bfed34c2a31a18d27570c Mon Sep 17 00:00:00 2001 From: Ben Andre Date: Wed, 16 Dec 2015 12:11:00 -0700 Subject: [PATCH 007/437] 'pull ed4x5fix_n09_r120 tags from svn' --- biogeochem/EDCohortDynamicsMod.F90 | 2 +- biogeochem/EDPatchDynamicsMod.F90 | 4 ++-- biogeochem/EDPhenologyType.F90 | 4 +++- biogeochem/EDPhysiologyMod.F90 | 6 +++--- biogeophys/EDAccumulateFluxesMod.F90 | 2 +- biogeophys/EDPhotosynthesisMod.F90 | 15 +++++++++++++-- biogeophys/EDSurfaceAlbedoMod.F90 | 2 +- main/EDCLMLinkMod.F90 | 2 +- main/EDInitMod.F90 | 4 ++-- main/EDMainMod.F90 | 8 +++++--- main/EDParamsMod.F90 | 3 ++- main/EDTypesMod.F90 | 3 ++- 12 files changed, 36 insertions(+), 19 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 7903d4f1..ece8d394 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -28,7 +28,7 @@ module EDCohortDynamicsMod public :: countCohorts public :: allocate_live_biomass - logical, parameter :: DEBUG = .true. ! local debug flag + logical, parameter :: DEBUG = .false. ! local debug flag ! 10/30/09: Created by Rosie Fisher !-------------------------------------------------------------------------------------! diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index ff55b8db..27a32db5 100755 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -808,7 +808,7 @@ subroutine zero_patch(cp_p) currentPatch%bare_frac_area = nan currentPatch%tlai_profile(:,:,:) = nan - currentPatch%elai_profile(:,:,:) = nan + currentPatch%elai_profile(:,:,:) = 0._r8 currentPatch%tsai_profile(:,:,:) = nan currentPatch%esai_profile(:,:,:) = nan currentPatch%canopy_area_profile(:,:,:) = nan @@ -822,7 +822,7 @@ subroutine zero_patch(cp_p) currentPatch%ed_laisha_z(:,:,:) = nan currentPatch%ed_parsun_z(:,:,:) = nan currentPatch%ed_parsha_z(:,:,:) = nan - currentPatch%psn_z(:,:,:) = nan + currentPatch%psn_z(:,:,:) = 0._r8 currentPatch%f_sun(:,:,:) = nan currentPatch%tr_soil_dir(:) = nan ! fraction of incoming direct radiation that is transmitted to the soil as direct diff --git a/biogeochem/EDPhenologyType.F90 b/biogeochem/EDPhenologyType.F90 index dc0f7ec8..beb83bfc 100644 --- a/biogeochem/EDPhenologyType.F90 +++ b/biogeochem/EDPhenologyType.F90 @@ -281,7 +281,9 @@ subroutine initAccVars(this, bounds) call extract_accum_field (this%accString, rbufslp, get_nstep()) this%ED_GDD_patch(bounds%begp:bounds%endp) = rbufslp(bounds%begp:bounds%endp) - write(iulog,*) 'ED_GDD initAccVars ',this%ED_GDD_patch(bounds%begp:bounds%endp) + if ( this%DEBUG ) then + write(iulog,*) 'ED_GDD initAccVars ',this%ED_GDD_patch(bounds%begp:bounds%endp) + endif deallocate(rbufslp) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index ef719afc..c8f5f0b6 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -36,7 +36,7 @@ module EDPhysiologyMod public :: seed_decay public :: seed_germination - logical, parameter :: DEBUG = .true. ! local debug flag + logical, parameter :: DEBUG = .false. ! local debug flag ! ============================================================================ @@ -186,13 +186,13 @@ subroutine trim_canopy( currentSite ) 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) + currentCohort%leaf_cost = currentCohort%leaf_cost * (ED_val_grperc(1) + 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) + currentCohort%leaf_cost = currentCohort%leaf_cost * (ED_val_grperc(1) + 1._r8) endif if (currentCohort%year_net_uptake(z) < currentCohort%leaf_cost)then if (currentCohort%canopy_trim > trim_limit)then diff --git a/biogeophys/EDAccumulateFluxesMod.F90 b/biogeophys/EDAccumulateFluxesMod.F90 index 6247cae0..07464781 100644 --- a/biogeophys/EDAccumulateFluxesMod.F90 +++ b/biogeophys/EDAccumulateFluxesMod.F90 @@ -14,7 +14,7 @@ module EDAccumulateFluxesMod ! public :: AccumulateFluxes_ED - logical :: DEBUG = .true. ! for debugging this module + logical :: DEBUG = .false. ! for debugging this module !------------------------------------------------------------------------------ contains diff --git a/biogeophys/EDPhotosynthesisMod.F90 b/biogeophys/EDPhotosynthesisMod.F90 index c80b886d..8a1f4be1 100644 --- a/biogeophys/EDPhotosynthesisMod.F90 +++ b/biogeophys/EDPhotosynthesisMod.F90 @@ -76,7 +76,7 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & ! integer , parameter :: psn_type = 2 !c3 or c4. - logical :: DEBUG = .true. + logical :: DEBUG = .false. ! ! Leaf photosynthesis parameters @@ -815,7 +815,9 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & do while (associated(currentCohort)) ! Cohort loop call t_startf('edfluxunpack1') + if(currentCohort%n > 0._r8)then + ! Zero cohort flux accumulators. currentCohort%npp_clm = 0.0_r8 currentCohort%resp_clm = 0.0_r8 @@ -866,6 +868,15 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & gs_cohort = 1.0_r8/(rs_z(cl,ft,currentCohort%nv)+rb(p))*laifrac*tree_area currentCohort%gscan = currentCohort%gscan+gs_cohort + if ( DEBUG ) then + write(iulog,*) 'EDPhoto 868 ', currentCohort%gpp_clm + write(iulog,*) 'EDPhoto 869 ', currentPatch%psn_z(cl,ft,currentCohort%nv) + write(iulog,*) 'EDPhoto 870 ', currentPatch%elai_profile(cl,ft,currentCohort%nv) + write(iulog,*) 'EDPhoto 871 ', laifrac + write(iulog,*) 'EDPhoto 872 ', tree_area + write(iulog,*) 'EDPhoto 873 ', currentCohort%nv, cl, ft + endif + currentCohort%gpp_clm = currentCohort%gpp_clm + currentPatch%psn_z(cl,ft,currentCohort%nv) * & currentPatch%elai_profile(cl,ft,currentCohort%nv) * laifrac * tree_area @@ -959,7 +970,7 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & if ( DEBUG ) write(iulog,*) 'EDPhoto 912 ', currentCohort%resp_clm if ( DEBUG ) write(iulog,*) 'EDPhoto 913 ', currentCohort%resp_m - currentCohort%resp_g = ED_val_grperc * (max(0._r8,currentCohort%gpp_clm - currentCohort%resp_m)) + currentCohort%resp_g = ED_val_grperc(1) * (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 diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index 9c300edf..ed774aeb 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -23,7 +23,7 @@ module EDSurfaceAlbedoMod ! 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. - logical :: DEBUG = .true. ! for debugging this module + logical :: DEBUG = .false. ! for debugging this module real(r8), public :: albice(numrad) = & ! albedo land ice by waveband (1=vis, 2=nir) (/ 0.80_r8, 0.55_r8 /) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 99d33b5b..fffb57ca 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -14,7 +14,7 @@ module EDCLMLinkMod implicit none private ! - logical :: DEBUG = .true. ! for debugging this module (EDCLMLinkMod.F90) + logical :: DEBUG = .false. ! for debugging this module (EDCLMLinkMod.F90) type, public :: ed_clm_type diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 4b44b85a..7b0fb34a 100755 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -28,7 +28,7 @@ module EDInitMod implicit none private - logical :: DEBUG = .true. + logical :: DEBUG = .false. public :: ed_init public :: ed_init_sites @@ -383,7 +383,7 @@ subroutine init_cohorts( patch_in ) cstatus = patch_in%siteptr%dstatus endif - write(iulog,*) 'EDInitMod.F90 call create_cohort ' + if ( DEBUG ) write(iulog,*) 'EDInitMod.F90 call create_cohort ' call create_cohort(patch_in, pft, temp_cohort%n, temp_cohort%hite, temp_cohort%dbh, & temp_cohort%balive, temp_cohort%bdead, temp_cohort%bstore, & diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index fd656c0b..9873c2c7 100755 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -34,7 +34,7 @@ module EDMainMod private :: ed_integrate_state_variables private :: ed_total_balance_check - logical :: DEBUG_main = .true. + logical :: DEBUG = .false. ! ! 10/30/09: Created by Rosie Fisher !----------------------------------------------------------------------- @@ -287,9 +287,10 @@ subroutine ed_integrate_state_variables(currentSite, soilstate_inst, temperature enddo - if (DEBUG_main) then + if ( DEBUG ) then write(6,*)'DEBUG18: calling non_canopy_derivs with pno= ',currentPatch%clm_pno endif + call non_canopy_derivs( currentPatch, temperature_inst, soilstate_inst, waterstate_inst ) !update state variables simultaneously according to derivatives for this time period. @@ -391,9 +392,10 @@ subroutine ed_update_site( currentSite ) ! 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 + if ( DEBUG ) 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 diff --git a/main/EDParamsMod.F90 b/main/EDParamsMod.F90 index cf851430..16e2f2f5 100644 --- a/main/EDParamsMod.F90 +++ b/main/EDParamsMod.F90 @@ -3,6 +3,7 @@ module EDParamsMod ! module that deals with reading the ED parameter file ! use shr_kind_mod , only: r8 => shr_kind_r8 + use EDtypesMod , only: maxPft implicit none save @@ -16,7 +17,7 @@ module EDParamsMod 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_grperc(maxPft) real(r8),protected :: ED_val_maxspread real(r8),protected :: ED_val_minspread real(r8),protected :: ED_val_init_litter diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index f9b44cd4..1c48875e 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -39,9 +39,10 @@ module EDTypesMod 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. + integer , parameter :: maxPft = 79 ! max number of PFTs potentially used by CLM ! SPITFIRE - integer , parameter :: NLSC = 5 ! number carbon compartments in above ground litter array + integer , parameter :: NLSC = 6 ! 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 From 1b1d3d7f68fb2bfa0c9ec8a249ba41320759b7ac Mon Sep 17 00:00:00 2001 From: Ben Andre Date: Mon, 21 Dec 2015 15:43:37 -0700 Subject: [PATCH 008/437] 'pull ed4x5fix_n10_r120 tags from svn' --- biogeochem/EDPhenologyType.F90 | 5 ----- biogeophys/EDSurfaceAlbedoMod.F90 | 6 ++---- main/EDCLMLinkMod.F90 | 21 +++++++++++++++++++-- main/EDMainMod.F90 | 2 +- main/EDRestVectorMod.F90 | 18 ++++++++++++++++++ 5 files changed, 40 insertions(+), 12 deletions(-) diff --git a/biogeochem/EDPhenologyType.F90 b/biogeochem/EDPhenologyType.F90 index beb83bfc..c0293c97 100644 --- a/biogeochem/EDPhenologyType.F90 +++ b/biogeochem/EDPhenologyType.F90 @@ -130,11 +130,6 @@ subroutine accumulateAndExtract( this, bounds, & call update_accum_field ( trim(this%accString), rbufslp, get_nstep() ) call extract_accum_field ( trim(this%accstring), this%ED_GDD_patch, get_nstep() ) - if (is_restart()) then - if (this%DEBUG) write(iulog,*) 'EDPhenologyType.F90 130 ' - this%ED_GDD_patch(:) = 0.0_r8 - end if - if (this%DEBUG) write(iulog,*) 'ED_GDD accumAndExtract ', this%ED_GDD_patch deallocate(rbufslp) diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index ed774aeb..0457ede8 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -904,6 +904,7 @@ subroutine ED_Norman_Radiation (bounds, & if (abs(error) > 1.e-9_r8 .and. abs(error) < 0.15_r8)then 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) @@ -917,17 +918,14 @@ subroutine ED_Norman_Radiation (bounds, & 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 diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index fffb57ca..60c6844e 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -1150,8 +1150,13 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, waterstate_inst, canopys ! 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 + + if ( DEBUG ) write(iulog,*) 'EDCLMLink 1154 ', currentPatch%elai_profile(1,ft,iv) + + currentPatch%elai_profile(1,ft,iv) = currentPatch%tlai_profile(1,ft,iv) * fraction_exposed + currentPatch%esai_profile(1,ft,iv) = currentPatch%tsai_profile(1,ft,iv) * fraction_exposed + + if ( DEBUG ) write(iulog,*) 'EDCLMLink 1159 ', currentPatch%elai_profile(1,ft,iv) enddo ! (iv) hite bins @@ -1238,7 +1243,12 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, waterstate_inst, canopys (layer_top_hite-layer_bottom_hite )))) endif + if ( DEBUG ) write(iulog,*) 'EDCLMLink 1246 ', currentPatch%elai_profile(1,ft,iv) + currentPatch%elai_profile(L,ft,iv) = currentPatch%tlai_profile(L,ft,iv) *fraction_exposed + + if ( DEBUG ) write(iulog,*) 'EDCLMLink 1250 ', currentPatch%elai_profile(1,ft,iv) + !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 @@ -1279,8 +1289,12 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, waterstate_inst, canopys currentPatch%tsai_profile(L,ft,iv) = currentPatch%tsai_profile(L,ft,iv)+ remainder * & (1.0_r8-fleaf) * currentCohort%c_area/currentPatch%total_canopy_area + + if ( DEBUG ) write(iulog,*) 'EDCLMLink 1293 ', currentPatch%elai_profile(L,ft,iv) + 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) @@ -1306,6 +1320,9 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, waterstate_inst, canopys 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) + + if ( DEBUG ) write(iulog,*) 'EDCLMLink 1293 ', currentPatch%elai_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) / & diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 9873c2c7..b3c62b68 100755 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -113,7 +113,7 @@ subroutine ed_driver( bounds, ed_allsites_inst, ed_clm_inst, ed_phenology_inst, ed_phenology_inst, waterstate_inst, canopystate_inst) if (masterproc) then - write(iulog,*) 'leaving ed model',bounds%begg,bounds%endg,dayDiffInt + write(iulog,*) 'clm: leaving ED model',bounds%begg,bounds%endg,dayDiffInt end if end subroutine ed_driver diff --git a/main/EDRestVectorMod.F90 b/main/EDRestVectorMod.F90 index 2e480f44..c8332783 100755 --- a/main/EDRestVectorMod.F90 +++ b/main/EDRestVectorMod.F90 @@ -83,6 +83,7 @@ module EDRestVectorMod real(r8), pointer :: livegrass(:) ! this can probably be removed real(r8), pointer :: age(:) real(r8), pointer :: areaRestart(:) + real(r8), pointer :: f_sun(:) real(r8), pointer :: fabd_sun_z(:) real(r8), pointer :: fabi_sun_z(:) real(r8), pointer :: fabd_sha_z(:) @@ -179,6 +180,7 @@ subroutine deleteEDRestartVectorClass( this ) deallocate(this%livegrass ) deallocate(this%age ) deallocate(this%areaRestart ) + deallocate(this%f_sun ) deallocate(this%fabd_sun_z ) deallocate(this%fabi_sun_z ) deallocate(this%fabd_sha_z ) @@ -379,6 +381,11 @@ function newEDRestartVectorClass( bounds ) SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) new%areaRestart(:) = 0.0_r8 + allocate(new%f_sun & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%f_sun(:) = 0.0_r8 + allocate(new%fabd_sun_z & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) @@ -723,6 +730,12 @@ subroutine doVectorIO( this, ncid, flag ) interpinic_flag='interp', data=this%areaRestart, & readvar=readvar) + call restartvar(ncid=ncid, flag=flag, varname='ed_f_sun', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed patch - f_sun', units='unitless', & + interpinic_flag='interp', data=this%f_sun, & + readvar=readvar) + call restartvar(ncid=ncid, flag=flag, varname='ed_fabd_sun_z', xtype=ncd_double, & dim1name=dimName, & long_name='ed patch - fabd_sun_z', units='unitless', & @@ -850,6 +863,8 @@ subroutine printDataInfoVector( this ) this%age(iSta:iSto) write(iulog,*) trim(methodName)//' :: area ', & this%areaRestart(iSta:iSto) + write(iulog,*) trim(methodName)//' :: f_sun ', & + this%f_sun(iSta:iSto) write(iulog,*) trim(methodName)//' :: fabd_sun_z ', & this%fabd_sun_z(iSta:iSto) write(iulog,*) trim(methodName)//' :: fabi_sun_z ', & @@ -954,6 +969,7 @@ subroutine printDataInfoLL( this, bounds, ed_allsites_inst ) 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)//' f_sun (sum) ' ,sum(currentPatch%f_sun) write(iulog,*) trim(methodName)//' fabd_sun_z (sum) ' ,sum(currentPatch%fabd_sun_z) write(iulog,*) trim(methodName)//' fabi_sun_z (sum) ' ,sum(currentPatch%fabi_sun_z) write(iulog,*) trim(methodName)//' fabd_sha_z (sum) ' ,sum(currentPatch%fabd_sha_z) @@ -1220,6 +1236,7 @@ subroutine convertCohortListToVector( this, bounds, ed_allsites_inst ) do k = 1,nlevcan_ed ! nlevcan_ed currently 40 do j = 1,numpft_ed ! numpft_ed currently 2 do i = 1,nclmax ! nclmax currently 2 + this%f_sun(countSunZ) = currentPatch%f_sun(i,j,k) this%fabd_sun_z(countSunZ) = currentPatch%fabd_sun_z(i,j,k) this%fabi_sun_z(countSunZ) = currentPatch%fabi_sun_z(i,j,k) this%fabd_sha_z(countSunZ) = currentPatch%fabd_sha_z(i,j,k) @@ -1607,6 +1624,7 @@ subroutine convertCohortVectorToList( this, bounds, ed_allsites_inst ) do k = 1,nlevcan_ed ! nlevcan_ed currently 40 do j = 1,numpft_ed ! numpft_ed currently 2 do i = 1,nclmax ! nclmax currently 2 + currentPatch%f_sun(i,j,k) = this%f_sun(countSunZ) currentPatch%fabd_sun_z(i,j,k) = this%fabd_sun_z(countSunZ) currentPatch%fabi_sun_z(i,j,k) = this%fabi_sun_z(countSunZ) currentPatch%fabd_sha_z(i,j,k) = this%fabd_sha_z(countSunZ) From 9a527bbc215882de13fb4770647cebe33480f96f Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 11 Jan 2016 12:06:18 -0800 Subject: [PATCH 009/437] Porting of master (120) to lawrencium LR2 partition. Minor bug fix in EDInitMod.F90. Configuration and machine files were added to lawrencium-lr2. Some extra changes were required beyond what had been established with ACME, as cime-gptl build were having trouble identifying if the sys/time.h library was available to provide machine time. It was also having trouble printing errors correctly, this was enabled by passing c-compiler directives in config_compilers.xml. The bug fix in EDInitMod.F90 placed a filter on the initd values read in from the pft parameter file, thus preventing the model from trying to initialize cohorts from pfts with zero initial density (this prevents div0's). Test suite: aux_clm45 Test baseline: none Test namelist changes: none Test status: [bit for bit, roundoff, climate changing] DONE SMS_Ld5.f19_g16.ICLM45ED.lawrencium-lr2_intel.clm-edTest : (test finished, successful coupler log) --- Test Functionality: --- PASS SMS_Ld5.f19_g16.ICLM45ED.lawrencium-lr2_intel.clm-edTest : successful coupler log PASS SMS_Ld5.f19_g16.ICLM45ED.lawrencium-lr2_intel.clm-edTest.memleak --- Test time is 46 seconds --- DONE ERS_D_Mmpi-serial_Ld5.1x1_brazil.ICLM45ED.lawrencium-lr2_intel.clm-edTest : (test finished, successful coupler log) --- Test Functionality ---: /global/home/users/rgknox/Models/ed-clm-lcport2/cime/scripts/Tools/component_compare.sh: line 318: //global/scratch/rgknox/tools/cprnc/cprnc: No such file or directory FAIL ERS_D_Mmpi-serial_Ld5.1x1_brazil.ICLM45ED.lawrencium-lr2_intel.clm-edTest.clm2.h0.nc : test compare clm2.h0 (.base and .rest files) /global/home/users/rgknox/Models/ed-clm-lcport2/cime/scripts/Tools/component_compare.sh: line 318: //global/scratch/rgknox/tools/cprnc/cprnc: No such file or directory FAIL ERS_D_Mmpi-serial_Ld5.1x1_brazil.ICLM45ED.lawrencium-lr2_intel.clm-edTest.cpl.hi.nc : test compare cpl.hi (.base and .rest files) FAIL ERS_D_Mmpi-serial_Ld5.1x1_brazil.ICLM45ED.lawrencium-lr2_intel.clm-edTest : test functionality summary (ERS_test) PASS ERS_D_Mmpi-serial_Ld5.1x1_brazil.ICLM45ED.lawrencium-lr2_intel.clm-edTest.memleak --- Test time is 59 seconds --- DONE SMS_Ld5.f10_f10.ICLM45ED.lawrencium-lr2_intel.clm-edTest : (test finished, successful coupler log) --- Test Functionality: --- PASS SMS_Ld5.f10_f10.ICLM45ED.lawrencium-lr2_intel.clm-edTest : successful coupler log PASS SMS_Ld5.f10_f10.ICLM45ED.lawrencium-lr2_intel.clm-edTest.memleak --- Test time is 34 seconds --- RUN ERS_D_Ld5.f19_g16.ICLM45ED.lawrencium-lr2_intel.clm-edTest.160110-203643 DONE SMS_D_Mmpi-serial_Ld5.5x5_amazon.ICLM45ED.lawrencium-lr2_intel.clm-edTest : (test finished, successful coupler log) --- Test Functionality: --- PASS SMS_D_Mmpi-serial_Ld5.5x5_amazon.ICLM45ED.lawrencium-lr2_intel.clm-edTest : successful coupler log PASS SMS_D_Mmpi-serial_Ld5.5x5_amazon.ICLM45ED.lawrencium-lr2_intel.clm-edTest.memleak --- Test time is 47 seconds --- Fixes: Addresses teamwork task: "Develop consolidated codebase from which to start": https://ngeetropics.teamwork.com/tasks/5048570 User interface changes?: machine files are intended to be buffered from the user. Code review: self --- biogeochem/EDGrowthFunctionsMod.F90 | 2 +- main/EDInitMod.F90 | 4 ++++ main/EDTypesMod.F90 | 2 +- 3 files changed, 6 insertions(+), 2 deletions(-) diff --git a/biogeochem/EDGrowthFunctionsMod.F90 b/biogeochem/EDGrowthFunctionsMod.F90 index a497df20..27ed64cd 100755 --- a/biogeochem/EDGrowthFunctionsMod.F90 +++ b/biogeochem/EDGrowthFunctionsMod.F90 @@ -140,7 +140,7 @@ real(r8) function tree_lai( cohort_in ) 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 + 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 diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 3390053c..8e6201ba 100755 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -335,6 +335,8 @@ subroutine init_cohorts( patch_in ) do pft = 1,numpft_ed !FIX(RF,032414) - turning off veg dynamics + if(EDecophyscon%initd(pft)>1.0E-7) then + allocate(temp_cohort) ! temporary cohort temp_cohort%pft = pft @@ -378,6 +380,8 @@ subroutine init_cohorts( patch_in ) deallocate(temp_cohort) ! get rid of temporary cohort + endif + enddo !numpft call fuse_cohorts(patch_in) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 1362b048..c609a763 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -34,7 +34,7 @@ module EDTypesMod 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. + integer , parameter :: numpft_ed = 10 ! number of PFTs used in ED. ! SPITFIRE integer , parameter :: NLSC = 5 ! number carbon compartments in above ground litter array From c20215befcef1cc0b8b2ee7d8742f583001506e4 Mon Sep 17 00:00:00 2001 From: jenniferholm Date: Mon, 11 Jan 2016 14:04:52 -0800 Subject: [PATCH 010/437] PARTIAL - Updated size class distriution and mortality diagnostics --- biogeochem/EDCohortDynamicsMod.F90 | 123 +++++++++++++- biogeochem/EDGrowthFunctionsMod.F90 | 27 ++- biogeochem/EDPatchDynamicsMod.F90 | 97 +++++++++-- biogeochem/EDPhysiologyMod.F90 | 22 ++- main/EDCLMLinkMod.F90 | 247 +++++++++++++++++++++++++++- main/EDTypesMod.F90 | 94 ++++++++++- 6 files changed, 575 insertions(+), 35 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 7fe96b45..82da0f92 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -12,6 +12,7 @@ module EDCohortDynamicsMod use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type use EDTypesMod , only : fusetol, nclmax use EDtypesMod , only : ncwd, numcohortsperpatch, udata + use EDtypesMod , only : sclass_ed,nlevsclass_ed,AREA ! implicit none private @@ -127,6 +128,13 @@ subroutine create_cohort(patchptr, pft, nn, hite, dbh, & patchptr%shortest => new_cohort endif + ! Recuits do not have mortality rates, nor have they moved any + ! carbon when they are created. They will bias our statistics + ! until they have experienced a full day. We need a newly recruited flag. + ! This flag will be set to false after it has experienced + ! growth, disturbance and mortality. + new_cohort%isnew = .true. + call insert_cohort(new_cohort, patchptr%tallest, patchptr%shortest, tnull, snull, & storebigcohort, storesmallcohort) @@ -136,7 +144,7 @@ subroutine create_cohort(patchptr, pft, nn, hite, dbh, & end subroutine create_cohort !-------------------------------------------------------------------------------------! - subroutine allocate_live_biomass(cc_p) + subroutine allocate_live_biomass(cc_p,mode) ! ! !DESCRIPTION: ! Divide alive biomass between leaf, root and sapwood parts. @@ -146,6 +154,7 @@ subroutine allocate_live_biomass(cc_p) ! ! !ARGUMENTS type (ed_cohort_type), intent(inout), target :: cc_p ! current cohort pointer + integer , intent(in) :: mode ! ! !LOCAL VARIABLES: type (ed_cohort_type), pointer :: currentCohort @@ -163,7 +172,7 @@ subroutine allocate_live_biomass(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 + !currentcohort%bl = currentcohort%balive*leaf_frac ratio_balive = 1.0_r8 !for deciduous trees, there are no leaves @@ -174,9 +183,9 @@ subroutine allocate_live_biomass(cc_p) !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 + !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 @@ -186,6 +195,38 @@ subroutine allocate_live_biomass(cc_p) leaves_off_switch = 1 !cold decid endif + + ! Use different proportions if the leaves are on vs off + if(leaves_off_switch==0)then + + ! Tracking npp/gpp diagnostics only occur after growth derivatives is called + if(mode==1)then + ! it will not be able to put out as many leaves as it had previous timestep + currentcohort%npp_leaf = currentcohort%npp_leaf + & + max(0.0_r8,currentcohort%balive*leaf_frac - currentcohort%bl)/udata%deltat + end if + + currentcohort%bl = currentcohort%balive*leaf_frac + + !diagnose the root and stem biomass from the functional balance hypothesis. This is used when the leaves are + !fully on. + if(mode==1)then + + currentcohort%npp_froot = currentcohort%npp_froot + & + max(0._r8,pftcon%froot_leaf(ft)*(currentcohort%balive+currentcohort%laimemory)*leaf_frac - currentcohort%br)/udata%deltat + + currentcohort%npp_bsw = max(0._r8,EDecophyscon%sapwood_ratio(ft) * currentcohort%hite *(currentcohort%balive + & + currentcohort%laimemory)*leaf_frac - currentcohort%bsw)/udata%deltat + + currentcohort%npp_bdead = currentCohort%dbdeaddt + + end if + + 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 + + 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 @@ -205,6 +246,21 @@ subroutine allocate_live_biomass(cc_p) currentcohort%bsw = currentcohort%bsw * ratio_balive endif + + ! Diagnostics + if(mode==1)then + + currentcohort%npp_froot = currentcohort%npp_froot + & + max(0.0_r8,pftcon%froot_leaf(ft)*(ideal_balive + & + currentcohort%laimemory)*leaf_frac*ratio_balive-currentcohort%br)/udata%deltat + + currentcohort%npp_bsw = max(0.0_r8,EDecophyscon%sapwood_ratio(ft) * currentcohort%hite *(ideal_balive + & + currentcohort%laimemory)*leaf_frac*ratio_balive - currentcohort%bsw)/udata%deltat + + currentcohort%npp_bdead = currentCohort%dbdeaddt + + end if + if (abs(currentcohort%balive -currentcohort%bl- currentcohort%br - currentcohort%bsw)>1e-12) then write(iulog,*) 'issue with carbon allocation in create_cohort',& @@ -286,6 +342,14 @@ subroutine nan_cohort(cc_p) currentCohort%resp_clm = nan ! RESP: kgC/indiv/timestep currentCohort%resp_acc = nan ! RESP: kGC/cohort/day + currentCohort%npp_leaf = nan + currentCohort%npp_froot = nan + currentCohort%npp_bsw = nan + currentCohort%npp_bdead = nan + currentCohort%npp_bseed = nan + currentCohort%npp_store = nan + + !RESPIRATION currentCohort%rd = nan currentCohort%resp_m = nan ! Maintenance respiration. kGC/cohort/year @@ -379,6 +443,13 @@ subroutine zero_cohort(cc_p) currentcohort%gscan = 0._r8 currentcohort%treesai = 0._r8 + ! currentCohort%npp_leaf = 0._r8 + ! currentCohort%npp_froot = 0._r8 + ! currentCohort%npp_bsw = 0._r8 + ! currentCohort%npp_bdead = 0._r8 + ! currentCohort%npp_bseed = 0._r8 + ! currentCohort%npp_store = 0._r8 + end subroutine zero_cohort !-------------------------------------------------------------------------------------! @@ -510,7 +581,9 @@ subroutine fuse_cohorts(patchptr) iterate = 1 fusion_took_place = 0 currentPatch => patchptr - maxcohorts = currentPatch%NCL_p * numCohortsPerPatch + ! maxcohorts = currentPatch%NCL_p * numCohortsPerPatch + maxcohorts = numCohortsPerPatch + !---------------------------------------------------------------------! ! Keep doing this until nocohorts <= maxcohorts ! !---------------------------------------------------------------------! @@ -537,6 +610,10 @@ subroutine fuse_cohorts(patchptr) ! check cohorts in same c. layer. before fusing if (currentCohort%canopy_layer == nextc%canopy_layer) then + + ! check to make sure one is not a new recruit (npp=nan flag) + if( (.not.(currentCohort%isnew)).and.(.not.(nextc%isnew)) ) then + fusion_took_place = 1 newn = currentCohort%n + nextc%n ! sum individuals in both cohorts. @@ -571,6 +648,21 @@ subroutine fuse_cohorts(patchptr) 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 + ! mortality diagnostics + currentCohort%cmort = (currentCohort%n*currentCohort%cmort + nextc%n*nextc%cmort)/newn + currentCohort%hmort = (currentCohort%n*currentCohort%hmort + nextc%n*nextc%hmort)/newn + currentCohort%bmort = (currentCohort%n*currentCohort%bmort + nextc%n*nextc%bmort)/newn + currentCohort%imort = (currentCohort%n*currentCohort%imort + nextc%n*nextc%imort)/newn + currentCohort%fmort = (currentCohort%n*currentCohort%fmort + nextc%n*nextc%fmort)/newn + + ! npp diagnostics + currentCohort%npp_leaf = (currentCohort%n*currentCohort%npp_leaf + nextc%n*nextc%npp_leaf)/newn + currentCohort%npp_froot = (currentCohort%n*currentCohort%npp_froot + nextc%n*nextc%npp_froot)/newn + currentCohort%npp_bsw = (currentCohort%n*currentCohort%npp_bsw + nextc%n*nextc%npp_bsw)/newn + currentCohort%npp_bdead = (currentCohort%n*currentCohort%npp_bdead + nextc%n*nextc%npp_bdead)/newn + currentCohort%npp_bseed = (currentCohort%n*currentCohort%npp_bseed + nextc%n*nextc%npp_bseed)/newn + currentCohort%npp_store = (currentCohort%n*currentCohort%npp_store + nextc%n*nextc%npp_store)/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)) @@ -591,6 +683,8 @@ subroutine fuse_cohorts(patchptr) if (associated(nextc)) then deallocate(nextc) endif + + endif ! Not a recruit endif !canopy layer endif !pft endif !index no. @@ -862,6 +956,13 @@ subroutine copy_cohort( currentCohort,copyc ) n%year_net_uptake = o%year_net_uptake n%ts_net_uptake = o%ts_net_uptake + n%npp_leaf = o%npp_leaf + n%npp_froot = o%npp_froot + n%npp_bsw = o%npp_bsw + n%npp_bdead = o%npp_bdead + n%npp_bseed = o%npp_bseed + n%npp_store = o%npp_store + !RESPIRATION n%rd = o%rd n%resp_m = o%resp_m @@ -888,6 +989,16 @@ subroutine copy_cohort( currentCohort,copyc ) n%c_area = o%c_area n%woody_turnover = o%woody_turnover + ! Mortality diagnostics + n%cmort = o%cmort + n%bmort = o%bmort + n%imort = o%imort + n%fmort = o%fmort + n%hmort = o%hmort + + ! Flags + n%isnew = o%isnew + ! VARIABLES NEEDED FOR INTEGRATION n%dndt = o%dndt n%dhdt = o%dhdt diff --git a/biogeochem/EDGrowthFunctionsMod.F90 b/biogeochem/EDGrowthFunctionsMod.F90 index a497df20..73f56662 100755 --- a/biogeochem/EDGrowthFunctionsMod.F90 +++ b/biogeochem/EDGrowthFunctionsMod.F90 @@ -324,7 +324,8 @@ end function dDbhdBl ! ============================================================================ - real(r8) function mortality_rates( cohort_in ) + !real(r8) function mortality_rates( cohort_in ) + real(r8) function mortality_rates( cohort_in,cmort,hmort,bmort ) ! ============================================================================ ! Calculate mortality rates as a function of carbon storage @@ -335,30 +336,42 @@ real(r8) function mortality_rates( cohort_in ) type (ed_cohort_type), intent(in) :: cohort_in real(r8) :: frac ! relativised stored carbohydrate - real(r8) :: smort ! stress mortality : Fraction per year + !real(r8) :: smort ! stress mortality : Fraction per year real(r8) :: bmort ! background mortality : Fraction per year + real(r8) :: cmort ! carbon starvation mortality + real(r8) :: hmort ! hydraulic failure mortality + ! '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 + !smort = 0.0_r8 if(cohort_in%patchptr%btran_ft(cohort_in%pft) <= 0.000001_r8)then - smort = smort + ED_val_stress_mort - endif + !smort = smort + ED_val_stress_mort + hmort = ED_val_stress_mort + else + hmort = 0.0_r8 + endif + !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)) + !smort = smort + max(0.0_r8,ED_val_stress_mort*(1.0_r8 - frac)) + cmort = max(0.0_r8,ED_val_stress_mort*(1.0_r8 - frac)) + else + cmort = 0.0_r8 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 + !mortality_rates = smort + bmort + mortality_rates = bmort + hmort + cmort end function mortality_rates diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 826e7a60..c1ef4c9d 100755 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -8,7 +8,7 @@ module EDPatchDynamicsMod 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 : ncwd, n_dbh_bins, ntol, numpft_ed, area, dbhmax, numPatchesPerGridCell use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type, udata ! implicit none @@ -50,6 +50,9 @@ subroutine disturbance_rates( site_in) ! !LOCAL VARIABLES: type (ed_patch_type) , pointer :: currentPatch type (ed_cohort_type), pointer :: currentCohort + real(r8) :: cmort + real(r8) :: bmort + real(r8) :: hmort !--------------------------------------------------------------------- !MORTALITY @@ -65,9 +68,17 @@ subroutine disturbance_rates( site_in) ! Mortality for trees in the understorey. currentCohort%patchptr => currentPatch + call mortality_rates(currentCohort,cmort,hmort,bmort) currentCohort%dmort = mortality_rates(currentCohort) currentCohort%c_area = c_area(currentCohort) + ! Initialize diagnostic mortality rates + currentCohort%cmort = cmort + currentCohort%bmort = bmort + currentCohort%hmort = hmort + currentCohort%imort = 0.0_r8 ! Impact mortality is always zero except in new patches + currentCohort%fmort = 0.0_r8 ! Fire mortality is initialized as zero, but may be changed + if(currentCohort%canopy_layer == 1)then currentPatch%disturbance_rates(1) = currentPatch%disturbance_rates(1) + & @@ -91,6 +102,27 @@ subroutine disturbance_rates( site_in) !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) + + ! RGK 02-18-2014 + ! Since treefall mortality is not actually being applied + ! Go through and zero the diagnostic rates + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + if(currentCohort%canopy_layer == 1)then + currentCohort%cmort=0.0_r8 + currentCohort%hmort=0.0_r8 + currentCohort%bmort=0.0_r8 + end if + + ! This may be counter-intuitive, but the diagnostic fire-mortality rate + ! will stay zero in the patch that undergoes fire, this is because + ! the actual cohorts who experience the fire are only those in the + ! newly created patch so currentCohort%fmort = 0.0_r8 + ! Don't worry, the cohorts in the newly created patch will reflect burn + + currentCohort => currentCohort%taller + enddo !currentCohort + else currentPatch%disturbance_rate = currentPatch%disturbance_rates(1) ! DISTURBANCE IS MORTALITY endif @@ -226,26 +258,64 @@ subroutine spawn_patches( currentSite ) !mortality is dominant disturbance if(currentPatch%disturbance_rates(1) > currentPatch%disturbance_rates(2))then - if(currentCohort%canopy_layer == 1)then + if(currentCohort%canopy_layer == 1)then + ! In the donor patch we are left with fewer trees because the area has decreased + ! the plant density for large trees does not actually decrease in the donor patch + ! because this is the part of the original patch where no trees have actually fallen + ! The diagnostic cmort,bmort and hmort rates have already been saved ! 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 + + nc%n = 0.0_r8 ! kill all of the trees who caused the disturbance. + nc%cmort = nan ! The mortality diagnostics are set to nan because the cohort should dissappear + nc%hmort = nan + nc%bmort = nan + nc%fmort = nan + nc%imort = nan + else + ! small trees if(pftcon%woody(currentCohort%pft) == 1)then + ! Number of trees in the understory of new patch, before we impose impact mortality and survivorship + nc%n = currentCohort%n * patch_site_areadis/currentPatch%area + ! 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 + + ! since the donor patch split and sent a fraction of its members + ! to the new patch and a fraction to be preserved in itself, + ! when reporting diagnostic rates, we must carry over the mortality rates from + ! the donor that were applied before the patch split. Remember this is only + ! for diagnostics. But think of it this way, the rates are weighted by + ! number density in EDCLMLink, and the number density of this new patch is donated + ! so with the number density must come the effective mortality rates. + + nc%fmort = 0.0_r8 ! Should had also been zero in the donor + nc%imort = ED_val_understorey_death/udata%deltat ! This was zero in the donor + nc%cmort = currentCohort%cmort + nc%hmort = currentCohort%hmort + nc%bmort = currentCohort%bmort + ! 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. + ! The existing (donor) patch should not have any impact mortality, it should + ! only lose cohorts due to the decrease in area. This is not mortality. + ! Besides, the current and newly created patch sum to unity + currentCohort%n = currentCohort%n * (1._r8 - patch_site_areadis/currentPatch%area) else + ! grass is not killed by mortality disturbance events. Just move it into the new patch area. + ! Just split the grass into the existing and new patch structures + nc%n = currentCohort%n * patch_site_areadis/currentPatch%area - ! 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. + ! Those remaining in the existing currentCohort%n = currentCohort%n * (1._r8 - patch_site_areadis/currentPatch%area) + nc%fmort = nan ! These should not make it to the diagnostics + nc%imort = nan ! If they do.. they should invalidate it + nc%cmort = nan ! + nc%hmort = nan ! + nc%bmort = nan ! + endif endif else !fire @@ -255,6 +325,12 @@ subroutine spawn_patches( currentSite ) ! loss of individuals from source patch currentCohort%n = currentCohort%n * (1._r8 - patch_site_areadis/currentPatch%area) + nc%fmort = currentCohort%fire_mort/udata%deltat + nc%imort = 0.0_r8 + nc%cmort = currentCohort%cmort + nc%hmort = currentCohort%hmort + nc%bmort = currentCohort%bmort + endif if (nc%n > 0.0_r8) then @@ -910,7 +986,8 @@ subroutine fuse_patches( csite ) integer :: fuse_flag !do patches get fused (1) or not (0). !--------------------------------------------------------------------- - maxpatch = 4 + !maxpatch = 4 + maxpatch = numPatchesPerGridCell currentSite => csite diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index ab543045..bc63c30e 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -677,6 +677,9 @@ subroutine Growth_Derivatives( currentCohort) 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) :: cmort ! starvation mortality rate (fraction per year) + real(r8) :: bmort ! background mortality rate (fraction per year) + real(r8) :: hmort ! hydraulic failure mortality rate (fraction per year) real(r8) :: balive_loss !---------------------------------------------------------------------- @@ -685,7 +688,8 @@ subroutine Growth_Derivatives( currentCohort) ! 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 + call mortality_rates(currentCohort,cmort,hmort,bmort) + currentCohort%dndt = -1.0_r8 * (cmort+hmort+bmort) * currentCohort%n else currentCohort%dndt = 0._r8 endif @@ -694,7 +698,7 @@ subroutine Growth_Derivatives( currentCohort) currentCohort%hite = Hite(currentCohort) h = currentCohort%hite - call allocate_live_biomass(currentCohort) + call allocate_live_biomass(currentCohort,0) ! calculate target size of living biomass compartment for a given dbh. target_balive = Bleaf(currentCohort) * (1.0_r8 + pftcon%froot_leaf(currentCohort%pft) + & @@ -752,6 +756,14 @@ subroutine Growth_Derivatives( currentCohort) currentCohort%carbon_balance = currentCohort%npp - currentCohort%md * EDecophyscon%leaf_stor_priority(currentCohort%pft) + ! Allowing only carbon from NPP pool to account for npp flux into the maintenance pools + ! ie this does not include any use of storage carbon or balive to make up for missing carbon balance in the transfer + currentCohort%npp_leaf = min(currentCohort%npp*currentCohort%leaf_md/currentCohort%md, & + currentCohort%leaf_md*EDecophyscon%leaf_stor_priority(currentCohort%pft)) + currentCohort%npp_froot = min(currentCohort%npp*currentCohort%root_md/currentCohort%md, & + currentCohort%root_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 @@ -850,10 +862,16 @@ subroutine Growth_Derivatives( currentCohort) currentCohort%dbalivedt = 0._r8 endif + currentCohort%npp_bseed = currentCohort%seed_prod + currentCohort%npp_store = max(0.0_r8,currentCohort%storage_flux) + ! calculate change in diameter and height currentCohort%ddbhdt = currentCohort%dbdeaddt * dDbhdBd(currentCohort) currentCohort%dhdt = currentCohort%dbdeaddt * dHdBd(currentCohort) + ! If the cohort has grown, it is not new + currentCohort%isnew=.false. + end subroutine Growth_Derivatives ! ============================================================================ diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 5de402f3..6a62f125 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -7,9 +7,12 @@ module EDCLMLinkMod 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_varpar , only : nclmax, nlevcan_ed, numpft, numcft, mxpft use clm_varctl , only : iulog - use EDtypesMod , only : ed_site_type, ed_cohort_type, ed_patch_type + use EDtypesMod , only : ed_site_type, ed_cohort_type, ed_patch_type, nlevsclass_ed + use EDtypesMod , only : sclass_ed,nlevsclass_ed,AREA + use EDParamsMod , only : ED_val_ag_biomass + ! implicit none private @@ -70,6 +73,36 @@ module EDCLMLinkMod 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 + + real(r8), pointer :: ed_gpp_gd_scpf (:,:) ! [kg/m2/yr] gross primary production + real(r8), pointer :: ed_npp_totl_gd_scpf (:,:) ! [kg/m2/yr] net primary production (npp) + real(r8), pointer :: ed_npp_leaf_gd_scpf (:,:) ! [kg/m2/yr] npp flux into leaf pool + real(r8), pointer :: ed_npp_seed_gd_scpf (:,:) ! [kg/m2/yr] npp flux into flower,fruit,nut,seed + real(r8), pointer :: ed_npp_fnrt_gd_scpf (:,:) ! [kg/m2/yr] npp flux into fine roots + real(r8), pointer :: ed_npp_bgsw_gd_scpf (:,:) ! [kg/m2/yr] npp flux into below ground sapwood + real(r8), pointer :: ed_npp_bgdw_gd_scpf (:,:) ! [kg/m2/yr] npp flux into below ground structural (dead) wood + real(r8), pointer :: ed_npp_agsw_gd_scpf (:,:) ! [kg/m2/yr] npp flux into above ground sapwood + real(r8), pointer :: ed_npp_agdw_gd_scpf (:,:) ! [kg/m2/yr] npp flux into below ground structural (dead) wood + real(r8), pointer :: ed_npp_stor_gd_scpf (:,:) ! [kg/m2/yr] npp flux through the storage pool + real(r8), pointer :: ed_litt_leaf_gd_scpf (:,:) ! [kg/m2/yr] carbon flux of live leaves to litter + real(r8), pointer :: ed_litt_fnrt_gd_scpf (:,:) ! [kg/m2/yr] carbon flux of fine roots to litter + real(r8), pointer :: ed_litt_sawd_gd_scpf (:,:) ! [kg/m2/yr] carbon flux of sapwood to litter (above+below) + real(r8), pointer :: ed_litt_ddwd_gd_scpf (:,:) ! [kg/m2/yr] carbon flux of dead wood (above+below) to litter + real(r8), pointer :: ed_r_leaf_gd_scpf (:,:) ! [kg/m2/yr] totat leaf respiration + real(r8), pointer :: ed_r_stem_gd_scpf (:,:) ! [kg/m2/yr] total above ground live wood (stem) respiration + real(r8), pointer :: ed_r_root_gd_scpf (:,:) ! [kg/m2/yr] total below ground live wood (root) respiration + real(r8), pointer :: ed_r_stor_gd_scpf (:,:) ! [kg/m2/yr] total storage respiration + + ! Carbon State Variables for direct comparison to inventory - dimensions: (disturbance patch, pft x size) + + real(r8), pointer :: ed_ddbh_gd_scpf (:,:) ! [cm/yr] diameter increment + real(r8), pointer :: ed_ba_gd_scpf (:,:) ! [m2/ha] basal area + real(r8), pointer :: ed_np_gd_scpf (:,:) ! [/m2] number of plants + real(r8), pointer :: ed_m1_gd_scpf (:,:) ! [Stems/ha/yr] Mean Background Mortality + real(r8), pointer :: ed_m2_gd_scpf (:,:) ! [Stems/ha/yr] Mean Hydraulic Mortaliry rate + real(r8), pointer :: ed_m3_gd_scpf (:,:) ! [Stems/ha/yr] Mean Carbon Starvation Mortality rate + real(r8), pointer :: ed_m4_gd_scpf (:,:) ! [Stems/ha/yr] Mean Impact Mortality Rate + real(r8), pointer :: ed_m5_gd_scpf (:,:) ! [Stems/ha/yr] Mean Fire Mortality Rate contains @@ -123,9 +156,13 @@ subroutine InitAllocate(this, bounds) ! ! !LOCAL VARIABLES: integer :: begp,endp + integer :: begc,endc !bounds + integer :: begg,endg !------------------------------------------------------------------------ begp = bounds%begp; endp = bounds%endp + begc = bounds%begc; endc = bounds%endc + 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 @@ -171,6 +208,36 @@ subroutine InitAllocate(this, bounds) allocate(this%gpp_patch (begp:endp)) ; this%gpp_patch (:) = nan allocate(this%npp_patch (begp:endp)) ; this%npp_patch (:) = nan + begg = bounds%begg; endg = bounds%endg + allocate(this%ed_gpp_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)); this%ed_gpp_gd_scpf (:,:) = 0.0_r8 + allocate(this%ed_npp_totl_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)); this%ed_npp_totl_gd_scpf (:,:) = 0.0_r8 + allocate(this%ed_npp_leaf_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)); this%ed_npp_leaf_gd_scpf (:,:) = 0.0_r8 + allocate(this%ed_npp_seed_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)); this%ed_npp_seed_gd_scpf (:,:) = 0.0_r8 + allocate(this%ed_npp_fnrt_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)); this%ed_npp_fnrt_gd_scpf (:,:) = 0.0_r8 + allocate(this%ed_npp_bgsw_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)); this%ed_npp_bgsw_gd_scpf (:,:) = 0.0_r8 + allocate(this%ed_npp_bgdw_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)); this%ed_npp_bgdw_gd_scpf (:,:) = 0.0_r8 + allocate(this%ed_npp_agsw_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)); this%ed_npp_agsw_gd_scpf (:,:) = 0.0_r8 + allocate(this%ed_npp_agdw_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)); this%ed_npp_agdw_gd_scpf (:,:) = 0.0_r8 + allocate(this%ed_npp_stor_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)); this%ed_npp_stor_gd_scpf (:,:) = 0.0_r8 + allocate(this%ed_litt_leaf_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)); this%ed_litt_leaf_gd_scpf (:,:) = 0.0_r8 + allocate(this%ed_litt_fnrt_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)); this%ed_litt_fnrt_gd_scpf (:,:) = 0.0_r8 + allocate(this%ed_litt_sawd_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)); this%ed_litt_sawd_gd_scpf (:,:) = 0.0_r8 + allocate(this%ed_litt_ddwd_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)); this%ed_litt_ddwd_gd_scpf (:,:) = 0.0_r8 + allocate(this%ed_r_leaf_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)); this%ed_r_leaf_gd_scpf (:,:) = 0.0_r8 + allocate(this%ed_r_stem_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)); this%ed_r_stem_gd_scpf (:,:) = 0.0_r8 + allocate(this%ed_r_root_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)); this%ed_r_root_gd_scpf (:,:) = 0.0_r8 + allocate(this%ed_r_stor_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)); this%ed_r_stor_gd_scpf (:,:) = 0.0_r8 + + ! Carbon State Variables for direct comparison to inventory - dimensions: (disturbance patch, pft x size) + allocate(this%ed_ddbh_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)) ; this%ed_ddbh_gd_scpf (:,:) = 0.0_r8 + allocate(this%ed_ba_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)) ; this%ed_ba_gd_scpf (:,:) = 0.0_r8 + allocate(this%ed_np_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)) ; this%ed_np_gd_scpf (:,:) = 0.0_r8 + allocate(this%ed_m1_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)) ; this%ed_m1_gd_scpf (:,:) = 0.0_r8 + allocate(this%ed_m2_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)) ; this%ed_m2_gd_scpf (:,:) = 0.0_r8 + allocate(this%ed_m3_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)) ; this%ed_m3_gd_scpf (:,:) = 0.0_r8 + allocate(this%ed_m4_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)) ; this%ed_m4_gd_scpf (:,:) = 0.0_r8 + allocate(this%ed_m5_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)) ; this%ed_m5_gd_scpf (:,:) = 0.0_r8 + end subroutine InitAllocate !------------------------------------------------------------------------ @@ -379,6 +446,78 @@ subroutine InitHistory(this, bounds) avgflag='A', long_name='net primary production', & ptr_patch=this%npp_patch) + + ! Carbon Flux (grid dimension x scpf) + ! ============================================================== + + call hist_addfld2d (fname='ED_GPP_GD_SCPF',units='kgC/m2/yr',type2d='levscpf',& + avgflag='A', long_name='gross primary production', & + ptr_gcell=this%ed_gpp_gd_scpf,default='inactive') + + call hist_addfld2d (fname='ED_NPP_LEAF_GD_SCPF',units='kgC/m2/yr',type2d='levscpf',& + avgflag='A', long_name='NPP flux into leaves', & + ptr_gcell=this%ed_npp_leaf_gd_scpf,default='inactive') + + call hist_addfld2d (fname='ED_NPP_SEED_GD_SCPF',units='kgC/m2/yr',type2d='levscpf',& + avgflag='A', long_name='NPP flux into seeds', & + ptr_gcell=this%ed_npp_seed_gd_scpf,default='inactive') + + call hist_addfld2d (fname='ED_NPP_FNRT_GD_SCPF',units='kgC/m2/yr',type2d='levscpf',& + avgflag='A', long_name='NPP flux into fine roots', & + ptr_gcell=this%ed_npp_fnrt_gd_scpf,default='inactive') + + call hist_addfld2d (fname='ED_NPP_BGSW_GD_SCPF',units='kgC/m2/yr',type2d='levscpf',& + avgflag='A', long_name='NPP flux into below-ground sapwood', & + ptr_gcell=this%ed_npp_bgsw_gd_scpf,default='inactive') + + call hist_addfld2d (fname='ED_NPP_BGDW_GD_SCPF',units='kgC/m2/yr',type2d='levscpf',& + avgflag='A', long_name='NPP flux into below-ground deadwood', & + ptr_gcell=this%ed_npp_bgdw_gd_scpf,default='inactive') + + call hist_addfld2d (fname='ED_NPP_AGSW_GD_SCPF',units='kgC/m2/yr',type2d='levscpf',& + avgflag='A', long_name='NPP flux into above-ground sapwood', & + ptr_gcell=this%ed_npp_agsw_gd_scpf,default='inactive') + + call hist_addfld2d ( fname = 'ED_NPP_AGDW_GD_SCPF', units='kgC/m2/yr',type2d='levscpf',& + avgflag='A', long_name='NPP flux into above-ground deadwood', & + ptr_gcell=this%ed_npp_agdw_gd_scpf,default='inactive') + + call hist_addfld2d ( fname = 'ED_NPP_STOR_GD_SCPF', units='kgC/m2/yr',type2d='levscpf',& + avgflag='A', long_name='NPP flux into storage', & + ptr_gcell=this%ed_npp_stor_gd_scpf,default='inactive') + + call hist_addfld2d (fname='ED_DDBH_GD_SCPF', units = 'cm/yr/ha', type2d = 'levscpf', & + avgflag='A', long_name='diameter growth increment and pft/size', & + ptr_gcell=this%ed_ddbh_gd_scpf, default='inactive') + + call hist_addfld2d (fname='ED_BA_GD_SCPF',units = 'm2/ha', type2d = 'levscpf', & + avgflag='A', long_name='basal area by patch and pft/size', & + ptr_gcell=this%ed_ba_gd_scpf, default='inactive') + + call hist_addfld2d (fname='ED_NPLANT_GD_SCPF',units = 'N/ha', type2d = 'levscpf', & + avgflag='A', long_name='stem number density by patch and pft/size', & + ptr_gcell=this%ed_np_gd_scpf, default='inactive') + + call hist_addfld2d (fname='ED_M1_GD_SCPF',units = 'N/ha/yr', type2d = 'levscpf', & + avgflag='A', long_name='background mortality rate by patch and pft/size', & + ptr_gcell=this%ed_m1_gd_scpf, default='inactive') + + call hist_addfld2d (fname='ED_M2_GD_SCPF',units = 'N/ha/yr', type2d = 'levscpf', & + avgflag='A', long_name='hydraulic mortality rate by patch and pft/size', & + ptr_gcell=this%ed_m2_gd_scpf, default='inactive') + + call hist_addfld2d (fname='ED_M3_GD_SCPF',units = 'N/ha/yr', type2d = 'levscpf', & + avgflag='A', long_name='carbon starvation mortality rate by patch and pft/size', & + ptr_gcell=this%ed_m3_gd_scpf, default='inactive') + + call hist_addfld2d (fname='ED_M4_GD_SCPF',units = 'N/ha/yr', type2d = 'levscpf', & + avgflag='A', long_name='impact mortality rate by patch and pft/size', & + ptr_gcell=this%ed_m4_gd_scpf, default='inactive') + + call hist_addfld2d (fname='ED_M5_GD_SCPF',units = 'N/ha/yr', type2d = 'levscpf', & + avgflag='A', long_name='fire mortality rate by patch and pft/size', & + ptr_gcell=this%ed_m5_gd_scpf, default='inactive') + end subroutine InitHistory !----------------------------------------------------------------------- @@ -743,6 +882,10 @@ subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & integer :: G,p,ft integer :: firstsoilpatch(bounds%begg:bounds%endg) real(r8) :: n_density ! individual of cohort per m2. + real(r8) :: n_perm2 ! individuals per m2 for the whole grid cell + real(r8) :: dbh ! actual dbh used to identify relevant size class + integer :: scpf ! size class x pft index + integer :: sc !----------------------------------------------------------------------- associate( & @@ -783,7 +926,27 @@ subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & gpp => this%gpp_patch , & ! Output: npp => this%npp_patch , & ! Output: - + + ed_gpp_scpf => this%ed_gpp_gd_scpf , & + ed_npp_totl_scpf => this%ed_npp_totl_gd_scpf , & + ed_npp_leaf_scpf => this%ed_npp_leaf_gd_scpf , & + ed_npp_seed_scpf => this%ed_npp_seed_gd_scpf , & + ed_npp_fnrt_scpf => this%ed_npp_fnrt_gd_scpf , & + ed_npp_bgsw_scpf => this%ed_npp_bgsw_gd_scpf , & + ed_npp_bgdw_scpf => this%ed_npp_bgdw_gd_scpf , & + ed_npp_agsw_scpf => this%ed_npp_agsw_gd_scpf , & + ed_npp_agdw_scpf => this%ed_npp_agdw_gd_scpf , & + ed_npp_stor_scpf => this%ed_npp_stor_gd_scpf , & + + ed_ddbh_gd_scpf => this%ed_ddbh_gd_scpf , & + ed_ba_gd_scpf => this%ed_ba_gd_scpf , & + ed_np_gd_scpf => this%ed_np_gd_scpf , & + ed_m1_gd_scpf => this%ed_m1_gd_scpf , & + ed_m2_gd_scpf => this%ed_m2_gd_scpf , & + ed_m3_gd_scpf => this%ed_m3_gd_scpf , & + ed_m4_gd_scpf => this%ed_m4_gd_scpf , & + ed_m5_gd_scpf => this%ed_m5_gd_scpf , & + tlai => canopystate_inst%tlai_patch , & ! InOut: elai => canopystate_inst%elai_patch , & ! InOut: tsai => canopystate_inst%tsai_patch , & ! InOut: @@ -832,6 +995,26 @@ subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & ED_balive(:) = 0.0_r8 phen_cd_status(:) = 2 + ed_gpp_scpf(:,:) = 0.0_r8 + ed_npp_totl_scpf(:,:) = 0.0_r8 + ed_npp_leaf_scpf(:,:) = 0.0_r8 + ed_npp_seed_scpf(:,:) = 0.0_r8 + ed_npp_fnrt_scpf(:,:) = 0.0_r8 + ed_npp_bgsw_scpf(:,:) = 0.0_r8 + ed_npp_bgdw_scpf(:,:) = 0.0_r8 + ed_npp_agsw_scpf(:,:) = 0.0_r8 + ed_npp_agdw_scpf(:,:) = 0.0_r8 + ed_npp_stor_scpf(:,:) = 0.0_r8 + + ed_ddbh_gd_scpf(:,:) = 0.0_r8 + ed_ba_gd_scpf(:,:) = 0.0_r8 + ed_np_gd_scpf(:,:) = 0.0_r8 + ed_m1_gd_scpf(:,:) = 0.0_r8 + ed_m2_gd_scpf(:,:) = 0.0_r8 + ed_m3_gd_scpf(:,:) = 0.0_r8 + ed_m4_gd_scpf(:,:) = 0.0_r8 + ed_m5_gd_scpf(:,:) = 0.0_r8 + do g = bounds%begg,bounds%endg if (firstsoilpatch(g) >= 0 .and. ed_allsites_inst(g)%istheresoil) then @@ -907,7 +1090,63 @@ subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & 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 + + dbh = currentCohort%dbh !-0.5*(1./365.25)*currentCohort%ddbhdt + sc = count(dbh-sclass_ed.ge.0.0) + scpf = (ft-1)*nlevsclass_ed+sc + + ! Flux Variables (must pass a NaN check on growth increment and not be recruits) + if(currentCohort%ddbhdt == currentCohort%ddbhdt .and. .not.(currentCohort%isnew)) then + ed_gpp_scpf(g,scpf) = ed_gpp_scpf(g,scpf) + n_perm2*currentCohort%gpp ! [kgC/m2/yr] + ed_npp_totl_scpf(g,scpf) = ed_npp_totl_scpf(g,scpf) + currentcohort%npp*n_perm2 + ed_npp_leaf_scpf(g,scpf) = ed_npp_leaf_scpf(g,scpf) + currentcohort%npp_leaf*n_perm2 + ed_npp_fnrt_scpf(g,scpf) = ed_npp_fnrt_scpf(g,scpf) + currentcohort%npp_froot*n_perm2 + ed_npp_bgsw_scpf(g,scpf) = ed_npp_bgsw_scpf(g,scpf) + currentcohort%npp_bsw*(1._r8-ED_val_ag_biomass)*n_perm2 + ed_npp_agsw_scpf(g,scpf) = ed_npp_agsw_scpf(g,scpf) + currentcohort%npp_bsw*ED_val_ag_biomass*n_perm2 + ed_npp_bgdw_scpf(g,scpf) = ed_npp_bgdw_scpf(g,scpf) + currentcohort%npp_bdead*(1._r8-ED_val_ag_biomass)*n_perm2 + ed_npp_agdw_scpf(g,scpf) = ed_npp_agdw_scpf(g,scpf) + currentcohort%npp_bdead*ED_val_ag_biomass*n_perm2 + ed_npp_seed_scpf(g,scpf) = ed_npp_seed_scpf(g,scpf) + currentcohort%npp_bseed*n_perm2 + ed_npp_stor_scpf(g,scpf) = ed_npp_stor_scpf(g,scpf) + currentcohort%npp_store*n_perm2 + if( abs(currentcohort%npp-(currentcohort%npp_leaf+currentcohort%npp_froot+ & + currentcohort%npp_bsw+currentcohort%npp_bdead+ & + currentcohort%npp_bseed+currentcohort%npp_store))>1.e-9) then + write(iulog,*) 'NPP Partitions are not balancing' + write(iulog,*) 'Fractional Error: ',abs(currentcohort%npp-(currentcohort%npp_leaf+currentcohort%npp_froot+ & + currentcohort%npp_bsw+currentcohort%npp_bdead+ & + currentcohort%npp_bseed+currentcohort%npp_store))/currentcohort%npp + write(iulog,*) 'Terms: ',currentcohort%npp,currentcohort%npp_leaf,currentcohort%npp_froot, & + currentcohort%npp_bsw,currentcohort%npp_bdead, & + currentcohort%npp_bseed,currentcohort%npp_store + stop + end if + ! Woody State Variables (basal area and number density and mortality) + if (pftcon%woody(ft) == 1) then + + ed_m1_gd_scpf(g,scpf) = ed_m1_gd_scpf(g,scpf) + currentcohort%bmort*n_perm2*AREA + ed_m2_gd_scpf(g,scpf) = ed_m2_gd_scpf(g,scpf) + currentcohort%hmort*n_perm2*AREA + ed_m3_gd_scpf(g,scpf) = ed_m3_gd_scpf(g,scpf) + currentcohort%cmort*n_perm2*AREA + ed_m4_gd_scpf(g,scpf) = ed_m4_gd_scpf(g,scpf) + currentcohort%imort*n_perm2*AREA + ed_m5_gd_scpf(g,scpf) = ed_m5_gd_scpf(g,scpf) + currentcohort%fmort*n_perm2*AREA + + ! basal area [m2/ha] + ed_ba_gd_scpf(g,scpf) = ed_ba_gd_scpf(g,scpf) + & + 0.25*3.14159*((dbh/100.0)**2.0)*n_perm2*AREA + + ! number density [/ha] + ed_np_gd_scpf(g,scpf) = ed_np_gd_scpf(g,scpf) + AREA*n_perm2 + + ! Growth Incrments must have NaN check and woody check + if(currentCohort%ddbhdt == currentCohort%ddbhdt) then + ed_ddbh_gd_scpf(g,scpf) = ed_ddbh_gd_scpf(g,scpf) + & + currentCohort%ddbhdt*n_perm2*AREA + else + ed_ddbh_gd_scpf(g,scpf) = -999.9 + end if + end if + + end if + + currentCohort => currentCohort%taller enddo ! cohort loop !Patch specific variables that are already calculated diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 1362b048..961ff2a4 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -2,7 +2,7 @@ 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 clm_varpar , only : nlevcan_ed, nclmax, numrad, nlevgrnd, mxpft use domainMod , only : domain_type use shr_sys_mod , only : shr_sys_flush @@ -23,9 +23,9 @@ module EDTypesMod ! 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 :: numPatchesPerGridCell = 20 ! + integer, parameter :: numCohortsPerPatch = 30 ! + integer, parameter :: cohorts_per_gcell = 600 ! should be numPatchesPerGridCell*numCohortsPerPatch integer, parameter :: numWaterMem = 10 ! watermemory saved as site level var ! BIOLOGY/BIOGEOCHEMISTRY @@ -34,7 +34,7 @@ module EDTypesMod 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. + integer , parameter :: numpft_ed = 10 ! number of PFTs used in ED. ! SPITFIRE integer , parameter :: NLSC = 5 ! number carbon compartments in above ground litter array @@ -57,7 +57,39 @@ module EDTypesMod 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 + character*4 yearchar + + !the lower limit of the size classes of ED cohorts + !0-10,10-20.... + integer, parameter :: nlevsclass_ed = 16 ! Number of dbh size classes for size structure analysis + ! |0-1,1-2,2-3,3-4,4-5,5-10,10-20,20-30,30-40,40-50,50-60,60-70,70-80,80-90,90-100,100+| + real(r8), parameter, dimension(16) :: sclass_ed = (/0.0_r8,1.0_r8,2.0_r8,3.0_r8,4.0_r8,5.0_r8,10.0_r8,20.0_r8,30.0_r8,40.0_r8, & + 50.0_r8,60.0_r8,70.0_r8,80.0_r8,90.0_r8,100.0_r8/) + + !real(r8), parameter, dimension(11) :: sclass_ed = (/0.0_r8,10.0_r8,20.0_r8,30.0_r8,40.0_r8, & + !50.0_r8,60.0_r8,70.0_r8,80.0_r8,90.0_r8,100.0_r8/) + + + ! integer, parameter :: nlevsclass_ed = 17 + ! real(r8), parameter, dimension(17) :: sclass_ed = (/0.1_r8, 5.0_r8,10.0_r8,15.0_r8,20.0_r8,25.0_r8, & + ! 30.0_r8,35.0_r8,40.0_r8,45.0_r8,50.0_r8,55.0_r8, & + ! 60.0_r8,65.0_r8,70.0_r8,75.0_r8,80.0_r8/) + + integer, parameter :: nlevmclass_ed = 5 ! nlev "mortality" classes in ED + ! Number of ways to die + ! (background,hydraulic,carbon,impact,fire) + + character(len = 10), parameter,dimension(5) :: char_list = (/"background","hydraulic ","carbon ","impact ","fire "/) + + + ! These three vectors are used for history output mapping + real(r8) ,allocatable :: levsclass_ed(:) ! The lower bound on size classes for ED trees. This + ! is used really for IO into the + ! history tapes. It gets copied from + ! the parameter array sclass_ed. + integer , allocatable :: pft_levscpf_ed(:) + integer , allocatable :: scls_levscpf_ed(:) + !************************************ !** COHORT type structure ** @@ -97,6 +129,8 @@ module EDTypesMod 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) + logical :: isnew ! flag to signify a new cohort, new cohorts have not experienced + ! npp or mortality and should therefore not be fused or averaged ! CARBON FLUXES real(r8) :: gpp ! GPP: kgC/indiv/year @@ -109,6 +143,13 @@ module EDTypesMod real(r8) :: resp_acc ! Resp: kgC/indiv/day real(r8) :: resp_clm ! Resp: kgC/indiv/timestep + real(r8) :: npp_leaf ! NPP into leaves (includes replacement of turnover): KgC/indiv/day + real(r8) :: npp_froot ! NPP into fine roots (includes replacement of turnover): KgC/indiv/day + real(r8) :: npp_bsw ! NPP into sapwood: KgC/indiv/day + real(r8) :: npp_bdead ! NPP into deadwood (structure): KgC/indiv/day + real(r8) :: npp_bseed ! NPP into seeds: KgC/indiv/day + real(r8) :: npp_store ! NPP into storage: KgC/indiv/day + 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 @@ -132,6 +173,13 @@ module EDTypesMod !MORTALITY real(r8) :: dmort ! proportional mortality rate. (year-1) + ! Mortality Rate Partitions + real(r8) :: bmort ! background mortality rate n/year + real(r8) :: cmort ! carbon starvation mortality rate n/year + real(r8) :: hmort ! hydraulic failure mortality rate n/year + real(r8) :: imort ! mortality from impacts by others n/year + real(r8) :: fmort ! fire mortality n/year + ! NITROGEN POOLS real(r8) :: livestemn ! live stem nitrogen : KgN/invid real(r8) :: livecrootn ! live coarse root nitrogen: KgN/invid @@ -381,8 +429,42 @@ module EDTypesMod type(userdata), public, target :: udata !-------------------------------------------------------------------------------------! + public :: ed_hist_scpfmaps + contains + !-------------------------------------------------------------------------------------! + subroutine ed_hist_scpfmaps + ! This subroutine allocates and populates the variables + ! that define the mapping of variables in history files in the "scpf" format + ! back to + ! its respective size-class "sc" and pft "pf" + + integer :: i + integer :: isc + integer :: ipft + + allocate( levsclass_ed(1:nlevsclass_ed )) + allocate( pft_levscpf_ed(1:nlevsclass_ed*mxpft)) + allocate(scls_levscpf_ed(1:nlevsclass_ed*mxpft)) + + ! Fill the IO array of plant size classes + ! For some reason the history files did not like + ! a hard allocation of sclass_ed + levsclass_ed(:) = sclass_ed(:) + + ! Fill the IO arrays that match pft and size class to their combined array + i=0 + do ipft=1,mxpft + do isc=1,nlevsclass_ed + i=i+1 + pft_levscpf_ed(i) = ipft + scls_levscpf_ed(i) = isc + end do + end do + + end subroutine ed_hist_scpfmaps + !-------------------------------------------------------------------------------------! function map_clmpatch_to_edpatch(site, clmpatch_number) result(edpatch_pointer) ! From 0bb4ac9864e2956f2738a4d89e314084eb650260 Mon Sep 17 00:00:00 2001 From: rgknox Date: Mon, 11 Jan 2016 18:49:00 -0800 Subject: [PATCH 011/437] comparing JAH diffs with RGK diffs, rectifying differences --- biogeochem/EDCohortDynamicsMod.F90 | 3 +-- biogeochem/EDGrowthFunctionsMod.F90 | 26 ++++++++++++-------------- biogeochem/EDPatchDynamicsMod.F90 | 16 ++++++++++------ biogeochem/EDPhysiologyMod.F90 | 12 ++++++++++++ main/EDCLMLinkMod.F90 | 22 ++++++++++++---------- main/EDMainMod.F90 | 2 +- main/EDTypesMod.F90 | 16 ++++++++-------- 7 files changed, 56 insertions(+), 41 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 82da0f92..cff77896 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -102,7 +102,7 @@ subroutine create_cohort(patchptr, pft, nn, hite, dbh, & endif ! Calculate live biomass allocation - call allocate_live_biomass(new_cohort) + call allocate_live_biomass(new_cohort,0) ! Assign canopy extent and depth new_cohort%c_area = c_area(new_cohort) @@ -173,7 +173,6 @@ subroutine allocate_live_biomass(cc_p,mode) 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 diff --git a/biogeochem/EDGrowthFunctionsMod.F90 b/biogeochem/EDGrowthFunctionsMod.F90 index 4a48c81d..17318298 100755 --- a/biogeochem/EDGrowthFunctionsMod.F90 +++ b/biogeochem/EDGrowthFunctionsMod.F90 @@ -316,7 +316,11 @@ real(r8) function dDbhdBl( cohort_in ) 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 + if( cohort_in%dbh 0._r8 ) then - if(Bleaf(cohort_in) > 0._r8.and.cohort_in%bstore <= Bleaf(cohort_in))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)) cmort = max(0.0_r8,ED_val_stress_mort*(1.0_r8 - frac)) else - cmort = 0.0_r8 + cmort = 0.0_r8 endif else diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index c1ef4c9d..40443947 100755 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -69,7 +69,7 @@ subroutine disturbance_rates( site_in) currentCohort%patchptr => currentPatch call mortality_rates(currentCohort,cmort,hmort,bmort) - currentCohort%dmort = mortality_rates(currentCohort) + currentCohort%dmort = cmort+hmort+bmort currentCohort%c_area = c_area(currentCohort) ! Initialize diagnostic mortality rates @@ -234,7 +234,7 @@ subroutine spawn_patches( currentSite ) 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) + call average_patch_properties(currentPatch, new_patch, patch_site_areadis) ! MAY BE REDUNDANT CALL if (currentSite%disturbance_mortality > currentSite%disturbance_fire) then !mortality is dominant disturbance call mortality_litter_fluxes(currentPatch, new_patch, patch_site_areadis) else @@ -263,7 +263,7 @@ subroutine spawn_patches( currentSite ) ! the plant density for large trees does not actually decrease in the donor patch ! because this is the part of the original patch where no trees have actually fallen ! The diagnostic cmort,bmort and hmort rates have already been saved - ! 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. @@ -320,11 +320,15 @@ subroutine spawn_patches( currentSite ) 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 + ! Number of members in the new patch, before we impose fire survivorship + nc%n = currentCohort%n * patch_site_areadis/currentPatch%area + + ! loss of individuals from source patch due to area shrinking currentCohort%n = currentCohort%n * (1._r8 - patch_site_areadis/currentPatch%area) + ! loss of individual from fire in new patch. + nc%n = nc%n * (1.0_r8 - currentCohort%fire_mort) + nc%fmort = currentCohort%fire_mort/udata%deltat nc%imort = 0.0_r8 nc%cmort = currentCohort%cmort diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index bc63c30e..33dc5a88 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -796,7 +796,19 @@ subroutine Growth_Derivatives( currentCohort) 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)) + + currentCohort%npp_leaf = currentCohort%npp_leaf + & + currentCohort%leaf_md * (1.0_r8-EDecophyscon%leaf_stor_priority(currentCohort%pft)) + currentCohort%npp_froot = currentCohort%npp_froot + & + currentCohort%root_md * (1.0_r8-EDecophyscon%leaf_stor_priority(currentCohort%pft)) + else ! we can't maintain constant leaf area and root area. Balive is reduced + + currentCohort%npp_leaf = currentCohort%npp_leaf + & + max(0.0_r8,currentCohort%carbon_balance*(currentCohort%leaf_md/currentCohort%md)) + currentCohort%npp_froot = currentCohort%npp_froot + & + max(0.0_r8,currentCohort%carbon_balance*(currentCohort%root_md/currentCohort%md)) + balive_loss = currentCohort%md *(1.0_r8- EDecophyscon%leaf_stor_priority(currentCohort%pft))- currentCohort%carbon_balance currentCohort%carbon_balance = 0._r8 endif diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 6a62f125..ccecc2e6 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -88,7 +88,7 @@ module EDCLMLinkMod real(r8), pointer :: ed_litt_fnrt_gd_scpf (:,:) ! [kg/m2/yr] carbon flux of fine roots to litter real(r8), pointer :: ed_litt_sawd_gd_scpf (:,:) ! [kg/m2/yr] carbon flux of sapwood to litter (above+below) real(r8), pointer :: ed_litt_ddwd_gd_scpf (:,:) ! [kg/m2/yr] carbon flux of dead wood (above+below) to litter - real(r8), pointer :: ed_r_leaf_gd_scpf (:,:) ! [kg/m2/yr] totat leaf respiration + real(r8), pointer :: ed_r_leaf_gd_scpf (:,:) ! [kg/m2/yr] total leaf respiration real(r8), pointer :: ed_r_stem_gd_scpf (:,:) ! [kg/m2/yr] total above ground live wood (stem) respiration real(r8), pointer :: ed_r_root_gd_scpf (:,:) ! [kg/m2/yr] total below ground live wood (root) respiration real(r8), pointer :: ed_r_stor_gd_scpf (:,:) ! [kg/m2/yr] total storage respiration @@ -99,10 +99,10 @@ module EDCLMLinkMod real(r8), pointer :: ed_ba_gd_scpf (:,:) ! [m2/ha] basal area real(r8), pointer :: ed_np_gd_scpf (:,:) ! [/m2] number of plants real(r8), pointer :: ed_m1_gd_scpf (:,:) ! [Stems/ha/yr] Mean Background Mortality - real(r8), pointer :: ed_m2_gd_scpf (:,:) ! [Stems/ha/yr] Mean Hydraulic Mortaliry rate - real(r8), pointer :: ed_m3_gd_scpf (:,:) ! [Stems/ha/yr] Mean Carbon Starvation Mortality rate - real(r8), pointer :: ed_m4_gd_scpf (:,:) ! [Stems/ha/yr] Mean Impact Mortality Rate - real(r8), pointer :: ed_m5_gd_scpf (:,:) ! [Stems/ha/yr] Mean Fire Mortality Rate + real(r8), pointer :: ed_m2_gd_scpf (:,:) ! [Stems/ha/yr] Mean Hydraulic Mortaliry + real(r8), pointer :: ed_m3_gd_scpf (:,:) ! [Stems/ha/yr] Mean Carbon Starvation Mortality + real(r8), pointer :: ed_m4_gd_scpf (:,:) ! [Stems/ha/yr] Mean Impact Mortality + real(r8), pointer :: ed_m5_gd_scpf (:,:) ! [Stems/ha/yr] Mean Fire Mortality contains @@ -499,23 +499,23 @@ subroutine InitHistory(this, bounds) ptr_gcell=this%ed_np_gd_scpf, default='inactive') call hist_addfld2d (fname='ED_M1_GD_SCPF',units = 'N/ha/yr', type2d = 'levscpf', & - avgflag='A', long_name='background mortality rate by patch and pft/size', & + avgflag='A', long_name='background mortality count by patch and pft/size', & ptr_gcell=this%ed_m1_gd_scpf, default='inactive') call hist_addfld2d (fname='ED_M2_GD_SCPF',units = 'N/ha/yr', type2d = 'levscpf', & - avgflag='A', long_name='hydraulic mortality rate by patch and pft/size', & + avgflag='A', long_name='hydraulic mortality count by patch and pft/size', & ptr_gcell=this%ed_m2_gd_scpf, default='inactive') call hist_addfld2d (fname='ED_M3_GD_SCPF',units = 'N/ha/yr', type2d = 'levscpf', & - avgflag='A', long_name='carbon starvation mortality rate by patch and pft/size', & + avgflag='A', long_name='carbon starvation mortality count by patch and pft/size', & ptr_gcell=this%ed_m3_gd_scpf, default='inactive') call hist_addfld2d (fname='ED_M4_GD_SCPF',units = 'N/ha/yr', type2d = 'levscpf', & - avgflag='A', long_name='impact mortality rate by patch and pft/size', & + avgflag='A', long_name='impact mortality count by patch and pft/size', & ptr_gcell=this%ed_m4_gd_scpf, default='inactive') call hist_addfld2d (fname='ED_M5_GD_SCPF',units = 'N/ha/yr', type2d = 'levscpf', & - avgflag='A', long_name='fire mortality rate by patch and pft/size', & + avgflag='A', long_name='fire mortality count by patch and pft/size', & ptr_gcell=this%ed_m5_gd_scpf, default='inactive') end subroutine InitHistory @@ -1076,8 +1076,10 @@ subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & ft = currentCohort%pft if(currentPatch%area>0._r8)then n_density = currentCohort%n/currentPatch%area + n_perm2 = currentCohort%n/AREA ! plant density using whole area (for grid cell averages) else n_density = 0.0_r8 + n_perm2 = 0.0_r8 endif ED_bleaf(p) = ED_bleaf(p) + n_density * currentCohort%bl ED_bstore(p) = ED_bstore(p) + n_density * currentCohort%bstore diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index ccabb1ba..1322ef85 100755 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -276,7 +276,7 @@ subroutine ed_integrate_state_variables(currentSite, soilstate_inst, temperature currentCohort%gpp_acc = 0.0_r8 currentCohort%resp_acc = 0.0_r8 - call allocate_live_biomass(currentCohort) + call allocate_live_biomass(currentCohort,1) currentCohort => currentCohort%taller diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 961ff2a4..33e172ed 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -23,9 +23,9 @@ module EDTypesMod ! for setting number of patches per gridcell and number of cohorts per patch ! for I/O and converting to a vector - integer, parameter :: numPatchesPerGridCell = 20 ! + integer, parameter :: numPatchesPerGridCell = 10 ! integer, parameter :: numCohortsPerPatch = 30 ! - integer, parameter :: cohorts_per_gcell = 600 ! should be numPatchesPerGridCell*numCohortsPerPatch + integer, parameter :: cohorts_per_gcell = 300 ! should be numPatchesPerGridCell*numCohortsPerPatch integer, parameter :: numWaterMem = 10 ! watermemory saved as site level var ! BIOLOGY/BIOGEOCHEMISTRY @@ -60,14 +60,14 @@ module EDTypesMod character*4 yearchar !the lower limit of the size classes of ED cohorts - !0-10,10-20.... - integer, parameter :: nlevsclass_ed = 16 ! Number of dbh size classes for size structure analysis + !0-10,10-20... + integer, parameter :: nlevsclass_ed = 13 ! Number of dbh size classes for size structure analysis ! |0-1,1-2,2-3,3-4,4-5,5-10,10-20,20-30,30-40,40-50,50-60,60-70,70-80,80-90,90-100,100+| - real(r8), parameter, dimension(16) :: sclass_ed = (/0.0_r8,1.0_r8,2.0_r8,3.0_r8,4.0_r8,5.0_r8,10.0_r8,20.0_r8,30.0_r8,40.0_r8, & - 50.0_r8,60.0_r8,70.0_r8,80.0_r8,90.0_r8,100.0_r8/) +! real(r8), parameter, dimension(16) :: sclass_ed = (/0.0_r8,1.0_r8,2.0_r8,3.0_r8,4.0_r8,5.0_r8,10.0_r8,20.0_r8,30.0_r8,40.0_r8, & +! 50.0_r8,60.0_r8,70.0_r8,80.0_r8,90.0_r8,100.0_r8/) - !real(r8), parameter, dimension(11) :: sclass_ed = (/0.0_r8,10.0_r8,20.0_r8,30.0_r8,40.0_r8, & - !50.0_r8,60.0_r8,70.0_r8,80.0_r8,90.0_r8,100.0_r8/) + real(r8), parameter, dimension(13) :: sclass_ed = (/0.0_r8,5.0_r8,10.0_r8,15.0_r8,20.0_r8,30.0_r8,40.0_r8, & + 50.0_r8,60.0_r8,70.0_r8,80.0_r8,90.0_r8,100.0_r8/) ! integer, parameter :: nlevsclass_ed = 17 From 2123751ef1bde41b860d326f378aecb1c5b62a9a Mon Sep 17 00:00:00 2001 From: rgknox Date: Tue, 12 Jan 2016 13:13:27 -0800 Subject: [PATCH 012/437] updates/fixes/review of size-composition structured output --- biogeochem/EDCohortDynamicsMod.F90 | 15 ++++++++------- biogeochem/EDGrowthFunctionsMod.F90 | 10 ++++------ biogeochem/EDPatchDynamicsMod.F90 | 1 + main/EDCLMLinkMod.F90 | 3 ++- 4 files changed, 15 insertions(+), 14 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index cff77896..7b63d4e0 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -180,7 +180,7 @@ subroutine allocate_live_biomass(cc_p,mode) currentcohort%status_coh = 2 endif - !diagnore the root and stem biomass from the functional balance hypothesis. This is used when the leaves are + ! iagnore 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 + & @@ -225,14 +225,15 @@ subroutine allocate_live_biomass(cc_p,mode) currentcohort%bsw = EDecophyscon%sapwood_ratio(ft) * currentcohort%hite *(currentcohort%balive + & currentcohort%laimemory)*leaf_frac - - if (leaves_off_switch==1) then + + else ! Leaves are on (leaves_off_switch==1) !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 @@ -242,11 +243,9 @@ subroutine allocate_live_biomass(cc_p,mode) ratio_balive = currentcohort%balive / ideal_balive currentcohort%br = currentcohort%br * ratio_balive - currentcohort%bsw = currentcohort%bsw * ratio_balive - endif + currentcohort%bsw = currentcohort%bsw * ratio_balive - - ! Diagnostics + ! Diagnostics if(mode==1)then currentcohort%npp_froot = currentcohort%npp_froot + & @@ -260,6 +259,8 @@ subroutine allocate_live_biomass(cc_p,mode) end if + + endif if (abs(currentcohort%balive -currentcohort%bl- currentcohort%br - currentcohort%bsw)>1e-12) then write(iulog,*) 'issue with carbon allocation in create_cohort',& diff --git a/biogeochem/EDGrowthFunctionsMod.F90 b/biogeochem/EDGrowthFunctionsMod.F90 index 17318298..4f0fbd5b 100755 --- a/biogeochem/EDGrowthFunctionsMod.F90 +++ b/biogeochem/EDGrowthFunctionsMod.F90 @@ -316,11 +316,11 @@ real(r8) function dDbhdBl( cohort_in ) 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 - if( cohort_in%dbh shr_kind_r8; + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) use clm_varctl , only : iulog use pftconMod , only : pftcon use EDCohortDynamicsMod , only : fuse_cohorts, sort_cohorts, insert_cohort diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index ccecc2e6..3a25a5c0 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -868,6 +868,7 @@ subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & use EDPhenologyType , only : ed_phenology_type use CanopyStateType , only : canopystate_type use PatchType , only : clmpatch => patch + use pftconMod , only : pftcon ! ! !ARGUMENTS: class(ed_clm_type) :: this @@ -1098,7 +1099,7 @@ subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & scpf = (ft-1)*nlevsclass_ed+sc ! Flux Variables (must pass a NaN check on growth increment and not be recruits) - if(currentCohort%ddbhdt == currentCohort%ddbhdt .and. .not.(currentCohort%isnew)) then + if( .not.(isnan(currentCohort%ddbhdt)) .and. .not.(currentCohort%isnew)) then ed_gpp_scpf(g,scpf) = ed_gpp_scpf(g,scpf) + n_perm2*currentCohort%gpp ! [kgC/m2/yr] ed_npp_totl_scpf(g,scpf) = ed_npp_totl_scpf(g,scpf) + currentcohort%npp*n_perm2 ed_npp_leaf_scpf(g,scpf) = ed_npp_leaf_scpf(g,scpf) + currentcohort%npp_leaf*n_perm2 From 2706b8d9fee424f4ea9aaf9b656198f1d311fcc9 Mon Sep 17 00:00:00 2001 From: rgknox Date: Tue, 12 Jan 2016 13:18:24 -0800 Subject: [PATCH 013/437] repaired an old typo bug, jmax should be 1.67*vcmax, not 0.167*vcmax --- biogeophys/EDPhotosynthesisMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeophys/EDPhotosynthesisMod.F90 b/biogeophys/EDPhotosynthesisMod.F90 index 889c9054..2577b208 100644 --- a/biogeophys/EDPhotosynthesisMod.F90 +++ b/biogeophys/EDPhotosynthesisMod.F90 @@ -435,7 +435,7 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & !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) + jmax25top(FT) = 1.67_r8 * vcmax25top(FT) ! Reverting and old typo RGK 01-12-2016 tpu25top(FT) = 0.167_r8 * vcmax25top(FT) kp25top(FT) = 20000._r8 * vcmax25top(FT) From d0c5f1a5798b1da8dd297a731079c4bcbf99614f Mon Sep 17 00:00:00 2001 From: Ben Andre Date: Wed, 13 Jan 2016 20:34:46 -0700 Subject: [PATCH 014/437] Update ED patch an cohort sizes Update the numPatchesPerGridCell and numCohortsPerPatch, per request from Ryan Knox and Rosie Fisher. Code reviews: self Test suite: ed yellowstone intel, gnu, pgi Test baseline: ed-clm, changeset eff944c0 Test namelist changes: none Test status: bit for bit --- main/EDTypesMod.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 8ba2179f..41b42f64 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -23,8 +23,8 @@ module EDTypesMod ! 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 = 200 ! + integer, parameter :: numPatchesPerGridCell = 20 ! + integer, parameter :: numCohortsPerPatch = 40 ! integer, parameter :: cohorts_per_gcell = 800 ! This is the max number of individual items one can store per ! each grid cell and effects the striding in the ED restart ! data as some fields are arrays where each array is From 821ab6b4c42dd9975baef07c378e9c572c6d7303 Mon Sep 17 00:00:00 2001 From: Ben Andre Date: Thu, 14 Jan 2016 13:48:19 -0700 Subject: [PATCH 015/437] Bugfix for bit for bit restart. The change of numpft_ed from 2 to 10 in commit fc94f000eb breaks bit for bit restart when merged with Stef Muszala's restart bugfix branch. Temporarily reverting the change to bring the restart branch to master, then this change can be reapplied. Code reviews: self Test suite: ed, yellowstone intel, gnu, pgi Test baseline: ed-clm eff944c0 Test namelist changes: none Test status: not bit for bit, fixes bit for bit restart problem. --- main/EDTypesMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 41b42f64..725ead98 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -38,7 +38,7 @@ module EDTypesMod 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 = 10 ! number of PFTs used in ED. + integer , parameter :: numpft_ed = 2 ! number of PFTs used in ED. integer , parameter :: maxPft = 79 ! max number of PFTs potentially used by CLM ! SPITFIRE From d88f8003035853e3b254483e9b52d66292375798 Mon Sep 17 00:00:00 2001 From: Ben Andre Date: Wed, 27 Jan 2016 14:52:59 -0700 Subject: [PATCH 016/437] Bugfix in ED restart variable name Fix an error in an ED restart variable name (space instead of underscore). Problem found by running 'ed' test suite on yellowstone intel, pgi, gnu. This change fixed a runtime problem with: ERS_D_Ld5.f19_g16.ICLM45ED.yellowstone_intel.clm-edTest but there are other tests that fail in the parent changeset. Test suite: ed yellowstone intel, gnu, pgi Test baseline: n/a Test namelist changes: none Test status: see above. Fixes see above Code reviews: self. --- main/EDRestVectorMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/EDRestVectorMod.F90 b/main/EDRestVectorMod.F90 index 06e7be0e..9efbb237 100755 --- a/main/EDRestVectorMod.F90 +++ b/main/EDRestVectorMod.F90 @@ -847,7 +847,7 @@ subroutine doVectorIO( this, ncid, flag ) readvar=readvar) - call restartvar(ncid=ncid, flag=flag, varname='ed_chilling days', xtype=ncd_double, & + call restartvar(ncid=ncid, flag=flag, varname='ed_chilling_days', xtype=ncd_double, & dim1name=dimName, & long_name='ed chilling day counter', units='unitless', & interpinic_flag='interp', data=this%ncd, & From 48d63cb996d0b189e6eece52c757e4b2aa7dee1e Mon Sep 17 00:00:00 2001 From: rgknox Date: Fri, 29 Jan 2016 13:30:05 -0800 Subject: [PATCH 017/437] Conflict resolution 2: both branches master and io/sclass had made the bug fix to the scaling of jcmax25 to vcmax25, both were the same, differences were only formatting --- biogeophys/EDPhotosynthesisMod.F90 | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/biogeophys/EDPhotosynthesisMod.F90 b/biogeophys/EDPhotosynthesisMod.F90 index 04df8a90..6bf500cc 100644 --- a/biogeophys/EDPhotosynthesisMod.F90 +++ b/biogeophys/EDPhotosynthesisMod.F90 @@ -438,13 +438,9 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & !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) -<<<<<<< HEAD - jmax25top(FT) = 1.67_r8 * vcmax25top(FT) ! Reverting and old typo RGK 01-12-2016 - tpu25top(FT) = 0.167_r8 * vcmax25top(FT) -======= + jmax25top(FT) = 1.67_r8 * vcmax25top(FT) tpu25top(FT) = 0.167_r8 * vcmax25top(FT) ->>>>>>> master kp25top(FT) = 20000._r8 * vcmax25top(FT) ! Nitrogen scaling factor. Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 used From a5d9b50e270c04fc99064e024460616e85ca7f8b Mon Sep 17 00:00:00 2001 From: rgknox Date: Fri, 29 Jan 2016 13:43:40 -0800 Subject: [PATCH 018/437] Conflict resolution 3: In cohort dynamics mod, the main loops controlling fusion were given a flag that checks for the existence of recently created cohorts, and ignores their fusion to prevent their contamination of other cohorts with their uninitalized values. --- biogeochem/EDCohortDynamicsMod.F90 | 9 ++------- 1 file changed, 2 insertions(+), 7 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 1cc88472..d70e6616 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -632,14 +632,11 @@ subroutine fuse_cohorts(patchptr) if (currentCohort%pft == nextc%pft) then ! check cohorts in same c. layer. before fusing -<<<<<<< HEAD + if (currentCohort%canopy_layer == nextc%canopy_layer) then ! check to make sure one is not a new recruit (npp=nan flag) if( (.not.(currentCohort%isnew)).and.(.not.(nextc%isnew)) ) then -======= - if (currentCohort%canopy_layer == nextc%canopy_layer) then ->>>>>>> master fusion_took_place = 1 newn = currentCohort%n + nextc%n ! sum individuals in both cohorts. @@ -734,10 +731,8 @@ subroutine fuse_cohorts(patchptr) deallocate(nextc) endif -<<<<<<< HEAD endif ! Not a recruit -======= ->>>>>>> master + endif !canopy layer endif !pft endif !index no. From 01327ee2ee124b17f6caf337109c737c39a74abd Mon Sep 17 00:00:00 2001 From: rgknox Date: Fri, 29 Jan 2016 13:51:28 -0800 Subject: [PATCH 019/437] Conflict resolution 3.1: Added the allowance that two cohorts may fuse if they are BOTH new, improving total fusion rates and reducing contamination. --- biogeochem/EDCohortDynamicsMod.F90 | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index d70e6616..1d35772e 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -635,8 +635,14 @@ subroutine fuse_cohorts(patchptr) if (currentCohort%canopy_layer == nextc%canopy_layer) then - ! check to make sure one is not a new recruit (npp=nan flag) - if( (.not.(currentCohort%isnew)).and.(.not.(nextc%isnew)) ) then + ! Note: because newly recruited cohorts that have not experienced + ! a day yet will have un-known flux quantities or change rates + ! we don't want them fusing with non-new cohorts. We allow them + ! to fuse with other new cohorts to keep the total number of cohorts + ! down. + + if( (.not.(currentCohort%isnew)).and.(.not.(nextc%isnew)) .or. & + ((currentCohort%isnew)).and.((nextc%isnew)) ) then fusion_took_place = 1 newn = currentCohort%n + nextc%n ! sum individuals in both cohorts. @@ -690,7 +696,7 @@ subroutine fuse_cohorts(patchptr) 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%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 From f76841238da733c2db1cffdc6ab7f725e8bfaf06 Mon Sep 17 00:00:00 2001 From: rgknox Date: Fri, 29 Jan 2016 14:09:27 -0800 Subject: [PATCH 020/437] Conflict resolution 4: Trivial merge conflict resolutions in EDTypesMod and EDCLMLinkMod --- main/EDCLMLinkMod.F90 | 5 +---- main/EDTypesMod.F90 | 12 ++---------- 2 files changed, 3 insertions(+), 14 deletions(-) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 5d47822b..10d6ab5a 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -72,7 +72,7 @@ module EDCLMLinkMod 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 -<<<<<<< HEAD + real(r8), pointer, private :: gpp_patch (:) ! (gC/m2/s) patch gross primary production real(r8), pointer :: ed_gpp_gd_scpf (:,:) ! [kg/m2/yr] gross primary production @@ -104,9 +104,6 @@ module EDCLMLinkMod real(r8), pointer :: ed_m3_gd_scpf (:,:) ! [Stems/ha/yr] Mean Carbon Starvation Mortality real(r8), pointer :: ed_m4_gd_scpf (:,:) ! [Stems/ha/yr] Mean Impact Mortality real(r8), pointer :: ed_m5_gd_scpf (:,:) ! [Stems/ha/yr] Mean Fire Mortality -======= - real(r8), pointer, public :: gpp_patch (:) ! (gC/m2/s) patch gross primary production ->>>>>>> master contains diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 3bc15384..f877151e 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -23,11 +23,7 @@ module EDTypesMod ! for setting number of patches per gridcell and number of cohorts per patch ! for I/O and converting to a vector -<<<<<<< HEAD - integer, parameter :: numPatchesPerGridCell = 10 ! - integer, parameter :: numCohortsPerPatch = 30 ! - integer, parameter :: cohorts_per_gcell = 300 ! should be numPatchesPerGridCell*numCohortsPerPatch -======= + integer, parameter :: numPatchesPerGridCell = 20 ! integer, parameter :: numCohortsPerPatch = 40 ! integer, parameter :: cohorts_per_gcell = 800 ! This is the max number of individual items one can store per @@ -35,7 +31,6 @@ module EDTypesMod ! data as some fields are arrays where each array is ! associated with one cohort ->>>>>>> master integer, parameter :: numWaterMem = 10 ! watermemory saved as site level var ! BIOLOGY/BIOGEOCHEMISTRY @@ -44,12 +39,9 @@ module EDTypesMod 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) -<<<<<<< HEAD - integer , parameter :: numpft_ed = 10 ! number of PFTs used in ED. -======= integer , parameter :: numpft_ed = 2 ! number of PFTs used in ED. integer , parameter :: maxPft = 79 ! max number of PFTs potentially used by CLM ->>>>>>> master + ! SPITFIRE integer , parameter :: NLSC = 6 ! number carbon compartments in above ground litter array From c99ea8f59580a9f42e310e16a62690d813a37ea6 Mon Sep 17 00:00:00 2001 From: rgknox Date: Mon, 1 Feb 2016 15:15:41 -0800 Subject: [PATCH 021/437] Re-evaluated newly introduced logic on new cohort fusion. --- biogeochem/EDCohortDynamicsMod.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 1d35772e..d921e425 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -641,8 +641,8 @@ subroutine fuse_cohorts(patchptr) ! to fuse with other new cohorts to keep the total number of cohorts ! down. - if( (.not.(currentCohort%isnew)).and.(.not.(nextc%isnew)) .or. & - ((currentCohort%isnew)).and.((nextc%isnew)) ) then + if( (.not.(currentCohort%isnew) .and. .not.(nextc%isnew) ) .or. & + ( currentCohort%isnew .and. nextc%isnew ) ) then fusion_took_place = 1 newn = currentCohort%n + nextc%n ! sum individuals in both cohorts. From db5835e05bc417e8eb5bb2f8e3f4e0adb82927eb Mon Sep 17 00:00:00 2001 From: rgknox Date: Wed, 3 Feb 2016 15:19:10 -0800 Subject: [PATCH 022/437] changed offset incrementing within patch loops to match maximum number of cohorts, instead of maxcohorts * maxpatch --- main/EDRestVectorMod.F90 | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/main/EDRestVectorMod.F90 b/main/EDRestVectorMod.F90 index 9efbb237..01c875c4 100755 --- a/main/EDRestVectorMod.F90 +++ b/main/EDRestVectorMod.F90 @@ -1388,7 +1388,8 @@ subroutine convertCohortListToVector( this, bounds, ed_allsites_inst ) ! set numpatches for this gcell this%numPatchesPerCell( ed_allsites_inst(g)%clmgcell ) = numPatches - incrementOffset = incrementOffset + cohorts_per_gcell + 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 @@ -1591,7 +1592,7 @@ subroutine createPatchCohortStructure( this, bounds, ed_allsites_inst ) endif - currIdx = currIdx + cohorts_per_gcell + currIdx = currIdx + numCohortsPerPatch enddo ! ends loop over patchIdx @@ -1776,7 +1777,8 @@ subroutine convertCohortVectorToList( this, bounds, ed_allsites_inst ) if (this%DEBUG) write(iulog,*) 'CVTL countSunZ 2 ',countSunZ - incrementOffset = incrementOffset + cohorts_per_gcell + incrementOffset = incrementOffset + numCohortsPerPatch + ! reset counters so that they are all advanced evenly. Currently ! the offset must be > 160, nlevcan_ed*numpft_ed*nclmax ! and the number of allowed cohorts per patch (currently 200) From 7e8a242b1524ad6f6b8d7942642b551fd2482c42 Mon Sep 17 00:00:00 2001 From: rgknox Date: Wed, 3 Feb 2016 15:28:01 -0800 Subject: [PATCH 023/437] modified maximum number of cohorts to exceed nlevcan_ed x nclmax x npft_ed, allowing for enough IO array space on radiation restart variables --- main/EDTypesMod.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 725ead98..515086f8 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -23,9 +23,9 @@ module EDTypesMod ! for setting number of patches per gridcell and number of cohorts per patch ! for I/O and converting to a vector - integer, parameter :: numPatchesPerGridCell = 20 ! - integer, parameter :: numCohortsPerPatch = 40 ! - integer, parameter :: cohorts_per_gcell = 800 ! This is the max number of individual items one can store per + integer, parameter :: numPatchesPerGridCell = 10 ! + integer, parameter :: numCohortsPerPatch = 160 ! + integer, parameter :: cohorts_per_gcell = 1600 ! This is the max number of individual items one can store per ! each grid cell and effects the striding in the ED restart ! data as some fields are arrays where each array is ! associated with one cohort From ea9c6debc4bdc4962ca8379a06c4a010da6c80d7 Mon Sep 17 00:00:00 2001 From: Ben Andre Date: Fri, 5 Feb 2016 13:52:43 -0700 Subject: [PATCH 024/437] Bugfix for pgi compiler error pgi yellowstone could not compile ed-clm because of the following error: PGF90-S-0038-Symbol, isnan, has not been explicitly declared (/glade/p/work/andre/ed/ed-clm-pr10-test/components/clm/src/ED/main/EDCLMLinkMod.F90) Code reviews: self Test suite: ed, yellowstone intel, pgi, gnu Test baseline: 69a361b0 Test namelist changes: none Test status: pass except for: answer changing wrt 69a361b0, expected failures of f09 and f19 restart. --- main/EDCLMLinkMod.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 10d6ab5a..5257751e 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -5,7 +5,8 @@ module EDCLMLinkMod ! diagnostics, or as input to the land surface components. ! ============================================================================ - use shr_kind_mod , only : r8 => shr_kind_r8; + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_infnan_mod, only : isnan => shr_infnan_isnan use decompMod , only : bounds_type use clm_varpar , only : nclmax, nlevcan_ed, numpft, numcft, mxpft use clm_varctl , only : iulog From 3f35106dd02a8e2d5da0baf7981216fd55bf599d Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Wed, 17 Feb 2016 16:24:50 -0800 Subject: [PATCH 025/437] added restart variables to edclmlinkmod --- main/EDCLMLinkMod.F90 | 47 ++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 46 insertions(+), 1 deletion(-) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index df6eb3a4..11f2b63c 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -614,6 +614,8 @@ subroutine Restart ( this, bounds, ncid, flag ) ! ! !LOCAL VARIABLES: logical :: readvar + character(LEN=3) :: istr1 + integer :: k !------------------------------------------------------------------------ call restartvar(ncid=ncid, flag=flag, varname='leafc', xtype=ncd_double, & @@ -626,12 +628,55 @@ subroutine Restart ( this, bounds, ncid, flag ) 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) + interpinic_flag='interp', readvar=readvar, data=this%deadstemc_patch) 4 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) + call restartvar(ncid=ncid, flag=flag, varname='ED_c_to_litr_lab_c_col', xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%ED_c_to_litr_lab_c_col) + + call restartvar(ncid=ncid, flag=flag, varname='ED_c_to_litr_cel_c_col', xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%ED_c_to_litr_cel_c_col) + + call restartvar(ncid=ncid, flag=flag, varname='ED_c_to_litr_lig_c_col', xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%ED_c_to_litr_lig_c_col) + + call restartvar(ncid=ncid, flag=flag, varname='leaf_prof_col', xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%leaf_prof_col) + + call restartvar(ncid=ncid, flag=flag, varname='croot_prof_col', xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%croot_prof_col) + + call restartvar(ncid=ncid, flag=flag, varname='stem_prof_col', xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%stem_prof_col) + + call restartvar(ncid=ncid, flag=flag, varname='ED_c_to_litr_lab_c_col', xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%ED_c_to_litr_lab_c_col) + + do k = 1, numpft_ed + write(istr1,"(I3.3)") k + call restartvar(ncid=ncid, flag=flag, varname='froot_prof_col_PFT'//istr1, xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%froot_prof_col(:,k,:)) + end do + end subroutine Restart !----------------------------------------------------------------------- From f8b18ae2d3857b4a1f1637efe6bbe78d6aebed27 Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Wed, 17 Feb 2016 16:32:39 -0800 Subject: [PATCH 026/437] typo bugfix --- main/EDCLMLinkMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 11f2b63c..6170c343 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -628,7 +628,7 @@ subroutine Restart ( this, bounds, ncid, flag ) 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) 4 + 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='', & From 4373dd6f12a8c8beac885a9c66946dd11ee68e3b Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Thu, 18 Feb 2016 14:16:51 -0800 Subject: [PATCH 027/437] removed profile variables from restart file as I don't believe they are needed --- main/EDCLMLinkMod.F90 | 60 ++++++++++++++++++++++--------------------- 1 file changed, 31 insertions(+), 29 deletions(-) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 6170c343..0a2ec387 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -605,6 +605,8 @@ subroutine Restart ( this, bounds, ncid, flag ) ! !USES: use restUtilMod use ncdio_pio + ! use EDtypesMod , only : numpft_ed + ! ! !ARGUMENTS: class (ed_clm_type) :: this @@ -614,8 +616,8 @@ subroutine Restart ( this, bounds, ncid, flag ) ! ! !LOCAL VARIABLES: logical :: readvar - character(LEN=3) :: istr1 - integer :: k + ! character(LEN=3) :: istr1 + ! integer :: k !------------------------------------------------------------------------ call restartvar(ncid=ncid, flag=flag, varname='leafc', xtype=ncd_double, & @@ -649,33 +651,33 @@ subroutine Restart ( this, bounds, ncid, flag ) long_name='', units='', & interpinic_flag='interp', readvar=readvar, data=this%ED_c_to_litr_lig_c_col) - call restartvar(ncid=ncid, flag=flag, varname='leaf_prof_col', xtype=ncd_double, & - dim1name='column', dim2name='levgrnd', switchdim=.true., & - long_name='', units='', & - interpinic_flag='interp', readvar=readvar, data=this%leaf_prof_col) - - call restartvar(ncid=ncid, flag=flag, varname='croot_prof_col', xtype=ncd_double, & - dim1name='column', dim2name='levgrnd', switchdim=.true., & - long_name='', units='', & - interpinic_flag='interp', readvar=readvar, data=this%croot_prof_col) - - call restartvar(ncid=ncid, flag=flag, varname='stem_prof_col', xtype=ncd_double, & - dim1name='column', dim2name='levgrnd', switchdim=.true., & - long_name='', units='', & - interpinic_flag='interp', readvar=readvar, data=this%stem_prof_col) - - call restartvar(ncid=ncid, flag=flag, varname='ED_c_to_litr_lab_c_col', xtype=ncd_double, & - dim1name='column', dim2name='levgrnd', switchdim=.true., & - long_name='', units='', & - interpinic_flag='interp', readvar=readvar, data=this%ED_c_to_litr_lab_c_col) - - do k = 1, numpft_ed - write(istr1,"(I3.3)") k - call restartvar(ncid=ncid, flag=flag, varname='froot_prof_col_PFT'//istr1, xtype=ncd_double, & - dim1name='column', dim2name='levgrnd', switchdim=.true., & - long_name='', units='', & - interpinic_flag='interp', readvar=readvar, data=this%froot_prof_col(:,k,:)) - end do + ! call restartvar(ncid=ncid, flag=flag, varname='leaf_prof_col', xtype=ncd_double, & + ! dim1name='column', dim2name='levgrnd', switchdim=.true., & + ! long_name='', units='', & + ! interpinic_flag='interp', readvar=readvar, data=this%leaf_prof_col) + + ! call restartvar(ncid=ncid, flag=flag, varname='croot_prof_col', xtype=ncd_double, & + ! dim1name='column', dim2name='levgrnd', switchdim=.true., & + ! long_name='', units='', & + ! interpinic_flag='interp', readvar=readvar, data=this%croot_prof_col) + + ! call restartvar(ncid=ncid, flag=flag, varname='stem_prof_col', xtype=ncd_double, & + ! dim1name='column', dim2name='levgrnd', switchdim=.true., & + ! long_name='', units='', & + ! interpinic_flag='interp', readvar=readvar, data=this%stem_prof_col) + + ! call restartvar(ncid=ncid, flag=flag, varname='ED_c_to_litr_lab_c_col', xtype=ncd_double, & + ! dim1name='column', dim2name='levgrnd', switchdim=.true., & + ! long_name='', units='', & + ! interpinic_flag='interp', readvar=readvar, data=this%ED_c_to_litr_lab_c_col) + + ! do k = 1, numpft_ed + ! write(istr1,"(I3.3)") k + ! call restartvar(ncid=ncid, flag=flag, varname='froot_prof_col_PFT'//istr1, xtype=ncd_double, & + ! dim1name='column', dim2name='levgrnd', switchdim=.true., & + ! long_name='', units='', & + ! interpinic_flag='interp', readvar=readvar, data=this%froot_prof_col(:,k,:)) + ! end do end subroutine Restart From 6d8ac15b4199f067396cc166e271a225d7801eee Mon Sep 17 00:00:00 2001 From: ckoven Date: Thu, 18 Feb 2016 22:59:12 -0800 Subject: [PATCH 028/437] working on restarts still.. --- main/EDCLMLinkMod.F90 | 87 ++++++++++++++++++++++++++----------------- 1 file changed, 52 insertions(+), 35 deletions(-) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 0a2ec387..d75c8208 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -616,40 +616,62 @@ subroutine Restart ( this, bounds, ncid, flag ) ! ! !LOCAL VARIABLES: logical :: readvar + real(r8), pointer :: ptr2d(:,:) ! temp. pointers for slicing larger arrays + real(r8), pointer :: ptr1d(:) ! temp. pointers for slicing larger arrays ! character(LEN=3) :: istr1 ! integer :: k !------------------------------------------------------------------------ - 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) - - call restartvar(ncid=ncid, flag=flag, varname='ED_c_to_litr_lab_c_col', xtype=ncd_double, & - dim1name='column', dim2name='levgrnd', switchdim=.true., & - long_name='', units='', & - interpinic_flag='interp', readvar=readvar, data=this%ED_c_to_litr_lab_c_col) - - call restartvar(ncid=ncid, flag=flag, varname='ED_c_to_litr_cel_c_col', xtype=ncd_double, & - dim1name='column', dim2name='levgrnd', switchdim=.true., & - long_name='', units='', & - interpinic_flag='interp', readvar=readvar, data=this%ED_c_to_litr_cel_c_col) - - call restartvar(ncid=ncid, flag=flag, varname='ED_c_to_litr_lig_c_col', xtype=ncd_double, & - dim1name='column', dim2name='levgrnd', switchdim=.true., & - long_name='', units='', & - interpinic_flag='interp', readvar=readvar, data=this%ED_c_to_litr_lig_c_col) + ! 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) + + if (use_vertsoilc) then + ptr2d => this%ED_c_to_litr_lab_c_col + call restartvar(ncid=ncid, flag=flag, varname='ED_c_to_litr_lab_c_col', xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=ptr2d) + + ptr2d => this%ED_c_to_litr_cel_c_col + call restartvar(ncid=ncid, flag=flag, varname='ED_c_to_litr_cel_c_col', xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=ptr2d) + + ptr2d => this%ED_c_to_litr_lig_c_col + call restartvar(ncid=ncid, flag=flag, varname='ED_c_to_litr_lig_c_col', xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=ptr2d) + else + ptr1d => this%ED_c_to_litr_lab_c_col(:,1) + call restartvar(ncid=ncid, flag=flag, varname='ED_c_to_litr_lab_c_col', xtype=ncd_double, & + dim1name='column', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=ptr1d) + + ptr1d => this%ED_c_to_litr_cel_c_col(:,1) + call restartvar(ncid=ncid, flag=flag, varname='ED_c_to_litr_cel_c_col', xtype=ncd_double, & + dim1name='column', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=ptr1d) + + ptr1d => this%ED_c_to_litr_lig_c_col(:,1) + call restartvar(ncid=ncid, flag=flag, varname='ED_c_to_litr_lig_c_col', xtype=ncd_double, & + dim1name='column', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=ptr1d) + end if ! call restartvar(ncid=ncid, flag=flag, varname='leaf_prof_col', xtype=ncd_double, & ! dim1name='column', dim2name='levgrnd', switchdim=.true., & @@ -666,11 +688,6 @@ subroutine Restart ( this, bounds, ncid, flag ) ! long_name='', units='', & ! interpinic_flag='interp', readvar=readvar, data=this%stem_prof_col) - ! call restartvar(ncid=ncid, flag=flag, varname='ED_c_to_litr_lab_c_col', xtype=ncd_double, & - ! dim1name='column', dim2name='levgrnd', switchdim=.true., & - ! long_name='', units='', & - ! interpinic_flag='interp', readvar=readvar, data=this%ED_c_to_litr_lab_c_col) - ! do k = 1, numpft_ed ! write(istr1,"(I3.3)") k ! call restartvar(ncid=ncid, flag=flag, varname='froot_prof_col_PFT'//istr1, xtype=ncd_double, & From c8317cd7323e6b9bf3493ffc2c0cf9a708fb5f73 Mon Sep 17 00:00:00 2001 From: ckoven Date: Fri, 19 Feb 2016 17:04:24 -0800 Subject: [PATCH 029/437] more fixes on ED/BGC intersection. model should now pass tests --- main/EDCLMLinkMod.F90 | 72 ++++++++++++++++++++++++++++++------------- 1 file changed, 50 insertions(+), 22 deletions(-) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index d75c8208..ee17c99e 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -656,6 +656,33 @@ subroutine Restart ( this, bounds, ncid, flag ) dim1name='column', dim2name='levgrnd', switchdim=.true., & long_name='', units='', & interpinic_flag='interp', readvar=readvar, data=ptr2d) + + ! ptr2d => this%leaf_prof_col + ! call restartvar(ncid=ncid, flag=flag, varname='leaf_prof_col', xtype=ncd_double, & + ! dim1name='column', dim2name='levgrnd', switchdim=.true., & + ! long_name='', units='', & + ! interpinic_flag='interp', readvar=readvar, data=ptr2d) + + ! ptr2d => this%croot_prof_col + ! call restartvar(ncid=ncid, flag=flag, varname='croot_prof_col', xtype=ncd_double, & + ! dim1name='column', dim2name='levgrnd', switchdim=.true., & + ! long_name='', units='', & + ! interpinic_flag='interp', readvar=readvar, data=ptr2d) + + ! ptr2d => this%stem_prof_col + ! call restartvar(ncid=ncid, flag=flag, varname='stem_prof_col', xtype=ncd_double, & + ! dim1name='column', dim2name='levgrnd', switchdim=.true., & + ! long_name='', units='', & + ! interpinic_flag='interp', readvar=readvar, data=ptr2d) + + ! do k = 1, numpft_ed + ! write(istr1,"(I3.3)") k + ! ptr2d => this%froot_prof_col(:,k,:) + ! call restartvar(ncid=ncid, flag=flag, varname='froot_prof_col_PFT'//istr1, xtype=ncd_double, & + ! dim1name='column', dim2name='levgrnd', switchdim=.true., & + ! long_name='', units='', & + ! interpinic_flag='interp', readvar=readvar, data=ptr2d) + ! end do else ptr1d => this%ED_c_to_litr_lab_c_col(:,1) call restartvar(ncid=ncid, flag=flag, varname='ED_c_to_litr_lab_c_col', xtype=ncd_double, & @@ -671,30 +698,31 @@ subroutine Restart ( this, bounds, ncid, flag ) call restartvar(ncid=ncid, flag=flag, varname='ED_c_to_litr_lig_c_col', xtype=ncd_double, & dim1name='column', long_name='', units='', & interpinic_flag='interp', readvar=readvar, data=ptr1d) + + ! ptr1d => this%leaf_prof_col(:,1) + ! call restartvar(ncid=ncid, flag=flag, varname='leaf_prof_col', xtype=ncd_double, & + ! dim1name='column', long_name='', units='', & + ! interpinic_flag='interp', readvar=readvar, data=ptr1d) + + ! ptr1d => this%croot_prof_col(:,1) + ! call restartvar(ncid=ncid, flag=flag, varname='croot_prof_col', xtype=ncd_double, & + ! dim1name='column', long_name='', units='', & + ! interpinic_flag='interp', readvar=readvar, data=ptr1d) + + ! ptr1d => this%stem_prof_col(:,1) + ! call restartvar(ncid=ncid, flag=flag, varname='stem_prof_col', xtype=ncd_double, & + ! dim1name='column', long_name='', units='', & + ! interpinic_flag='interp', readvar=readvar, data=ptr1d) + + ! do k = 1, numpft_ed + ! write(istr1,"(I3.3)") k + ! ptr1d => this%froot_prof_col(:,k,1) + ! call restartvar(ncid=ncid, flag=flag, varname='froot_prof_col_PFT'//istr1, xtype=ncd_double, & + ! dim1name='column', long_name='', units='', & + ! interpinic_flag='interp', readvar=readvar, data=ptr1d) + ! end do end if - ! call restartvar(ncid=ncid, flag=flag, varname='leaf_prof_col', xtype=ncd_double, & - ! dim1name='column', dim2name='levgrnd', switchdim=.true., & - ! long_name='', units='', & - ! interpinic_flag='interp', readvar=readvar, data=this%leaf_prof_col) - - ! call restartvar(ncid=ncid, flag=flag, varname='croot_prof_col', xtype=ncd_double, & - ! dim1name='column', dim2name='levgrnd', switchdim=.true., & - ! long_name='', units='', & - ! interpinic_flag='interp', readvar=readvar, data=this%croot_prof_col) - - ! call restartvar(ncid=ncid, flag=flag, varname='stem_prof_col', xtype=ncd_double, & - ! dim1name='column', dim2name='levgrnd', switchdim=.true., & - ! long_name='', units='', & - ! interpinic_flag='interp', readvar=readvar, data=this%stem_prof_col) - - ! do k = 1, numpft_ed - ! write(istr1,"(I3.3)") k - ! call restartvar(ncid=ncid, flag=flag, varname='froot_prof_col_PFT'//istr1, xtype=ncd_double, & - ! dim1name='column', dim2name='levgrnd', switchdim=.true., & - ! long_name='', units='', & - ! interpinic_flag='interp', readvar=readvar, data=this%froot_prof_col(:,k,:)) - ! end do end subroutine Restart From e33555b04c50212a6bdfad416a0b35e720bb978f Mon Sep 17 00:00:00 2001 From: Rosie Fisher Date: Wed, 24 Feb 2016 16:40:29 -0700 Subject: [PATCH 030/437] Changed temporary_spitfire_switch to 1 --- fire/SFMainMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index 60194c17..f63c60c2 100755 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -56,7 +56,7 @@ subroutine fire_model( currentSite, atm2lnd_inst, temperature_inst) !zero fire things currentPatch => currentSite%youngest_patch - temporary_SF_switch = 0 + temporary_SF_switch = 1 do while(associated(currentPatch)) currentPatch%frac_burnt = 0.0_r8 currentPatch%AB = 0.0_r8 From fab596526dfb34e091ae8f3588eb9bd4b436ae42 Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Fri, 26 Feb 2016 15:42:40 -0800 Subject: [PATCH 031/437] added first instance of NEP and NBP fluxes --- biogeochem/EDBGCDynMod.F90 | 13 ++++-- main/EDCLMLinkMod.F90 | 84 ++++++++++++++++++++++++++++++++++++++ 2 files changed, 94 insertions(+), 3 deletions(-) diff --git a/biogeochem/EDBGCDynMod.F90 b/biogeochem/EDBGCDynMod.F90 index 6ba670fb..d90b36c3 100644 --- a/biogeochem/EDBGCDynMod.F90 +++ b/biogeochem/EDBGCDynMod.F90 @@ -27,7 +27,7 @@ module EDBGCDynMod use atm2lndType , only : atm2lnd_type use SoilStateType , only : soilstate_type use ch4Mod , only : ch4_type - + use EDtypesMod , only : ed_site_type ! public :: EDBGCDynInit ! BGC dynamics: initialization public :: EDBGCDyn ! BGC Dynamics @@ -270,10 +270,12 @@ subroutine EDBGCDynSummary(bounds, num_soilc, filter_soilc, num_soilp, filter_so soilbiogeochem_carbonflux_inst, soilbiogeochem_carbonstate_inst, & c13_soilbiogeochem_carbonflux_inst, c13_soilbiogeochem_carbonstate_inst, & c14_soilbiogeochem_carbonflux_inst, c14_soilbiogeochem_carbonstate_inst, & - soilbiogeochem_nitrogenflux_inst, soilbiogeochem_nitrogenstate_inst) + soilbiogeochem_nitrogenflux_inst, soilbiogeochem_nitrogenstate_inst, & + ed_clm_inst, ed_allsites_inst) ! ! !DESCRIPTION: ! Call to all CN and SoilBiogeochem summary routines + ! also aggregate production and decomposition fluxes to whole-ecosystem balance fluxes ! ! !USES: use clm_varpar , only: ndecomp_cascade_transitions @@ -294,6 +296,8 @@ subroutine EDBGCDynSummary(bounds, num_soilc, filter_soilc, num_soilp, filter_so type(soilbiogeochem_carbonstate_type) , intent(inout) :: c14_soilbiogeochem_carbonstate_inst type(soilbiogeochem_nitrogenflux_type) , intent(inout) :: soilbiogeochem_nitrogenflux_inst type(soilbiogeochem_nitrogenstate_type) , intent(inout) :: soilbiogeochem_nitrogenstate_inst + type(ed_clm_type) , intent(inout) :: ed_clm_inst + type(ed_site_type) , intent(inout), target :: ed_allsites_inst( bounds%begg: ) ! ! !LOCAL VARIABLES: integer :: begc,endc @@ -341,8 +345,11 @@ subroutine EDBGCDynSummary(bounds, num_soilc, filter_soilc, num_soilp, filter_so ! call soilbiogeochem_nitrogenflux_inst%Summary(bounds, num_soilc, filter_soilc) ! ---------------------------------------------- - ! ed veg carbon state summary + ! ed veg carbon flux summary ! ---------------------------------------------- + + call ed_clm_inst%Summary(bounds, numsoilc, filter_soilc, num_soilp, filter_soilp, & + ed_allsites_inst(bounds%begg:bounds%endg), soilbiogeochem_carbonflux_inst) ! ---------------------------------------------- ! ed veg carbon/nitrogen flux summary diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index ee17c99e..e2ceb437 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -16,6 +16,8 @@ module EDCLMLinkMod use CanopyStateType , only : canopystate_type use clm_varctl , only : use_vertsoilc use EDParamsMod , only : ED_val_ag_biomass + use SoilBiogeochemCarbonFluxType , only : soilbiogeochem_carbonflux_type + use clm_time_manager , only : get_step_size ! implicit none @@ -123,6 +125,11 @@ module EDCLMLinkMod real(r8), pointer, private :: croot_prof_col(:,:) !(1/m) profile of coarse roots real(r8), pointer, private :: stem_prof_col(:,:) !(1/m) profile of leaves + ! summary carbon fluxes at the column level + real(r8), pointer, public :: nep_col(:) ! [gC/m2/s] Net ecosystem production, i.e. fast-timescale carbon balance that does not include disturbance + real(r8), pointer, public :: nbp_col(:) ! [gC/m2/s] Net biosphere production, i.e. slow-timescale carbon balance that integrates to total carbon change + real(r8), pointer, public :: npp_hifreq_col(:) ! [gC/m2/s] Net primary production at the fast timescale, aggregated to the column level + contains ! Public routines @@ -130,6 +137,7 @@ module EDCLMLinkMod procedure , public :: Restart procedure , public :: SetValues procedure , public :: ed_clm_link + procedure , public :: Summary ! Private routines procedure , private :: ed_clm_leaf_area_profile @@ -239,6 +247,10 @@ subroutine InitAllocate(this, bounds) allocate(this%croot_prof_col (begc:endc,1:nlevdecomp_full)) ; this%croot_prof_col (:,:) = nan allocate(this%stem_prof_col (begc:endc,1:nlevdecomp_full)) ; this%stem_prof_col (:,:) = nan + allocate(this%nep_col (begc:endc)) ; this%nep_col (:) = nan + allocate(this%nbp_col (begc:endc)) ; this%nbp_col (:) = nan + allocate(this%npp_hifreq_col (begc:endc)) ; this%npp_hifreq_col (:) = nan + allocate(this%ed_gpp_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)); this%ed_gpp_gd_scpf (:,:) = 0.0_r8 allocate(this%ed_npp_totl_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)); this%ed_npp_totl_gd_scpf (:,:) = 0.0_r8 allocate(this%ed_npp_leaf_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)); this%ed_npp_leaf_gd_scpf (:,:) = 0.0_r8 @@ -476,6 +488,21 @@ subroutine InitHistory(this, bounds) avgflag='A', long_name='net primary production', & ptr_patch=this%npp_patch) + this%nep_col(begc:endc) = spval + call hist_addfld1d (fname='NEP', units='gC/m^2/s', & + avgflag='A', long_name='net ecosystem production', & + ptr_col=this%nep_col) + + this%nbp_col(begc:endc) = spval + call hist_addfld1d (fname='NBP', units='gC/m^2/s', & + avgflag='A', long_name='net biosphere production', & + ptr_col=this%nbp_col) + + this%npp_hifreq_col(begc:endc) = spval + call hist_addfld1d (fname='NPP at high frequency', units='gC/m^2/s', & + avgflag='A', long_name='net primary production at high frequency', & + ptr_col=this%npp_hifreq_col) + !!! carbon fluxes into soil grid (dimensioned depth x column) call hist_addfld_decomp (fname='ED_c_to_litr_lab_c', units='gC/m^2/s', type2d='levdcmp', & avgflag='A', long_name='ED_c_to_litr_lab_c', & @@ -2184,7 +2211,64 @@ subroutine flux_into_litter_pools(this, bounds, ed_allsites_inst, firstsoilpatch end associate end subroutine flux_into_litter_pools + + !------------------------------------------------------------------------ + subroutine Summary(this, bounds, numsoilc, filter_soilc, num_soilp, filter_soilp, & + ed_allsites_inst, soilbiogeochem_carbonflux_inst) + + ! Summarize the combined production and decomposition fluxes into net fluxes + ! Written by Charlie Koven, Feb 2016 + + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + type(ed_site_type) , intent(inout), target :: ed_allsites_inst( bounds%begg: ) + type(soilbiogeochem_carbonflux_type) , intent(inout) :: soilbiogeochem_carbonflux_inst + + real(r8) :: npp_hifreq_col(bounds%begc:bounds%endc ! column-level, high frequency NPP + real(r8) :: dt ! radiation time step (seconds) + + associate(& + hr => soilbiogeochem_carbonflux_inst%hr_col & ! Output: (gC/m2/s) total heterotrophic respiration + npp_hifreq => this%npp_hifreq_col + nep => this%nep_col + nbp => this%nbp_col + ) + + ! set time steps + dt = real( get_step_size(), r8 ) + + do c = bounds%begc,bounds%endc + npp_hifreq(c) = 0._r8 + end do + + do g = bounds%begg,bounds%endg + if (firstsoilpatch(g) >= 0 .and. ed_allsites_inst(g)%istheresoil) then + currentPatch => ed_allsites_inst(g)%oldest_patch + do while(associated(currentPatch)) + cs => currentpatch%siteptr + cc = cs%clmcolumn + currentCohort => currentPatch%tallest + do while(associated(currentCohort)) + npp_hifreq(cc) = npp_hifreq(cc) + currentpatch%npp_clm * 1e3 / ( AREA * dt) + enddo !currentCohort + currentPatch => currentPatch%younger + end do !currentPatch + end if + end do + + ! calculate NEP and NBP fluxes. + !!!! CDK FEB/26/2016: THIS IS IMPORTANT AND NEEDS TO CHANGE AS IT IS ONLY A PLACEHOLDER. + !!!! NEP AND NBP ARE BOTH THE SAME RIGHT NOW BECAUSE I DON'T KNOW HOW TO ADD IN THE FIRE, DISTURBANCE, ETC FLUXES INTO THE NBP FLUX YET + do fc = 1,num_soilc + c = filter_soilc(fc) + nep(c) = npp_hifreq(c) - hr(c) + nbp(c) = npp_hifreq(c) - hr(c) + end do + end module EDCLMLinkMod From 12bb2e894892cfff0ca5edc252874398f9f713e9 Mon Sep 17 00:00:00 2001 From: ckoven Date: Fri, 26 Feb 2016 16:15:50 -0800 Subject: [PATCH 032/437] first set of bugfixes on NEP/NBP code --- main/EDCLMLinkMod.F90 | 26 +++++++++++++++++--------- 1 file changed, 17 insertions(+), 9 deletions(-) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index e2ceb437..8fb56007 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -2214,12 +2214,13 @@ end subroutine flux_into_litter_pools !------------------------------------------------------------------------ - subroutine Summary(this, bounds, numsoilc, filter_soilc, num_soilp, filter_soilp, & + subroutine Summary(this, bounds, num_soilc, filter_soilc, num_soilp, filter_soilp, & ed_allsites_inst, soilbiogeochem_carbonflux_inst) ! Summarize the combined production and decomposition fluxes into net fluxes ! Written by Charlie Koven, Feb 2016 + class(ed_clm_type) :: this type(bounds_type) , intent(in) :: bounds integer , intent(in) :: num_soilc ! number of soil columns in filter integer , intent(in) :: filter_soilc(:) ! filter for soil columns @@ -2228,14 +2229,18 @@ subroutine Summary(this, bounds, numsoilc, filter_soilc, num_soilp, filter_soilp type(ed_site_type) , intent(inout), target :: ed_allsites_inst( bounds%begg: ) type(soilbiogeochem_carbonflux_type) , intent(inout) :: soilbiogeochem_carbonflux_inst - real(r8) :: npp_hifreq_col(bounds%begc:bounds%endc ! column-level, high frequency NPP + real(r8) :: npp_hifreq_col(bounds%begc:bounds%endc) ! column-level, high frequency NPP real(r8) :: dt ! radiation time step (seconds) + integer :: c, g, cc, fc + type(ed_site_type), pointer :: cs + type (ed_patch_type) , pointer :: currentPatch + type (ed_cohort_type) , pointer :: currentCohort associate(& - hr => soilbiogeochem_carbonflux_inst%hr_col & ! Output: (gC/m2/s) total heterotrophic respiration - npp_hifreq => this%npp_hifreq_col - nep => this%nep_col - nbp => this%nbp_col + hr => soilbiogeochem_carbonflux_inst%hr_col, & ! Output: (gC/m2/s) total heterotrophic respiration + npp_hifreq => this%npp_hifreq_col, & + nep => this%nep_col, & + nbp => this%nbp_col & ) ! set time steps @@ -2246,14 +2251,14 @@ subroutine Summary(this, bounds, numsoilc, filter_soilc, num_soilp, filter_soilp end do do g = bounds%begg,bounds%endg - if (firstsoilpatch(g) >= 0 .and. ed_allsites_inst(g)%istheresoil) then + if (ed_allsites_inst(g)%istheresoil) then currentPatch => ed_allsites_inst(g)%oldest_patch do while(associated(currentPatch)) - cs => currentpatch%siteptr + cs => currentPatch%siteptr cc = cs%clmcolumn currentCohort => currentPatch%tallest do while(associated(currentCohort)) - npp_hifreq(cc) = npp_hifreq(cc) + currentpatch%npp_clm * 1e3 / ( AREA * dt) + npp_hifreq(cc) = npp_hifreq(cc) + currentCohort%npp_clm * 1e3 * currentCohort%n / ( AREA * dt) enddo !currentCohort currentPatch => currentPatch%younger end do !currentPatch @@ -2269,6 +2274,9 @@ subroutine Summary(this, bounds, numsoilc, filter_soilc, num_soilp, filter_soilp nbp(c) = npp_hifreq(c) - hr(c) end do + end associate + +end subroutine Summary end module EDCLMLinkMod From d854d4a84098d9d8c8bf1140305b352bb06dea17 Mon Sep 17 00:00:00 2001 From: ckoven Date: Fri, 26 Feb 2016 18:21:13 -0800 Subject: [PATCH 033/437] second set of bugfixes on NEP/NBP code --- biogeochem/EDBGCDynMod.F90 | 2 +- main/EDCLMLinkMod.F90 | 146 +++++++++++++++++++++---------------- 2 files changed, 83 insertions(+), 65 deletions(-) diff --git a/biogeochem/EDBGCDynMod.F90 b/biogeochem/EDBGCDynMod.F90 index d90b36c3..9e234084 100644 --- a/biogeochem/EDBGCDynMod.F90 +++ b/biogeochem/EDBGCDynMod.F90 @@ -348,7 +348,7 @@ subroutine EDBGCDynSummary(bounds, num_soilc, filter_soilc, num_soilp, filter_so ! ed veg carbon flux summary ! ---------------------------------------------- - call ed_clm_inst%Summary(bounds, numsoilc, filter_soilc, num_soilp, filter_soilp, & + call ed_clm_inst%Summary(bounds, num_soilc, filter_soilc, num_soilp, filter_soilp, & ed_allsites_inst(bounds%begg:bounds%endg), soilbiogeochem_carbonflux_inst) ! ---------------------------------------------- diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 8fb56007..697e6254 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -499,9 +499,9 @@ subroutine InitHistory(this, bounds) ptr_col=this%nbp_col) this%npp_hifreq_col(begc:endc) = spval - call hist_addfld1d (fname='NPP at high frequency', units='gC/m^2/s', & + call hist_addfld1d (fname='NPP_hifreq', units='gC/m^2/s', & avgflag='A', long_name='net primary production at high frequency', & - ptr_col=this%npp_hifreq_col) + ptr_col=this%npp_hifreq_col,default='inactive') !!! carbon fluxes into soil grid (dimensioned depth x column) call hist_addfld_decomp (fname='ED_c_to_litr_lab_c', units='gC/m^2/s', type2d='levdcmp', & @@ -518,15 +518,15 @@ subroutine InitHistory(this, bounds) call hist_addfld_decomp (fname='leaf_prof', units='1/m', type2d='levdcmp', & avgflag='A', long_name='leaf_prof', & - ptr_col=this%leaf_prof_col) + ptr_col=this%leaf_prof_col,default='inactive') call hist_addfld_decomp (fname='croot_prof', units='1/m', type2d='levdcmp', & avgflag='A', long_name='croot_prof', & - ptr_col=this%croot_prof_col) + ptr_col=this%croot_prof_col,default='inactive') call hist_addfld_decomp (fname='stem_prof', units='1/m', type2d='levdcmp', & avgflag='A', long_name='stem_prof', & - ptr_col=this%stem_prof_col) + ptr_col=this%stem_prof_col,default='inactive') ! Carbon Flux (grid dimension x scpf) @@ -2219,64 +2219,82 @@ subroutine Summary(this, bounds, num_soilc, filter_soilc, num_soilp, filter_soil ! Summarize the combined production and decomposition fluxes into net fluxes ! Written by Charlie Koven, Feb 2016 - - class(ed_clm_type) :: this - type(bounds_type) , intent(in) :: bounds - integer , intent(in) :: num_soilc ! number of soil columns in filter - integer , intent(in) :: filter_soilc(:) ! filter for soil columns - integer , intent(in) :: num_soilp ! number of soil patches in filter - integer , intent(in) :: filter_soilp(:) ! filter for soil patches - type(ed_site_type) , intent(inout), target :: ed_allsites_inst( bounds%begg: ) - type(soilbiogeochem_carbonflux_type) , intent(inout) :: soilbiogeochem_carbonflux_inst - - real(r8) :: npp_hifreq_col(bounds%begc:bounds%endc) ! column-level, high frequency NPP - real(r8) :: dt ! radiation time step (seconds) - integer :: c, g, cc, fc - type(ed_site_type), pointer :: cs - type (ed_patch_type) , pointer :: currentPatch - type (ed_cohort_type) , pointer :: currentCohort - - associate(& - hr => soilbiogeochem_carbonflux_inst%hr_col, & ! Output: (gC/m2/s) total heterotrophic respiration - npp_hifreq => this%npp_hifreq_col, & - nep => this%nep_col, & - nbp => this%nbp_col & - ) - - ! set time steps - dt = real( get_step_size(), r8 ) - - do c = bounds%begc,bounds%endc - npp_hifreq(c) = 0._r8 - end do - - do g = bounds%begg,bounds%endg - if (ed_allsites_inst(g)%istheresoil) then - currentPatch => ed_allsites_inst(g)%oldest_patch - do while(associated(currentPatch)) - cs => currentPatch%siteptr - cc = cs%clmcolumn - currentCohort => currentPatch%tallest - do while(associated(currentCohort)) - npp_hifreq(cc) = npp_hifreq(cc) + currentCohort%npp_clm * 1e3 * currentCohort%n / ( AREA * dt) - enddo !currentCohort - currentPatch => currentPatch%younger - end do !currentPatch - end if - end do - - ! calculate NEP and NBP fluxes. - !!!! CDK FEB/26/2016: THIS IS IMPORTANT AND NEEDS TO CHANGE AS IT IS ONLY A PLACEHOLDER. - !!!! NEP AND NBP ARE BOTH THE SAME RIGHT NOW BECAUSE I DON'T KNOW HOW TO ADD IN THE FIRE, DISTURBANCE, ETC FLUXES INTO THE NBP FLUX YET - do fc = 1,num_soilc - c = filter_soilc(fc) - nep(c) = npp_hifreq(c) - hr(c) - nbp(c) = npp_hifreq(c) - hr(c) - end do - - end associate - -end subroutine Summary - + ! + ! !USES: + use ColumnType , only : col + use LandunitType , only : lun + use landunit_varcon , only : istsoil + + class(ed_clm_type) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + type(ed_site_type) , intent(inout), target :: ed_allsites_inst( bounds%begg: ) + type(soilbiogeochem_carbonflux_type) , intent(inout) :: soilbiogeochem_carbonflux_inst + + real(r8) :: npp_hifreq_col(bounds%begc:bounds%endc) ! column-level, high frequency NPP + real(r8) :: dt ! radiation time step (seconds) + integer :: c, g, cc, fc, l + type(ed_site_type), pointer :: cs + type (ed_patch_type) , pointer :: currentPatch + type (ed_cohort_type) , pointer :: currentCohort + integer :: firstsoilpatch(bounds%begg:bounds%endg) ! the first patch in this gridcell that is soil and thus bare... + + associate(& + hr => soilbiogeochem_carbonflux_inst%hr_col, & ! Output: (gC/m2/s) total heterotrophic respiration + npp_hifreq => this%npp_hifreq_col, & + nep => this%nep_col, & + nbp => this%nbp_col & + ) + + ! set time steps + dt = real( get_step_size(), r8 ) + + do c = bounds%begc,bounds%endc + npp_hifreq(c) = 0._r8 + end do + + ! retrieve the first soil patch associated with each gridcell. + ! make sure we only get the first patch value for places which have soil. + firstsoilpatch(bounds%begg:bounds%endg) = -999 + do c = bounds%begc,bounds%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) + endif + enddo + do g = bounds%begg,bounds%endg + if (firstsoilpatch(g) >= 0 .and. ed_allsites_inst(g)%istheresoil) then + currentPatch => ed_allsites_inst(g)%oldest_patch + do while(associated(currentPatch)) + cs => currentPatch%siteptr + cc = cs%clmcolumn + currentCohort => currentPatch%tallest + do while(associated(currentCohort)) + npp_hifreq(cc) = npp_hifreq(cc) + currentCohort%npp_clm * 1e3 * currentCohort%n / ( AREA * dt) + currentCohort => currentCohort%shorter + enddo !currentCohort + currentPatch => currentPatch%younger + end do !currentPatch + end if + end do + + ! calculate NEP and NBP fluxes. + !!!! CDK FEB/26/2016: THIS IS IMPORTANT AND NEEDS TO CHANGE AS IT IS ONLY A PLACEHOLDER. + !!!! NEP AND NBP ARE BOTH THE SAME RIGHT NOW BECAUSE I DON'T KNOW HOW TO ADD IN THE FIRE, DISTURBANCE, ETC FLUXES INTO THE NBP FLUX YET + do fc = 1,num_soilc + c = filter_soilc(fc) + nep(c) = npp_hifreq(c) - hr(c) + nbp(c) = npp_hifreq(c) - hr(c) + end do + + end associate + + end subroutine Summary + + end module EDCLMLinkMod From bcc4092a71fc04e7acaf298b6c085734c22e1e29 Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Sat, 27 Feb 2016 17:51:57 -0800 Subject: [PATCH 034/437] added code to aggregate column-level fire carbon fluxes and use these as the difference between NEP and NBP --- biogeochem/EDPatchDynamicsMod.F90 | 13 ++++++++++++- main/EDCLMLinkMod.F90 | 26 ++++++++++++++++++-------- main/EDTypesMod.F90 | 5 +++-- 3 files changed, 33 insertions(+), 11 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index dab3b7fe..1f3f1c61 100755 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -198,8 +198,11 @@ subroutine spawn_patches( currentSite ) ! calculate area of disturbed land, in this timestep, by summing contributions from each existing patch. currentPatch => currentSite%youngest_patch + + ! zero site-level fire fluxes currentSite%cwd_ag_burned = 0.0_r8 currentSite%leaf_litter_burned = 0.0_r8 + currentSite%total_burn_flux_to_atm = 0.0_r8 site_areadis = 0.0_r8 do while(associated(currentPatch)) @@ -546,12 +549,14 @@ subroutine fire_litter_fluxes(cp_target, new_patch_target, patch_site_areadis) 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 + currentSite%total_burn_flux_to_atm = currentSite%total_burn_flux_to_atm + burned_litter * new_patch%area !kG/site/day enddo do p = 1,numpft_ed 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 + currentSite%flux_out = currentSite%flux_out + burned_litter * new_patch%area !kG/site/day + currentSite%total_burn_flux_to_atm = currentSite%total_burn_flux_to_atm + burned_litter * new_patch%area !kG/site/day enddo !************************************/ @@ -613,6 +618,8 @@ subroutine fire_litter_fluxes(cp_target, new_patch_target, patch_site_areadis) 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 + currentSite%total_burn_flux_to_atm = currentSite%total_burn_flux_to_atm + dead_tree_density * & + AREA * SF_val_CWD_frac(c) * bstem * currentCohort%cfa enddo @@ -623,6 +630,8 @@ subroutine fire_litter_fluxes(cp_target, new_patch_target, patch_site_areadis) dead_tree_density * currentCohort%bl * currentCohort%cfa currentSite%flux_out = currentSite%flux_out + & dead_tree_density * AREA * currentCohort%bl * currentCohort%cfa + currentSite%total_burn_flux_to_atm = currentSite%total_burn_flux_to_atm + & + dead_tree_density * AREA * currentCohort%bl * currentCohort%cfa enddo @@ -653,6 +662,8 @@ subroutine fire_litter_fluxes(cp_target, new_patch_target, patch_site_areadis) !KgC/gridcell/day currentSite%flux_out = currentSite%flux_out + burned_leaves * currentCohort%n * & patch_site_areadis/currentPatch%area * AREA + currentSite%total_burn_flux_to_atm = currentSite%total_burn_flux_to_atm+ burned_leaves * currentCohort%n * & + patch_site_areadis/currentPatch%area * AREA endif currentCohort%cfa = 0.0_r8 diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 697e6254..c53da614 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -128,7 +128,9 @@ module EDCLMLinkMod ! summary carbon fluxes at the column level real(r8), pointer, public :: nep_col(:) ! [gC/m2/s] Net ecosystem production, i.e. fast-timescale carbon balance that does not include disturbance real(r8), pointer, public :: nbp_col(:) ! [gC/m2/s] Net biosphere production, i.e. slow-timescale carbon balance that integrates to total carbon change - real(r8), pointer, public :: npp_hifreq_col(:) ! [gC/m2/s] Net primary production at the fast timescale, aggregated to the column level + real(r8), pointer, public :: npp_hifreq_col(:) ! [gC/m2/s] Net primary production at the fast timescale, aggregated to the column level + real(r8), pointer, public :: fire_c_to_atm_col(:) ! [gC/m2/s] total fire carbon loss to atmosphere + contains @@ -250,6 +252,7 @@ subroutine InitAllocate(this, bounds) allocate(this%nep_col (begc:endc)) ; this%nep_col (:) = nan allocate(this%nbp_col (begc:endc)) ; this%nbp_col (:) = nan allocate(this%npp_hifreq_col (begc:endc)) ; this%npp_hifreq_col (:) = nan + allocate(this%fire_c_to_atm_col (begc:endc)) ; this%fire_c_to_atm_col (:) = nan allocate(this%ed_gpp_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)); this%ed_gpp_gd_scpf (:,:) = 0.0_r8 allocate(this%ed_npp_totl_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)); this%ed_npp_totl_gd_scpf (:,:) = 0.0_r8 @@ -388,10 +391,6 @@ subroutine InitHistory(this, bounds) 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) @@ -493,6 +492,11 @@ subroutine InitHistory(this, bounds) avgflag='A', long_name='net ecosystem production', & ptr_col=this%nep_col) + this%fire_c_to_atm_col(begc:endc) = spval + call hist_addfld1d (fname='Fire_Closs', units='gC/m^2/s', & + avgflag='A', long_name='ED/SPitfire Carbon loss to atmosphere', & + ptr_col=this%fire_c_to_atm_col) + this%nbp_col(begc:endc) = spval call hist_addfld1d (fname='NBP', units='gC/m^2/s', & avgflag='A', long_name='net biosphere production', & @@ -2246,14 +2250,17 @@ subroutine Summary(this, bounds, num_soilc, filter_soilc, num_soilp, filter_soil hr => soilbiogeochem_carbonflux_inst%hr_col, & ! Output: (gC/m2/s) total heterotrophic respiration npp_hifreq => this%npp_hifreq_col, & nep => this%nep_col, & + fire_c_to_atm => this%fire_c_to_atm_col, & nbp => this%nbp_col & ) ! set time steps dt = real( get_step_size(), r8 ) + ! zero npp first do c = bounds%begc,bounds%endc npp_hifreq(c) = 0._r8 + fire_c_to_atm(c) = 0._r8 end do ! retrieve the first soil patch associated with each gridcell. @@ -2269,6 +2276,11 @@ subroutine Summary(this, bounds, num_soilc, filter_soilc, num_soilp, filter_soil do g = bounds%begg,bounds%endg if (firstsoilpatch(g) >= 0 .and. ed_allsites_inst(g)%istheresoil) then + ! first map ed site-level fire fluxes to clm column fluxes + cc = ed_allsites_inst(g)%clmcolumn + fire_c_to_atm(cc) = ed_allsites_inst(g)%total_burn_flux_to_atm / ( AREA * SHR_CONST_CDAY * 1.e3_r8) + + ! second map ed cohort-level npp fluxes to clm column fluxes currentPatch => ed_allsites_inst(g)%oldest_patch do while(associated(currentPatch)) cs => currentPatch%siteptr @@ -2284,12 +2296,10 @@ subroutine Summary(this, bounds, num_soilc, filter_soilc, num_soilp, filter_soil end do ! calculate NEP and NBP fluxes. - !!!! CDK FEB/26/2016: THIS IS IMPORTANT AND NEEDS TO CHANGE AS IT IS ONLY A PLACEHOLDER. - !!!! NEP AND NBP ARE BOTH THE SAME RIGHT NOW BECAUSE I DON'T KNOW HOW TO ADD IN THE FIRE, DISTURBANCE, ETC FLUXES INTO THE NBP FLUX YET do fc = 1,num_soilc c = filter_soilc(fc) nep(c) = npp_hifreq(c) - hr(c) - nbp(c) = npp_hifreq(c) - hr(c) + nbp(c) = npp_hifreq(c) - ( hr(c) + fire_c_to_atm(c) ) end do end associate diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index ab816a9d..c4cb994d 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -413,13 +413,14 @@ module EDTypesMod 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. + real(r8) :: total_burn_flux_to_atm ! total carbon burnt to the atmosphere in this day. KgC/site + real(r8) :: cwd_ag_burned(ncwd) + real(r8) :: leaf_litter_burned(numpft_ed) end type ed_site_type From cabab7c1556ce1d886057b1197d218b393df5c46 Mon Sep 17 00:00:00 2001 From: ckoven Date: Sun, 28 Feb 2016 10:00:45 -0800 Subject: [PATCH 035/437] bugfixes on fire NEP/NBP code --- main/EDCLMLinkMod.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index c53da614..94cb3ef1 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -2228,6 +2228,7 @@ subroutine Summary(this, bounds, num_soilc, filter_soilc, num_soilp, filter_soil use ColumnType , only : col use LandunitType , only : lun use landunit_varcon , only : istsoil + use shr_const_mod, only: SHR_CONST_CDAY class(ed_clm_type) :: this type(bounds_type) , intent(in) :: bounds From 98366eb04f821af8c2cd842e4eac3a9c93b732b2 Mon Sep 17 00:00:00 2001 From: Chonggang Xu Date: Mon, 29 Feb 2016 11:07:50 -0700 Subject: [PATCH 036/437] update lanl machines --- biogeochem/EDGrowthFunctionsMod.F90 | 2 +- biogeochem/EDPhysiologyMod.F90 | 4 ++-- main/EDPftvarcon.F90 | 4 ++++ 3 files changed, 7 insertions(+), 3 deletions(-) diff --git a/biogeochem/EDGrowthFunctionsMod.F90 b/biogeochem/EDGrowthFunctionsMod.F90 index 98925f16..f7b5706e 100755 --- a/biogeochem/EDGrowthFunctionsMod.F90 +++ b/biogeochem/EDGrowthFunctionsMod.F90 @@ -350,7 +350,7 @@ subroutine mortality_rates( cohort_in,cmort,hmort,bmort ) real(r8) :: frac ! relativised stored carbohydrate ! '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 + bmort = EDecophyscon%b_mort(cohort_in%pft) !0.014_r8 ! Proxy for hydraulic failure induced mortality. if(cohort_in%patchptr%btran_ft(cohort_in%pft) <= 0.000001_r8)then diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index b949c5fd..e77e9168 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -309,13 +309,13 @@ subroutine phenology( currentSite, ed_phenology_inst, temperature_inst, watersta a = -68.0_r8 b = 638.0_r8 c = -0.001_r8 - coldday = 5.0_r8 + coldday = 5.0_r8 !ed_ph_chiltemp mindayson = 30 !Parameters from SDGVM model of senesence ncolddayslim = 5 - cold_t = 7.5_r8 + cold_t = 7.5_r8 ! ed_ph_coldtemp t = udata%time_period temp_in_C = t_veg24(currentSite%oldest_patch%clm_pno-1) - tfrz diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index 421828a6..fa80e189 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -38,6 +38,7 @@ module EDPftvarcon 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 + real(r8) :: dbh2h_m (0:mxpft) ! allocation parameter m from dbh to height end type EDPftvarcon_type type(EDPftvarcon_type), public :: EDPftvarcon_inst @@ -131,6 +132,9 @@ subroutine EDpftconrd( ncid ) 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') + + call ncd_io('dbh2h_m',EDPftvarcon_inst%dbh2h_m, 'read', ncid, readvar=readv) + if ( .not. readv) call endrun(trim(subname)// ' ERROR : error in reading in pft data') end subroutine EDpftconrd From 92f3e7357fe28501a74c7fe66818d2b38a33a04f Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Mon, 29 Feb 2016 11:56:37 -0800 Subject: [PATCH 037/437] added combined ED/BGC C stock balance check versus daily-integrated NBP infrastructure --- biogeochem/EDBGCDynMod.F90 | 19 +++- main/EDCLMLinkMod.F90 | 217 +++++++++++++++++++++++++++++++++---- 2 files changed, 212 insertions(+), 24 deletions(-) diff --git a/biogeochem/EDBGCDynMod.F90 b/biogeochem/EDBGCDynMod.F90 index 9e234084..05443a48 100644 --- a/biogeochem/EDBGCDynMod.F90 +++ b/biogeochem/EDBGCDynMod.F90 @@ -345,16 +345,27 @@ subroutine EDBGCDynSummary(bounds, num_soilc, filter_soilc, num_soilp, filter_so ! call soilbiogeochem_nitrogenflux_inst%Summary(bounds, num_soilc, filter_soilc) ! ---------------------------------------------- - ! ed veg carbon flux summary + ! ed veg carbon state and flux summary ! ---------------------------------------------- - call ed_clm_inst%Summary(bounds, num_soilc, filter_soilc, num_soilp, filter_soilp, & - ed_allsites_inst(bounds%begg:bounds%endg), soilbiogeochem_carbonflux_inst) + call ed_clm_inst%Summary(bounds, num_soilc, filter_soilc, & + ed_allsites_inst(bounds%begg:bounds%endg), & + soilbiogeochem_carbonflux_inst, & + soilbiogeochem_carbonstate_inst) ! ---------------------------------------------- - ! ed veg carbon/nitrogen flux summary + ! ed veg nitrogen flux summary ! ---------------------------------------------- + ! TBD... + + ! ---------------------------------------------- + ! calculate balance checks on entire carbon cycle (ED + BGC) + ! ---------------------------------------------- + + call ed_clm_inst%ED_BGC_Carbon_Balancecheck(bounds, num_soilc, filter_soilc, & + ed_allsites_inst(bounds%begg:bounds%endg)) + call t_stopf('BGCsum') end subroutine EDBGCDynSummary diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 94cb3ef1..3abd5ef3 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -17,6 +17,7 @@ module EDCLMLinkMod use clm_varctl , only : use_vertsoilc use EDParamsMod , only : ED_val_ag_biomass use SoilBiogeochemCarbonFluxType , only : soilbiogeochem_carbonflux_type + use SoilBiogeochemCarbonStatetype , only : soilbiogeochem_carbonstate_type use clm_time_manager , only : get_step_size ! @@ -127,10 +128,18 @@ module EDCLMLinkMod ! summary carbon fluxes at the column level real(r8), pointer, public :: nep_col(:) ! [gC/m2/s] Net ecosystem production, i.e. fast-timescale carbon balance that does not include disturbance + real(r8), pointer, public :: nep_timeintegrated_col(:) ! [gC/m2/s] Net ecosystem production, i.e. fast-timescale carbon balance that does not include disturbance real(r8), pointer, public :: nbp_col(:) ! [gC/m2/s] Net biosphere production, i.e. slow-timescale carbon balance that integrates to total carbon change real(r8), pointer, public :: npp_hifreq_col(:) ! [gC/m2/s] Net primary production at the fast timescale, aggregated to the column level real(r8), pointer, public :: fire_c_to_atm_col(:) ! [gC/m2/s] total fire carbon loss to atmosphere + ! summary carbon states at the column level + real(r8), pointer, public :: totecosysc_col(:) ! [gC/m2] Total ecosystem carbon at the column level, including vegetation, CWD, litter, and soil pools + real(r8), pointer, public :: totecosysc_old_col(:) ! [gC/m2] Total ecosystem C at the column level from last call to balance check + real(r8), pointer, public :: biomass_stock_col(:) ! [gC/m2] total biomass at the column level in gC / m2 + real(r8), pointer, public :: ed_litter_stock_col(:) ! [gC/m2] ED litter at the column level in gC / m2 + real(r8), pointer, public :: cwd_stock_col(:) ! [gC/m2] ED CWD at the column level in gC / m2 + real(r8), pointer, public :: seed_stock_col(:) ! [gC/m2] ED seed mass carbon at the column level in gC / m2 contains @@ -140,6 +149,8 @@ module EDCLMLinkMod procedure , public :: SetValues procedure , public :: ed_clm_link procedure , public :: Summary + procedure , public :: ED_BGC_Carbon_Balancecheck + procedure , public :: Summary ! Private routines procedure , private :: ed_clm_leaf_area_profile @@ -250,10 +261,18 @@ subroutine InitAllocate(this, bounds) allocate(this%stem_prof_col (begc:endc,1:nlevdecomp_full)) ; this%stem_prof_col (:,:) = nan allocate(this%nep_col (begc:endc)) ; this%nep_col (:) = nan + allocate(this%nep_timeintegrated_col (begc:endc)) ; this%nep_timeintegrated_col (:) = nan allocate(this%nbp_col (begc:endc)) ; this%nbp_col (:) = nan allocate(this%npp_hifreq_col (begc:endc)) ; this%npp_hifreq_col (:) = nan allocate(this%fire_c_to_atm_col (begc:endc)) ; this%fire_c_to_atm_col (:) = nan + allocate(this%totecosysc_col (begc:endc)) ; this%totecosysc_col (:) = nan + allocate(this%totecosysc_old_col (begc:endc)) ; this%totecosysc_old_col (:) = nan + allocate(this%biomass_stock_col (begc:endc)) ; this%biomass_stock_col (:) = nan + allocate(this%ed_litter_stock_col (begc:endc)) ; this%ed_litter_stock_col (:) = nan + allocate(this%cwd_stock_col (begc:endc)) ; this%cwd_stock_col (:) = nan + allocate(this%seed_stock_col (begc:endc)) ; this%seed_stock_col (:) = nan + allocate(this%ed_gpp_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)); this%ed_gpp_gd_scpf (:,:) = 0.0_r8 allocate(this%ed_npp_totl_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)); this%ed_npp_totl_gd_scpf (:,:) = 0.0_r8 allocate(this%ed_npp_leaf_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)); this%ed_npp_leaf_gd_scpf (:,:) = 0.0_r8 @@ -336,15 +355,15 @@ subroutine InitHistory(this, bounds) 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', & + avgflag='A', long_name='total PFT level leaf 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', & + avgflag='A', long_name='total PFT level stored 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', & + call hist_addfld2d (fname='PFTnindivs', units='indiv / m2', type2d='levgrnd', & + avgflag='A', long_name='total PFT level number of individuals', & ptr_patch=this%PFTnindivs_patch, set_lake=0._r8, set_urb=0._r8) call hist_addfld1d (fname='FIRE_NESTEROV_INDEX', units='none', & @@ -507,6 +526,31 @@ subroutine InitHistory(this, bounds) avgflag='A', long_name='net primary production at high frequency', & ptr_col=this%npp_hifreq_col,default='inactive') + this%totecosysc_col(begc:endc) = spval + call hist_addfld1d (fname='TOTECOSYSC', units='gC/m^2', & + avgflag='A', long_name='total ecosystem carbon', & + ptr_col=this%totecosysc_col) + + this%biomass_stock_col(begc:endc) = spval + call hist_addfld1d (fname='BIOMASS_STOCK_COL', units='gC/m^2', & + avgflag='A', long_name='total ED biomass carbon at the column level', & + ptr_col=this%biomass_stock_col) + + this%ed_litter_stock_col(begc:endc) = spval + call hist_addfld1d (fname='ED_LITTER_STOCK_COL', units='gC/m^2', & + avgflag='A', long_name='total ED litter carbon at the column level', & + ptr_col=this%ed_litter_stock_col) + + this%cwd_stock_col(begc:endc) = spval + call hist_addfld1d (fname='CWD_STOCK_COL', units='gC/m^2', & + avgflag='A', long_name='total CWD carbon at the column level', & + ptr_col=this%cwd_stock_col) + + this%seed_stock_col(begc:endc) = spval + call hist_addfld1d (fname='SEED_STOCK_COL', units='gC/m^2', & + avgflag='A', long_name='total seed carbon at the column level', & + ptr_col=this%seed_stock_col) + !!! carbon fluxes into soil grid (dimensioned depth x column) call hist_addfld_decomp (fname='ED_c_to_litr_lab_c', units='gC/m^2/s', type2d='levdcmp', & avgflag='A', long_name='ED_c_to_litr_lab_c', & @@ -669,6 +713,16 @@ subroutine Restart ( this, bounds, ncid, flag ) ! dim1name='pft', long_name='', units='', & ! interpinic_flag='interp', readvar=readvar, data=this%livestemn_patch) + ptr1d => this%nep_timeintegrated_col(:) + call restartvar(ncid=ncid, flag=flag, varname='nep_timeintegrated_col', xtype=ncd_double, & + dim1name='column', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=ptr1d) + + ptr1d => this%totecosysc_old_col(:) + call restartvar(ncid=ncid, flag=flag, varname='totecosysc_old_col', xtype=ncd_double, & + dim1name='column', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=ptr1d) + if (use_vertsoilc) then ptr2d => this%ED_c_to_litr_lab_c_col call restartvar(ncid=ncid, flag=flag, varname='ED_c_to_litr_lab_c_col', xtype=ncd_double, & @@ -2218,8 +2272,9 @@ end subroutine flux_into_litter_pools !------------------------------------------------------------------------ - subroutine Summary(this, bounds, num_soilc, filter_soilc, num_soilp, filter_soilp, & - ed_allsites_inst, soilbiogeochem_carbonflux_inst) + subroutine Summary(this, bounds, num_soilc, filter_soilc, & + ed_allsites_inst, soilbiogeochem_carbonflux_inst, & + soilbiogeochem_carbonstate_inst) ! Summarize the combined production and decomposition fluxes into net fluxes ! Written by Charlie Koven, Feb 2016 @@ -2229,16 +2284,19 @@ subroutine Summary(this, bounds, num_soilc, filter_soilc, num_soilp, filter_soil use LandunitType , only : lun use landunit_varcon , only : istsoil use shr_const_mod, only: SHR_CONST_CDAY - - class(ed_clm_type) :: this + ! + implicit none + ! + ! !ARGUMENTS + class(ed_clm_type) :: this type(bounds_type) , intent(in) :: bounds integer , intent(in) :: num_soilc ! number of soil columns in filter integer , intent(in) :: filter_soilc(:) ! filter for soil columns - integer , intent(in) :: num_soilp ! number of soil patches in filter - integer , intent(in) :: filter_soilp(:) ! filter for soil patches type(ed_site_type) , intent(inout), target :: ed_allsites_inst( bounds%begg: ) type(soilbiogeochem_carbonflux_type) , intent(inout) :: soilbiogeochem_carbonflux_inst - + type(soilbiogeochem_carbonstate_type) , intent(inout) :: soilbiogeochem_carbonstate_inst + ! + ! !LOCAL VARIABLES: real(r8) :: npp_hifreq_col(bounds%begc:bounds%endc) ! column-level, high frequency NPP real(r8) :: dt ! radiation time step (seconds) integer :: c, g, cc, fc, l @@ -2248,20 +2306,34 @@ subroutine Summary(this, bounds, num_soilc, filter_soilc, num_soilp, filter_soil integer :: firstsoilpatch(bounds%begg:bounds%endg) ! the first patch in this gridcell that is soil and thus bare... associate(& - hr => soilbiogeochem_carbonflux_inst%hr_col, & ! Output: (gC/m2/s) total heterotrophic respiration + hr => soilbiogeochem_carbonflux_inst%hr_col, & ! (gC/m2/s) total heterotrophic respiration + totsomc => soilbiogeochem_carbonstate_inst%totsomc_col, & ! (gC/m2) total soil organic matter carbon + totlitc => soilbiogeochem_carbonstate_inst%totlitc_col, & ! (gC/m2) total litter carbon in BGC pools npp_hifreq => this%npp_hifreq_col, & nep => this%nep_col, & fire_c_to_atm => this%fire_c_to_atm_col, & - nbp => this%nbp_col & + nbp => this%nbp_col, & + totecosysc => this%totecosysc_col, & + biomass_stock => this%biomass_stock_col, & ! total biomass in gC / m2 + ed_litter_stock => this%ed_litter_stock_col, & ! ED litter in gC / m2 + cwd_stock => this%cwd_stock_col, & ! total CWD in gC / m2 + seed_stock => this%seed_stock_col & ! total seed mass in gC / m2 ) ! set time steps dt = real( get_step_size(), r8 ) - ! zero npp first + ! zero variables first do c = bounds%begc,bounds%endc + ! summary flux variables npp_hifreq(c) = 0._r8 fire_c_to_atm(c) = 0._r8 + + ! summary stock variables + ed_litter_stock(c) = 0._r8 + cwd_stock(c) = 0._r8 + seed_stock(c) = 0._r8 + biomass_stock(c) = 0._r8 end do ! retrieve the first soil patch associated with each gridcell. @@ -2277,18 +2349,31 @@ subroutine Summary(this, bounds, num_soilc, filter_soilc, num_soilp, filter_soil do g = bounds%begg,bounds%endg if (firstsoilpatch(g) >= 0 .and. ed_allsites_inst(g)%istheresoil) then - ! first map ed site-level fire fluxes to clm column fluxes cc = ed_allsites_inst(g)%clmcolumn + + ! map ed site-level fire fluxes to clm column fluxes fire_c_to_atm(cc) = ed_allsites_inst(g)%total_burn_flux_to_atm / ( AREA * SHR_CONST_CDAY * 1.e3_r8) - - ! second map ed cohort-level npp fluxes to clm column fluxes + currentPatch => ed_allsites_inst(g)%oldest_patch do while(associated(currentPatch)) - cs => currentPatch%siteptr - cc = cs%clmcolumn + + ! map litter, CWD, and seed pools to column level + cwd_stock(cc) = cwd_stock(cc) + (currentPatch%area / AREA) * (sum(currentPatch%cwd_ag)+ & + sum(currentPatch%cwd_bg) + ed_litter_stock(cc) = ed_litter_stock(cc) + (currentPatch%area / AREA) * & + (sum(currentPatch%leaf_litter)+sum(currentPatch%root_litter)) + seed_stock(cc) = seed_stock(cc) + (currentPatch%area / AREA) * sum(currentPatch%seed_bank) + currentCohort => currentPatch%tallest do while(associated(currentCohort)) + + ! map ed cohort-level npp fluxes to clm column fluxes npp_hifreq(cc) = npp_hifreq(cc) + currentCohort%npp_clm * 1e3 * currentCohort%n / ( AREA * dt) + + ! map biomass pools to column level + biomass_stock(cc) = biomass_stock(cc) + (currentCohort%bdead + currentCohort%balive + & + currentCohort%bstore) * currentCohort%n / AREA + currentCohort => currentCohort%shorter enddo !currentCohort currentPatch => currentPatch%younger @@ -2303,9 +2388,101 @@ subroutine Summary(this, bounds, num_soilc, filter_soilc, num_soilp, filter_soil nbp(c) = npp_hifreq(c) - ( hr(c) + fire_c_to_atm(c) ) end do + ! calculate total stocks + do fc = 1,num_soilc + c = filter_soilc(fc) + + totecosysc(c) = totsomc(c) + totlitc(c) + & ! BGC stocks + ed_litter_stock(c) + cwd_stock(c) + seed_stock(c) + biomass_stock(c) ! ED stocks + end do + end associate end subroutine Summary - + + + subroutine ED_BGC_Carbon_Balancecheck(this, bounds, num_soilc, filter_soilc, & + ed_allsites_inst) + + ! Integrate in time the fluxes into and out of the ecosystem, and compare these on a daily timestep + ! to the chagne in carbon stocks of the ecosystem + ! + ! Written by Charlie Koven, Feb 2016 + ! + ! !USES: + use clm_time_manager , only : is_beg_curr_day, get_step_size, get_nstep + ! + implicit none + ! + ! !ARGUMENTS + class(ed_clm_type) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + ! + ! !LOCAL VARIABLES: + real(r8) :: dtime ! land model time step (sec) + real(r8) :: nstep ! model timestep + real(r8) :: nbp_integrated(bounds%begc:bounds%endc) ! total net biome production integrated + real(r8) :: error_tolerance = 1.e-6_r8 + + associate(& + nep => this%nep_col, & + nep_timeintegrated => this%nep_timeintegrated_col, & + fire_c_to_atm => this%fire_c_to_atm_col, & + totecosysc_old => this%totecosysc_old_col, & + totecosysc => this%totecosysc_col & + ) + + dtime = get_step_size() + nstep = get_nstep() + + if (nstep .eq. 1) then + ! when starting up the model, initialize the integrator variables + do fc = 1,num_soilc + c = filter_soilc(fc) + totecosysc_old(c) = totecosysc(c) + nep_timeintegrated(c) = 0._r8 + end do + endif + + if ( .not. is_beg_curr_day() ) then + ! on CLM (half-hourly) timesteps, integrate the NEP fluxes + do fc = 1,num_soilc + c = filter_soilc(fc) + nep_timeintegrated(c) = nep_timeintegrated(c) + nep(c) * dtime + end do + else + ! on ED (daily) timesteps, first integrate the NEP fluxes and add in the daily disturbance flux + do fc = 1,num_soilc + c = filter_soilc(fc) + nep_timeintegrated(c) = nep_timeintegrated(c) + nep(c) * dtime + nbp_integrated(c) = nep_timeintegrated(c) + fire_c_to_atm(c) * SHR_CONST_CDAY + end do + + ! next compare the change in carbon and calculate the error + do fc = 1,num_soilc + c = filter_soilc(fc) + error(c) = totecosysc_old(c) - totecosysc(c) - nbp_integrated(c) + end do + + ! for now, rather than crashing the model, lets just report the largest error to see what we're up against + ! + ! RETURN TO THIS LATER AND ADD A CRASHER IF BALANCE EXCEEDS THRESHOLD + ! + write(iulog,*) 'ED_BGC_Carbon_Balancecheck: max carbon balance error (gC / m2 / day): ', max(abs(error(:))) + + ! reset the C stock and flux integrators + do fc = 1,num_soilc + c = filter_soilc(fc) + totecosysc_old(c) = totecosysc(c) + nep_timeintegrated(c) = 0._r8 + end do + + endif + + end associate + + end subroutine ED_BGC_Carbon_Balancecheck end module EDCLMLinkMod From 0d7d6ddb1af695c3b4ffebb02e20bee485503a63 Mon Sep 17 00:00:00 2001 From: rgknox Date: Mon, 29 Feb 2016 14:45:41 -0800 Subject: [PATCH 038/437] commented out calls to new sensitivity analysis parameters b_mort and dbh2h_m, will be used in later commits --- biogeochem/EDGrowthFunctionsMod.F90 | 6 ++++-- main/EDPftvarcon.F90 | 7 ++++--- 2 files changed, 8 insertions(+), 5 deletions(-) diff --git a/biogeochem/EDGrowthFunctionsMod.F90 b/biogeochem/EDGrowthFunctionsMod.F90 index f7b5706e..ea3dc4c7 100755 --- a/biogeochem/EDGrowthFunctionsMod.F90 +++ b/biogeochem/EDGrowthFunctionsMod.F90 @@ -350,8 +350,10 @@ subroutine mortality_rates( cohort_in,cmort,hmort,bmort ) real(r8) :: frac ! relativised stored carbohydrate ! 'Background' mortality (can vary as a function of density as in ED1.0 and ED2.0, but doesn't here for tractability) - bmort = EDecophyscon%b_mort(cohort_in%pft) !0.014_r8 - + ! bmort = EDecophyscon%b_mort(cohort_in%pft) !0.014_r8 + ! RGK:/CX HOLDING OFF ON SENS-ANALYSIS UNTIL MACHINE CONFIGS SQUARED AWAY + bmort = 0.014_r8 + ! Proxy for hydraulic failure induced mortality. if(cohort_in%patchptr%btran_ft(cohort_in%pft) <= 0.000001_r8)then hmort = ED_val_stress_mort diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index fa80e189..475ee7b1 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -132,9 +132,10 @@ subroutine EDpftconrd( ncid ) 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') - - call ncd_io('dbh2h_m',EDPftvarcon_inst%dbh2h_m, 'read', ncid, readvar=readv) - if ( .not. readv) call endrun(trim(subname)// ' ERROR : error in reading in pft data') + +! HOLDING ON SEW ENSITIVITY-ANALYSIS PARAMETERS UNTIL MACHINE CONFIGS SET RGK/CX +! call ncd_io('dbh2h_m',EDPftvarcon_inst%dbh2h_m, 'read', ncid, readvar=readv) +! if ( .not. readv) call endrun(trim(subname)// ' ERROR : error in reading in pft data') end subroutine EDpftconrd From c2aa9c26b8293100941bf9b35ec1ca318763f4f4 Mon Sep 17 00:00:00 2001 From: ckoven Date: Mon, 29 Feb 2016 15:05:40 -0800 Subject: [PATCH 039/437] compile bugfixes. still crashing in some tests though --- biogeochem/EDBGCDynMod.F90 | 3 +-- main/EDCLMLinkMod.F90 | 22 ++++++++++++++++------ 2 files changed, 17 insertions(+), 8 deletions(-) diff --git a/biogeochem/EDBGCDynMod.F90 b/biogeochem/EDBGCDynMod.F90 index 05443a48..9a590305 100644 --- a/biogeochem/EDBGCDynMod.F90 +++ b/biogeochem/EDBGCDynMod.F90 @@ -363,8 +363,7 @@ subroutine EDBGCDynSummary(bounds, num_soilc, filter_soilc, num_soilp, filter_so ! calculate balance checks on entire carbon cycle (ED + BGC) ! ---------------------------------------------- - call ed_clm_inst%ED_BGC_Carbon_Balancecheck(bounds, num_soilc, filter_soilc, & - ed_allsites_inst(bounds%begg:bounds%endg)) + call ed_clm_inst%ED_BGC_Carbon_Balancecheck(bounds, num_soilc, filter_soilc) call t_stopf('BGCsum') diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 3abd5ef3..3de0c816 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -150,7 +150,6 @@ module EDCLMLinkMod procedure , public :: ed_clm_link procedure , public :: Summary procedure , public :: ED_BGC_Carbon_Balancecheck - procedure , public :: Summary ! Private routines procedure , private :: ed_clm_leaf_area_profile @@ -1956,12 +1955,13 @@ subroutine flux_into_litter_pools(this, bounds, ed_allsites_inst, firstsoilpatch use EDTypesMod, only : AREA, numpft_ed use SoilBiogeochemVerticalProfileMod, only: exponential_rooting_profile, pftspecific_rootingprofile, rootprof_exp, surfprof_exp use pftconMod, only : pftcon - use shr_const_mod, only: SHR_CONST_CDAY + use clm_varcon, only : zisoi, dzsoi_decomp, zsoi use ColumnType , only : col use abortutils , only : endrun use shr_log_mod , only : errMsg => shr_log_errMsg use EDParamsMod, only : ED_val_ag_biomass + use shr_const_mod, only: SHR_CONST_CDAY ! implicit none ! @@ -2359,7 +2359,7 @@ subroutine Summary(this, bounds, num_soilc, filter_soilc, & ! map litter, CWD, and seed pools to column level cwd_stock(cc) = cwd_stock(cc) + (currentPatch%area / AREA) * (sum(currentPatch%cwd_ag)+ & - sum(currentPatch%cwd_bg) + sum(currentPatch%cwd_bg)) ed_litter_stock(cc) = ed_litter_stock(cc) + (currentPatch%area / AREA) * & (sum(currentPatch%leaf_litter)+sum(currentPatch%root_litter)) seed_stock(cc) = seed_stock(cc) + (currentPatch%area / AREA) * sum(currentPatch%seed_bank) @@ -2401,8 +2401,7 @@ subroutine Summary(this, bounds, num_soilc, filter_soilc, & end subroutine Summary - subroutine ED_BGC_Carbon_Balancecheck(this, bounds, num_soilc, filter_soilc, & - ed_allsites_inst) + subroutine ED_BGC_Carbon_Balancecheck(this, bounds, num_soilc, filter_soilc) ! Integrate in time the fluxes into and out of the ecosystem, and compare these on a daily timestep ! to the chagne in carbon stocks of the ecosystem @@ -2411,6 +2410,7 @@ subroutine ED_BGC_Carbon_Balancecheck(this, bounds, num_soilc, filter_soilc, & ! ! !USES: use clm_time_manager , only : is_beg_curr_day, get_step_size, get_nstep + use shr_const_mod, only: SHR_CONST_CDAY ! implicit none ! @@ -2424,7 +2424,10 @@ subroutine ED_BGC_Carbon_Balancecheck(this, bounds, num_soilc, filter_soilc, & real(r8) :: dtime ! land model time step (sec) real(r8) :: nstep ! model timestep real(r8) :: nbp_integrated(bounds%begc:bounds%endc) ! total net biome production integrated + real(r8) :: error(bounds%begc:bounds%endc) real(r8) :: error_tolerance = 1.e-6_r8 + real(r8) :: max_error + integer :: fc,c associate(& nep => this%nep_col, & @@ -2470,7 +2473,14 @@ subroutine ED_BGC_Carbon_Balancecheck(this, bounds, num_soilc, filter_soilc, & ! ! RETURN TO THIS LATER AND ADD A CRASHER IF BALANCE EXCEEDS THRESHOLD ! - write(iulog,*) 'ED_BGC_Carbon_Balancecheck: max carbon balance error (gC / m2 / day): ', max(abs(error(:))) + max_error = 0._r8 + do fc = 1,num_soilc + c = filter_soilc(fc) + if (abs(error(c)) .gt. max_error) then + max_error = abs(error(c)) + endif + end do + write(iulog,*) 'ED_BGC_Carbon_Balancecheck: max carbon balance error (gC / m2 / day): ', max_error ! reset the C stock and flux integrators do fc = 1,num_soilc From 2077d7ff00d1aa7d9028b2a1193374a571d756a4 Mon Sep 17 00:00:00 2001 From: ckoven Date: Mon, 29 Feb 2016 16:48:29 -0800 Subject: [PATCH 040/437] runtime bugfix --- main/EDCLMLinkMod.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 3de0c816..4fc885c3 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -2422,7 +2422,7 @@ subroutine ED_BGC_Carbon_Balancecheck(this, bounds, num_soilc, filter_soilc) ! ! !LOCAL VARIABLES: real(r8) :: dtime ! land model time step (sec) - real(r8) :: nstep ! model timestep + integer :: nstep ! model timestep real(r8) :: nbp_integrated(bounds%begc:bounds%endc) ! total net biome production integrated real(r8) :: error(bounds%begc:bounds%endc) real(r8) :: error_tolerance = 1.e-6_r8 @@ -2440,13 +2440,13 @@ subroutine ED_BGC_Carbon_Balancecheck(this, bounds, num_soilc, filter_soilc) dtime = get_step_size() nstep = get_nstep() - if (nstep .eq. 1) then + if (nstep .le. 1) then ! when starting up the model, initialize the integrator variables do fc = 1,num_soilc c = filter_soilc(fc) totecosysc_old(c) = totecosysc(c) nep_timeintegrated(c) = 0._r8 - end do + end do endif if ( .not. is_beg_curr_day() ) then From abb443e3d4b332a3da947fd3b1b041b999d4dfc8 Mon Sep 17 00:00:00 2001 From: rgknox Date: Mon, 29 Feb 2016 18:00:06 -0800 Subject: [PATCH 041/437] added a call to update current time prior to eds gdd accumulator in the main model loop --- biogeochem/EDPhenologyType.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/biogeochem/EDPhenologyType.F90 b/biogeochem/EDPhenologyType.F90 index 6924b2d3..ea49fb44 100644 --- a/biogeochem/EDPhenologyType.F90 +++ b/biogeochem/EDPhenologyType.F90 @@ -131,7 +131,7 @@ subroutine accumulateAndExtract( this, bounds, & ! Accumulate and extract GDD0 for ED do p = bounds%begp,bounds%endp - + g = gridcell(p) if (latdeg(g) >= 0._r8) then @@ -143,8 +143,8 @@ subroutine accumulateAndExtract( this, bounds, & ! 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) = accumResetVal ! reset ED_GDD0 + else rbufslp(p) = max(0._r8, min(this%checkRefVal, t_ref2m_patch(p)-SHR_CONST_TKFRZ)) & * get_step_size()/SHR_CONST_CDAY end if From d87b9e90358cb3eaaebc63a3b5fb275666f11eaa Mon Sep 17 00:00:00 2001 From: rgknox Date: Mon, 29 Feb 2016 22:52:09 -0800 Subject: [PATCH 042/437] fixed call order of mon,day,sec between clm_driv and accumulateandExtract --- biogeochem/EDPhenologyType.F90 | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/biogeochem/EDPhenologyType.F90 b/biogeochem/EDPhenologyType.F90 index ea49fb44..d38923d7 100644 --- a/biogeochem/EDPhenologyType.F90 +++ b/biogeochem/EDPhenologyType.F90 @@ -93,7 +93,7 @@ end subroutine restart subroutine accumulateAndExtract( this, bounds, & t_ref2m_patch, & gridcell, latdeg, & - day, month, secs ) + month, day, secs ) ! ! start formal argument list -- ! group formal (dummy) arguments by use/similarity @@ -165,6 +165,8 @@ subroutine accumulateAndExtract( this, bounds, & call update_accum_field ( trim(this%accString), rbufslp, get_nstep() ) call extract_accum_field ( trim(this%accString), this%ED_GDD_patch, get_nstep() ) + if (this%DEBUG) write(iulog,*) 'MM-DD-SSSS',month,'-',day,'-',secs + if (this%DEBUG) write(iulog,*) 'cd_status:',this%phen_cd_status_patch(:) if (this%DEBUG) write(iulog,*) 'ED_GDD accumAndExtract ', this%ED_GDD_patch deallocate(rbufslp) From 0e73caa72813a78aac199ff7043f1dd579da5c7c Mon Sep 17 00:00:00 2001 From: ckoven Date: Wed, 2 Mar 2016 15:15:44 -0800 Subject: [PATCH 043/437] runtime bugfix to prevent history file crashes on bgc profiles --- main/EDCLMLinkMod.F90 | 22 +++++++++++++++++++--- 1 file changed, 19 insertions(+), 3 deletions(-) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 4fc885c3..e3c8f64c 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -551,26 +551,32 @@ subroutine InitHistory(this, bounds) ptr_col=this%seed_stock_col) !!! carbon fluxes into soil grid (dimensioned depth x column) + this%ED_c_to_litr_lab_c_col(begc:endc,1:nlevdecomp_full) = spval call hist_addfld_decomp (fname='ED_c_to_litr_lab_c', units='gC/m^2/s', type2d='levdcmp', & avgflag='A', long_name='ED_c_to_litr_lab_c', & ptr_col=this%ED_c_to_litr_lab_c_col) + this%ED_c_to_litr_cel_c_col(begc:endc,1:nlevdecomp_full) = spval call hist_addfld_decomp (fname='ED_c_to_litr_cel_c', units='gC/m^2/s', type2d='levdcmp', & avgflag='A', long_name='ED_c_to_litr_cel_c', & ptr_col=this%ED_c_to_litr_cel_c_col) + this%ED_c_to_litr_lig_c_col(begc:endc,1:nlevdecomp_full) = spval call hist_addfld_decomp (fname='ED_c_to_litr_lig_c', units='gC/m^2/s', type2d='levdcmp', & avgflag='A', long_name='ED_c_to_litr_lig_c', & ptr_col=this%ED_c_to_litr_lig_c_col) + this%leaf_prof_col(begc:endc,1:nlevdecomp_full) = spval call hist_addfld_decomp (fname='leaf_prof', units='1/m', type2d='levdcmp', & avgflag='A', long_name='leaf_prof', & ptr_col=this%leaf_prof_col,default='inactive') + this%croot_prof_col(begc:endc,1:nlevdecomp_full) = spval call hist_addfld_decomp (fname='croot_prof', units='1/m', type2d='levdcmp', & avgflag='A', long_name='croot_prof', & ptr_col=this%croot_prof_col,default='inactive') + this%stem_prof_col(begc:endc,1:nlevdecomp_full) = spval call hist_addfld_decomp (fname='stem_prof', units='1/m', type2d='levdcmp', & avgflag='A', long_name='stem_prof', & ptr_col=this%stem_prof_col,default='inactive') @@ -2094,7 +2100,7 @@ subroutine flux_into_litter_pools(this, bounds, ed_allsites_inst, firstsoilpatch end do else ! if fully frozen, or no roots, put everything in the top layer - froot_prof(c,ft,1) = 1./dzsoi_decomp(1) + froot_prof(c,ft,1) = 1._r8/dzsoi_decomp(1) endif end do ! @@ -2109,8 +2115,12 @@ subroutine flux_into_litter_pools(this, bounds, ed_allsites_inst, firstsoilpatch end do else ! if fully frozen, or no roots, put everything in the top layer - leaf_prof(c,1) = 1./dzsoi_decomp(1) - stem_prof(c,1) = 1./dzsoi_decomp(1) + leaf_prof(c,1) = 1._r8/dzsoi_decomp(1) + stem_prof(c,1) = 1._r8/dzsoi_decomp(1) + do j = 2, nlevdecomp + leaf_prof(c,j) = 0._r8 + stem_prof(c,j) = 0._r8 + end do endif end do @@ -2266,6 +2276,12 @@ subroutine flux_into_litter_pools(this, bounds, ed_allsites_inst, firstsoilpatch ! write(iulog,*)'cdk ED_c_to_litr_lab_c: ', ED_c_to_litr_lab_c ! write(iulog,*)'cdk ED_c_to_litr_cel_c: ', ED_c_to_litr_cel_c ! write(iulog,*)'cdk ED_c_to_litr_lig_c: ', ED_c_to_litr_lig_c + ! write(iulog,*)'cdk nlevdecomp_full, bounds%begc, bounds%endc: ', nlevdecomp_full, bounds%begc, bounds%endc + ! write(iulog,*)'cdk leaf_prof: ', leaf_prof + ! write(iulog,*)'cdk stem_prof: ', stem_prof + ! write(iulog,*)'cdk froot_prof: ', froot_prof + ! write(iulog,*)'cdk croot_prof_perpatch: ', croot_prof_perpatch + ! write(iulog,*)'cdk croot_prof: ', croot_prof end associate end subroutine flux_into_litter_pools From 02dacef7b61c8f6b5427b8f134541f0f80e1f6c5 Mon Sep 17 00:00:00 2001 From: rgknox Date: Thu, 3 Mar 2016 23:20:05 -0800 Subject: [PATCH 044/437] test: filtering-out recruits with small number densities to avoid fusion problems --- biogeochem/EDCohortDynamicsMod.F90 | 25 ++++++++++++++++++++++--- biogeochem/EDPhysiologyMod.F90 | 8 ++++++-- 2 files changed, 28 insertions(+), 5 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index d921e425..0c331bd3 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -31,6 +31,10 @@ module EDCohortDynamicsMod logical, parameter :: DEBUG = .false. ! local debug flag + real(r8), parameter :: npha_term = 1.0d-2 ! minimum number density per hectare + real(r8), parameter :: npm2_term = 1.0d-6 ! minimum number density per m2 + + ! 10/30/09: Created by Rosie Fisher !-------------------------------------------------------------------------------------! @@ -489,8 +493,9 @@ subroutine terminate_cohorts( patchptr ) 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 + if (currentCohort%n/currentPatch%area <= npm2_term .or. & ! since area is < 10k, this will never trigger? + currentCohort%n <= npha_term .or. & + (currentCohort%dbh < 0.00001_r8.and.currentCohort%bstore < 0._r8) ) then terminate = 1 if ( DEBUG ) then @@ -644,8 +649,22 @@ subroutine fuse_cohorts(patchptr) if( (.not.(currentCohort%isnew) .and. .not.(nextc%isnew) ) .or. & ( currentCohort%isnew .and. nextc%isnew ) ) then + newn = currentCohort%n + nextc%n + if ( newn < npha_term ) then + ! This is the rare case where the combined number + ! density of both cohorts is so small, and we + ! have not terminated them yet, that they could + ! generate div0s. + write(iulog,*) 'Somehow a small number density is present during' + write(iulog,*) 'cohort fusion. A call to termination should had' + write(iulog,*) 'preceded this to filter out plants with low enough' + write(iulog,*) 'number densities to make them irrelevant' + stop ! TO DO: add our own error handling and ED logs + end if + + 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 diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index b949c5fd..093f4f04 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -14,7 +14,9 @@ module EDPhysiologyMod 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 EDCohortDynamicsMod , only : allocate_live_biomass, zero_cohort + use EDCohortDynamicsMod , only : create_cohort, fuse_cohorts, sort_cohorts + use EDCohortDynamicsMod , only : npha_term 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 @@ -1016,7 +1018,9 @@ subroutine recruitment( t, currentPatch ) cohortstatus = currentPatch%siteptr%dstatus endif - if (temp_cohort%n > 0.0_r8)then + ! Temporary Solution, if we terminate a cohort, we should still + ! still send the carbon into the soil pool + if (temp_cohort%n >= npha_term )then if ( DEBUG ) write(iulog,*) 'EDPhysiologyMod.F90 call create_cohort ' From 9309eb7b5c647eba1554b8c6ff5d4a499b906fa8 Mon Sep 17 00:00:00 2001 From: rgknox Date: Fri, 4 Mar 2016 11:53:54 -0800 Subject: [PATCH 045/437] tweaked thresholds on number density and removing redundant fusion call to avoid fpes --- biogeochem/EDCohortDynamicsMod.F90 | 9 +++------ biogeochem/EDPatchDynamicsMod.F90 | 4 +++- biogeochem/EDPhysiologyMod.F90 | 26 +++++++++++++------------- main/EDTypesMod.F90 | 5 +++++ 4 files changed, 24 insertions(+), 20 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 0c331bd3..163962f0 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -13,6 +13,7 @@ module EDCohortDynamicsMod use EDTypesMod , only : fusetol, nclmax use EDtypesMod , only : ncwd, numcohortsperpatch, udata use EDtypesMod , only : sclass_ed,nlevsclass_ed,AREA + use EDtypesMod , only : min_npm2, min_nppatch ! implicit none private @@ -31,10 +32,6 @@ module EDCohortDynamicsMod logical, parameter :: DEBUG = .false. ! local debug flag - real(r8), parameter :: npha_term = 1.0d-2 ! minimum number density per hectare - real(r8), parameter :: npm2_term = 1.0d-6 ! minimum number density per m2 - - ! 10/30/09: Created by Rosie Fisher !-------------------------------------------------------------------------------------! @@ -493,8 +490,8 @@ subroutine terminate_cohorts( patchptr ) terminate = 0 ! Not enough n or dbh - if (currentCohort%n/currentPatch%area <= npm2_term .or. & ! since area is < 10k, this will never trigger? - currentCohort%n <= npha_term .or. & + if (currentCohort%n/currentPatch%area <= min_npm2 .or. & ! + currentCohort%n <= min_nppatch .or. & (currentCohort%dbh < 0.00001_r8.and.currentCohort%bstore < 0._r8) ) then terminate = 1 diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 780beee0..5bfdf1c7 100755 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -11,6 +11,7 @@ module EDPatchDynamicsMod use EDCohortDynamicsMod , only : fuse_cohorts, sort_cohorts, insert_cohort use EDtypesMod , only : ncwd, n_dbh_bins, ntol, numpft_ed, area, dbhmax, numPatchesPerGridCell use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type, udata + use EDTypesMod , only : min_patch_area ! implicit none private @@ -27,6 +28,7 @@ module EDPatchDynamicsMod private:: fuse_2_patches + ! 10/30/09: Created by Rosie Fisher ! ============================================================================ @@ -1285,7 +1287,7 @@ subroutine terminate_patches(cs_pnt) !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(currentPatch%area <= min_patch_area)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. diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 093f4f04..7811d7c7 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1018,24 +1018,24 @@ subroutine recruitment( t, currentPatch ) cohortstatus = currentPatch%siteptr%dstatus endif - ! Temporary Solution, if we terminate a cohort, we should still - ! still send the carbon into the soil pool - if (temp_cohort%n >= npha_term )then - - if ( DEBUG ) write(iulog,*) 'EDPhysiologyMod.F90 call create_cohort ' - - 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 +! ! Temporary Solution, if we terminate a cohort, we should still +! ! still send the carbon into the soil pool +! if (temp_cohort%n >= npha_term )then +! +! if ( DEBUG ) write(iulog,*) 'EDPhysiologyMod.F90 call create_cohort ' +! +! 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) +! call fuse_cohorts(currentPatch) +! call sort_cohorts(currentPatch) end subroutine recruitment diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index ab816a9d..16786480 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -65,6 +65,11 @@ module EDTypesMod 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 + + real(r8), parameter :: min_npm2 = 1.0d-5 ! minimum cohort number density per m2 before termination + real(r8), parameter :: min_patch_area = 0.001_r8 ! smallest allowable patch area before termination + real(r8), parameter :: min_nppatch = 1.0d-8 ! minimum number of cohorts per patch (min_npm2*min_patch_area) + character*4 yearchar !the lower limit of the size classes of ED cohorts From 700d19b80aef4537ded83cf7ee6afb8f01e9f13b Mon Sep 17 00:00:00 2001 From: rgknox Date: Fri, 4 Mar 2016 12:28:08 -0800 Subject: [PATCH 046/437] removed uneccesary number density check (cleanup) --- biogeochem/EDCohortDynamicsMod.F90 | 13 ------------- biogeochem/EDPhysiologyMod.F90 | 1 - 2 files changed, 14 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 163962f0..d5a89956 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -647,19 +647,6 @@ subroutine fuse_cohorts(patchptr) ( currentCohort%isnew .and. nextc%isnew ) ) then newn = currentCohort%n + nextc%n - if ( newn < npha_term ) then - ! This is the rare case where the combined number - ! density of both cohorts is so small, and we - ! have not terminated them yet, that they could - ! generate div0s. - write(iulog,*) 'Somehow a small number density is present during' - write(iulog,*) 'cohort fusion. A call to termination should had' - write(iulog,*) 'preceded this to filter out plants with low enough' - write(iulog,*) 'number densities to make them irrelevant' - stop ! TO DO: add our own error handling and ED logs - end if - - fusion_took_place = 1 diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 7811d7c7..9541f99c 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -16,7 +16,6 @@ module EDPhysiologyMod use EDEcophysContype , only : EDecophyscon use EDCohortDynamicsMod , only : allocate_live_biomass, zero_cohort use EDCohortDynamicsMod , only : create_cohort, fuse_cohorts, sort_cohorts - use EDCohortDynamicsMod , only : npha_term 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 From 82115aee47a0ce9fc4f5ce5b65e035db237ca220 Mon Sep 17 00:00:00 2001 From: rgknox Date: Fri, 4 Mar 2016 13:23:45 -0800 Subject: [PATCH 047/437] tests passed, removing commented changes --- biogeochem/EDPhysiologyMod.F90 | 15 --------------- 1 file changed, 15 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 82449cd8..d98559d0 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1017,25 +1017,10 @@ subroutine recruitment( t, currentPatch ) cohortstatus = currentPatch%siteptr%dstatus endif -! ! Temporary Solution, if we terminate a cohort, we should still -! ! still send the carbon into the soil pool -! if (temp_cohort%n >= npha_term )then -! -! if ( DEBUG ) write(iulog,*) 'EDPhysiologyMod.F90 call create_cohort ' -! -! 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 ! ============================================================================ From a3a9692acda43d7dfad14743cc05037c7c4f88c7 Mon Sep 17 00:00:00 2001 From: rgknox Date: Fri, 4 Mar 2016 15:52:50 -0800 Subject: [PATCH 048/437] changed termination logic: added a safemath minimum cohort threshold that is also applied to new recruits, and changed the order of termination calls as per discussion in PR --- biogeochem/EDCanopyStructureMod.F90 | 1 - biogeochem/EDCohortDynamicsMod.F90 | 83 ++++++++++++++++------------- biogeochem/EDPhysiologyMod.F90 | 8 +++ main/EDMainMod.F90 | 7 +-- main/EDTypesMod.F90 | 3 ++ 5 files changed, 60 insertions(+), 42 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 133639fc..9323ac0f 100755 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1,4 +1,3 @@ - module EDCanopyStructureMod ! ============================================================================ diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index d5a89956..288c8c9d 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -13,7 +13,7 @@ module EDCohortDynamicsMod use EDTypesMod , only : fusetol, nclmax use EDtypesMod , only : ncwd, numcohortsperpatch, udata use EDtypesMod , only : sclass_ed,nlevsclass_ed,AREA - use EDtypesMod , only : min_npm2, min_nppatch + use EDtypesMod , only : min_npm2, min_nppatch, min_n_safemath ! implicit none private @@ -489,48 +489,55 @@ subroutine terminate_cohorts( patchptr ) nextc => currentCohort%shorter terminate = 0 - ! Not enough n or dbh - if (currentCohort%n/currentPatch%area <= min_npm2 .or. & ! - currentCohort%n <= min_nppatch .or. & - (currentCohort%dbh < 0.00001_r8.and.currentCohort%bstore < 0._r8) ) then - terminate = 1 - - if ( DEBUG ) then - write(iulog,*) 'terminating cohorts 1',currentCohort%n/currentPatch%area,currentCohort%dbh - endif - - endif - - ! In the third canopy layer - if (currentCohort%canopy_layer > NCLMAX) then - terminate = 1 - - if ( DEBUG ) then - write(iulog,*) 'terminating cohorts 2', currentCohort%canopy_layer - endif - + ! Check if number density is so low is breaks math + if (currentcohort%n < min_n_safemath) then + terminate = 1 + if ( DEBUG ) then + write(iulog,*) 'terminating cohorts 0',currentCohort%n/currentPatch%area,currentCohort%dbh + endif endif - ! live biomass pools are terminally depleted - if (currentCohort%balive < 1e-10_r8 .or. currentCohort%bstore < 1e-10_r8) then - terminate = 1 - - if ( DEBUG ) then - write(iulog,*) 'terminating cohorts 3', currentCohort%balive,currentCohort%bstore - endif - - endif - - ! Total cohort biomass is negative - if (currentCohort%balive+currentCohort%bdead+currentCohort%bstore < 0._r8) then - terminate = 1 - - if ( DEBUG ) then - write(iulog,*) 'terminating cohorts 4', currentCohort%balive, currentCohort%bstore, currentCohort%bdead, & + ! The rest of these are only allowed if we are not dealing with a recruit + if (.not.currentCohort%isnew) then + + ! Not enough n or dbh + if (currentCohort%n/currentPatch%area <= min_npm2 .or. & ! + currentCohort%n <= min_nppatch .or. & + (currentCohort%dbh < 0.00001_r8.and.currentCohort%bstore < 0._r8) ) then + terminate = 1 + + if ( DEBUG ) then + write(iulog,*) 'terminating cohorts 1',currentCohort%n/currentPatch%area,currentCohort%dbh + endif + endif + + ! In the third canopy layer + if (currentCohort%canopy_layer > NCLMAX) then + terminate = 1 + if ( DEBUG ) then + write(iulog,*) 'terminating cohorts 2', currentCohort%canopy_layer + endif + endif + + ! live biomass pools are terminally depleted + if (currentCohort%balive < 1e-10_r8 .or. currentCohort%bstore < 1e-10_r8) then + terminate = 1 + if ( DEBUG ) then + write(iulog,*) 'terminating cohorts 3', currentCohort%balive,currentCohort%bstore + endif + endif + + ! Total cohort biomass is negative + if (currentCohort%balive+currentCohort%bdead+currentCohort%bstore < 0._r8) then + terminate = 1 + if ( DEBUG ) then + write(iulog,*) 'terminating cohorts 4', currentCohort%balive, & + currentCohort%bstore, currentCohort%bdead, & currentCohort%balive+currentCohort%bdead+& currentCohort%bstore, currentCohort%n - endif + endif + endif endif if (terminate == 1) then diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index d98559d0..526f9930 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1017,6 +1017,14 @@ subroutine recruitment( t, currentPatch ) cohortstatus = currentPatch%siteptr%dstatus endif + + if (temp_cohort%n >= 0.0_r8 )then + if ( DEBUG ) write(iulog,*) 'EDPhysiologyMod.F90 call create_cohort ' + 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 diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 17d132a8..c52c6330 100755 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -176,15 +176,16 @@ subroutine ed_ecosystem_dynamics(currentSite, & 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) + ! kills cohorts that are too small + call terminate_cohorts(currentPatch) + + currentPatch => currentPatch%younger enddo diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 16786480..2aedbc27 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -69,6 +69,9 @@ module EDTypesMod real(r8), parameter :: min_npm2 = 1.0d-5 ! minimum cohort number density per m2 before termination real(r8), parameter :: min_patch_area = 0.001_r8 ! smallest allowable patch area before termination real(r8), parameter :: min_nppatch = 1.0d-8 ! minimum number of cohorts per patch (min_npm2*min_patch_area) + real(r8), parameter :: min_n_safemath = 1.0d-15 ! in some cases, we want to immediately remove super small + ! number densities of cohorts to prevent FPEs, this is usually + ! just relevant in the first day after recruitment character*4 yearchar From 02368a26acc1540bd00996ae329ae37729db9552 Mon Sep 17 00:00:00 2001 From: ckoven Date: Fri, 4 Mar 2016 17:08:05 -0800 Subject: [PATCH 049/437] regularized the units of many of the history outputs to be consistent with the rest of CLM --- biogeochem/EDCohortDynamicsMod.F90 | 2 +- main/EDCLMLinkMod.F90 | 196 ++++++++++++++--------------- 2 files changed, 98 insertions(+), 100 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index d921e425..111a4a4d 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -723,7 +723,7 @@ subroutine fuse_cohorts(patchptr) nextc%n*nextc%year_net_uptake(i))/newn endif enddo - + currentCohort%n = newn !remove fused cohort from the list nextc%taller%shorter => nextnextc diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index e3c8f64c..4d44d8de 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -19,6 +19,7 @@ module EDCLMLinkMod use SoilBiogeochemCarbonFluxType , only : soilbiogeochem_carbonflux_type use SoilBiogeochemCarbonStatetype , only : soilbiogeochem_carbonstate_type use clm_time_manager , only : get_step_size + use shr_const_mod, only: SHR_CONST_CDAY ! implicit none @@ -76,14 +77,14 @@ module EDCLMLinkMod 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 :: 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 real(r8), pointer :: ed_gpp_gd_scpf (:,:) ! [kg/m2/yr] gross primary production @@ -156,7 +157,7 @@ module EDCLMLinkMod procedure , private :: ed_update_history_variables procedure , private :: InitAllocate procedure , private :: InitHistory - procedure , private :: InitCold +! procedure , private :: InitCold procedure , private :: flux_into_litter_pools end type ed_clm_type @@ -179,7 +180,7 @@ subroutine Init(this, bounds) call this%InitAllocate(bounds) call this%InitHistory(bounds) - call this%InitCold(bounds) + !call this%InitCold(bounds) end subroutine Init @@ -240,12 +241,12 @@ subroutine InitAllocate(this, bounds) 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%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 @@ -349,15 +350,15 @@ subroutine InitHistory(this, bounds) 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', & + call hist_addfld2d (fname='PFTbiomass', units='gC/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', & + call hist_addfld2d (fname='PFTleafbiomass', units='gC/m2', type2d='levgrnd', & avgflag='A', long_name='total PFT level leaf biomass', & ptr_patch=this%PFTleafbiomass_patch, set_lake=0._r8, set_urb=0._r8) - call hist_addfld2d (fname='PFTstorebiomass', units='kgC/m2', type2d='levgrnd', & + call hist_addfld2d (fname='PFTstorebiomass', units='gC/m2', type2d='levgrnd', & avgflag='A', long_name='total PFT level stored biomass', & ptr_patch=this%PFTstorebiomass_patch, set_lake=0._r8, set_urb=0._r8) @@ -409,55 +410,55 @@ subroutine InitHistory(this, bounds) 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='SUM_FUEL', units=' KgC m-2 y-1', & - avgflag='A', long_name='Litter flux in leaves', & + call hist_addfld1d (fname='SUM_FUEL', units='gC m-2', & + avgflag='A', long_name='total ground fuel related to ros (omits 1000hr fuels)', & 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', & + call hist_addfld1d (fname='LITTER_IN', units='gC m-2 s-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', & + call hist_addfld1d (fname='LITTER_OUT', units='gC m-2 s-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', & + call hist_addfld1d (fname='SEED_BANK', units='gC 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', & + call hist_addfld1d (fname='SEEDS_IN', units='gC m-2 s-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', & + call hist_addfld1d (fname='SEED_GERMINATION', units='gC m-2 s-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', & + call hist_addfld1d (fname='SEED_DECAY', units='gC m-2 s-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', & + call hist_addfld1d (fname='ED_bstore', units='gC 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', & + call hist_addfld1d (fname='ED_bdead', units='gC 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', & + call hist_addfld1d (fname='ED_balive', units='gC 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', & + call hist_addfld1d (fname='ED_bleaf', units='gC 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', & + call hist_addfld1d (fname='ED_biomass', units='gC 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', & + 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) @@ -465,35 +466,35 @@ subroutine InitHistory(this, bounds) 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%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%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%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%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%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%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', & @@ -656,26 +657,25 @@ subroutine InitHistory(this, bounds) 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 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 ) ! @@ -1342,16 +1342,16 @@ subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & write(iulog,*) 'EDCLMLinkMod II ',p,ED_bstore(p) 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 + ED_bleaf(p) = ED_bleaf(p) + n_density * currentCohort%bl * 1.e3_r8 + ED_bstore(p) = ED_bstore(p) + n_density * currentCohort%bstore * 1.e3_r8 + ED_biomass(p) = ED_biomass(p) + n_density * currentCohort%b * 1.e3_r8 + ED_bdead(p) = ED_bdead(p) + n_density * currentCohort%bdead * 1.e3_r8 + ED_balive(p) = ED_balive(p) + n_density * currentCohort%balive * 1.e3_r8 + npp(p) = npp(p) + n_density * currentCohort%npp * 1.e3_r8 / (365. * SHR_CONST_CDAY) + gpp(p) = gpp(p) + n_density * currentCohort%gpp * 1.e3_r8 / (365. * SHR_CONST_CDAY) + PFTbiomass(p,ft) = PFTbiomass(p,ft) + n_density * currentCohort%b * 1.e3_r8 + PFTleafbiomass(p,ft) = PFTleafbiomass(p,ft) + n_density * currentCohort%bl * 1.e3_r8 + PFTstorebiomass(p,ft) = PFTstorebiomass(p,ft) + n_density * currentCohort%bstore * 1.e3_r8 PFTnindivs(p,ft) = PFTnindivs(p,ft) + currentCohort%n dbh = currentCohort%dbh !-0.5*(1./365.25)*currentCohort%ddbhdt @@ -1426,13 +1426,13 @@ subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & 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) + sum_fuel(p) = currentPatch%sum_fuel * 1.e3_r8 + litter_in(p) = (sum(currentPatch%CWD_AG_in) +sum(currentPatch%leaf_litter_in)) * 1.e3_r8 * 365.0_r8 * SHR_CONST_CDAY + litter_out(p) = (sum(currentPatch%CWD_AG_out)+sum(currentPatch%leaf_litter_out)) * 1.e3_r8 * 365.0_r8 * SHR_CONST_CDAY + seed_bank(p) = sum(currentPatch%seed_bank) * 1.e3_r8 + seeds_in(p) = sum(currentPatch%seeds_in) * 1.e3_r8 * 365.0_r8 * SHR_CONST_CDAY + seed_decay(p) = sum(currentPatch%seed_decay) * 1.e3_r8 * 365.0_r8 * SHR_CONST_CDAY + seed_germination(p) = sum(currentPatch%seed_germination) * 1.e3_r8 * 365.0_r8 * SHR_CONST_CDAY canopy_spread(p) = currentPatch%spread(1) area_plant(p) = currentPatch%total_canopy_area /currentPatch%area area_trees(p) = currentPatch%total_tree_area /currentPatch%area @@ -1967,7 +1967,6 @@ subroutine flux_into_litter_pools(this, bounds, ed_allsites_inst, firstsoilpatch use abortutils , only : endrun use shr_log_mod , only : errMsg => shr_log_errMsg use EDParamsMod, only : ED_val_ag_biomass - use shr_const_mod, only: SHR_CONST_CDAY ! implicit none ! @@ -2299,7 +2298,6 @@ subroutine Summary(this, bounds, num_soilc, filter_soilc, & use ColumnType , only : col use LandunitType , only : lun use landunit_varcon , only : istsoil - use shr_const_mod, only: SHR_CONST_CDAY ! implicit none ! @@ -2375,10 +2373,10 @@ subroutine Summary(this, bounds, num_soilc, filter_soilc, & ! map litter, CWD, and seed pools to column level cwd_stock(cc) = cwd_stock(cc) + (currentPatch%area / AREA) * (sum(currentPatch%cwd_ag)+ & - sum(currentPatch%cwd_bg)) + sum(currentPatch%cwd_bg)) * 1.e3_r8 ed_litter_stock(cc) = ed_litter_stock(cc) + (currentPatch%area / AREA) * & - (sum(currentPatch%leaf_litter)+sum(currentPatch%root_litter)) - seed_stock(cc) = seed_stock(cc) + (currentPatch%area / AREA) * sum(currentPatch%seed_bank) + (sum(currentPatch%leaf_litter)+sum(currentPatch%root_litter)) * 1.e3_r8 + seed_stock(cc) = seed_stock(cc) + (currentPatch%area / AREA) * sum(currentPatch%seed_bank) * 1.e3_r8 currentCohort => currentPatch%tallest do while(associated(currentCohort)) @@ -2388,7 +2386,7 @@ subroutine Summary(this, bounds, num_soilc, filter_soilc, & ! map biomass pools to column level biomass_stock(cc) = biomass_stock(cc) + (currentCohort%bdead + currentCohort%balive + & - currentCohort%bstore) * currentCohort%n / AREA + currentCohort%bstore) * currentCohort%n * 1.e3_r8 / AREA currentCohort => currentCohort%shorter enddo !currentCohort From 2c3e52dbe0e32e49dd8dd93c2866251e74493e23 Mon Sep 17 00:00:00 2001 From: rgknox Date: Sat, 5 Mar 2016 12:00:10 -0800 Subject: [PATCH 050/437] fixed logical comparison operator in create_cohort, typo from prev commit --- biogeochem/EDPhysiologyMod.F90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 526f9930..8de0ecc9 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1017,8 +1017,7 @@ subroutine recruitment( t, currentPatch ) cohortstatus = currentPatch%siteptr%dstatus endif - - if (temp_cohort%n >= 0.0_r8 )then + if (temp_cohort%n > 0.0_r8 )then if ( DEBUG ) write(iulog,*) 'EDPhysiologyMod.F90 call create_cohort ' 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, & From 90ef9fbe90c3f2b2dc8941478ae1999b35e726b1 Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Mon, 7 Mar 2016 11:10:02 -0800 Subject: [PATCH 051/437] added term to take into acocunt time offset of reconciling ED and CLM litter fluxes for balance check purposes --- main/EDCLMLinkMod.F90 | 65 +++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 62 insertions(+), 3 deletions(-) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 4d44d8de..83d994de 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -133,6 +133,8 @@ module EDCLMLinkMod real(r8), pointer, public :: nbp_col(:) ! [gC/m2/s] Net biosphere production, i.e. slow-timescale carbon balance that integrates to total carbon change real(r8), pointer, public :: npp_hifreq_col(:) ! [gC/m2/s] Net primary production at the fast timescale, aggregated to the column level real(r8), pointer, public :: fire_c_to_atm_col(:) ! [gC/m2/s] total fire carbon loss to atmosphere + real(r8), pointer, public :: ed_to_bgc_this_edts_col(:) ! [gC/m2/s] total flux of carbon from ED to BGC models on current ED timestep + real(r8), pointer, public :: ed_to_bgc_last_edts_col(:) ! [gC/m2/s] total flux of carbon from ED to BGC models on prior ED timestep ! summary carbon states at the column level real(r8), pointer, public :: totecosysc_col(:) ! [gC/m2] Total ecosystem carbon at the column level, including vegetation, CWD, litter, and soil pools @@ -260,6 +262,9 @@ subroutine InitAllocate(this, bounds) allocate(this%croot_prof_col (begc:endc,1:nlevdecomp_full)) ; this%croot_prof_col (:,:) = nan allocate(this%stem_prof_col (begc:endc,1:nlevdecomp_full)) ; this%stem_prof_col (:,:) = nan + allocate(this%ed_to_bgc_this_edts_col (begc:endc)) ; this%ed_to_bgc_this_edts_col (:) = nan + allocate(this%ed_to_bgc_last_edts_col (begc:endc)) ; this%ed_to_bgc_last_edts_col (:) = nan + allocate(this%nep_col (begc:endc)) ; this%nep_col (:) = nan allocate(this%nep_timeintegrated_col (begc:endc)) ; this%nep_timeintegrated_col (:) = nan allocate(this%nbp_col (begc:endc)) ; this%nbp_col (:) = nan @@ -728,6 +733,16 @@ subroutine Restart ( this, bounds, ncid, flag ) dim1name='column', long_name='', units='', & interpinic_flag='interp', readvar=readvar, data=ptr1d) + ptr1d => this%ed_to_bgc_this_edts_col(:) + call restartvar(ncid=ncid, flag=flag, varname='ed_to_bgc_this_edts_col', xtype=ncd_double, & + dim1name='column', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=ptr1d) + + ptr1d => this%ed_to_bgc_last_edts_col(:) + call restartvar(ncid=ncid, flag=flag, varname='ed_to_bgc_last_edts_col', xtype=ncd_double, & + dim1name='column', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=ptr1d) + if (use_vertsoilc) then ptr2d => this%ED_c_to_litr_lab_c_col call restartvar(ncid=ncid, flag=flag, varname='ED_c_to_litr_lab_c_col', xtype=ncd_double, & @@ -2331,7 +2346,9 @@ subroutine Summary(this, bounds, num_soilc, filter_soilc, & biomass_stock => this%biomass_stock_col, & ! total biomass in gC / m2 ed_litter_stock => this%ed_litter_stock_col, & ! ED litter in gC / m2 cwd_stock => this%cwd_stock_col, & ! total CWD in gC / m2 - seed_stock => this%seed_stock_col & ! total seed mass in gC / m2 + seed_stock => this%seed_stock_col, & ! total seed mass in gC / m2 + ed_to_bgc_this_edts => this%ed_to_bgc_this_edts_col, & + ed_to_bgc_last_edts => this%ed_to_bgc_last_edts_col & ) ! set time steps @@ -2410,6 +2427,36 @@ subroutine Summary(this, bounds, num_soilc, filter_soilc, & ed_litter_stock(c) + cwd_stock(c) + seed_stock(c) + biomass_stock(c) ! ED stocks end do + ! in ED timesteps, because of offset between when ED and BGC reconcile the gain and loss of litterfall carbon, + ! (i.e. ED reconciles it instantly, while BGC reconciles it incrementally over the subsequent day) + ! calculate the total ED -> BGC flux and keep track of the last day's info for balance checking purposes + if ( is_beg_curr_day() ) then + do fc = 1,num_soilc + c = filter_soilc(fc) + ed_to_bgc_last_edts(c) = ed_to_bgc_this_edts(c) + end do + ! + do fc = 1,num_soilc + c = filter_soilc(fc) + ed_to_bgc_this_edts(c) = 0._r8 + end do + ! + do g = bounds%begg,bounds%endg + if (firstsoilpatch(g) >= 0 .and. ed_allsites_inst(g)%istheresoil) then + cc = ed_allsites_inst(g)%clmcolumn + currentPatch => ed_allsites_inst(g)%oldest_patch + do while(associated(currentPatch)) + ! + ed_to_bgc_this_edts(c) = ed_to_bgc_this_edts(c) + (currentpatch%CWD_AG_out(c) + currentpatch%CWD_BG_out(c) + & + sum(currentpatch%leaf_litter_out(:)) + sum(currentpatch%root_litter_out(:))) & + * currentpatch%area/AREA * 1.e3_r8 / ( 365.0_r8*SHR_CONST_CDAY) + ! + currentPatch => currentPatch%younger + end do !currentPatch + end if + end do + endif + end associate end subroutine Summary @@ -2448,7 +2495,9 @@ subroutine ED_BGC_Carbon_Balancecheck(this, bounds, num_soilc, filter_soilc) nep_timeintegrated => this%nep_timeintegrated_col, & fire_c_to_atm => this%fire_c_to_atm_col, & totecosysc_old => this%totecosysc_old_col, & - totecosysc => this%totecosysc_col & + totecosysc => this%totecosysc_col, & + ed_to_bgc_this_edts => this%ed_to_bgc_this_edts_col, & + ed_to_bgc_last_edts => this%ed_to_bgc_last_edts_col & ) dtime = get_step_size() @@ -2460,6 +2509,10 @@ subroutine ED_BGC_Carbon_Balancecheck(this, bounds, num_soilc, filter_soilc) c = filter_soilc(fc) totecosysc_old(c) = totecosysc(c) nep_timeintegrated(c) = 0._r8 + ! + ! also initialize the ed-BGC flux variables + ed_to_bgc_this_edts(c) = 0._r8 + ed_to_bgc_last_edts(c) = 0._r8 end do endif @@ -2477,10 +2530,16 @@ subroutine ED_BGC_Carbon_Balancecheck(this, bounds, num_soilc, filter_soilc) nbp_integrated(c) = nep_timeintegrated(c) + fire_c_to_atm(c) * SHR_CONST_CDAY end do + ! adjust the nbp to take into account the fact that ED litter stocks reflect today's changes while BGC reflects yesterday's + do fc = 1,num_soilc + c = filter_soilc(fc) + nbp_integrated(c) = nbp_integrated(c) - (ed_to_bgc_this_edts(c) - ed_to_bgc_last_edts(c)) * SHR_CONST_CDAY + end do + ! next compare the change in carbon and calculate the error do fc = 1,num_soilc c = filter_soilc(fc) - error(c) = totecosysc_old(c) - totecosysc(c) - nbp_integrated(c) + error(c) = totecosysc(c) - totecosysc_old(c) - nbp_integrated(c) end do ! for now, rather than crashing the model, lets just report the largest error to see what we're up against From 51172991373fcd429e34dc9e968e6de79af466f2 Mon Sep 17 00:00:00 2001 From: ckoven Date: Mon, 7 Mar 2016 17:30:07 -0800 Subject: [PATCH 052/437] still chasing carbon balance errors... --- biogeochem/EDBGCDynMod.F90 | 3 +- main/EDCLMLinkMod.F90 | 108 +++++++++++++++++++++++++++++-------- 2 files changed, 88 insertions(+), 23 deletions(-) diff --git a/biogeochem/EDBGCDynMod.F90 b/biogeochem/EDBGCDynMod.F90 index 9a590305..fe8acf09 100644 --- a/biogeochem/EDBGCDynMod.F90 +++ b/biogeochem/EDBGCDynMod.F90 @@ -363,7 +363,8 @@ subroutine EDBGCDynSummary(bounds, num_soilc, filter_soilc, num_soilp, filter_so ! calculate balance checks on entire carbon cycle (ED + BGC) ! ---------------------------------------------- - call ed_clm_inst%ED_BGC_Carbon_Balancecheck(bounds, num_soilc, filter_soilc) + call ed_clm_inst%ED_BGC_Carbon_Balancecheck(bounds, num_soilc, filter_soilc, & + soilbiogeochem_carbonflux_inst) call t_stopf('BGCsum') diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 83d994de..3df957e3 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -18,7 +18,7 @@ module EDCLMLinkMod use EDParamsMod , only : ED_val_ag_biomass use SoilBiogeochemCarbonFluxType , only : soilbiogeochem_carbonflux_type use SoilBiogeochemCarbonStatetype , only : soilbiogeochem_carbonstate_type - use clm_time_manager , only : get_step_size + use clm_time_manager , only : is_beg_curr_day, get_step_size, get_nstep use shr_const_mod, only: SHR_CONST_CDAY ! @@ -130,6 +130,8 @@ module EDCLMLinkMod ! summary carbon fluxes at the column level real(r8), pointer, public :: nep_col(:) ! [gC/m2/s] Net ecosystem production, i.e. fast-timescale carbon balance that does not include disturbance real(r8), pointer, public :: nep_timeintegrated_col(:) ! [gC/m2/s] Net ecosystem production, i.e. fast-timescale carbon balance that does not include disturbance + real(r8), pointer, public :: npp_timeintegrated_col(:) ! [gC/m2/s] Net primary production, time integrated at column level for carbon balance checking + real(r8), pointer, public :: hr_timeintegrated_col(:) ! [gC/m2/s] heterotrophic respiration, time integrated for carbon balance checking real(r8), pointer, public :: nbp_col(:) ! [gC/m2/s] Net biosphere production, i.e. slow-timescale carbon balance that integrates to total carbon change real(r8), pointer, public :: npp_hifreq_col(:) ! [gC/m2/s] Net primary production at the fast timescale, aggregated to the column level real(r8), pointer, public :: fire_c_to_atm_col(:) ! [gC/m2/s] total fire carbon loss to atmosphere @@ -139,6 +141,10 @@ module EDCLMLinkMod ! summary carbon states at the column level real(r8), pointer, public :: totecosysc_col(:) ! [gC/m2] Total ecosystem carbon at the column level, including vegetation, CWD, litter, and soil pools real(r8), pointer, public :: totecosysc_old_col(:) ! [gC/m2] Total ecosystem C at the column level from last call to balance check + real(r8), pointer, public :: totedc_col(:) ! [gC/m2] Total ED carbon at the column level, including vegetation, CWD, seeds, and ED litter + real(r8), pointer, public :: totedc_old_col(:) ! [gC/m2] Total ED C at the column level from last call to balance check + real(r8), pointer, public :: totbgcc_col(:) ! [gC/m2] Total BGC carbon at the column level, including litter, and soil pools + real(r8), pointer, public :: totbgcc_old_col(:) ! [gC/m2] Total BGC C at the column level from last call to balance check real(r8), pointer, public :: biomass_stock_col(:) ! [gC/m2] total biomass at the column level in gC / m2 real(r8), pointer, public :: ed_litter_stock_col(:) ! [gC/m2] ED litter at the column level in gC / m2 real(r8), pointer, public :: cwd_stock_col(:) ! [gC/m2] ED CWD at the column level in gC / m2 @@ -267,12 +273,19 @@ subroutine InitAllocate(this, bounds) allocate(this%nep_col (begc:endc)) ; this%nep_col (:) = nan allocate(this%nep_timeintegrated_col (begc:endc)) ; this%nep_timeintegrated_col (:) = nan + allocate(this%npp_timeintegrated_col (begc:endc)) ; this%npp_timeintegrated_col (:) = nan + allocate(this%hr_timeintegrated_col (begc:endc)) ; this%hr_timeintegrated_col (:) = nan + allocate(this%nbp_col (begc:endc)) ; this%nbp_col (:) = nan allocate(this%npp_hifreq_col (begc:endc)) ; this%npp_hifreq_col (:) = nan allocate(this%fire_c_to_atm_col (begc:endc)) ; this%fire_c_to_atm_col (:) = nan allocate(this%totecosysc_col (begc:endc)) ; this%totecosysc_col (:) = nan allocate(this%totecosysc_old_col (begc:endc)) ; this%totecosysc_old_col (:) = nan + allocate(this%totedc_col (begc:endc)) ; this%totedc_col (:) = nan + allocate(this%totedc_old_col (begc:endc)) ; this%totedc_old_col (:) = nan + allocate(this%totbgcc_col (begc:endc)) ; this%totbgcc_col (:) = nan + allocate(this%totbgcc_old_col (begc:endc)) ; this%totbgcc_old_col (:) = nan allocate(this%biomass_stock_col (begc:endc)) ; this%biomass_stock_col (:) = nan allocate(this%ed_litter_stock_col (begc:endc)) ; this%ed_litter_stock_col (:) = nan allocate(this%cwd_stock_col (begc:endc)) ; this%cwd_stock_col (:) = nan @@ -728,11 +741,31 @@ subroutine Restart ( this, bounds, ncid, flag ) dim1name='column', long_name='', units='', & interpinic_flag='interp', readvar=readvar, data=ptr1d) + ptr1d => this%npp_timeintegrated_col(:) + call restartvar(ncid=ncid, flag=flag, varname='npp_timeintegrated_col', xtype=ncd_double, & + dim1name='column', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=ptr1d) + + ptr1d => this%hr_timeintegrated_col(:) + call restartvar(ncid=ncid, flag=flag, varname='hr_timeintegrated_col', xtype=ncd_double, & + dim1name='column', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=ptr1d) + ptr1d => this%totecosysc_old_col(:) call restartvar(ncid=ncid, flag=flag, varname='totecosysc_old_col', xtype=ncd_double, & dim1name='column', long_name='', units='', & interpinic_flag='interp', readvar=readvar, data=ptr1d) + ptr1d => this%totedc_old_col(:) + call restartvar(ncid=ncid, flag=flag, varname='totedc_old_col', xtype=ncd_double, & + dim1name='column', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=ptr1d) + + ptr1d => this%totbgcc_old_col(:) + call restartvar(ncid=ncid, flag=flag, varname='totbgcc_old_col', xtype=ncd_double, & + dim1name='column', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=ptr1d) + ptr1d => this%ed_to_bgc_this_edts_col(:) call restartvar(ncid=ncid, flag=flag, varname='ed_to_bgc_this_edts_col', xtype=ncd_double, & dim1name='column', long_name='', units='', & @@ -2269,6 +2302,12 @@ subroutine flux_into_litter_pools(this, bounds, ed_allsites_inst, firstsoilpatch ED_c_to_litr_lab_c(cc,j) = ED_c_to_litr_lab_c(cc,j) + currentpatch%root_litter_out(ft) * pftcon%fr_flab(ft) * currentpatch%area/AREA * froot_prof(cc,ft,j) ED_c_to_litr_cel_c(cc,j) = ED_c_to_litr_cel_c(cc,j) + currentpatch%root_litter_out(ft) * pftcon%fr_fcel(ft) * currentpatch%area/AREA * froot_prof(cc,ft,j) ED_c_to_litr_lig_c(cc,j) = ED_c_to_litr_lig_c(cc,j) + currentpatch%root_litter_out(ft) * pftcon%fr_flig(ft) * currentpatch%area/AREA * froot_prof(cc,ft,j) + ! + !! and seed_decay too. for now, use the same lability fractions as for leaf litter + ED_c_to_litr_lab_c(cc,j) = ED_c_to_litr_lab_c(cc,j) + currentpatch%seed_decay(ft) * pftcon%lf_flab(ft) * currentpatch%area/AREA * leaf_prof(cc,j) + ED_c_to_litr_cel_c(cc,j) = ED_c_to_litr_cel_c(cc,j) + currentpatch%seed_decay(ft) * pftcon%lf_fcel(ft) * currentpatch%area/AREA * leaf_prof(cc,j) + ED_c_to_litr_lig_c(cc,j) = ED_c_to_litr_lig_c(cc,j) + currentpatch%seed_decay(ft) * pftcon%lf_flig(ft) * currentpatch%area/AREA * leaf_prof(cc,j) + ! enddo end do @@ -2343,6 +2382,8 @@ subroutine Summary(this, bounds, num_soilc, filter_soilc, & fire_c_to_atm => this%fire_c_to_atm_col, & nbp => this%nbp_col, & totecosysc => this%totecosysc_col, & + totedc => this%totedc_col, & + totbgcc => this%totbgcc_col, & biomass_stock => this%biomass_stock_col, & ! total biomass in gC / m2 ed_litter_stock => this%ed_litter_stock_col, & ! ED litter in gC / m2 cwd_stock => this%cwd_stock_col, & ! total CWD in gC / m2 @@ -2422,9 +2463,11 @@ subroutine Summary(this, bounds, num_soilc, filter_soilc, & ! calculate total stocks do fc = 1,num_soilc c = filter_soilc(fc) + + totedc(c) = ed_litter_stock(c) + cwd_stock(c) + seed_stock(c) + biomass_stock(c) ! ED stocks + totbgcc(c) = totsomc(c) + totlitc(c) ! BGC stocks + totecosysc(c) = totedc(c) + totbgcc(c) - totecosysc(c) = totsomc(c) + totlitc(c) + & ! BGC stocks - ed_litter_stock(c) + cwd_stock(c) + seed_stock(c) + biomass_stock(c) ! ED stocks end do ! in ED timesteps, because of offset between when ED and BGC reconcile the gain and loss of litterfall carbon, @@ -2447,8 +2490,8 @@ subroutine Summary(this, bounds, num_soilc, filter_soilc, & currentPatch => ed_allsites_inst(g)%oldest_patch do while(associated(currentPatch)) ! - ed_to_bgc_this_edts(c) = ed_to_bgc_this_edts(c) + (currentpatch%CWD_AG_out(c) + currentpatch%CWD_BG_out(c) + & - sum(currentpatch%leaf_litter_out(:)) + sum(currentpatch%root_litter_out(:))) & + ed_to_bgc_this_edts(cc) = ed_to_bgc_this_edts(cc) + (sum(currentpatch%CWD_AG_out(:)) + sum(currentpatch%CWD_BG_out(:)) + & + + sum(currentpatch%seed_decay(:)) + sum(currentpatch%leaf_litter_out(:)) + sum(currentpatch%root_litter_out(:))) & * currentpatch%area/AREA * 1.e3_r8 / ( 365.0_r8*SHR_CONST_CDAY) ! currentPatch => currentPatch%younger @@ -2462,7 +2505,7 @@ subroutine Summary(this, bounds, num_soilc, filter_soilc, & end subroutine Summary - subroutine ED_BGC_Carbon_Balancecheck(this, bounds, num_soilc, filter_soilc) + subroutine ED_BGC_Carbon_Balancecheck(this, bounds, num_soilc, filter_soilc, soilbiogeochem_carbonflux_inst) ! Integrate in time the fluxes into and out of the ecosystem, and compare these on a daily timestep ! to the chagne in carbon stocks of the ecosystem @@ -2470,8 +2513,6 @@ subroutine ED_BGC_Carbon_Balancecheck(this, bounds, num_soilc, filter_soilc) ! Written by Charlie Koven, Feb 2016 ! ! !USES: - use clm_time_manager , only : is_beg_curr_day, get_step_size, get_nstep - use shr_const_mod, only: SHR_CONST_CDAY ! implicit none ! @@ -2480,22 +2521,35 @@ subroutine ED_BGC_Carbon_Balancecheck(this, bounds, num_soilc, filter_soilc) type(bounds_type) , intent(in) :: bounds integer , intent(in) :: num_soilc ! number of soil columns in filter integer , intent(in) :: filter_soilc(:) ! filter for soil columns + type(soilbiogeochem_carbonflux_type) , intent(inout) :: soilbiogeochem_carbonflux_inst ! ! !LOCAL VARIABLES: real(r8) :: dtime ! land model time step (sec) integer :: nstep ! model timestep real(r8) :: nbp_integrated(bounds%begc:bounds%endc) ! total net biome production integrated - real(r8) :: error(bounds%begc:bounds%endc) + real(r8) :: error_total(bounds%begc:bounds%endc) + real(r8) :: error_ed(bounds%begc:bounds%endc) + real(r8) :: error_bgc(bounds%begc:bounds%endc) real(r8) :: error_tolerance = 1.e-6_r8 - real(r8) :: max_error + real(r8) :: max_error_ed + real(r8) :: max_error_bgc + real(r8) :: max_error_total integer :: fc,c associate(& nep => this%nep_col, & nep_timeintegrated => this%nep_timeintegrated_col, & + hr => soilbiogeochem_carbonflux_inst%hr_col, & + hr_timeintegrated => this%hr_timeintegrated_col, & + npp_hifreq => this%npp_hifreq_col, & + npp_timeintegrated => this%npp_timeintegrated_col, & fire_c_to_atm => this%fire_c_to_atm_col, & totecosysc_old => this%totecosysc_old_col, & totecosysc => this%totecosysc_col, & + totedc_old => this%totedc_old_col, & + totedc => this%totedc_col, & + totbgcc_old => this%totbgcc_old_col, & + totbgcc => this%totbgcc_col, & ed_to_bgc_this_edts => this%ed_to_bgc_this_edts_col, & ed_to_bgc_last_edts => this%ed_to_bgc_last_edts_col & ) @@ -2508,7 +2562,11 @@ subroutine ED_BGC_Carbon_Balancecheck(this, bounds, num_soilc, filter_soilc) do fc = 1,num_soilc c = filter_soilc(fc) totecosysc_old(c) = totecosysc(c) + totedc_old(c) = totedc(c) + totbgcc_old(c) = totbgcc(c) nep_timeintegrated(c) = 0._r8 + hr_timeintegrated(c) = 0._r8 + npp_timeintegrated(c) = 0._r8 ! ! also initialize the ed-BGC flux variables ed_to_bgc_this_edts(c) = 0._r8 @@ -2521,45 +2579,51 @@ subroutine ED_BGC_Carbon_Balancecheck(this, bounds, num_soilc, filter_soilc) do fc = 1,num_soilc c = filter_soilc(fc) nep_timeintegrated(c) = nep_timeintegrated(c) + nep(c) * dtime + hr_timeintegrated(c) = hr_timeintegrated(c) + hr(c) * dtime + npp_timeintegrated(c) = npp_timeintegrated(c) + npp_hifreq(c) * dtime end do else ! on ED (daily) timesteps, first integrate the NEP fluxes and add in the daily disturbance flux do fc = 1,num_soilc c = filter_soilc(fc) nep_timeintegrated(c) = nep_timeintegrated(c) + nep(c) * dtime - nbp_integrated(c) = nep_timeintegrated(c) + fire_c_to_atm(c) * SHR_CONST_CDAY - end do - - ! adjust the nbp to take into account the fact that ED litter stocks reflect today's changes while BGC reflects yesterday's - do fc = 1,num_soilc - c = filter_soilc(fc) - nbp_integrated(c) = nbp_integrated(c) - (ed_to_bgc_this_edts(c) - ed_to_bgc_last_edts(c)) * SHR_CONST_CDAY + hr_timeintegrated(c) = hr_timeintegrated(c) + hr(c) * dtime + npp_timeintegrated(c) = npp_timeintegrated(c) + npp_hifreq(c) * dtime + nbp_integrated(c) = nep_timeintegrated(c) - fire_c_to_atm(c) * SHR_CONST_CDAY end do ! next compare the change in carbon and calculate the error do fc = 1,num_soilc c = filter_soilc(fc) - error(c) = totecosysc(c) - totecosysc_old(c) - nbp_integrated(c) + error_ed(c) = totedc(c) - totedc_old(c) - (npp_timeintegrated(c) - ed_to_bgc_this_edts(c)* SHR_CONST_CDAY - fire_c_to_atm(c) * SHR_CONST_CDAY) + error_bgc(c) = totbgcc(c) - totbgcc_old(c) - (ed_to_bgc_last_edts(c)* SHR_CONST_CDAY - hr_timeintegrated(c)) + error_total(c) = totecosysc(c) - totecosysc_old(c) - (nbp_integrated(c) + ed_to_bgc_last_edts(c)* SHR_CONST_CDAY - ed_to_bgc_this_edts(c)* SHR_CONST_CDAY) end do ! for now, rather than crashing the model, lets just report the largest error to see what we're up against ! ! RETURN TO THIS LATER AND ADD A CRASHER IF BALANCE EXCEEDS THRESHOLD ! - max_error = 0._r8 + max_error_total = 0._r8 do fc = 1,num_soilc c = filter_soilc(fc) - if (abs(error(c)) .gt. max_error) then - max_error = abs(error(c)) + if (abs(error_total(c)) .gt. max_error_total) then + max_error_ed = abs(error_ed(c)) + max_error_bgc = abs(error_bgc(c)) + max_error_total = abs(error_total(c)) endif end do - write(iulog,*) 'ED_BGC_Carbon_Balancecheck: max carbon balance error (gC / m2 / day): ', max_error + write(iulog,*) 'ED_BGC_Carbon_Balancecheck: max_error_ed, max_error_bgc, max_error_total (gC / m2 / day): ', max_error_ed, max_error_bgc, max_error_total ! reset the C stock and flux integrators do fc = 1,num_soilc c = filter_soilc(fc) totecosysc_old(c) = totecosysc(c) + totedc_old(c) = totedc(c) + totbgcc_old(c) = totbgcc(c) nep_timeintegrated(c) = 0._r8 + npp_timeintegrated(c) = 0._r8 + hr_timeintegrated(c) = 0._r8 end do endif From 473480e9822688d30adda9c45078b49f8920dd6c Mon Sep 17 00:00:00 2001 From: ckoven Date: Tue, 8 Mar 2016 13:33:27 -0800 Subject: [PATCH 053/437] runtime bugfix to prevent crash due to filter mismatch; though filter mismatch is likely still happening. --- main/EDCLMLinkMod.F90 | 23 ++++++++++++++--------- 1 file changed, 14 insertions(+), 9 deletions(-) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 3df957e3..32366e9a 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -2474,14 +2474,19 @@ subroutine Summary(this, bounds, num_soilc, filter_soilc, & ! (i.e. ED reconciles it instantly, while BGC reconciles it incrementally over the subsequent day) ! calculate the total ED -> BGC flux and keep track of the last day's info for balance checking purposes if ( is_beg_curr_day() ) then - do fc = 1,num_soilc - c = filter_soilc(fc) - ed_to_bgc_last_edts(c) = ed_to_bgc_this_edts(c) + ! + do g = bounds%begg,bounds%endg + if (firstsoilpatch(g) >= 0 .and. ed_allsites_inst(g)%istheresoil) then + cc = ed_allsites_inst(g)%clmcolumn + ed_to_bgc_last_edts(cc) = ed_to_bgc_this_edts(cc) + endif end do ! - do fc = 1,num_soilc - c = filter_soilc(fc) - ed_to_bgc_this_edts(c) = 0._r8 + do g = bounds%begg,bounds%endg + if (firstsoilpatch(g) >= 0 .and. ed_allsites_inst(g)%istheresoil) then + cc = ed_allsites_inst(g)%clmcolumn + ed_to_bgc_this_edts(cc) = 0._r8 + endif end do ! do g = bounds%begg,bounds%endg @@ -2490,9 +2495,9 @@ subroutine Summary(this, bounds, num_soilc, filter_soilc, & currentPatch => ed_allsites_inst(g)%oldest_patch do while(associated(currentPatch)) ! - ed_to_bgc_this_edts(cc) = ed_to_bgc_this_edts(cc) + (sum(currentpatch%CWD_AG_out(:)) + sum(currentpatch%CWD_BG_out(:)) + & - + sum(currentpatch%seed_decay(:)) + sum(currentpatch%leaf_litter_out(:)) + sum(currentpatch%root_litter_out(:))) & - * currentpatch%area/AREA * 1.e3_r8 / ( 365.0_r8*SHR_CONST_CDAY) + ed_to_bgc_this_edts(cc) = ed_to_bgc_this_edts(cc) + (sum(currentPatch%CWD_AG_out) + sum(currentPatch%CWD_BG_out) + & + + sum(currentPatch%seed_decay) + sum(currentPatch%leaf_litter_out) + sum(currentPatch%root_litter_out)) & + * ( currentPatch%area/AREA ) * 1.e3_r8 / ( 365.0_r8*SHR_CONST_CDAY ) ! currentPatch => currentPatch%younger end do !currentPatch From 6f5f9ff6346a6ad8ea63f31f603c55bca7c2778b Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Wed, 9 Mar 2016 15:57:39 -0800 Subject: [PATCH 054/437] added seed rain flux to carbon balance logic --- biogeochem/EDPhysiologyMod.F90 | 3 +++ main/EDCLMLinkMod.F90 | 20 ++++++++++++++++---- main/EDTypesMod.F90 | 1 + 3 files changed, 20 insertions(+), 4 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index f8e3464f..f773adb1 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -634,6 +634,8 @@ subroutine seeds_in( cp_pnt ) currentSite => currentPatch%siteptr currentPatch%seeds_in(:) = 0.0_r8 + currentPatch%seed_rain_flux(:) = 0.0_r8 + currentCohort => currentPatch%tallest do while (associated(currentCohort)) p = currentCohort%pft @@ -647,6 +649,7 @@ subroutine seeds_in( cp_pnt ) 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 + currentPatch%seed_rain_flux(p) = currentPatch%seed_rain_flux(p) + EDecophyscon%seed_rain(p) !KgC/m2/year enddo endif currentPatch => currentPatch%younger diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 32366e9a..4908cdb7 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -137,6 +137,7 @@ module EDCLMLinkMod real(r8), pointer, public :: fire_c_to_atm_col(:) ! [gC/m2/s] total fire carbon loss to atmosphere real(r8), pointer, public :: ed_to_bgc_this_edts_col(:) ! [gC/m2/s] total flux of carbon from ED to BGC models on current ED timestep real(r8), pointer, public :: ed_to_bgc_last_edts_col(:) ! [gC/m2/s] total flux of carbon from ED to BGC models on prior ED timestep + real(r8), pointer, public :: seed_rain_flux_col(:) ! [gC/m2/s] total flux of carbon from seed rain ! summary carbon states at the column level real(r8), pointer, public :: totecosysc_col(:) ! [gC/m2] Total ecosystem carbon at the column level, including vegetation, CWD, litter, and soil pools @@ -270,6 +271,7 @@ subroutine InitAllocate(this, bounds) allocate(this%ed_to_bgc_this_edts_col (begc:endc)) ; this%ed_to_bgc_this_edts_col (:) = nan allocate(this%ed_to_bgc_last_edts_col (begc:endc)) ; this%ed_to_bgc_last_edts_col (:) = nan + allocate(this%seed_rain_flux_col (begc:endc)) ; this%seed_rain_flux_col (:) = nan allocate(this%nep_col (begc:endc)) ; this%nep_col (:) = nan allocate(this%nep_timeintegrated_col (begc:endc)) ; this%nep_timeintegrated_col (:) = nan @@ -775,6 +777,11 @@ subroutine Restart ( this, bounds, ncid, flag ) call restartvar(ncid=ncid, flag=flag, varname='ed_to_bgc_last_edts_col', xtype=ncd_double, & dim1name='column', long_name='', units='', & interpinic_flag='interp', readvar=readvar, data=ptr1d) + + ptr1d => this%seed_rain_flux_col(:) + call restartvar(ncid=ncid, flag=flag, varname='seed_rain_flux_col', xtype=ncd_double, & + dim1name='column', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=ptr1d) if (use_vertsoilc) then ptr2d => this%ED_c_to_litr_lab_c_col @@ -2389,7 +2396,8 @@ subroutine Summary(this, bounds, num_soilc, filter_soilc, & cwd_stock => this%cwd_stock_col, & ! total CWD in gC / m2 seed_stock => this%seed_stock_col, & ! total seed mass in gC / m2 ed_to_bgc_this_edts => this%ed_to_bgc_this_edts_col, & - ed_to_bgc_last_edts => this%ed_to_bgc_last_edts_col & + ed_to_bgc_last_edts => this%ed_to_bgc_last_edts_col, & + seed_rain_flux => this%seed_rain_flux_col ) ! set time steps @@ -2486,6 +2494,7 @@ subroutine Summary(this, bounds, num_soilc, filter_soilc, & if (firstsoilpatch(g) >= 0 .and. ed_allsites_inst(g)%istheresoil) then cc = ed_allsites_inst(g)%clmcolumn ed_to_bgc_this_edts(cc) = 0._r8 + seed_rain_flux(cc) = 0._r8 endif end do ! @@ -2499,6 +2508,8 @@ subroutine Summary(this, bounds, num_soilc, filter_soilc, & + sum(currentPatch%seed_decay) + sum(currentPatch%leaf_litter_out) + sum(currentPatch%root_litter_out)) & * ( currentPatch%area/AREA ) * 1.e3_r8 / ( 365.0_r8*SHR_CONST_CDAY ) ! + seed_rain_flux(cc) = seed_rain_flux(cc) + sum(currentPatch%seed_rain_flux) * 1.e3_r8 / ( 365.0_r8*SHR_CONST_CDAY ) + ! currentPatch => currentPatch%younger end do !currentPatch end if @@ -2556,7 +2567,8 @@ subroutine ED_BGC_Carbon_Balancecheck(this, bounds, num_soilc, filter_soilc, soi totbgcc_old => this%totbgcc_old_col, & totbgcc => this%totbgcc_col, & ed_to_bgc_this_edts => this%ed_to_bgc_this_edts_col, & - ed_to_bgc_last_edts => this%ed_to_bgc_last_edts_col & + ed_to_bgc_last_edts => this%ed_to_bgc_last_edts_col, & + seed_rain_flux => this%seed_rain_flux_col & ) dtime = get_step_size() @@ -2594,13 +2606,13 @@ subroutine ED_BGC_Carbon_Balancecheck(this, bounds, num_soilc, filter_soilc, soi nep_timeintegrated(c) = nep_timeintegrated(c) + nep(c) * dtime hr_timeintegrated(c) = hr_timeintegrated(c) + hr(c) * dtime npp_timeintegrated(c) = npp_timeintegrated(c) + npp_hifreq(c) * dtime - nbp_integrated(c) = nep_timeintegrated(c) - fire_c_to_atm(c) * SHR_CONST_CDAY + nbp_integrated(c) = nep_timeintegrated(c) - fire_c_to_atm(c) * SHR_CONST_CDAY + seed_rain_flux(c)* SHR_CONST_CDAY end do ! next compare the change in carbon and calculate the error do fc = 1,num_soilc c = filter_soilc(fc) - error_ed(c) = totedc(c) - totedc_old(c) - (npp_timeintegrated(c) - ed_to_bgc_this_edts(c)* SHR_CONST_CDAY - fire_c_to_atm(c) * SHR_CONST_CDAY) + error_ed(c) = totedc(c) - totedc_old(c) - (npp_timeintegrated(c) + seed_rain_flux(c)* SHR_CONST_CDAY - ed_to_bgc_this_edts(c)* SHR_CONST_CDAY - fire_c_to_atm(c) * SHR_CONST_CDAY) error_bgc(c) = totbgcc(c) - totbgcc_old(c) - (ed_to_bgc_last_edts(c)* SHR_CONST_CDAY - hr_timeintegrated(c)) error_total(c) = totecosysc(c) - totecosysc_old(c) - (nbp_integrated(c) + ed_to_bgc_last_edts(c)* SHR_CONST_CDAY - ed_to_bgc_this_edts(c)* SHR_CONST_CDAY) end do diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index c4cb994d..b06b26c6 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -290,6 +290,7 @@ module EDTypesMod 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) + real(r8) :: seed_rain_flux(numpft_ed) ! flux of seeds from exterior KgC/m2/year (needed for C balance purposes) ! PHOTOSYNTHESIS real(r8) :: psn_z(nclmax,numpft_ed,nlevcan_ed) ! carbon assimilation in each canopy layer, pft, and leaf layer. umolC/m2/s From 992c0b95ee38146ba07f8e20e7610d07a57a7507 Mon Sep 17 00:00:00 2001 From: ckoven Date: Wed, 9 Mar 2016 17:20:17 -0800 Subject: [PATCH 055/437] sending C balance errors to history file to keep track of --- main/EDCLMLinkMod.F90 | 80 ++++++++++++++++++++++++++++++++++++------- 1 file changed, 67 insertions(+), 13 deletions(-) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 4908cdb7..53b79e1f 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -151,6 +151,11 @@ module EDCLMLinkMod real(r8), pointer, public :: cwd_stock_col(:) ! [gC/m2] ED CWD at the column level in gC / m2 real(r8), pointer, public :: seed_stock_col(:) ! [gC/m2] ED seed mass carbon at the column level in gC / m2 + ! carbon balance errors. at some point we'll reduce these to close to zero and delete, but for now we'll just keep[ track of them + real(r8), pointer, public :: cbalance_error_ed_col(:) ! [gC/m2/s] total carbon balance error for the ED side + real(r8), pointer, public :: cbalance_error_bgc_col(:) ! [gC/m2/s] total carbon balance error for the BGC side + real(r8), pointer, public :: cbalance_error_total_col(:) ! [gC/m2/s] total carbon balance error for the whole thing + contains ! Public routines @@ -291,7 +296,11 @@ subroutine InitAllocate(this, bounds) allocate(this%biomass_stock_col (begc:endc)) ; this%biomass_stock_col (:) = nan allocate(this%ed_litter_stock_col (begc:endc)) ; this%ed_litter_stock_col (:) = nan allocate(this%cwd_stock_col (begc:endc)) ; this%cwd_stock_col (:) = nan - allocate(this%seed_stock_col (begc:endc)) ; this%seed_stock_col (:) = nan + allocate(this%seed_stock_col (begc:endc)) ; this%seed_stock_col (:) = nan + + allocate(this%cbalance_error_ed_col (begc:endc)) ; this%cbalance_error_ed_col (:) = nan + allocate(this%cbalance_error_bgc_col (begc:endc)) ; this%cbalance_error_bgc_col (:) = nan + allocate(this%cbalance_error_total_col (begc:endc)) ; this%cbalance_error_total_col (:) = nan allocate(this%ed_gpp_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)); this%ed_gpp_gd_scpf (:,:) = 0.0_r8 allocate(this%ed_npp_totl_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)); this%ed_npp_totl_gd_scpf (:,:) = 0.0_r8 @@ -551,6 +560,21 @@ subroutine InitHistory(this, bounds) avgflag='A', long_name='total ecosystem carbon', & ptr_col=this%totecosysc_col) + this%cbalance_error_ed_col(begc:endc) = spval + call hist_addfld1d (fname='CBALANCE_ERROR_ED', units='gC/m^2/s', & + avgflag='A', long_name='total carbon balance error on ED side', & + ptr_col=this%cbalance_error_ed_col) + + this%cbalance_error_bgc_col(begc:endc) = spval + call hist_addfld1d (fname='CBALANCE_ERROR_BGC', units='gC/m^2/s', & + avgflag='A', long_name='total carbon balance error on BGC side', & + ptr_col=this%cbalance_error_bgc_col) + + this%cbalance_error_total_col(begc:endc) = spval + call hist_addfld1d (fname='CBALANCE_ERROR_TOTAL', units='gC/m^2/s', & + avgflag='A', long_name='total carbon balance error total', & + ptr_col=this%cbalance_error_total_col) + this%biomass_stock_col(begc:endc) = spval call hist_addfld1d (fname='BIOMASS_STOCK_COL', units='gC/m^2', & avgflag='A', long_name='total ED biomass carbon at the column level', & @@ -758,6 +782,21 @@ subroutine Restart ( this, bounds, ncid, flag ) dim1name='column', long_name='', units='', & interpinic_flag='interp', readvar=readvar, data=ptr1d) + ptr1d => this%cbalance_error_ed_col(:) + call restartvar(ncid=ncid, flag=flag, varname='cbalance_error_ed_col', xtype=ncd_double, & + dim1name='column', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=ptr1d) + + ptr1d => this%cbalance_error_bgc_col(:) + call restartvar(ncid=ncid, flag=flag, varname='cbalance_error_bgc_col', xtype=ncd_double, & + dim1name='column', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=ptr1d) + + ptr1d => this%cbalance_error_total_col(:) + call restartvar(ncid=ncid, flag=flag, varname='cbalance_error_total_col', xtype=ncd_double, & + dim1name='column', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=ptr1d) + ptr1d => this%totedc_old_col(:) call restartvar(ncid=ncid, flag=flag, varname='totedc_old_col', xtype=ncd_double, & dim1name='column', long_name='', units='', & @@ -2397,7 +2436,7 @@ subroutine Summary(this, bounds, num_soilc, filter_soilc, & seed_stock => this%seed_stock_col, & ! total seed mass in gC / m2 ed_to_bgc_this_edts => this%ed_to_bgc_this_edts_col, & ed_to_bgc_last_edts => this%ed_to_bgc_last_edts_col, & - seed_rain_flux => this%seed_rain_flux_col + seed_rain_flux => this%seed_rain_flux_col & ) ! set time steps @@ -2568,7 +2607,10 @@ subroutine ED_BGC_Carbon_Balancecheck(this, bounds, num_soilc, filter_soilc, soi totbgcc => this%totbgcc_col, & ed_to_bgc_this_edts => this%ed_to_bgc_this_edts_col, & ed_to_bgc_last_edts => this%ed_to_bgc_last_edts_col, & - seed_rain_flux => this%seed_rain_flux_col & + seed_rain_flux => this%seed_rain_flux_col, & + cbalance_error_ed => this%cbalance_error_ed_col, & + cbalance_error_bgc => this%cbalance_error_bgc_col, & + cbalance_error_total=> this%cbalance_error_total_col & ) dtime = get_step_size() @@ -2588,6 +2630,10 @@ subroutine ED_BGC_Carbon_Balancecheck(this, bounds, num_soilc, filter_soilc, soi ! also initialize the ed-BGC flux variables ed_to_bgc_this_edts(c) = 0._r8 ed_to_bgc_last_edts(c) = 0._r8 + ! + cbalance_error_ed(c) = 0._r8 + cbalance_error_bgc(c) = 0._r8 + cbalance_error_total(c) = 0._r8 end do endif @@ -2616,21 +2662,29 @@ subroutine ED_BGC_Carbon_Balancecheck(this, bounds, num_soilc, filter_soilc, soi error_bgc(c) = totbgcc(c) - totbgcc_old(c) - (ed_to_bgc_last_edts(c)* SHR_CONST_CDAY - hr_timeintegrated(c)) error_total(c) = totecosysc(c) - totecosysc_old(c) - (nbp_integrated(c) + ed_to_bgc_last_edts(c)* SHR_CONST_CDAY - ed_to_bgc_this_edts(c)* SHR_CONST_CDAY) end do + ! + ! put in consistent flux units and send to history so we can keep track of the errors + do fc = 1,num_soilc + c = filter_soilc(fc) + cbalance_error_ed(c) = error_ed(c) / SHR_CONST_CDAY + cbalance_error_bgc(c) = error_bgc(c) / SHR_CONST_CDAY + cbalance_error_total(c) = error_total(c) / SHR_CONST_CDAY + end do ! for now, rather than crashing the model, lets just report the largest error to see what we're up against ! ! RETURN TO THIS LATER AND ADD A CRASHER IF BALANCE EXCEEDS THRESHOLD ! - max_error_total = 0._r8 - do fc = 1,num_soilc - c = filter_soilc(fc) - if (abs(error_total(c)) .gt. max_error_total) then - max_error_ed = abs(error_ed(c)) - max_error_bgc = abs(error_bgc(c)) - max_error_total = abs(error_total(c)) - endif - end do - write(iulog,*) 'ED_BGC_Carbon_Balancecheck: max_error_ed, max_error_bgc, max_error_total (gC / m2 / day): ', max_error_ed, max_error_bgc, max_error_total + ! max_error_total = 0._r8 + ! do fc = 1,num_soilc + ! c = filter_soilc(fc) + ! if (abs(error_total(c)) .gt. max_error_total) then + ! max_error_ed = abs(error_ed(c)) + ! max_error_bgc = abs(error_bgc(c)) + ! max_error_total = abs(error_total(c)) + ! endif + ! end do + ! write(iulog,*) 'ED_BGC_Carbon_Balancecheck: max_error_ed, max_error_bgc, max_error_total (gC / m2 / day): ', max_error_ed, max_error_bgc, max_error_total ! reset the C stock and flux integrators do fc = 1,num_soilc From 4230198710ab6292d38b6c7b072696bd64e937e1 Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Tue, 22 Mar 2016 11:22:53 -0700 Subject: [PATCH 056/437] changed inline description in EDBGCDynMod and moved it outside the ED subdirectory hierarchy since it properly sits outside the area defined by the interface --- biogeochem/EDBGCDynMod.F90 | 373 ------------------------------------- 1 file changed, 373 deletions(-) delete mode 100644 biogeochem/EDBGCDynMod.F90 diff --git a/biogeochem/EDBGCDynMod.F90 b/biogeochem/EDBGCDynMod.F90 deleted file mode 100644 index fe8acf09..00000000 --- a/biogeochem/EDBGCDynMod.F90 +++ /dev/null @@ -1,373 +0,0 @@ -module EDBGCDynMod - -! Interface from ED calls to CLM belowground biogeochemistry module - - use shr_kind_mod , only : r8 => shr_kind_r8 - use clm_varctl , only : use_c13, use_c14, use_ed - use decompMod , only : bounds_type - use perf_mod , only : t_startf, t_stopf - use clm_varctl , only : use_century_decomp, use_nitrif_denitrif - use CNVegStateType , only : cnveg_state_type - use CNVegCarbonStateType , only : cnveg_carbonstate_type - use CNVegCarbonFluxType , only : cnveg_carbonflux_type - use CNVegNitrogenStateType , only : cnveg_nitrogenstate_type - use CNVegNitrogenFluxType , only : cnveg_nitrogenflux_type - use SoilBiogeochemStateType , only : soilbiogeochem_state_type - use SoilBiogeochemCarbonStateType , only : soilbiogeochem_carbonstate_type - use SoilBiogeochemCarbonFluxType , only : soilbiogeochem_carbonflux_type - use SoilBiogeochemNitrogenStateType , only : soilbiogeochem_nitrogenstate_type - use SoilBiogeochemNitrogenFluxType , only : soilbiogeochem_nitrogenflux_type - use EDCLMLinkMod , only : ed_clm_type - use CanopyStateType , only : canopystate_type - use SoilStateType , only : soilstate_type - use SoilHydrologyType , only : soilhydrology_type - use TemperatureType , only : temperature_type - use WaterstateType , only : waterstate_type - use WaterfluxType , only : waterflux_type - use atm2lndType , only : atm2lnd_type - use SoilStateType , only : soilstate_type - use ch4Mod , only : ch4_type - use EDtypesMod , only : ed_site_type - - ! public :: EDBGCDynInit ! BGC dynamics: initialization - public :: EDBGCDyn ! BGC Dynamics - public :: EDBGCDynSummary ! BGC dynamics: summary - -contains - - - !----------------------------------------------------------------------- - subroutine EDBGCDyn(bounds, & - num_soilc, filter_soilc, num_soilp, filter_soilp, num_pcropp, filter_pcropp, doalb, & - cnveg_state_inst, & - cnveg_carbonflux_inst, cnveg_carbonstate_inst, & - ed_clm_inst, & - soilbiogeochem_carbonflux_inst, soilbiogeochem_carbonstate_inst, & - soilbiogeochem_state_inst, & - soilbiogeochem_nitrogenflux_inst, soilbiogeochem_nitrogenstate_inst, & - c13_soilbiogeochem_carbonstate_inst, c13_soilbiogeochem_carbonflux_inst, & - c14_soilbiogeochem_carbonstate_inst, c14_soilbiogeochem_carbonflux_inst, & - atm2lnd_inst, waterstate_inst, waterflux_inst, & - canopystate_inst, soilstate_inst, temperature_inst, crop_inst, ch4_inst) - ! - ! !DESCRIPTION: - - ! - ! !USES: - use clm_varpar , only: crop_prog, nlevgrnd, nlevdecomp_full - use clm_varpar , only: nlevdecomp, ndecomp_cascade_transitions, ndecomp_pools - use subgridAveMod , only: p2c - use CropType , only: crop_type - use CNNDynamicsMod , only: CNNDeposition,CNNFixation, CNNFert, CNSoyfix - use CNMRespMod , only: CNMResp - use CNPhenologyMod , only: CNPhenology - use CNGRespMod , only: CNGResp - use CNFireMod , only: CNFireArea, CNFireFluxes - use CNCIsoFluxMod , only: CIsoFlux1, CIsoFlux2, CIsoFlux2h, CIsoFlux3 - use CNC14DecayMod , only: C14Decay - use CNWoodProductsMod , only: CNWoodProducts - use CNCStateUpdate1Mod , only: CStateUpdate1,CStateUpdate0 - use CNCStateUpdate2Mod , only: CStateUpdate2, CStateUpdate2h - use CNCStateUpdate3Mod , only: CStateUpdate3 - use CNNStateUpdate1Mod , only: NStateUpdate1 - use CNNStateUpdate2Mod , only: NStateUpdate2, NStateUpdate2h - use CNGapMortalityMod , only: CNGapMortality - use dynHarvestMod , only: CNHarvest - use SoilBiogeochemDecompCascadeBGCMod , only: decomp_rate_constants_bgc - use SoilBiogeochemDecompCascadeCNMod , only: decomp_rate_constants_cn - use SoilBiogeochemCompetitionMod , only: SoilBiogeochemCompetition - use SoilBiogeochemDecompMod , only: SoilBiogeochemDecomp - use SoilBiogeochemLittVertTranspMod , only: SoilBiogeochemLittVertTransp - use SoilBiogeochemPotentialMod , only: SoilBiogeochemPotential - use SoilBiogeochemVerticalProfileMod , only: SoilBiogeochemVerticalProfile - use SoilBiogeochemNitrifDenitrifMod , only: SoilBiogeochemNitrifDenitrif - use SoilBiogeochemNStateUpdate1Mod , only: SoilBiogeochemNStateUpdate1 - ! - ! !ARGUMENTS: - type(bounds_type) , intent(in) :: bounds - integer , intent(in) :: num_soilc ! number of soil columns in filter - integer , intent(in) :: filter_soilc(:) ! filter for soil columns - integer , intent(in) :: num_soilp ! number of soil patches in filter - integer , intent(in) :: filter_soilp(:) ! filter for soil patches - integer , intent(in) :: num_pcropp ! number of prog. crop patches in filter - integer , intent(in) :: filter_pcropp(:) ! filter for prognostic crop patches - logical , intent(in) :: doalb ! true = surface albedo calculation time step - type(cnveg_state_type) , intent(inout) :: cnveg_state_inst - type(cnveg_carbonflux_type) , intent(inout) :: cnveg_carbonflux_inst - type(cnveg_carbonstate_type) , intent(inout) :: cnveg_carbonstate_inst - type(ed_clm_type) , intent(inout) :: ed_clm_inst - type(soilbiogeochem_state_type) , intent(inout) :: soilbiogeochem_state_inst - type(soilbiogeochem_carbonflux_type) , intent(inout) :: soilbiogeochem_carbonflux_inst - type(soilbiogeochem_carbonstate_type) , intent(inout) :: soilbiogeochem_carbonstate_inst - type(soilbiogeochem_carbonflux_type) , intent(inout) :: c13_soilbiogeochem_carbonflux_inst - type(soilbiogeochem_carbonstate_type) , intent(inout) :: c13_soilbiogeochem_carbonstate_inst - type(soilbiogeochem_carbonflux_type) , intent(inout) :: c14_soilbiogeochem_carbonflux_inst - type(soilbiogeochem_carbonstate_type) , intent(inout) :: c14_soilbiogeochem_carbonstate_inst - type(soilbiogeochem_nitrogenflux_type) , intent(inout) :: soilbiogeochem_nitrogenflux_inst - type(soilbiogeochem_nitrogenstate_type) , intent(inout) :: soilbiogeochem_nitrogenstate_inst - type(atm2lnd_type) , intent(in) :: atm2lnd_inst - type(waterstate_type) , intent(in) :: waterstate_inst - type(waterflux_type) , intent(in) :: waterflux_inst - type(canopystate_type) , intent(in) :: canopystate_inst - type(soilstate_type) , intent(in) :: soilstate_inst - type(temperature_type) , intent(inout) :: temperature_inst - type(crop_type) , intent(in) :: crop_inst - type(ch4_type) , intent(in) :: ch4_inst - ! - ! !LOCAL VARIABLES: - real(r8):: cn_decomp_pools(bounds%begc:bounds%endc,1:nlevdecomp,1:ndecomp_pools) - real(r8):: p_decomp_cpool_loss(bounds%begc:bounds%endc,1:nlevdecomp,1:ndecomp_cascade_transitions) !potential C loss from one pool to another - real(r8):: pmnf_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,1:ndecomp_cascade_transitions) !potential mineral N flux, from one pool to another - real(r8):: arepr(bounds%begp:bounds%endp) ! reproduction allocation coefficient (only used for crop_prog) - real(r8):: aroot(bounds%begp:bounds%endp) ! root allocation coefficient (only used for crop_prog) - integer :: begp,endp - integer :: begc,endc - !----------------------------------------------------------------------- - - begp = bounds%begp; endp = bounds%endp - begc = bounds%begc; endc = bounds%endc - - !real(r8) , intent(in) :: rootfr_patch(bounds%begp:, 1:) - !integer , intent(in) :: altmax_lastyear_indx_col(bounds%begc:) ! frost table depth (m) - - associate( & - rootfr_patch => soilstate_inst%rootfr_patch , & ! fraction of roots in each soil layer (nlevgrnd) - altmax_lastyear_indx_col => canopystate_inst%altmax_lastyear_indx_col , & ! frost table depth (m) - laisun => canopystate_inst%laisun_patch , & ! Input: [real(r8) (:) ] sunlit projected leaf area index - laisha => canopystate_inst%laisha_patch , & ! Input: [real(r8) (:) ] shaded projected leaf area index - frac_veg_nosno => canopystate_inst%frac_veg_nosno_patch , & ! Input: [integer (:) ] fraction of vegetation not covered by snow (0 OR 1) [-] - frac_veg_nosno_alb => canopystate_inst%frac_veg_nosno_alb_patch , & ! Output: [integer (:) ] frac of vegetation not covered by snow [-] - tlai => canopystate_inst%tlai_patch , & ! Input: [real(r8) (:) ] one-sided leaf area index, no burying by snow - tsai => canopystate_inst%tsai_patch , & ! Input: [real(r8) (:) ] one-sided stem area index, no burying by snow - elai => canopystate_inst%elai_patch , & ! Output: [real(r8) (:) ] one-sided leaf area index with burying by snow - esai => canopystate_inst%esai_patch , & ! Output: [real(r8) (:) ] one-sided stem area index with burying by snow - htop => canopystate_inst%htop_patch , & ! Output: [real(r8) (:) ] canopy top (m) - hbot => canopystate_inst%hbot_patch & ! Output: [real(r8) (:) ] canopy bottom (m) - ) - - ! -------------------------------------------------- - ! zero the column-level C and N fluxes - ! -------------------------------------------------- - - call t_startf('BGCZero') - - call soilbiogeochem_carbonflux_inst%SetValues( & - num_soilc, filter_soilc, 0._r8) - if ( use_c13 ) then - call c13_soilbiogeochem_carbonflux_inst%SetValues( & - num_soilc, filter_soilc, 0._r8) - end if - if ( use_c14 ) then - call c14_soilbiogeochem_carbonflux_inst%SetValues( & - num_soilc, filter_soilc, 0._r8) - end if - - call t_stopf('BGCZero') - - ! -------------------------------------------------- - ! Nitrogen Deposition, Fixation and Respiration - ! -------------------------------------------------- - - ! call t_startf('CNDeposition') - ! call CNNDeposition(bounds, & - ! atm2lnd_inst, soilbiogeochem_nitrogenflux_inst) - ! call t_stopf('CNDeposition') - - - ! if (crop_prog) then - ! call CNNFert(bounds, num_soilc,filter_soilc, & - ! cnveg_nitrogenflux_inst, soilbiogeochem_nitrogenflux_inst) - - ! call CNSoyfix (bounds, num_soilc, filter_soilc, num_soilp, filter_soilp, & - ! waterstate_inst, crop_inst, cnveg_state_inst, cnveg_nitrogenflux_inst , & - ! soilbiogeochem_state_inst, soilbiogeochem_nitrogenstate_inst, soilbiogeochem_nitrogenflux_inst) - ! end if - - !-------------------------------------------- - ! Soil Biogeochemistry - !-------------------------------------------- - - if (use_century_decomp) then - call decomp_rate_constants_bgc(bounds, num_soilc, filter_soilc, & - canopystate_inst, soilstate_inst, temperature_inst, ch4_inst, soilbiogeochem_carbonflux_inst) - else - call decomp_rate_constants_cn(bounds, num_soilc, filter_soilc, & - canopystate_inst, soilstate_inst, temperature_inst, ch4_inst, soilbiogeochem_carbonflux_inst) - end if - - ! calculate potential decomp rates and total immobilization demand (previously inlined in CNDecompAlloc) - call SoilBiogeochemPotential (bounds, num_soilc, filter_soilc, & - soilbiogeochem_state_inst, soilbiogeochem_carbonstate_inst, soilbiogeochem_carbonflux_inst, & - soilbiogeochem_nitrogenstate_inst, soilbiogeochem_nitrogenflux_inst, & - cn_decomp_pools=cn_decomp_pools(begc:endc,1:nlevdecomp,1:ndecomp_pools), & - p_decomp_cpool_loss=p_decomp_cpool_loss(begc:endc,1:nlevdecomp,1:ndecomp_cascade_transitions), & - pmnf_decomp_cascade=pmnf_decomp_cascade(begc:endc,1:nlevdecomp,1:ndecomp_cascade_transitions)) - - - !-------------------------------------------- - ! Resolve the competition between plants and soil heterotrophs - ! for available soil mineral N resource - !-------------------------------------------- - ! will add this back in when integrtating hte nutirent cycles - - - !-------------------------------------------- - ! Calculate litter and soil decomposition rate - !-------------------------------------------- - - ! Calculation of actual immobilization and decomp rates, following - ! resolution of plant/heterotroph competition for mineral N (previously inlined in CNDecompAllocation in CNDecompMod) - - call t_startf('SoilBiogeochemDecomp') - - call SoilBiogeochemDecomp (bounds, num_soilc, filter_soilc, & - soilbiogeochem_state_inst, soilbiogeochem_carbonstate_inst, soilbiogeochem_carbonflux_inst, & - soilbiogeochem_nitrogenstate_inst, soilbiogeochem_nitrogenflux_inst, & - cn_decomp_pools=cn_decomp_pools(begc:endc,1:nlevdecomp,1:ndecomp_pools), & - p_decomp_cpool_loss=p_decomp_cpool_loss(begc:endc,1:nlevdecomp,1:ndecomp_cascade_transitions), & - pmnf_decomp_cascade=pmnf_decomp_cascade(begc:endc,1:nlevdecomp,1:ndecomp_cascade_transitions)) - - call t_stopf('SoilBiogeochemDecomp') - - - !-------------------------------------------- - ! Update1 - !-------------------------------------------- - - call t_startf('BNGCUpdate1') - - - ! Update all prognostic carbon state variables (except for gap-phase mortality and fire fluxes) - call CStateUpdate1( num_soilc, filter_soilc, num_soilp, filter_soilp, & - cnveg_state_inst, cnveg_carbonflux_inst, cnveg_carbonstate_inst, & - ed_clm_inst, & - soilbiogeochem_carbonflux_inst) - - call t_stopf('BNGCUpdate1') - - !-------------------------------------------- - ! Calculate vertical mixing of soil and litter pools - !-------------------------------------------- - - call t_startf('SoilBiogeochemLittVertTransp') - - call SoilBiogeochemLittVertTransp(bounds, num_soilc, filter_soilc, & - canopystate_inst, soilbiogeochem_state_inst, & - soilbiogeochem_carbonstate_inst, soilbiogeochem_carbonflux_inst, & - c13_soilbiogeochem_carbonstate_inst, c13_soilbiogeochem_carbonflux_inst, & - c14_soilbiogeochem_carbonstate_inst, c14_soilbiogeochem_carbonflux_inst, & - soilbiogeochem_nitrogenstate_inst, soilbiogeochem_nitrogenflux_inst) - - call t_stopf('SoilBiogeochemLittVertTransp') - - end associate - - end subroutine EDBGCDyn - - - !----------------------------------------------------------------------- - subroutine EDBGCDynSummary(bounds, num_soilc, filter_soilc, num_soilp, filter_soilp, & - soilbiogeochem_carbonflux_inst, soilbiogeochem_carbonstate_inst, & - c13_soilbiogeochem_carbonflux_inst, c13_soilbiogeochem_carbonstate_inst, & - c14_soilbiogeochem_carbonflux_inst, c14_soilbiogeochem_carbonstate_inst, & - soilbiogeochem_nitrogenflux_inst, soilbiogeochem_nitrogenstate_inst, & - ed_clm_inst, ed_allsites_inst) - ! - ! !DESCRIPTION: - ! Call to all CN and SoilBiogeochem summary routines - ! also aggregate production and decomposition fluxes to whole-ecosystem balance fluxes - ! - ! !USES: - use clm_varpar , only: ndecomp_cascade_transitions - use CNPrecisionControlMod , only: CNPrecisionControl - use SoilBiogeochemPrecisionControlMod , only: SoilBiogeochemPrecisionControl - ! - ! !ARGUMENTS: - type(bounds_type) , intent(in) :: bounds - integer , intent(in) :: num_soilc ! number of soil columns in filter - integer , intent(in) :: filter_soilc(:) ! filter for soil columns - integer , intent(in) :: num_soilp ! number of soil patches in filter - integer , intent(in) :: filter_soilp(:) ! filter for soil patches - type(soilbiogeochem_carbonflux_type) , intent(inout) :: soilbiogeochem_carbonflux_inst - type(soilbiogeochem_carbonstate_type) , intent(inout) :: soilbiogeochem_carbonstate_inst - type(soilbiogeochem_carbonflux_type) , intent(inout) :: c13_soilbiogeochem_carbonflux_inst - type(soilbiogeochem_carbonstate_type) , intent(inout) :: c13_soilbiogeochem_carbonstate_inst - type(soilbiogeochem_carbonflux_type) , intent(inout) :: c14_soilbiogeochem_carbonflux_inst - type(soilbiogeochem_carbonstate_type) , intent(inout) :: c14_soilbiogeochem_carbonstate_inst - type(soilbiogeochem_nitrogenflux_type) , intent(inout) :: soilbiogeochem_nitrogenflux_inst - type(soilbiogeochem_nitrogenstate_type) , intent(inout) :: soilbiogeochem_nitrogenstate_inst - type(ed_clm_type) , intent(inout) :: ed_clm_inst - type(ed_site_type) , intent(inout), target :: ed_allsites_inst( bounds%begg: ) - ! - ! !LOCAL VARIABLES: - integer :: begc,endc - !----------------------------------------------------------------------- - - begc = bounds%begc; endc= bounds%endc - - ! Call to all summary routines - - call t_startf('BGCsum') - - ! Set controls on very low values in critical state variables - - call SoilBiogeochemPrecisionControl(num_soilc, filter_soilc, & - soilbiogeochem_carbonstate_inst, c13_soilbiogeochem_carbonstate_inst, & - c14_soilbiogeochem_carbonstate_inst,soilbiogeochem_nitrogenstate_inst) - - ! Note - all summary updates to cnveg_carbonstate_inst and cnveg_carbonflux_inst are done in - ! soilbiogeochem_carbonstate_inst%summary and CNVeg_carbonstate_inst%summary - - ! ---------------------------------------------- - ! soilbiogeochem carbon/nitrogen state summary - ! ---------------------------------------------- - - call soilbiogeochem_carbonstate_inst%summary(bounds, num_soilc, filter_soilc) - if ( use_c13 ) then - call c13_soilbiogeochem_carbonstate_inst%summary(bounds, num_soilc, filter_soilc) - end if - if ( use_c14 ) then - call c14_soilbiogeochem_carbonstate_inst%summary(bounds, num_soilc, filter_soilc) - end if - ! call soilbiogeochem_nitrogenstate_inst%summary(bounds, num_soilc, filter_soilc) - - ! ---------------------------------------------- - ! soilbiogeochem carbon/nitrogen flux summary - ! ---------------------------------------------- - - call soilbiogeochem_carbonflux_inst%Summary(bounds, num_soilc, filter_soilc) - if ( use_c13 ) then - call c13_soilbiogeochem_carbonflux_inst%Summary(bounds, num_soilc, filter_soilc) - end if - if ( use_c14 ) then - call c14_soilbiogeochem_carbonflux_inst%Summary(bounds, num_soilc, filter_soilc) - end if - ! call soilbiogeochem_nitrogenflux_inst%Summary(bounds, num_soilc, filter_soilc) - - ! ---------------------------------------------- - ! ed veg carbon state and flux summary - ! ---------------------------------------------- - - call ed_clm_inst%Summary(bounds, num_soilc, filter_soilc, & - ed_allsites_inst(bounds%begg:bounds%endg), & - soilbiogeochem_carbonflux_inst, & - soilbiogeochem_carbonstate_inst) - - ! ---------------------------------------------- - ! ed veg nitrogen flux summary - ! ---------------------------------------------- - - ! TBD... - - ! ---------------------------------------------- - ! calculate balance checks on entire carbon cycle (ED + BGC) - ! ---------------------------------------------- - - call ed_clm_inst%ED_BGC_Carbon_Balancecheck(bounds, num_soilc, filter_soilc, & - soilbiogeochem_carbonflux_inst) - - call t_stopf('BGCsum') - - end subroutine EDBGCDynSummary - -end module EDBGCDynMod From 970d9abb73e6a082b51dc1ca65285d1cb1da7a81 Mon Sep 17 00:00:00 2001 From: Chonggang Xu Date: Tue, 22 Mar 2016 14:29:42 -0600 Subject: [PATCH 057/437] avoid the new cohort fusion to fix nan bug for npp_leaf fix issue #38 --- biogeochem/EDCohortDynamicsMod.F90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 288c8c9d..fa5e4850 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -650,8 +650,7 @@ subroutine fuse_cohorts(patchptr) ! to fuse with other new cohorts to keep the total number of cohorts ! down. - if( (.not.(currentCohort%isnew) .and. .not.(nextc%isnew) ) .or. & - ( currentCohort%isnew .and. nextc%isnew ) ) then + if( .not.(currentCohort%isnew) .and. .not.(nextc%isnew) ) then newn = currentCohort%n + nextc%n fusion_took_place = 1 From d20439a8526e39230de6ed127dbbf840033d59b1 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 31 Mar 2016 23:29:48 -0700 Subject: [PATCH 058/437] modifications to enable fpe_traps to pass on gnu --- biogeochem/EDPhysiologyMod.F90 | 9 +++++---- main/EDCLMLinkMod.F90 | 2 +- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 846f8c11..5fd7fc9f 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -190,7 +190,7 @@ subroutine trim_canopy( currentSite ) currentCohort%leaf_cost = currentCohort%leaf_cost * (ED_val_grperc(1) + 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 + 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) + 1._r8) @@ -215,10 +215,11 @@ subroutine trim_canopy( currentSite ) 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 + ! leaf_cost may be uninitialized, removing its diagnostic from the log + ! to allow checking with fpe_traps (RGK) + write(iulog,*) 'nv>4',currentCohort%year_net_uptake(1:6),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 diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 53b79e1f..0aba01ee 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -1453,7 +1453,7 @@ subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & scpf = (ft-1)*nlevsclass_ed+sc ! Flux Variables (must pass a NaN check on growth increment and not be recruits) - if( .not.(isnan(currentCohort%ddbhdt)) .and. .not.(currentCohort%isnew)) then + if( .not.(currentCohort%isnew) ) then ed_gpp_scpf(g,scpf) = ed_gpp_scpf(g,scpf) + n_perm2*currentCohort%gpp ! [kgC/m2/yr] ed_npp_totl_scpf(g,scpf) = ed_npp_totl_scpf(g,scpf) + currentcohort%npp*n_perm2 ed_npp_leaf_scpf(g,scpf) = ed_npp_leaf_scpf(g,scpf) + currentcohort%npp_leaf*n_perm2 From 9e533cdec52c5f1cbd8363e59cb2a4d1b53c5a01 Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Wed, 6 Apr 2016 21:24:41 -0700 Subject: [PATCH 059/437] first set of changes to summary fluxes --- main/EDCLMLinkMod.F90 | 142 +++++++++++++++++++++++------------------- 1 file changed, 78 insertions(+), 64 deletions(-) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 53b79e1f..4cb76e3e 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -84,8 +84,15 @@ module EDCLMLinkMod ! real(r8), pointer, private :: deadstemc_patch (:) ! (gC/m2) dead stem C ! real(r8), pointer, private :: livestemn_patch (:) ! (gN/m2) live stem N + ! vegetation carbon fluxes at the patch scale 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 + real(r8), pointer, private :: ar_patch (:) ! (gC/m2/s) patch autotrophic respiration + real(r8), pointer, private :: root_resp_patch (:) ! (gC/m2/s) patch root respitation + real(r8), pointer, private :: stem_resp_patch (:) ! (gC/m2/s) patch stem respiration + real(r8), pointer, private :: leaf_resp_patch (:) ! (gC/m2/s) patch leaf respiration + real(r8), pointer, private :: maint_resp_patch (:) ! (gC/m2/s) patch maintenance respiration + real(r8), pointer, private :: growth_resp_patch (:) ! (gC/m2/s) patch growth respiration real(r8), pointer :: ed_gpp_gd_scpf (:,:) ! [kg/m2/yr] gross primary production real(r8), pointer :: ed_npp_totl_gd_scpf (:,:) ! [kg/m2/yr] net primary production (npp) @@ -118,43 +125,44 @@ module EDCLMLinkMod real(r8), pointer :: ed_m5_gd_scpf (:,:) ! [Stems/ha/yr] Mean Fire Mortality ! litterfall fluxes of C from ED patches to BGC columns - real(r8), pointer, public :: ED_c_to_litr_lab_c_col(:,:) !total labile litter coming from ED. gC/m3/s real(r8), pointer, public :: ED_c_to_litr_cel_c_col(:,:) !total cellulose litter coming from ED. gC/m3/s real(r8), pointer, public :: ED_c_to_litr_lig_c_col(:,:) !total lignin litter coming from ED. gC/m3/s + + ! profiles for vertically disaggregating litterfall fluxes real(r8), pointer, private :: leaf_prof_col(:,:) !(1/m) profile of leaves real(r8), pointer, private :: froot_prof_col(:,:,:) !(1/m) profile of fine roots real(r8), pointer, private :: croot_prof_col(:,:) !(1/m) profile of coarse roots real(r8), pointer, private :: stem_prof_col(:,:) !(1/m) profile of leaves ! summary carbon fluxes at the column level - real(r8), pointer, public :: nep_col(:) ! [gC/m2/s] Net ecosystem production, i.e. fast-timescale carbon balance that does not include disturbance - real(r8), pointer, public :: nep_timeintegrated_col(:) ! [gC/m2/s] Net ecosystem production, i.e. fast-timescale carbon balance that does not include disturbance - real(r8), pointer, public :: npp_timeintegrated_col(:) ! [gC/m2/s] Net primary production, time integrated at column level for carbon balance checking - real(r8), pointer, public :: hr_timeintegrated_col(:) ! [gC/m2/s] heterotrophic respiration, time integrated for carbon balance checking - real(r8), pointer, public :: nbp_col(:) ! [gC/m2/s] Net biosphere production, i.e. slow-timescale carbon balance that integrates to total carbon change - real(r8), pointer, public :: npp_hifreq_col(:) ! [gC/m2/s] Net primary production at the fast timescale, aggregated to the column level - real(r8), pointer, public :: fire_c_to_atm_col(:) ! [gC/m2/s] total fire carbon loss to atmosphere - real(r8), pointer, public :: ed_to_bgc_this_edts_col(:) ! [gC/m2/s] total flux of carbon from ED to BGC models on current ED timestep - real(r8), pointer, public :: ed_to_bgc_last_edts_col(:) ! [gC/m2/s] total flux of carbon from ED to BGC models on prior ED timestep - real(r8), pointer, public :: seed_rain_flux_col(:) ! [gC/m2/s] total flux of carbon from seed rain + real(r8), pointer, private :: nep_col(:) ! [gC/m2/s] Net ecosystem production, i.e. fast-timescale carbon balance that does not include disturbance + real(r8), pointer, private :: nep_timeintegrated_col(:) ! [gC/m2/s] Net ecosystem production, i.e. fast-timescale carbon balance that does not include disturbance + real(r8), pointer, private :: npp_timeintegrated_col(:) ! [gC/m2/s] Net primary production, time integrated at column level for carbon balance checking + real(r8), pointer, private :: hr_timeintegrated_col(:) ! [gC/m2/s] heterotrophic respiration, time integrated for carbon balance checking + real(r8), pointer, private :: nbp_col(:) ! [gC/m2/s] Net biosphere production, i.e. slow-timescale carbon balance that integrates to total carbon change + real(r8), pointer, private :: npp_hifreq_col(:) ! [gC/m2/s] Net primary production at the fast timescale, aggregated to the column level + real(r8), pointer, private :: fire_c_to_atm_col(:) ! [gC/m2/s] total fire carbon loss to atmosphere + real(r8), pointer, private :: ed_to_bgc_this_edts_col(:) ! [gC/m2/s] total flux of carbon from ED to BGC models on current ED timestep + real(r8), pointer, private :: ed_to_bgc_last_edts_col(:) ! [gC/m2/s] total flux of carbon from ED to BGC models on prior ED timestep + real(r8), pointer, private :: seed_rain_flux_col(:) ! [gC/m2/s] total flux of carbon from seed rain ! summary carbon states at the column level - real(r8), pointer, public :: totecosysc_col(:) ! [gC/m2] Total ecosystem carbon at the column level, including vegetation, CWD, litter, and soil pools - real(r8), pointer, public :: totecosysc_old_col(:) ! [gC/m2] Total ecosystem C at the column level from last call to balance check - real(r8), pointer, public :: totedc_col(:) ! [gC/m2] Total ED carbon at the column level, including vegetation, CWD, seeds, and ED litter - real(r8), pointer, public :: totedc_old_col(:) ! [gC/m2] Total ED C at the column level from last call to balance check - real(r8), pointer, public :: totbgcc_col(:) ! [gC/m2] Total BGC carbon at the column level, including litter, and soil pools - real(r8), pointer, public :: totbgcc_old_col(:) ! [gC/m2] Total BGC C at the column level from last call to balance check - real(r8), pointer, public :: biomass_stock_col(:) ! [gC/m2] total biomass at the column level in gC / m2 - real(r8), pointer, public :: ed_litter_stock_col(:) ! [gC/m2] ED litter at the column level in gC / m2 - real(r8), pointer, public :: cwd_stock_col(:) ! [gC/m2] ED CWD at the column level in gC / m2 - real(r8), pointer, public :: seed_stock_col(:) ! [gC/m2] ED seed mass carbon at the column level in gC / m2 + real(r8), pointer, private :: totecosysc_col(:) ! [gC/m2] Total ecosystem carbon at the column level, including vegetation, CWD, litter, and soil pools + real(r8), pointer, private :: totecosysc_old_col(:) ! [gC/m2] Total ecosystem C at the column level from last call to balance check + real(r8), pointer, private :: totedc_col(:) ! [gC/m2] Total ED carbon at the column level, including vegetation, CWD, seeds, and ED litter + real(r8), pointer, private :: totedc_old_col(:) ! [gC/m2] Total ED C at the column level from last call to balance check + real(r8), pointer, private :: totbgcc_col(:) ! [gC/m2] Total BGC carbon at the column level, including litter, and soil pools + real(r8), pointer, private :: totbgcc_old_col(:) ! [gC/m2] Total BGC C at the column level from last call to balance check + real(r8), pointer, private :: biomass_stock_col(:) ! [gC/m2] total biomass at the column level in gC / m2 + real(r8), pointer, private :: ed_litter_stock_col(:) ! [gC/m2] ED litter at the column level in gC / m2 + real(r8), pointer, private :: cwd_stock_col(:) ! [gC/m2] ED CWD at the column level in gC / m2 + real(r8), pointer, private :: seed_stock_col(:) ! [gC/m2] ED seed mass carbon at the column level in gC / m2 ! carbon balance errors. at some point we'll reduce these to close to zero and delete, but for now we'll just keep[ track of them - real(r8), pointer, public :: cbalance_error_ed_col(:) ! [gC/m2/s] total carbon balance error for the ED side - real(r8), pointer, public :: cbalance_error_bgc_col(:) ! [gC/m2/s] total carbon balance error for the BGC side - real(r8), pointer, public :: cbalance_error_total_col(:) ! [gC/m2/s] total carbon balance error for the whole thing + real(r8), pointer, private :: cbalance_error_ed_col(:) ! [gC/m2/s] total carbon balance error for the ED side + real(r8), pointer, private :: cbalance_error_bgc_col(:) ! [gC/m2/s] total carbon balance error for the BGC side + real(r8), pointer, private :: cbalance_error_total_col(:) ! [gC/m2/s] total carbon balance error for the whole thing contains @@ -264,6 +272,12 @@ subroutine InitAllocate(this, bounds) allocate(this%gpp_patch (begp:endp)) ; this%gpp_patch (:) = nan allocate(this%npp_patch (begp:endp)) ; this%npp_patch (:) = nan + allocate(this%ar_patch (begp:endp)) ; this%ar_patch (:) = nan + allocate(this%root_resp_patch (begp:endp)) ; this%root_resp_patch (:) = nan + allocate(this%stem_resp_patch (begp:endp)) ; this%stem_resp_patch (:) = nan + allocate(this%leaf_resp_patch (begp:endp)) ; this%leaf_resp_patch (:) = nan + allocate(this%maint_resp_patch (begp:endp)) ; this%maint_resp_patch (:) = nan + allocate(this%growth_resp_patch (begp:endp)) ; this%growth_resp_patch (:) = nan allocate(this%ED_c_to_litr_lab_c_col (begc:endc,1:nlevdecomp_full)) ; this%ED_c_to_litr_lab_c_col (:,:) = nan allocate(this%ED_c_to_litr_cel_c_col (begc:endc,1:nlevdecomp_full)) ; this%ED_c_to_litr_cel_c_col (:,:) = nan @@ -495,36 +509,6 @@ subroutine InitHistory(this, bounds) 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', & @@ -535,6 +519,36 @@ subroutine InitHistory(this, bounds) avgflag='A', long_name='net primary production', & ptr_patch=this%npp_patch) + this%npp_patch(begp:endp) = spval + call hist_addfld1d (fname='AR', units='gC/m^2/s', & + avgflag='A', long_name='autotrophic respiration', & + ptr_patch=this%ar_patch) + + this%npp_patch(begp:endp) = spval + call hist_addfld1d (fname='ROOT_RESP', units='gC/m^2/s', & + avgflag='A', long_name='root respiration', & + ptr_patch=this%root_resp_patch) + + this%npp_patch(begp:endp) = spval + call hist_addfld1d (fname='STEM_RESP', units='gC/m^2/s', & + avgflag='A', long_name='stem respiration', & + ptr_patch=this%stem_resp_patch) + + this%npp_patch(begp:endp) = spval + call hist_addfld1d (fname='LEAF_RESP', units='gC/m^2/s', & + avgflag='A', long_name='leaf respiration', & + ptr_patch=this%leaf_resp_patch) + + this%npp_patch(begp:endp) = spval + call hist_addfld1d (fname='GROWTH_RESP', units='gC/m^2/s', & + avgflag='A', long_name='growth respiration', & + ptr_patch=this%growth_resp_patch) + + this%npp_patch(begp:endp) = spval + call hist_addfld1d (fname='MAINT_RESP', units='gC/m^2/s', & + avgflag='A', long_name='maintenance respiration', & + ptr_patch=this%maint_resp_patch) + this%nep_col(begc:endc) = spval call hist_addfld1d (fname='NEP', units='gC/m^2/s', & avgflag='A', long_name='net ecosystem production', & @@ -551,8 +565,8 @@ subroutine InitHistory(this, bounds) ptr_col=this%nbp_col) this%npp_hifreq_col(begc:endc) = spval - call hist_addfld1d (fname='NPP_hifreq', units='gC/m^2/s', & - avgflag='A', long_name='net primary production at high frequency', & + call hist_addfld1d (fname='NPP_column', units='gC/m^2/s', & + avgflag='A', long_name='net primary production on column level at high frequency', & ptr_col=this%npp_hifreq_col,default='inactive') this%totecosysc_col(begc:endc) = spval @@ -1274,8 +1288,8 @@ subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & phen_cd_status => ed_phenology_inst%phen_cd_status_patch , & ! InOut: - gpp => this%gpp_patch , & ! Output: - npp => this%npp_patch , & ! Output: + ! gpp => this%gpp_patch , & ! Output: + ! npp => this%npp_patch , & ! Output: ed_gpp_scpf => this%ed_gpp_gd_scpf , & ed_npp_totl_scpf => this%ed_npp_totl_gd_scpf , & @@ -1316,8 +1330,8 @@ subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & PFTleafbiomass(:,:) = 0.0_r8 PFTstorebiomass(:,:) = 0.0_r8 PFTnindivs(:,:) = 0.0_r8 - gpp(:) = 0.0_r8 - npp(:) = 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 @@ -1378,8 +1392,8 @@ subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & 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 + ! 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 @@ -1441,8 +1455,8 @@ subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & ED_biomass(p) = ED_biomass(p) + n_density * currentCohort%b * 1.e3_r8 ED_bdead(p) = ED_bdead(p) + n_density * currentCohort%bdead * 1.e3_r8 ED_balive(p) = ED_balive(p) + n_density * currentCohort%balive * 1.e3_r8 - npp(p) = npp(p) + n_density * currentCohort%npp * 1.e3_r8 / (365. * SHR_CONST_CDAY) - gpp(p) = gpp(p) + n_density * currentCohort%gpp * 1.e3_r8 / (365. * SHR_CONST_CDAY) + ! npp(p) = npp(p) + n_density * currentCohort%npp * 1.e3_r8 / (365. * SHR_CONST_CDAY) + ! gpp(p) = gpp(p) + n_density * currentCohort%gpp * 1.e3_r8 / (365. * SHR_CONST_CDAY) PFTbiomass(p,ft) = PFTbiomass(p,ft) + n_density * currentCohort%b * 1.e3_r8 PFTleafbiomass(p,ft) = PFTleafbiomass(p,ft) + n_density * currentCohort%bl * 1.e3_r8 PFTstorebiomass(p,ft) = PFTstorebiomass(p,ft) + n_density * currentCohort%bstore * 1.e3_r8 From 6d315c530326aa40ae5dc62e457750f8783ebb51 Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Thu, 7 Apr 2016 13:52:56 -0700 Subject: [PATCH 060/437] second set of changes to summary fluxes --- main/EDCLMLinkMod.F90 | 55 +++++++++++++++++++++++-------------------- 1 file changed, 29 insertions(+), 26 deletions(-) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 4cb76e3e..911153e3 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -88,9 +88,6 @@ module EDCLMLinkMod 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 real(r8), pointer, private :: ar_patch (:) ! (gC/m2/s) patch autotrophic respiration - real(r8), pointer, private :: root_resp_patch (:) ! (gC/m2/s) patch root respitation - real(r8), pointer, private :: stem_resp_patch (:) ! (gC/m2/s) patch stem respiration - real(r8), pointer, private :: leaf_resp_patch (:) ! (gC/m2/s) patch leaf respiration real(r8), pointer, private :: maint_resp_patch (:) ! (gC/m2/s) patch maintenance respiration real(r8), pointer, private :: growth_resp_patch (:) ! (gC/m2/s) patch growth respiration @@ -273,9 +270,6 @@ subroutine InitAllocate(this, bounds) allocate(this%gpp_patch (begp:endp)) ; this%gpp_patch (:) = nan allocate(this%npp_patch (begp:endp)) ; this%npp_patch (:) = nan allocate(this%ar_patch (begp:endp)) ; this%ar_patch (:) = nan - allocate(this%root_resp_patch (begp:endp)) ; this%root_resp_patch (:) = nan - allocate(this%stem_resp_patch (begp:endp)) ; this%stem_resp_patch (:) = nan - allocate(this%leaf_resp_patch (begp:endp)) ; this%leaf_resp_patch (:) = nan allocate(this%maint_resp_patch (begp:endp)) ; this%maint_resp_patch (:) = nan allocate(this%growth_resp_patch (begp:endp)) ; this%growth_resp_patch (:) = nan @@ -519,32 +513,17 @@ subroutine InitHistory(this, bounds) avgflag='A', long_name='net primary production', & ptr_patch=this%npp_patch) - this%npp_patch(begp:endp) = spval + this%ar_patch(begp:endp) = spval call hist_addfld1d (fname='AR', units='gC/m^2/s', & avgflag='A', long_name='autotrophic respiration', & ptr_patch=this%ar_patch) - this%npp_patch(begp:endp) = spval - call hist_addfld1d (fname='ROOT_RESP', units='gC/m^2/s', & - avgflag='A', long_name='root respiration', & - ptr_patch=this%root_resp_patch) - - this%npp_patch(begp:endp) = spval - call hist_addfld1d (fname='STEM_RESP', units='gC/m^2/s', & - avgflag='A', long_name='stem respiration', & - ptr_patch=this%stem_resp_patch) - - this%npp_patch(begp:endp) = spval - call hist_addfld1d (fname='LEAF_RESP', units='gC/m^2/s', & - avgflag='A', long_name='leaf respiration', & - ptr_patch=this%leaf_resp_patch) - - this%npp_patch(begp:endp) = spval + this%growth_resp_patch(begp:endp) = spval call hist_addfld1d (fname='GROWTH_RESP', units='gC/m^2/s', & avgflag='A', long_name='growth respiration', & ptr_patch=this%growth_resp_patch) - this%npp_patch(begp:endp) = spval + this%maint_resp_patch(begp:endp) = spval call hist_addfld1d (fname='MAINT_RESP', units='gC/m^2/s', & avgflag='A', long_name='maintenance respiration', & ptr_patch=this%maint_resp_patch) @@ -2427,7 +2406,7 @@ subroutine Summary(this, bounds, num_soilc, filter_soilc, & ! !LOCAL VARIABLES: real(r8) :: npp_hifreq_col(bounds%begc:bounds%endc) ! column-level, high frequency NPP real(r8) :: dt ! radiation time step (seconds) - integer :: c, g, cc, fc, l + integer :: c, g, cc, fc, l, p, pp type(ed_site_type), pointer :: cs type (ed_patch_type) , pointer :: currentPatch type (ed_cohort_type) , pointer :: currentCohort @@ -2438,6 +2417,11 @@ subroutine Summary(this, bounds, num_soilc, filter_soilc, & totsomc => soilbiogeochem_carbonstate_inst%totsomc_col, & ! (gC/m2) total soil organic matter carbon totlitc => soilbiogeochem_carbonstate_inst%totlitc_col, & ! (gC/m2) total litter carbon in BGC pools npp_hifreq => this%npp_hifreq_col, & + npp => this%npp_patch, & + gpp => this%gpp_patch, & + ar => this%ar_patch, & + groth_resp => this%growth_resp_patch, & + maint_resp => this%maint_resp_patch, & nep => this%nep_col, & fire_c_to_atm => this%fire_c_to_atm_col, & nbp => this%nbp_col, & @@ -2457,6 +2441,7 @@ subroutine Summary(this, bounds, num_soilc, filter_soilc, & dt = real( get_step_size(), r8 ) ! zero variables first + ! column variables do c = bounds%begc,bounds%endc ! summary flux variables npp_hifreq(c) = 0._r8 @@ -2468,6 +2453,15 @@ subroutine Summary(this, bounds, num_soilc, filter_soilc, & seed_stock(c) = 0._r8 biomass_stock(c) = 0._r8 end do + + ! patch variables + do p = bounds%begp,bounds%endp + npp(p) = 0._r8 + gpp(p) = 0._r8 + ar(p) = 0._r8 + growth_resp(p) = 0._r8 + maint_resp(p) = 0._r8 + end do ! retrieve the first soil patch associated with each gridcell. ! make sure we only get the first patch value for places which have soil. @@ -2490,6 +2484,8 @@ subroutine Summary(this, bounds, num_soilc, filter_soilc, & currentPatch => ed_allsites_inst(g)%oldest_patch do while(associated(currentPatch)) + pp = currentPatch%clm_pno + ! map litter, CWD, and seed pools to column level cwd_stock(cc) = cwd_stock(cc) + (currentPatch%area / AREA) * (sum(currentPatch%cwd_ag)+ & sum(currentPatch%cwd_bg)) * 1.e3_r8 @@ -2498,7 +2494,14 @@ subroutine Summary(this, bounds, num_soilc, filter_soilc, & seed_stock(cc) = seed_stock(cc) + (currentPatch%area / AREA) * sum(currentPatch%seed_bank) * 1.e3_r8 currentCohort => currentPatch%tallest - do while(associated(currentCohort)) + do while(associated(currentCohort)) + + ! map ed cohort-level fluxes to clm patch fluxes + npp(pp) = npp(pp) + currentCohort%npp_clm * 1e3 * currentCohort%n / (currentPatch%area * dt) + gpp(pp) = gpp(pp) + currentCohort%gpp_clm * 1e3 * currentCohort%n / (currentPatch%area * dt) + ar(pp) = ar(pp) + currentCohort%resp_clm * 1e3 * currentCohort%n / (currentPatch%area * dt) + growth_resp(pp) = growth_resp(pp) + currentCohort%resp_g * 1e3 * currentCohort%n / (currentPatch%area * dt) + maint_resp(pp) = maint_resp(pp) + currentCohort%resp_m * 1e3 * currentCohort%n / (currentPatch%area * dt) ! map ed cohort-level npp fluxes to clm column fluxes npp_hifreq(cc) = npp_hifreq(cc) + currentCohort%npp_clm * 1e3 * currentCohort%n / ( AREA * dt) From 16d8524c9be21e733bfa7cc98288fc2107665b70 Mon Sep 17 00:00:00 2001 From: ckoven Date: Thu, 7 Apr 2016 15:26:06 -0700 Subject: [PATCH 061/437] compile-time bugs, cleanup, and a first, partial attempt to resolve patch to column issues --- main/EDCLMLinkMod.F90 | 62 +++++++++++++++++++++---------------------- 1 file changed, 31 insertions(+), 31 deletions(-) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 911153e3..5401969d 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -138,7 +138,7 @@ module EDCLMLinkMod real(r8), pointer, private :: npp_timeintegrated_col(:) ! [gC/m2/s] Net primary production, time integrated at column level for carbon balance checking real(r8), pointer, private :: hr_timeintegrated_col(:) ! [gC/m2/s] heterotrophic respiration, time integrated for carbon balance checking real(r8), pointer, private :: nbp_col(:) ! [gC/m2/s] Net biosphere production, i.e. slow-timescale carbon balance that integrates to total carbon change - real(r8), pointer, private :: npp_hifreq_col(:) ! [gC/m2/s] Net primary production at the fast timescale, aggregated to the column level + real(r8), pointer, private :: npp_col(:) ! [gC/m2/s] Net primary production at the fast timescale, aggregated to the column level real(r8), pointer, private :: fire_c_to_atm_col(:) ! [gC/m2/s] total fire carbon loss to atmosphere real(r8), pointer, private :: ed_to_bgc_this_edts_col(:) ! [gC/m2/s] total flux of carbon from ED to BGC models on current ED timestep real(r8), pointer, private :: ed_to_bgc_last_edts_col(:) ! [gC/m2/s] total flux of carbon from ED to BGC models on prior ED timestep @@ -292,7 +292,7 @@ subroutine InitAllocate(this, bounds) allocate(this%hr_timeintegrated_col (begc:endc)) ; this%hr_timeintegrated_col (:) = nan allocate(this%nbp_col (begc:endc)) ; this%nbp_col (:) = nan - allocate(this%npp_hifreq_col (begc:endc)) ; this%npp_hifreq_col (:) = nan + allocate(this%npp_col (begc:endc)) ; this%npp_col (:) = nan allocate(this%fire_c_to_atm_col (begc:endc)) ; this%fire_c_to_atm_col (:) = nan allocate(this%totecosysc_col (begc:endc)) ; this%totecosysc_col (:) = nan @@ -543,10 +543,10 @@ subroutine InitHistory(this, bounds) avgflag='A', long_name='net biosphere production', & ptr_col=this%nbp_col) - this%npp_hifreq_col(begc:endc) = spval + this%npp_col(begc:endc) = spval call hist_addfld1d (fname='NPP_column', units='gC/m^2/s', & - avgflag='A', long_name='net primary production on column level at high frequency', & - ptr_col=this%npp_hifreq_col,default='inactive') + avgflag='A', long_name='net primary production on column level', & + ptr_col=this%npp_col,default='inactive') this%totecosysc_col(begc:endc) = spval call hist_addfld1d (fname='TOTECOSYSC', units='gC/m^2', & @@ -1267,9 +1267,6 @@ subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & phen_cd_status => ed_phenology_inst%phen_cd_status_patch , & ! InOut: - ! gpp => this%gpp_patch , & ! Output: - ! npp => this%npp_patch , & ! Output: - ed_gpp_scpf => this%ed_gpp_gd_scpf , & ed_npp_totl_scpf => this%ed_npp_totl_gd_scpf , & ed_npp_leaf_scpf => this%ed_npp_leaf_gd_scpf , & @@ -1309,8 +1306,6 @@ subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & 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 @@ -1371,8 +1366,6 @@ subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & 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 @@ -1434,8 +1427,6 @@ subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & ED_biomass(p) = ED_biomass(p) + n_density * currentCohort%b * 1.e3_r8 ED_bdead(p) = ED_bdead(p) + n_density * currentCohort%bdead * 1.e3_r8 ED_balive(p) = ED_balive(p) + n_density * currentCohort%balive * 1.e3_r8 - ! npp(p) = npp(p) + n_density * currentCohort%npp * 1.e3_r8 / (365. * SHR_CONST_CDAY) - ! gpp(p) = gpp(p) + n_density * currentCohort%gpp * 1.e3_r8 / (365. * SHR_CONST_CDAY) PFTbiomass(p,ft) = PFTbiomass(p,ft) + n_density * currentCohort%b * 1.e3_r8 PFTleafbiomass(p,ft) = PFTleafbiomass(p,ft) + n_density * currentCohort%bl * 1.e3_r8 PFTstorebiomass(p,ft) = PFTstorebiomass(p,ft) + n_density * currentCohort%bstore * 1.e3_r8 @@ -2391,6 +2382,7 @@ subroutine Summary(this, bounds, num_soilc, filter_soilc, & use ColumnType , only : col use LandunitType , only : lun use landunit_varcon , only : istsoil + use subgridAveMod , only : p2c ! implicit none ! @@ -2404,23 +2396,23 @@ subroutine Summary(this, bounds, num_soilc, filter_soilc, & type(soilbiogeochem_carbonstate_type) , intent(inout) :: soilbiogeochem_carbonstate_inst ! ! !LOCAL VARIABLES: - real(r8) :: npp_hifreq_col(bounds%begc:bounds%endc) ! column-level, high frequency NPP real(r8) :: dt ! radiation time step (seconds) integer :: c, g, cc, fc, l, p, pp type(ed_site_type), pointer :: cs type (ed_patch_type) , pointer :: currentPatch type (ed_cohort_type) , pointer :: currentCohort integer :: firstsoilpatch(bounds%begg:bounds%endg) ! the first patch in this gridcell that is soil and thus bare... + real(r8) :: n_density ! individual of cohort per m2. associate(& hr => soilbiogeochem_carbonflux_inst%hr_col, & ! (gC/m2/s) total heterotrophic respiration totsomc => soilbiogeochem_carbonstate_inst%totsomc_col, & ! (gC/m2) total soil organic matter carbon totlitc => soilbiogeochem_carbonstate_inst%totlitc_col, & ! (gC/m2) total litter carbon in BGC pools - npp_hifreq => this%npp_hifreq_col, & + npp_col => this%npp_col, & npp => this%npp_patch, & gpp => this%gpp_patch, & ar => this%ar_patch, & - groth_resp => this%growth_resp_patch, & + growth_resp => this%growth_resp_patch, & maint_resp => this%maint_resp_patch, & nep => this%nep_col, & fire_c_to_atm => this%fire_c_to_atm_col, & @@ -2444,7 +2436,7 @@ subroutine Summary(this, bounds, num_soilc, filter_soilc, & ! column variables do c = bounds%begc,bounds%endc ! summary flux variables - npp_hifreq(c) = 0._r8 + npp_col(c) = 0._r8 fire_c_to_atm(c) = 0._r8 ! summary stock variables @@ -2485,7 +2477,7 @@ subroutine Summary(this, bounds, num_soilc, filter_soilc, & do while(associated(currentPatch)) pp = currentPatch%clm_pno - + ! map litter, CWD, and seed pools to column level cwd_stock(cc) = cwd_stock(cc) + (currentPatch%area / AREA) * (sum(currentPatch%cwd_ag)+ & sum(currentPatch%cwd_bg)) * 1.e3_r8 @@ -2495,16 +2487,22 @@ subroutine Summary(this, bounds, num_soilc, filter_soilc, & currentCohort => currentPatch%tallest do while(associated(currentCohort)) - + + if(currentPatch%area>0._r8)then + n_density = currentCohort%n/currentPatch%area + else + n_density = 0.0_r8 + endif + ! map ed cohort-level fluxes to clm patch fluxes - npp(pp) = npp(pp) + currentCohort%npp_clm * 1e3 * currentCohort%n / (currentPatch%area * dt) - gpp(pp) = gpp(pp) + currentCohort%gpp_clm * 1e3 * currentCohort%n / (currentPatch%area * dt) - ar(pp) = ar(pp) + currentCohort%resp_clm * 1e3 * currentCohort%n / (currentPatch%area * dt) - growth_resp(pp) = growth_resp(pp) + currentCohort%resp_g * 1e3 * currentCohort%n / (currentPatch%area * dt) - maint_resp(pp) = maint_resp(pp) + currentCohort%resp_m * 1e3 * currentCohort%n / (currentPatch%area * dt) + npp(pp) = npp(pp) + currentCohort%npp_clm * 1.e3_r8 * n_density / dt + gpp(pp) = gpp(pp) + currentCohort%gpp_clm * 1.e3_r8 * n_density / dt + ar(pp) = ar(pp) + currentCohort%resp_clm * 1.e3_r8 * n_density / dt + growth_resp(pp) = growth_resp(pp) + currentCohort%resp_g * 1.e3_r8 * n_density / dt + maint_resp(pp) = maint_resp(pp) + currentCohort%resp_m * 1.e3_r8 * n_density / dt ! map ed cohort-level npp fluxes to clm column fluxes - npp_hifreq(cc) = npp_hifreq(cc) + currentCohort%npp_clm * 1e3 * currentCohort%n / ( AREA * dt) + !npp_col(cc) = npp_col(cc) + currentCohort%npp_clm * 1.e3_r8 * currentCohort%n / ( AREA * dt) ! map biomass pools to column level biomass_stock(cc) = biomass_stock(cc) + (currentCohort%bdead + currentCohort%balive + & @@ -2516,12 +2514,14 @@ subroutine Summary(this, bounds, num_soilc, filter_soilc, & end do !currentPatch end if end do + + call p2c(bounds,num_soilc, filter_soilc, npp(bounds%begp:bounds%endp), npp_col(bounds%begc:bounds%endc)) ! calculate NEP and NBP fluxes. do fc = 1,num_soilc c = filter_soilc(fc) - nep(c) = npp_hifreq(c) - hr(c) - nbp(c) = npp_hifreq(c) - ( hr(c) + fire_c_to_atm(c) ) + nep(c) = npp_col(c) - hr(c) + nbp(c) = npp_col(c) - ( hr(c) + fire_c_to_atm(c) ) end do ! calculate total stocks @@ -2613,7 +2613,7 @@ subroutine ED_BGC_Carbon_Balancecheck(this, bounds, num_soilc, filter_soilc, soi nep_timeintegrated => this%nep_timeintegrated_col, & hr => soilbiogeochem_carbonflux_inst%hr_col, & hr_timeintegrated => this%hr_timeintegrated_col, & - npp_hifreq => this%npp_hifreq_col, & + npp_col => this%npp_col, & npp_timeintegrated => this%npp_timeintegrated_col, & fire_c_to_atm => this%fire_c_to_atm_col, & totecosysc_old => this%totecosysc_old_col, & @@ -2660,7 +2660,7 @@ subroutine ED_BGC_Carbon_Balancecheck(this, bounds, num_soilc, filter_soilc, soi c = filter_soilc(fc) nep_timeintegrated(c) = nep_timeintegrated(c) + nep(c) * dtime hr_timeintegrated(c) = hr_timeintegrated(c) + hr(c) * dtime - npp_timeintegrated(c) = npp_timeintegrated(c) + npp_hifreq(c) * dtime + npp_timeintegrated(c) = npp_timeintegrated(c) + npp_col(c) * dtime end do else ! on ED (daily) timesteps, first integrate the NEP fluxes and add in the daily disturbance flux @@ -2668,7 +2668,7 @@ subroutine ED_BGC_Carbon_Balancecheck(this, bounds, num_soilc, filter_soilc, soi c = filter_soilc(fc) nep_timeintegrated(c) = nep_timeintegrated(c) + nep(c) * dtime hr_timeintegrated(c) = hr_timeintegrated(c) + hr(c) * dtime - npp_timeintegrated(c) = npp_timeintegrated(c) + npp_hifreq(c) * dtime + npp_timeintegrated(c) = npp_timeintegrated(c) + npp_col(c) * dtime nbp_integrated(c) = nep_timeintegrated(c) - fire_c_to_atm(c) * SHR_CONST_CDAY + seed_rain_flux(c)* SHR_CONST_CDAY end do From 4b4a2818a4944beff6a5e19c4539e9c6b472300e Mon Sep 17 00:00:00 2001 From: ckoven Date: Fri, 8 Apr 2016 15:39:55 -0700 Subject: [PATCH 062/437] changed patch weighting of all carbon variables on history file to make them consistent with the patch weighting infrastructure use din albedo code --- main/EDCLMLinkMod.F90 | 39 ++++++++++++++++++++++++++++----------- 1 file changed, 28 insertions(+), 11 deletions(-) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 5401969d..3f67bacb 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -1225,7 +1225,7 @@ subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & integer :: G,p,ft integer :: firstsoilpatch(bounds%begg:bounds%endg) real(r8) :: n_density ! individual of cohort per m2. - real(r8) :: n_perm2 ! individuals per m2 for the whole grid cell + real(r8) :: n_perm2 ! individuals per m2 for the whole column real(r8) :: dbh ! actual dbh used to identify relevant size class integer :: scpf ! size class x pft index integer :: sc @@ -1409,9 +1409,16 @@ subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & do while(associated(currentCohort)) !accumulate into history variables. ft = currentCohort%pft - if(currentPatch%area>0._r8)then - n_density = currentCohort%n/currentPatch%area - n_perm2 = currentCohort%n/AREA ! plant density using whole area (for grid cell averages) + + if ((currentPatch%area .gt. 0._r8) .and. (currentPatch%total_canopy_area .gt. 0._r8)) then + + ! for quantities that are at the CLM patch level, because of the way that CLM patches are weighted for radiative purposes + ! this # density needs to be over either ED patch canopy area or ED patch total area, whichever is less + n_density = currentCohort%n/min(currentPatch%area,currentPatch%total_canopy_area) + + ! for quantities that are natively at column level, calculate plant density using whole area + n_perm2 = currentCohort%n/AREA + else n_density = 0.0_r8 n_perm2 = 0.0_r8 @@ -2382,7 +2389,7 @@ subroutine Summary(this, bounds, num_soilc, filter_soilc, & use ColumnType , only : col use LandunitType , only : lun use landunit_varcon , only : istsoil - use subgridAveMod , only : p2c + !use subgridAveMod , only : p2c ! implicit none ! @@ -2403,6 +2410,7 @@ subroutine Summary(this, bounds, num_soilc, filter_soilc, & type (ed_cohort_type) , pointer :: currentCohort integer :: firstsoilpatch(bounds%begg:bounds%endg) ! the first patch in this gridcell that is soil and thus bare... real(r8) :: n_density ! individual of cohort per m2. + real(r8) :: n_perm2 ! individuals per m2 of the whole column associate(& hr => soilbiogeochem_carbonflux_inst%hr_col, & ! (gC/m2/s) total heterotrophic respiration @@ -2488,12 +2496,21 @@ subroutine Summary(this, bounds, num_soilc, filter_soilc, & currentCohort => currentPatch%tallest do while(associated(currentCohort)) - if(currentPatch%area>0._r8)then - n_density = currentCohort%n/currentPatch%area + + if ((currentPatch%area .gt. 0._r8) .and. (currentPatch%total_canopy_area .gt. 0._r8)) then + + ! for quantities that are at the CLM patch level, because of the way that CLM patches are weighted for radiative purposes + ! this # density needs to be over either ED patch canopy area or ED patch total area, whichever is less + n_density = currentCohort%n/min(currentPatch%area,currentPatch%total_canopy_area) + + ! for quantities that are natively at column level or higher, calculate plant density using whole area (for grid cell averages) + n_perm2 = currentCohort%n/AREA + else n_density = 0.0_r8 + n_perm2 = 0.0_r8 endif - + ! map ed cohort-level fluxes to clm patch fluxes npp(pp) = npp(pp) + currentCohort%npp_clm * 1.e3_r8 * n_density / dt gpp(pp) = gpp(pp) + currentCohort%gpp_clm * 1.e3_r8 * n_density / dt @@ -2502,11 +2519,11 @@ subroutine Summary(this, bounds, num_soilc, filter_soilc, & maint_resp(pp) = maint_resp(pp) + currentCohort%resp_m * 1.e3_r8 * n_density / dt ! map ed cohort-level npp fluxes to clm column fluxes - !npp_col(cc) = npp_col(cc) + currentCohort%npp_clm * 1.e3_r8 * currentCohort%n / ( AREA * dt) + npp_col(cc) = npp_col(cc) + currentCohort%npp_clm * n_perm2 * 1.e3_r8 /dt ! map biomass pools to column level biomass_stock(cc) = biomass_stock(cc) + (currentCohort%bdead + currentCohort%balive + & - currentCohort%bstore) * currentCohort%n * 1.e3_r8 / AREA + currentCohort%bstore) * n_perm2 * 1.e3_r8 currentCohort => currentCohort%shorter enddo !currentCohort @@ -2515,7 +2532,7 @@ subroutine Summary(this, bounds, num_soilc, filter_soilc, & end if end do - call p2c(bounds,num_soilc, filter_soilc, npp(bounds%begp:bounds%endp), npp_col(bounds%begc:bounds%endc)) + !call p2c(bounds,num_soilc, filter_soilc, npp(bounds%begp:bounds%endp), npp_col(bounds%begc:bounds%endc)) ! calculate NEP and NBP fluxes. do fc = 1,num_soilc From c61950fce88feeed8e4810267a06c512bdfe972a Mon Sep 17 00:00:00 2001 From: ckoven Date: Sat, 9 Apr 2016 20:29:03 -0700 Subject: [PATCH 063/437] reverted compile flags to original --- main/EDCLMLinkMod.F90 | 22 +++++++++++++--------- 1 file changed, 13 insertions(+), 9 deletions(-) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 3f67bacb..96133b7b 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -2511,16 +2511,20 @@ subroutine Summary(this, bounds, num_soilc, filter_soilc, & n_perm2 = 0.0_r8 endif - ! map ed cohort-level fluxes to clm patch fluxes - npp(pp) = npp(pp) + currentCohort%npp_clm * 1.e3_r8 * n_density / dt - gpp(pp) = gpp(pp) + currentCohort%gpp_clm * 1.e3_r8 * n_density / dt - ar(pp) = ar(pp) + currentCohort%resp_clm * 1.e3_r8 * n_density / dt - growth_resp(pp) = growth_resp(pp) + currentCohort%resp_g * 1.e3_r8 * n_density / dt - maint_resp(pp) = maint_resp(pp) + currentCohort%resp_m * 1.e3_r8 * n_density / dt - - ! map ed cohort-level npp fluxes to clm column fluxes - npp_col(cc) = npp_col(cc) + currentCohort%npp_clm * n_perm2 * 1.e3_r8 /dt + if ( .not. currentCohort%isnew ) then + + ! map ed cohort-level fluxes to clm patch fluxes + npp(pp) = npp(pp) + currentCohort%npp_clm * 1.e3_r8 * n_density / dt + gpp(pp) = gpp(pp) + currentCohort%gpp_clm * 1.e3_r8 * n_density / dt + ar(pp) = ar(pp) + currentCohort%resp_clm * 1.e3_r8 * n_density / dt + growth_resp(pp) = growth_resp(pp) + currentCohort%resp_g * 1.e3_r8 * n_density / dt + maint_resp(pp) = maint_resp(pp) + currentCohort%resp_m * 1.e3_r8 * n_density / dt + + ! map ed cohort-level npp fluxes to clm column fluxes + npp_col(cc) = npp_col(cc) + currentCohort%npp_clm * n_perm2 * 1.e3_r8 /dt + endif + ! map biomass pools to column level biomass_stock(cc) = biomass_stock(cc) + (currentCohort%bdead + currentCohort%balive + & currentCohort%bstore) * n_perm2 * 1.e3_r8 From 94351d4f76ccde534033f8789449328299b28688 Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Sun, 10 Apr 2016 10:05:56 -0700 Subject: [PATCH 064/437] adding diagnostics of the number of patches and cohorts to the history file because thats eems like auseful thing to be able to track --- main/EDCLMLinkMod.F90 | 31 ++++++++++++++++++++++++++++++- 1 file changed, 30 insertions(+), 1 deletion(-) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 3f67bacb..7145b9e6 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -161,6 +161,10 @@ module EDCLMLinkMod real(r8), pointer, private :: cbalance_error_bgc_col(:) ! [gC/m2/s] total carbon balance error for the BGC side real(r8), pointer, private :: cbalance_error_total_col(:) ! [gC/m2/s] total carbon balance error for the whole thing + ! ED patch/cohort data + real(r8), pointer, private :: ed_npatches_col(:) ! [#] the number of patches per ED site + real(r8), pointer, private :: ed_ncohorts_col(:) ! [#] the number of cohorts per ED site + contains ! Public routines @@ -310,6 +314,9 @@ subroutine InitAllocate(this, bounds) allocate(this%cbalance_error_bgc_col (begc:endc)) ; this%cbalance_error_bgc_col (:) = nan allocate(this%cbalance_error_total_col (begc:endc)) ; this%cbalance_error_total_col (:) = nan + allocate(this%ed_npatches_col (begc:endc)) ; this%ed_npatches_col (:) = nan + allocate(this%ed_ncohorts_col (begc:endc)) ; this%ed_ncohorts_col (:) = nan + allocate(this%ed_gpp_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)); this%ed_gpp_gd_scpf (:,:) = 0.0_r8 allocate(this%ed_npp_totl_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)); this%ed_npp_totl_gd_scpf (:,:) = 0.0_r8 allocate(this%ed_npp_leaf_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)); this%ed_npp_leaf_gd_scpf (:,:) = 0.0_r8 @@ -691,6 +698,16 @@ subroutine InitHistory(this, bounds) avgflag='A', long_name='fire mortality count by patch and pft/size', & ptr_gcell=this%ed_m5_gd_scpf, default='inactive') + this%ed_npatches_col(begc:endc) = spval + call hist_addfld1d (fname='ED_NPATCHES', units='unitless', & + avgflag='A', long_name='ED total number of patches per site', & + ptr_col=this%ed_npatches_col) + + this%ed_ncohorts_col(begc:endc) = spval + call hist_addfld1d (fname='ED_NCOHORTS', units='unitless', & + avgflag='A', long_name='ED total number of cohorts per site', & + ptr_col=this%ed_ncohorts_col) + end subroutine InitHistory !----------------------------------------------------------------------- @@ -1222,7 +1239,7 @@ subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & type(canopystate_type) , intent(inout) :: canopystate_inst ! ! !LOCAL VARIABLES: - integer :: G,p,ft + integer :: G,p,ft,c integer :: firstsoilpatch(bounds%begg:bounds%endg) real(r8) :: n_density ! individual of cohort per m2. real(r8) :: n_perm2 ! individuals per m2 for the whole column @@ -1278,6 +1295,9 @@ subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & ed_npp_agdw_scpf => this%ed_npp_agdw_gd_scpf , & ed_npp_stor_scpf => this%ed_npp_stor_gd_scpf , & + ed_npatches => this%ed_npatches_col , & + ed_ncohorts => this%ed_ncohorts_col , & + ed_ddbh_gd_scpf => this%ed_ddbh_gd_scpf , & ed_ba_gd_scpf => this%ed_ba_gd_scpf , & ed_np_gd_scpf => this%ed_np_gd_scpf , & @@ -1352,6 +1372,9 @@ subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & ed_m4_gd_scpf(:,:) = 0.0_r8 ed_m5_gd_scpf(:,:) = 0.0_r8 + ed_npatches(:) = 0._r8 + ed_ncohorts(:) = 0._r8 + do g = bounds%begg,bounds%endg if (firstsoilpatch(g) >= 0 .and. ed_allsites_inst(g)%istheresoil) then @@ -1399,17 +1422,23 @@ subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & !this should probably be site level. phen_cd_status(firstsoilpatch(g)) = ed_allsites_inst(g)%status + c = ed_allsites_inst(g)%clmcolumn + 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 + ed_npatches(c) = ed_npatches(c) + 1._r8 + currentCohort => currentPatch%shortest do while(associated(currentCohort)) !accumulate into history variables. ft = currentCohort%pft + ed_ncohorts(c) = ed_ncohorts(c) + 1._r8 + if ((currentPatch%area .gt. 0._r8) .and. (currentPatch%total_canopy_area .gt. 0._r8)) then ! for quantities that are at the CLM patch level, because of the way that CLM patches are weighted for radiative purposes From 6e17d6838e15c8c0b78e8ca67b04a1938ac768ab Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Sun, 10 Apr 2016 13:56:36 -0700 Subject: [PATCH 065/437] splitting edclm summary routines into two parts: Summary1, which covers productivity fluxes and goes between canopyfluxes and ed_driver, and Summary2, which covers non-productivity fluxes and goes after both the BGC routines and ed_driver --- main/EDCLMLinkMod.F90 | 182 ++++++++++++++++++++++++++++++------------ 1 file changed, 132 insertions(+), 50 deletions(-) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index ca2e2804..c484bd74 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -172,7 +172,8 @@ module EDCLMLinkMod procedure , public :: Restart procedure , public :: SetValues procedure , public :: ed_clm_link - procedure , public :: Summary + procedure , public :: Summary2 + procedure , public :: Summary1 procedure , public :: ED_BGC_Carbon_Balancecheck ! Private routines @@ -2406,19 +2407,143 @@ subroutine flux_into_litter_pools(this, bounds, ed_allsites_inst, firstsoilpatch end subroutine flux_into_litter_pools !------------------------------------------------------------------------ + subroutine Summary1(this, bounds, ed_allsites_inst) + + ! Summarize the fast production inputs from fluxes per ED individual to fluxes per CLM patch and column + ! Must be called between calculation of productivity fluxes and daily ED calls + ! (since daily ED calls reorganize the patch / cohort structure) + + ! Written By Charlie Koven, April 2016 + ! + ! !USES: + use ColumnType , only : col + use LandunitType , only : lun + use landunit_varcon , only : istsoil + !use subgridAveMod , only : p2c + ! + implicit none + ! + ! !ARGUMENTS + class(ed_clm_type) :: this + type(bounds_type) , intent(in) :: bounds + type(ed_site_type) , intent(in), target :: ed_allsites_inst( bounds%begg: ) + ! + ! !LOCAL VARIABLES: + real(r8) :: dt ! radiation time step (seconds) + integer :: c, g, cc, fc, l, p, pp + type (ed_patch_type) , pointer :: currentPatch + type (ed_cohort_type) , pointer :: currentCohort + integer :: firstsoilpatch(bounds%begg:bounds%endg) ! the first patch in this gridcell that is soil and thus bare... + real(r8) :: n_density ! individual of cohort per m2. + real(r8) :: n_perm2 ! individuals per m2 of the whole column + + associate(& + npp_col => this%npp_col, & + npp => this%npp_patch, & + gpp => this%gpp_patch, & + ar => this%ar_patch, & + growth_resp => this%growth_resp_patch, & + maint_resp => this%maint_resp_patch, & + ) + + ! set time steps + dt = real( get_step_size(), r8 ) + + ! zero variables first + ! column variables + do c = bounds%begc,bounds%endc + ! summary flux variables + npp_col(c) = 0._r8 + end do + + ! patch variables + do p = bounds%begp,bounds%endp + npp(p) = 0._r8 + gpp(p) = 0._r8 + ar(p) = 0._r8 + growth_resp(p) = 0._r8 + maint_resp(p) = 0._r8 + end do + + ! retrieve the first soil patch associated with each gridcell. + ! make sure we only get the first patch value for places which have soil. + firstsoilpatch(bounds%begg:bounds%endg) = -999 + do c = bounds%begc,bounds%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) + endif + enddo - subroutine Summary(this, bounds, num_soilc, filter_soilc, & + do g = bounds%begg,bounds%endg + if (firstsoilpatch(g) >= 0 .and. ed_allsites_inst(g)%istheresoil) then + cc = ed_allsites_inst(g)%clmcolumn + + currentPatch => ed_allsites_inst(g)%oldest_patch + do while(associated(currentPatch)) + + pp = currentPatch%clm_pno + + currentCohort => currentPatch%tallest + do while(associated(currentCohort)) + + if ((currentPatch%area .gt. 0._r8) .and. (currentPatch%total_canopy_area .gt. 0._r8)) then + + ! for quantities that are at the CLM patch level, because of the way that CLM patches are weighted for radiative purposes + ! this # density needs to be over either ED patch canopy area or ED patch total area, whichever is less + n_density = currentCohort%n/min(currentPatch%area,currentPatch%total_canopy_area) + + ! for quantities that are natively at column level or higher, calculate plant density using whole area (for grid cell averages) + n_perm2 = currentCohort%n/AREA + + else + n_density = 0.0_r8 + n_perm2 = 0.0_r8 + endif + + if ( .not. currentCohort%isnew ) then + + ! map ed cohort-level fluxes to clm patch fluxes + npp(pp) = npp(pp) + currentCohort%npp_clm * 1.e3_r8 * n_density / dt + gpp(pp) = gpp(pp) + currentCohort%gpp_clm * 1.e3_r8 * n_density / dt + ar(pp) = ar(pp) + currentCohort%resp_clm * 1.e3_r8 * n_density / dt + growth_resp(pp) = growth_resp(pp) + currentCohort%resp_g * 1.e3_r8 * n_density / dt + maint_resp(pp) = maint_resp(pp) + currentCohort%resp_m * 1.e3_r8 * n_density / dt + + ! map ed cohort-level npp fluxes to clm column fluxes + npp_col(cc) = npp_col(cc) + currentCohort%npp_clm * n_perm2 * 1.e3_r8 /dt + + endif + + currentCohort => currentCohort%shorter + enddo !currentCohort + currentPatch => currentPatch%younger + end do !currentPatch + end if + end do + + ! leaving this as a comment here. it should produce same answer for npp_col as above, + ! so it may be useful to try as a check to make sure machinery is working proerly + !call p2c(bounds,num_soilc, filter_soilc, npp(bounds%begp:bounds%endp), npp_col(bounds%begc:bounds%endc)) + + end subroutine Summary1 + + !------------------------------------------------------------------------ + subroutine Summary2(this, bounds, num_soilc, filter_soilc, & ed_allsites_inst, soilbiogeochem_carbonflux_inst, & soilbiogeochem_carbonstate_inst) ! Summarize the combined production and decomposition fluxes into net fluxes + ! This is done on the fast timestep, and to be called after both daily ED calls and fast BGC calls + ! Does not include summarization of fast-timestsp productivity calls because these must be summarized prior to daily ED calls + ! ! Written by Charlie Koven, Feb 2016 ! ! !USES: use ColumnType , only : col use LandunitType , only : lun use landunit_varcon , only : istsoil - !use subgridAveMod , only : p2c ! implicit none ! @@ -2427,7 +2552,7 @@ subroutine Summary(this, bounds, num_soilc, filter_soilc, & type(bounds_type) , intent(in) :: bounds integer , intent(in) :: num_soilc ! number of soil columns in filter integer , intent(in) :: filter_soilc(:) ! filter for soil columns - type(ed_site_type) , intent(inout), target :: ed_allsites_inst( bounds%begg: ) + type(ed_site_type) , intent(in), target :: ed_allsites_inst( bounds%begg: ) type(soilbiogeochem_carbonflux_type) , intent(inout) :: soilbiogeochem_carbonflux_inst type(soilbiogeochem_carbonstate_type) , intent(inout) :: soilbiogeochem_carbonstate_inst ! @@ -2438,7 +2563,6 @@ subroutine Summary(this, bounds, num_soilc, filter_soilc, & type (ed_patch_type) , pointer :: currentPatch type (ed_cohort_type) , pointer :: currentCohort integer :: firstsoilpatch(bounds%begg:bounds%endg) ! the first patch in this gridcell that is soil and thus bare... - real(r8) :: n_density ! individual of cohort per m2. real(r8) :: n_perm2 ! individuals per m2 of the whole column associate(& @@ -2446,11 +2570,6 @@ subroutine Summary(this, bounds, num_soilc, filter_soilc, & totsomc => soilbiogeochem_carbonstate_inst%totsomc_col, & ! (gC/m2) total soil organic matter carbon totlitc => soilbiogeochem_carbonstate_inst%totlitc_col, & ! (gC/m2) total litter carbon in BGC pools npp_col => this%npp_col, & - npp => this%npp_patch, & - gpp => this%gpp_patch, & - ar => this%ar_patch, & - growth_resp => this%growth_resp_patch, & - maint_resp => this%maint_resp_patch, & nep => this%nep_col, & fire_c_to_atm => this%fire_c_to_atm_col, & nbp => this%nbp_col, & @@ -2482,15 +2601,6 @@ subroutine Summary(this, bounds, num_soilc, filter_soilc, & seed_stock(c) = 0._r8 biomass_stock(c) = 0._r8 end do - - ! patch variables - do p = bounds%begp,bounds%endp - npp(p) = 0._r8 - gpp(p) = 0._r8 - ar(p) = 0._r8 - growth_resp(p) = 0._r8 - maint_resp(p) = 0._r8 - end do ! retrieve the first soil patch associated with each gridcell. ! make sure we only get the first patch value for places which have soil. @@ -2525,34 +2635,8 @@ subroutine Summary(this, bounds, num_soilc, filter_soilc, & currentCohort => currentPatch%tallest do while(associated(currentCohort)) - - if ((currentPatch%area .gt. 0._r8) .and. (currentPatch%total_canopy_area .gt. 0._r8)) then - - ! for quantities that are at the CLM patch level, because of the way that CLM patches are weighted for radiative purposes - ! this # density needs to be over either ED patch canopy area or ED patch total area, whichever is less - n_density = currentCohort%n/min(currentPatch%area,currentPatch%total_canopy_area) - - ! for quantities that are natively at column level or higher, calculate plant density using whole area (for grid cell averages) - n_perm2 = currentCohort%n/AREA - - else - n_density = 0.0_r8 - n_perm2 = 0.0_r8 - endif - - if ( .not. currentCohort%isnew ) then - - ! map ed cohort-level fluxes to clm patch fluxes - npp(pp) = npp(pp) + currentCohort%npp_clm * 1.e3_r8 * n_density / dt - gpp(pp) = gpp(pp) + currentCohort%gpp_clm * 1.e3_r8 * n_density / dt - ar(pp) = ar(pp) + currentCohort%resp_clm * 1.e3_r8 * n_density / dt - growth_resp(pp) = growth_resp(pp) + currentCohort%resp_g * 1.e3_r8 * n_density / dt - maint_resp(pp) = maint_resp(pp) + currentCohort%resp_m * 1.e3_r8 * n_density / dt - - ! map ed cohort-level npp fluxes to clm column fluxes - npp_col(cc) = npp_col(cc) + currentCohort%npp_clm * n_perm2 * 1.e3_r8 /dt - - endif + ! for quantities that are natively at column level or higher, calculate plant density using whole area (for grid cell averages) + n_perm2 = currentCohort%n/AREA ! map biomass pools to column level biomass_stock(cc) = biomass_stock(cc) + (currentCohort%bdead + currentCohort%balive + & @@ -2565,8 +2649,6 @@ subroutine Summary(this, bounds, num_soilc, filter_soilc, & end if end do - !call p2c(bounds,num_soilc, filter_soilc, npp(bounds%begp:bounds%endp), npp_col(bounds%begc:bounds%endc)) - ! calculate NEP and NBP fluxes. do fc = 1,num_soilc c = filter_soilc(fc) @@ -2624,7 +2706,7 @@ subroutine Summary(this, bounds, num_soilc, filter_soilc, & end associate - end subroutine Summary + end subroutine Summary2 subroutine ED_BGC_Carbon_Balancecheck(this, bounds, num_soilc, filter_soilc, soilbiogeochem_carbonflux_inst) From 1d826faf046a3079d0ec046e1d45adc8d20054d1 Mon Sep 17 00:00:00 2001 From: ckoven Date: Sun, 10 Apr 2016 14:39:02 -0700 Subject: [PATCH 066/437] compile-time bugfixes --- main/EDCLMLinkMod.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index c484bd74..c798ac23 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -2443,7 +2443,7 @@ subroutine Summary1(this, bounds, ed_allsites_inst) gpp => this%gpp_patch, & ar => this%ar_patch, & growth_resp => this%growth_resp_patch, & - maint_resp => this%maint_resp_patch, & + maint_resp => this%maint_resp_patch & ) ! set time steps @@ -2527,6 +2527,7 @@ subroutine Summary1(this, bounds, ed_allsites_inst) ! so it may be useful to try as a check to make sure machinery is working proerly !call p2c(bounds,num_soilc, filter_soilc, npp(bounds%begp:bounds%endp), npp_col(bounds%begc:bounds%endc)) + end associate end subroutine Summary1 !------------------------------------------------------------------------ From 89f4c98631b487c85441e22071e1cd605d7a13fa Mon Sep 17 00:00:00 2001 From: ckoven Date: Sun, 10 Apr 2016 19:55:43 -0700 Subject: [PATCH 067/437] added canopy_closure diagnostic and also fixed runtime bug in npp_col from reorganization. now failing some restart tests in NPP, possibly because cohort%isnew is not being restarted --- main/EDCLMLinkMod.F90 | 25 +++++++++++++++++++++++-- 1 file changed, 23 insertions(+), 2 deletions(-) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index c798ac23..988e663c 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -37,6 +37,8 @@ module EDCLMLinkMod 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 :: canopy_closure_patch (:) + real(r8), pointer, private :: canopy_closure_col (:) 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 @@ -235,6 +237,8 @@ subroutine InitAllocate(this, bounds) 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%canopy_closure_patch (begp:endp)) ; this%canopy_closure_patch (:) = 0.0_r8 + allocate(this%canopy_closure_col (begc:endc)) ; this%canopy_closure_col (:) = 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 @@ -395,6 +399,14 @@ subroutine InitHistory(this, bounds) 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_addfld1d (fname='CANOPY_CLOSURE', units='m2/m2', & + avgflag='A', long_name='fraction of patch area that is closed canopy', & + ptr_patch=this%canopy_closure_patch, set_lake=0._r8, set_urb=0._r8) + + call hist_addfld1d (fname='CANOPY_CLOSURE_COL', units='m2/m2', & + avgflag='A', long_name='fraction of column area that is closed canopy', & + ptr_col=this%canopy_closure_col, set_lake=0._r8, set_urb=0._r8, default='inactive') + call hist_addfld2d (fname='PFTbiomass', units='gC/m2', type2d='levgrnd', & avgflag='A', long_name='total PFT level biomass', & ptr_patch=this%PFTbiomass_patch, set_lake=0._r8, set_urb=0._r8) @@ -1257,6 +1269,8 @@ subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & PFTstorebiomass => this%PFTstorebiomass_patch , & ! Output: PFTnindivs => this%PFTnindivs_patch , & ! Output: area_plant => this%area_plant_patch , & ! Output: + canopy_closure_patch => this%canopy_closure_patch , & ! Output: + canopy_closure_col => this%canopy_closure_col , & ! Output: area_trees => this%area_trees_patch , & ! Output: nesterov_fire_danger => this%nesterov_fire_danger_patch , & ! Output: spitfire_ROS => this%spitfire_ROS_patch , & ! Output: @@ -1375,7 +1389,10 @@ subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & ed_npatches(:) = 0._r8 ed_ncohorts(:) = 0._r8 - + + canopy_closure_patch(:) = 0._r8 + canopy_closure_col(:) = 0._r8 + do g = bounds%begg,bounds%endg if (firstsoilpatch(g) >= 0 .and. ed_allsites_inst(g)%istheresoil) then @@ -1433,6 +1450,11 @@ subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & ed_npatches(c) = ed_npatches(c) + 1._r8 + if ( (currentPatch%total_canopy_area .gt. 0._r8) .and. (currentPatch%area .gt. 0._r8) ) then + canopy_closure_patch(p) = 1._r8 ! since patch weighting is defined as per canopy area, this simplifies to 1 + canopy_closure_col(c) = canopy_closure_col(c) + min(currentPatch%total_canopy_area, currentPatch%area)/AREA ! should give the same answer as previous + endif + currentCohort => currentPatch%shortest do while(associated(currentCohort)) !accumulate into history variables. @@ -2593,7 +2615,6 @@ subroutine Summary2(this, bounds, num_soilc, filter_soilc, & ! column variables do c = bounds%begc,bounds%endc ! summary flux variables - npp_col(c) = 0._r8 fire_c_to_atm(c) = 0._r8 ! summary stock variables From 97d5eb169a3e6450f336fb0df32f844af1cb0fa4 Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Mon, 11 Apr 2016 11:49:49 -0700 Subject: [PATCH 068/437] added cohort%isnew to restart --- main/EDRestVectorMod.F90 | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) diff --git a/main/EDRestVectorMod.F90 b/main/EDRestVectorMod.F90 index 01c875c4..9e69086c 100755 --- a/main/EDRestVectorMod.F90 +++ b/main/EDRestVectorMod.F90 @@ -59,6 +59,7 @@ module EDRestVectorMod real(r8), pointer :: resp_clm(:) integer, pointer :: pft(:) integer, pointer :: status_coh(:) + logical, pointer :: isnew(:) ! ! patch level restart vars ! indexed by ncwd @@ -179,6 +180,7 @@ subroutine deleteEDRestartVectorClass( this ) deallocate(this%resp_clm ) deallocate(this%pft ) deallocate(this%status_coh ) + deallocate(this%isnew ) deallocate(this%cwd_ag ) deallocate(this%cwd_bg ) deallocate(this%leaf_litter ) @@ -341,6 +343,11 @@ function newEDRestartVectorClass( bounds ) SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) new%status_coh(:) = 0 + allocate(new%isnew & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%isnew(:) = .true. + ! ! some patch level variables that are required on restart ! @@ -718,6 +725,12 @@ subroutine doVectorIO( this, ncid, flag ) interpinic_flag='interp', data=this%status_coh, & readvar=readvar) + call restartvar(ncid=ncid, flag=flag, varname='isnew', xtype=ncd_log, & + dim1name=dimName, & + long_name='ed cohort - isnew', units='unitless', & + interpinic_flag='interp', data=this%isnew, & + readvar=readvar) + ! ! patch level vars ! @@ -948,6 +961,8 @@ subroutine printDataInfoVector( this ) this%pft(iSta:iSto) write(iulog,*) trim(methodName)//' :: status_coh ', & this%status_coh(iSta:iSto) + write(iulog,*) trim(methodName)//' :: isnew ', & + this%isnew(iSta:iSto) write(iulog,*) trim(methodName)//' :: cwd_ag ', & this%cwd_ag(iSta:iSto) @@ -1070,6 +1085,7 @@ subroutine printDataInfoLL( this, bounds, ed_allsites_inst ) 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 + write(iulog,*) trim(methodName)//' isnew ' ,totalCohorts,currentCohort%isnew numCohort = numCohort + 1 @@ -1192,6 +1208,7 @@ subroutine printIoInfoLL( this, bounds, ed_allsites_inst ) 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 + write(iulog,*) trim(methodName)//' isnew ',currentCohort%isnew currentCohort => currentCohort%taller enddo ! currentCohort do while @@ -1304,6 +1321,7 @@ subroutine convertCohortListToVector( this, bounds, ed_allsites_inst ) this%resp_clm(countCohort) = currentCohort%resp_clm this%pft(countCohort) = currentCohort%pft this%status_coh(countCohort) = currentCohort%status_coh + this%isnew(countCohort) = currentCohort%isnew if (this%DEBUG) then write(iulog,*) 'CLTV offsetNumCohorts II ',countCohort, & @@ -1692,6 +1710,7 @@ subroutine convertCohortVectorToList( this, bounds, ed_allsites_inst ) currentCohort%resp_clm = this%resp_clm(countCohort) currentCohort%pft = this%pft(countCohort) currentCohort%status_coh = this%status_coh(countCohort) + currentCohort%isnew = this%isnew(countCohort) if (this%DEBUG) then write(iulog,*) 'CVTL II ',countCohort, & From 2fd592a9d83edb1fa61aa99c5e0cfa7942d51fcf Mon Sep 17 00:00:00 2001 From: ckoven Date: Mon, 11 Apr 2016 14:44:04 -0700 Subject: [PATCH 069/437] compile-time bugfix for patch%isnew to convert memory logical to/from integer in restart file --- main/EDRestVectorMod.F90 | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/main/EDRestVectorMod.F90 b/main/EDRestVectorMod.F90 index 9e69086c..a818435c 100755 --- a/main/EDRestVectorMod.F90 +++ b/main/EDRestVectorMod.F90 @@ -59,7 +59,7 @@ module EDRestVectorMod real(r8), pointer :: resp_clm(:) integer, pointer :: pft(:) integer, pointer :: status_coh(:) - logical, pointer :: isnew(:) + integer, pointer :: isnew(:) ! ! patch level restart vars ! indexed by ncwd @@ -346,7 +346,7 @@ function newEDRestartVectorClass( bounds ) allocate(new%isnew & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) - new%isnew(:) = .true. + new%isnew(:) = 1 ! ! some patch level variables that are required on restart @@ -581,7 +581,7 @@ subroutine doVectorIO( this, ncid, flag ) ! implement VectorIO ! ! !USES: - use ncdio_pio , only : file_desc_t, ncd_int, ncd_double + use ncdio_pio , only : file_desc_t, ncd_int, ncd_double, ncd_log use restUtilMod, only : restartvar use clm_varcon, only : nameg, nameCohort use spmdMod, only : iam @@ -725,7 +725,7 @@ subroutine doVectorIO( this, ncid, flag ) interpinic_flag='interp', data=this%status_coh, & readvar=readvar) - call restartvar(ncid=ncid, flag=flag, varname='isnew', xtype=ncd_log, & + call restartvar(ncid=ncid, flag=flag, varname='ed_isnew', xtype=ncd_int, & dim1name=dimName, & long_name='ed cohort - isnew', units='unitless', & interpinic_flag='interp', data=this%isnew, & @@ -1321,7 +1321,11 @@ subroutine convertCohortListToVector( this, bounds, ed_allsites_inst ) this%resp_clm(countCohort) = currentCohort%resp_clm this%pft(countCohort) = currentCohort%pft this%status_coh(countCohort) = currentCohort%status_coh - this%isnew(countCohort) = currentCohort%isnew + if ( currentCohort%isnew ) then + this%isnew(countCohort) = 1 + else + this%isnew(countCohort) = 0 + endif if (this%DEBUG) then write(iulog,*) 'CLTV offsetNumCohorts II ',countCohort, & @@ -1710,7 +1714,7 @@ subroutine convertCohortVectorToList( this, bounds, ed_allsites_inst ) currentCohort%resp_clm = this%resp_clm(countCohort) currentCohort%pft = this%pft(countCohort) currentCohort%status_coh = this%status_coh(countCohort) - currentCohort%isnew = this%isnew(countCohort) + currentCohort%isnew = ( this%isnew(countCohort) .eq. 1 ) if (this%DEBUG) then write(iulog,*) 'CVTL II ',countCohort, & From 35b4f8727a8b8fbef0aa2cd20b01f6d462969772 Mon Sep 17 00:00:00 2001 From: ckoven Date: Mon, 11 Apr 2016 15:22:13 -0700 Subject: [PATCH 070/437] removed some now-redundant new diagnostics and added correction term for patch-native C terms --- main/EDCLMLinkMod.F90 | 49 ++++++++++++++++--------------------------- 1 file changed, 18 insertions(+), 31 deletions(-) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 988e663c..5737637a 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -37,8 +37,6 @@ module EDCLMLinkMod 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 :: canopy_closure_patch (:) - real(r8), pointer, private :: canopy_closure_col (:) 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 @@ -237,8 +235,6 @@ subroutine InitAllocate(this, bounds) 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%canopy_closure_patch (begp:endp)) ; this%canopy_closure_patch (:) = 0.0_r8 - allocate(this%canopy_closure_col (begc:endc)) ; this%canopy_closure_col (:) = 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 @@ -399,14 +395,6 @@ subroutine InitHistory(this, bounds) 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_addfld1d (fname='CANOPY_CLOSURE', units='m2/m2', & - avgflag='A', long_name='fraction of patch area that is closed canopy', & - ptr_patch=this%canopy_closure_patch, set_lake=0._r8, set_urb=0._r8) - - call hist_addfld1d (fname='CANOPY_CLOSURE_COL', units='m2/m2', & - avgflag='A', long_name='fraction of column area that is closed canopy', & - ptr_col=this%canopy_closure_col, set_lake=0._r8, set_urb=0._r8, default='inactive') - call hist_addfld2d (fname='PFTbiomass', units='gC/m2', type2d='levgrnd', & avgflag='A', long_name='total PFT level biomass', & ptr_patch=this%PFTbiomass_patch, set_lake=0._r8, set_urb=0._r8) @@ -1256,6 +1244,7 @@ subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & integer :: firstsoilpatch(bounds%begg:bounds%endg) real(r8) :: n_density ! individual of cohort per m2. real(r8) :: n_perm2 ! individuals per m2 for the whole column + real(r8) :: patch_scaling_scalar ! ratio of canopy to patch area for counteracting patch scaling real(r8) :: dbh ! actual dbh used to identify relevant size class integer :: scpf ! size class x pft index integer :: sc @@ -1269,8 +1258,6 @@ subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & PFTstorebiomass => this%PFTstorebiomass_patch , & ! Output: PFTnindivs => this%PFTnindivs_patch , & ! Output: area_plant => this%area_plant_patch , & ! Output: - canopy_closure_patch => this%canopy_closure_patch , & ! Output: - canopy_closure_col => this%canopy_closure_col , & ! Output: area_trees => this%area_trees_patch , & ! Output: nesterov_fire_danger => this%nesterov_fire_danger_patch , & ! Output: spitfire_ROS => this%spitfire_ROS_patch , & ! Output: @@ -1390,9 +1377,6 @@ subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & ed_npatches(:) = 0._r8 ed_ncohorts(:) = 0._r8 - canopy_closure_patch(:) = 0._r8 - canopy_closure_col(:) = 0._r8 - do g = bounds%begg,bounds%endg if (firstsoilpatch(g) >= 0 .and. ed_allsites_inst(g)%istheresoil) then @@ -1450,11 +1434,6 @@ subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & ed_npatches(c) = ed_npatches(c) + 1._r8 - if ( (currentPatch%total_canopy_area .gt. 0._r8) .and. (currentPatch%area .gt. 0._r8) ) then - canopy_closure_patch(p) = 1._r8 ! since patch weighting is defined as per canopy area, this simplifies to 1 - canopy_closure_col(c) = canopy_closure_col(c) + min(currentPatch%total_canopy_area, currentPatch%area)/AREA ! should give the same answer as previous - endif - currentCohort => currentPatch%shortest do while(associated(currentCohort)) !accumulate into history variables. @@ -1552,6 +1531,14 @@ subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & !Patch specific variables that are already calculated !These things are all duplicated. Should they all be converted to LL or array structures RF? + + ! define scalar to counteract the patch albedo scaling logic for conserved quantities + if (currentPatch%area .gt. 0._r8) then + patch_scaling_scalar = min(1._r8, currentPatch%area / currentPatch%total_canopy_area) + else + patch_scaling_scalar = 0._r8 + endif + nesterov_fire_danger(p) = ed_allsites_inst(g)%acc_NI spitfire_ROS(p) = currentPatch%ROS_front TFC_ROS(p) = currentPatch%TFC_ROS @@ -1563,16 +1550,16 @@ subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & 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 * 1.e3_r8 - litter_in(p) = (sum(currentPatch%CWD_AG_in) +sum(currentPatch%leaf_litter_in)) * 1.e3_r8 * 365.0_r8 * SHR_CONST_CDAY - litter_out(p) = (sum(currentPatch%CWD_AG_out)+sum(currentPatch%leaf_litter_out)) * 1.e3_r8 * 365.0_r8 * SHR_CONST_CDAY - seed_bank(p) = sum(currentPatch%seed_bank) * 1.e3_r8 - seeds_in(p) = sum(currentPatch%seeds_in) * 1.e3_r8 * 365.0_r8 * SHR_CONST_CDAY - seed_decay(p) = sum(currentPatch%seed_decay) * 1.e3_r8 * 365.0_r8 * SHR_CONST_CDAY - seed_germination(p) = sum(currentPatch%seed_germination) * 1.e3_r8 * 365.0_r8 * SHR_CONST_CDAY + sum_fuel(p) = currentPatch%sum_fuel * 1.e3_r8 * patch_scaling_scalar + litter_in(p) = (sum(currentPatch%CWD_AG_in) +sum(currentPatch%leaf_litter_in)) * 1.e3_r8 * 365.0_r8 * SHR_CONST_CDAY * patch_scaling_scalar + litter_out(p) = (sum(currentPatch%CWD_AG_out)+sum(currentPatch%leaf_litter_out)) * 1.e3_r8 * 365.0_r8 * SHR_CONST_CDAY * patch_scaling_scalar + seed_bank(p) = sum(currentPatch%seed_bank) * 1.e3_r8 * patch_scaling_scalar + seeds_in(p) = sum(currentPatch%seeds_in) * 1.e3_r8 * 365.0_r8 * SHR_CONST_CDAY * patch_scaling_scalar + seed_decay(p) = sum(currentPatch%seed_decay) * 1.e3_r8 * 365.0_r8 * SHR_CONST_CDAY * patch_scaling_scalar + seed_germination(p) = sum(currentPatch%seed_germination) * 1.e3_r8 * 365.0_r8 * SHR_CONST_CDAY * patch_scaling_scalar canopy_spread(p) = currentPatch%spread(1) - area_plant(p) = currentPatch%total_canopy_area /currentPatch%area - area_trees(p) = currentPatch%total_tree_area /currentPatch%area + area_plant(p) = 1._r8 + area_trees(p) = currentPatch%total_tree_area / min(currentPatch%total_canopy_area,currentPatch%area) phen_cd_status(p) = ed_allsites_inst(g)%status if(associated(currentPatch%tallest))then trimming(p) = currentPatch%tallest%canopy_trim From b574ba49fc7a34a72984d6aa6d0b94d796642914 Mon Sep 17 00:00:00 2001 From: ckoven Date: Tue, 12 Apr 2016 10:47:25 -0700 Subject: [PATCH 071/437] changed cohort%isnew integer magic numbers to module-level parameters --- main/EDRestVectorMod.F90 | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/main/EDRestVectorMod.F90 b/main/EDRestVectorMod.F90 index a818435c..a6d70d89 100755 --- a/main/EDRestVectorMod.F90 +++ b/main/EDRestVectorMod.F90 @@ -19,6 +19,10 @@ module EDRestVectorMod implicit none private ! + ! integer constants for storing logical data + integer, parameter :: old_cohort = 0 + integer, parameter :: new_cohort = 1 + ! ! ED cohort data as a type of vectors ! type, public :: EDRestartVectorClass @@ -346,7 +350,7 @@ function newEDRestartVectorClass( bounds ) allocate(new%isnew & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) - new%isnew(:) = 1 + new%isnew(:) = new_cohort ! ! some patch level variables that are required on restart @@ -1322,9 +1326,9 @@ subroutine convertCohortListToVector( this, bounds, ed_allsites_inst ) this%pft(countCohort) = currentCohort%pft this%status_coh(countCohort) = currentCohort%status_coh if ( currentCohort%isnew ) then - this%isnew(countCohort) = 1 + this%isnew(countCohort) = new_cohort else - this%isnew(countCohort) = 0 + this%isnew(countCohort) = old_cohort endif if (this%DEBUG) then @@ -1714,7 +1718,7 @@ subroutine convertCohortVectorToList( this, bounds, ed_allsites_inst ) currentCohort%resp_clm = this%resp_clm(countCohort) currentCohort%pft = this%pft(countCohort) currentCohort%status_coh = this%status_coh(countCohort) - currentCohort%isnew = ( this%isnew(countCohort) .eq. 1 ) + currentCohort%isnew = ( this%isnew(countCohort) .eq. new_cohort ) if (this%DEBUG) then write(iulog,*) 'CVTL II ',countCohort, & From 309b245ccb2980a481ae0d9485b9d9ef69f6562b Mon Sep 17 00:00:00 2001 From: ckoven Date: Tue, 12 Apr 2016 10:57:17 -0700 Subject: [PATCH 072/437] changed summary1 and summary2 to SummarizeProductivityFluxes and SummarizeNetFluxes --- main/EDCLMLinkMod.F90 | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 5737637a..abc7721d 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -172,8 +172,8 @@ module EDCLMLinkMod procedure , public :: Restart procedure , public :: SetValues procedure , public :: ed_clm_link - procedure , public :: Summary2 - procedure , public :: Summary1 + procedure , public :: SummarizeNetFluxes + procedure , public :: SummarizeProductivityFluxes procedure , public :: ED_BGC_Carbon_Balancecheck ! Private routines @@ -2416,7 +2416,7 @@ subroutine flux_into_litter_pools(this, bounds, ed_allsites_inst, firstsoilpatch end subroutine flux_into_litter_pools !------------------------------------------------------------------------ - subroutine Summary1(this, bounds, ed_allsites_inst) + subroutine SummarizeProductivityFluxes(this, bounds, ed_allsites_inst) ! Summarize the fast production inputs from fluxes per ED individual to fluxes per CLM patch and column ! Must be called between calculation of productivity fluxes and daily ED calls @@ -2537,10 +2537,10 @@ subroutine Summary1(this, bounds, ed_allsites_inst) !call p2c(bounds,num_soilc, filter_soilc, npp(bounds%begp:bounds%endp), npp_col(bounds%begc:bounds%endc)) end associate - end subroutine Summary1 + end subroutine SummarizeProductivityFluxes !------------------------------------------------------------------------ - subroutine Summary2(this, bounds, num_soilc, filter_soilc, & + subroutine SummarizeNetFluxes(this, bounds, num_soilc, filter_soilc, & ed_allsites_inst, soilbiogeochem_carbonflux_inst, & soilbiogeochem_carbonstate_inst) @@ -2715,7 +2715,7 @@ subroutine Summary2(this, bounds, num_soilc, filter_soilc, & end associate - end subroutine Summary2 + end subroutine SummarizeNetFluxes subroutine ED_BGC_Carbon_Balancecheck(this, bounds, num_soilc, filter_soilc, soilbiogeochem_carbonflux_inst) From 460209c7c468f03eab88181084a5f110673794e1 Mon Sep 17 00:00:00 2001 From: ckoven Date: Tue, 12 Apr 2016 16:32:01 -0700 Subject: [PATCH 073/437] removed ncd_log from ncdio_pio use statement in EDRestVectorMod.F90 --- main/EDRestVectorMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/EDRestVectorMod.F90 b/main/EDRestVectorMod.F90 index a6d70d89..238ba318 100755 --- a/main/EDRestVectorMod.F90 +++ b/main/EDRestVectorMod.F90 @@ -585,7 +585,7 @@ subroutine doVectorIO( this, ncid, flag ) ! implement VectorIO ! ! !USES: - use ncdio_pio , only : file_desc_t, ncd_int, ncd_double, ncd_log + 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 From 7d1883ad961f92d6c6a66aeb2286427fbba8b0be Mon Sep 17 00:00:00 2001 From: ckoven Date: Wed, 13 Apr 2016 15:51:44 -0700 Subject: [PATCH 074/437] added a bunch more patch diagnostic variables to ED restart file --- main/EDRestVectorMod.F90 | 266 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 266 insertions(+) diff --git a/main/EDRestVectorMod.F90 b/main/EDRestVectorMod.F90 index 238ba318..c45938e5 100755 --- a/main/EDRestVectorMod.F90 +++ b/main/EDRestVectorMod.F90 @@ -60,6 +60,20 @@ module EDRestVectorMod real(r8), pointer :: n(:) real(r8), pointer :: gpp_acc(:) real(r8), pointer :: npp_acc(:) + real(r8), pointer :: gpp(:) + real(r8), pointer :: npp(:) + real(r8), pointer :: npp_leaf(:) + real(r8), pointer :: npp_froot(:) + real(r8), pointer :: npp_bsw(:) + real(r8), pointer :: npp_bdead(:) + real(r8), pointer :: npp_bseed(:) + real(r8), pointer :: npp_store(:) + real(r8), pointer :: bmort(:) + real(r8), pointer :: hmort(:) + real(r8), pointer :: cmort(:) + real(r8), pointer :: imort(:) + real(r8), pointer :: fmort(:) + real(r8), pointer :: ddbhdt(:) real(r8), pointer :: resp_clm(:) integer, pointer :: pft(:) integer, pointer :: status_coh(:) @@ -181,6 +195,20 @@ subroutine deleteEDRestartVectorClass( this ) deallocate(this%n ) deallocate(this%gpp_acc ) deallocate(this%npp_acc ) + deallocate(this%gpp ) + deallocate(this%npp ) + deallocate(this%npp_leaf ) + deallocate(this%npp_froot ) + deallocate(this%npp_bsw ) + deallocate(this%npp_bdead ) + deallocate(this%npp_bseed ) + deallocate(this%npp_store ) + deallocate(this%bmort ) + deallocate(this%hmort ) + deallocate(this%cmort ) + deallocate(this%imort ) + deallocate(this%fmort ) + deallocate(this%ddbhdt ) deallocate(this%resp_clm ) deallocate(this%pft ) deallocate(this%status_coh ) @@ -332,6 +360,76 @@ function newEDRestartVectorClass( bounds ) SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) new%npp_acc(:) = 0.0_r8 + allocate(new%gpp & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%gpp(:) = 0.0_r8 + + allocate(new%npp & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%npp(:) = 0.0_r8 + + allocate(new%npp_leaf & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%npp_leaf(:) = 0.0_r8 + + allocate(new%npp_froot & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%npp_froot(:) = 0.0_r8 + + allocate(new%npp_bsw & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%npp_bsw(:) = 0.0_r8 + + allocate(new%npp_bdead & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%npp_bdead(:) = 0.0_r8 + + allocate(new%npp_bseed & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%npp_bseed(:) = 0.0_r8 + + allocate(new%npp_store & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%npp_store(:) = 0.0_r8 + + allocate(new%bmort & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%bmort(:) = 0.0_r8 + + allocate(new%hmort & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%hmort(:) = 0.0_r8 + + allocate(new%cmort & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%cmort(:) = 0.0_r8 + + allocate(new%imort & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%imort(:) = 0.0_r8 + + allocate(new%fmort & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%fmort(:) = 0.0_r8 + + allocate(new%ddbhdt & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%ddbhdt(:) = 0.0_r8 + allocate(new%resp_clm & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) @@ -711,6 +809,90 @@ subroutine doVectorIO( this, ncid, flag ) interpinic_flag='interp', data=this%npp_acc, & readvar=readvar) + call restartvar(ncid=ncid, flag=flag, varname='ed_gpp', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed cohort - gpp', units='unitless', & + interpinic_flag='interp', data=this%gpp, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_npp', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed cohort - npp', units='unitless', & + interpinic_flag='interp', data=this%npp, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_npp_leaf', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed cohort - npp_leaf', units='unitless', & + interpinic_flag='interp', data=this%npp_leaf, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_npp_froot', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed cohort - npp_froot', units='unitless', & + interpinic_flag='interp', data=this%npp_froot, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_npp_bsw', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed cohort - npp_bsw', units='unitless', & + interpinic_flag='interp', data=this%npp_bsw, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_npp_bdead', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed cohort - npp_bdead', units='unitless', & + interpinic_flag='interp', data=this%npp_bdead, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_npp_bseed', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed cohort - npp_bseed', units='unitless', & + interpinic_flag='interp', data=this%npp_bseed, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_npp_store', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed cohort - npp_store', units='unitless', & + interpinic_flag='interp', data=this%npp_store, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_bmort', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed cohort - bmort', units='unitless', & + interpinic_flag='interp', data=this%bmort, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_hmort', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed cohort - hmort', units='unitless', & + interpinic_flag='interp', data=this%hmort, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_cmort', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed cohort - cmort', units='unitless', & + interpinic_flag='interp', data=this%cmort, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_imort', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed cohort - imort', units='unitless', & + interpinic_flag='interp', data=this%imort, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_fmort', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed cohort - fmort', units='unitless', & + interpinic_flag='interp', data=this%fmort, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_ddbhdt', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed cohort - ddbhdt', units='unitless', & + interpinic_flag='interp', data=this%ddbhdt, & + 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', & @@ -958,6 +1140,34 @@ subroutine printDataInfoVector( this ) this%gpp_acc(iSta:iSto) write(iulog,*) trim(methodName)//' :: npp_acc ', & this%npp_acc(iSta:iSto) + write(iulog,*) trim(methodName)//' :: gpp ', & + this%gpp(iSta:iSto) + write(iulog,*) trim(methodName)//' :: npp ', & + this%npp(iSta:iSto) + write(iulog,*) trim(methodName)//' :: npp_leaf ', & + this%npp_leaf(iSta:iSto) + write(iulog,*) trim(methodName)//' :: npp_froot ', & + this%npp_froot(iSta:iSto) + write(iulog,*) trim(methodName)//' :: npp_bsw ', & + this%npp_bsw(iSta:iSto) + write(iulog,*) trim(methodName)//' :: npp_bdead ', & + this%npp_bdead(iSta:iSto) + write(iulog,*) trim(methodName)//' :: npp_bseed ', & + this%npp_bseed(iSta:iSto) + write(iulog,*) trim(methodName)//' :: npp_store ', & + this%npp_store(iSta:iSto) + write(iulog,*) trim(methodName)//' :: bmort ', & + this%bmort(iSta:iSto) + write(iulog,*) trim(methodName)//' :: hmort ', & + this%hmort(iSta:iSto) + write(iulog,*) trim(methodName)//' :: cmort ', & + this%cmort(iSta:iSto) + write(iulog,*) trim(methodName)//' :: imort ', & + this%imort(iSta:iSto) + write(iulog,*) trim(methodName)//' :: fmort ', & + this%fmort(iSta:iSto) + write(iulog,*) trim(methodName)//' :: ddbhdt ', & + this%ddbhdt(iSta:iSto) write(iulog,*) trim(methodName)//' :: resp_clm ', & this%resp_clm(iSta:iSto) @@ -1086,6 +1296,20 @@ subroutine printDataInfoLL( this, bounds, ed_allsites_inst ) 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)//' gpp ' ,totalCohorts,currentCohort%gpp + write(iulog,*) trim(methodName)//' npp ' ,totalCohorts,currentCohort%npp + write(iulog,*) trim(methodName)//' npp_leaf ' ,totalCohorts,currentCohort%npp_leaf + write(iulog,*) trim(methodName)//' npp_froot ' ,totalCohorts,currentCohort%npp_froot + write(iulog,*) trim(methodName)//' npp_bsw ' ,totalCohorts,currentCohort%npp_bsw + write(iulog,*) trim(methodName)//' npp_bdead ' ,totalCohorts,currentCohort%npp_bdead + write(iulog,*) trim(methodName)//' npp_bseed ' ,totalCohorts,currentCohort%npp_bseed + write(iulog,*) trim(methodName)//' npp_store ' ,totalCohorts,currentCohort%npp_store + write(iulog,*) trim(methodName)//' bmort ' ,totalCohorts,currentCohort%bmort + write(iulog,*) trim(methodName)//' hmort ' ,totalCohorts,currentCohort%hmort + write(iulog,*) trim(methodName)//' cmort ' ,totalCohorts,currentCohort%cmort + write(iulog,*) trim(methodName)//' imort ' ,totalCohorts,currentCohort%imort + write(iulog,*) trim(methodName)//' fmort ' ,totalCohorts,currentCohort%fmort + write(iulog,*) trim(methodName)//' ddbhdt ' ,totalCohorts,currentCohort%ddbhdt 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 @@ -1209,6 +1433,20 @@ subroutine printIoInfoLL( this, bounds, ed_allsites_inst ) 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)//' gpp ',currentCohort%gpp + write(iulog,*) trim(methodName)//' npp ',currentCohort%npp + write(iulog,*) trim(methodName)//' npp_leaf ',currentCohort%npp_leaf + write(iulog,*) trim(methodName)//' npp_froot ',currentCohort%npp_froot + write(iulog,*) trim(methodName)//' npp_bsw ',currentCohort%npp_bsw + write(iulog,*) trim(methodName)//' npp_bdead ',currentCohort%npp_bdead + write(iulog,*) trim(methodName)//' npp_bseed ',currentCohort%npp_bseed + write(iulog,*) trim(methodName)//' npp_store ',currentCohort%npp_store + write(iulog,*) trim(methodName)//' bmort ',currentCohort%bmort + write(iulog,*) trim(methodName)//' hmort ',currentCohort%hmort + write(iulog,*) trim(methodName)//' cmort ',currentCohort%cmort + write(iulog,*) trim(methodName)//' imort ',currentCohort%imort + write(iulog,*) trim(methodName)//' fmort ',currentCohort%fmort + write(iulog,*) trim(methodName)//' ddbhdt ',currentCohort%ddbhdt 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 @@ -1322,6 +1560,20 @@ subroutine convertCohortListToVector( this, bounds, ed_allsites_inst ) this%n(countCohort) = currentCohort%n this%gpp_acc(countCohort) = currentCohort%gpp_acc this%npp_acc(countCohort) = currentCohort%npp_acc + this%gpp(countCohort) = currentCohort%gpp + this%npp(countCohort) = currentCohort%npp + this%npp_leaf(countCohort) = currentCohort%npp_leaf + this%npp_froot(countCohort) = currentCohort%npp_froot + this%npp_bsw(countCohort) = currentCohort%npp_bsw + this%npp_bdead(countCohort) = currentCohort%npp_bdead + this%npp_bseed(countCohort) = currentCohort%npp_bseed + this%npp_store(countCohort) = currentCohort%npp_store + this%bmort(countCohort) = currentCohort%bmort + this%hmort(countCohort) = currentCohort%hmort + this%cmort(countCohort) = currentCohort%cmort + this%imort(countCohort) = currentCohort%imort + this%fmort(countCohort) = currentCohort%fmort + this%ddbhdt(countCohort) = currentCohort%ddbhdt this%resp_clm(countCohort) = currentCohort%resp_clm this%pft(countCohort) = currentCohort%pft this%status_coh(countCohort) = currentCohort%status_coh @@ -1715,6 +1967,20 @@ subroutine convertCohortVectorToList( this, bounds, ed_allsites_inst ) currentCohort%n = this%n(countCohort) currentCohort%gpp_acc = this%gpp_acc(countCohort) currentCohort%npp_acc = this%npp_acc(countCohort) + currentCohort%gpp = this%gpp(countCohort) + currentCohort%npp = this%npp(countCohort) + currentCohort%npp_leaf = this%npp_leaf(countCohort) + currentCohort%npp_froot = this%npp_froot(countCohort) + currentCohort%npp_bsw = this%npp_bsw(countCohort) + currentCohort%npp_bdead = this%npp_bdead(countCohort) + currentCohort%npp_bseed = this%npp_bseed(countCohort) + currentCohort%npp_store = this%npp_store(countCohort) + currentCohort%bmort = this%bmort(countCohort) + currentCohort%hmort = this%hmort(countCohort) + currentCohort%cmort = this%cmort(countCohort) + currentCohort%imort = this%imort(countCohort) + currentCohort%fmort = this%fmort(countCohort) + currentCohort%ddbhdt = this%ddbhdt(countCohort) currentCohort%resp_clm = this%resp_clm(countCohort) currentCohort%pft = this%pft(countCohort) currentCohort%status_coh = this%status_coh(countCohort) From 3426189e9aeeccb2f6febda20a83bbcf5743ddf2 Mon Sep 17 00:00:00 2001 From: ckoven Date: Fri, 15 Apr 2016 14:35:31 -0700 Subject: [PATCH 075/437] changes to fuse_2_patches to avoid crashing bug --- biogeochem/EDPatchDynamicsMod.F90 | 58 ++++++++++++++++++++++--------- 1 file changed, 41 insertions(+), 17 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 58c4656c..8e7f014e 100755 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -1158,6 +1158,9 @@ subroutine fuse_2_patches(dp, rp) 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? + type(ed_patch_type), pointer :: youngerp ! pointer to the patch younger than donor + type(ed_patch_type), pointer :: olderp ! pointer to the patch older than donor + type(ed_site_type), pointer :: csite ! pointer to the donor patch's site !--------------------------------------------------------------------- !area weighted average of ages & litter & seed bank @@ -1253,25 +1256,47 @@ subroutine fuse_2_patches(dp, rp) 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 + ! Define some aliases for the donor patches younger and older neighbors + ! which may or may not exist. After we set them, we will remove the donor + ! And then we will go about re-setting the map. + csite => dp%siteptr + if(associated(dp%older))then + olderp => dp%older + else + olderp => null() + end if + if(associated(dp%younger))then + youngerp => dp%younger + else + youngerp => null() + end if + ! We have no need for the dp pointer anymore, we have passed on it's legacy deallocate(dp) + + if(associated(youngerp))then + ! Update the younger patch's new older patch (because it isn't dp anymore) + youngerp%older => olderp + else + ! There was no younger patch than dp, so the head of the young order needs + ! to be set, and it is set as the patch older than dp. That patch + ! already knows it's older patch (so no need to set or change it) + csite%youngest_patch => olderp + end if + + + if(associated(olderp))then + ! Update the older patch's new younger patch (becuase it isn't dp anymore) + olderp%younger => youngerp + else + ! There was no patch older than dp, so the head of the old patch order needs + ! to be set, and it is set as the patch younger than dp. That patch already + ! knows it's younger patch, no need to set + csite%oldest_patch => youngerp + end if + + end subroutine fuse_2_patches ! ============================================================================ @@ -1305,7 +1330,6 @@ subroutine terminate_patches(cs_pnt) 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 From 0c6d18db3a0efb3d610f3e8bbe6703739cd21e4c Mon Sep 17 00:00:00 2001 From: ckoven Date: Tue, 19 Apr 2016 11:11:55 -0700 Subject: [PATCH 076/437] put in check of patch area before canopy structure calculation to prevent runtime hang due to infinite loop in arealayer calculation --- biogeochem/EDCanopyStructureMod.F90 | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 9323ac0f..e8ae4985 100755 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -67,7 +67,7 @@ subroutine canopy_structure( currentSite ) 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 + use EDtypesMod , only : ncwd, min_patch_area ! ! !ARGUMENTS type(ed_site_type) , intent(inout), target :: currentSite @@ -99,12 +99,15 @@ subroutine canopy_structure( currentSite ) new_total_area_check = 0._r8 do while (associated(currentPatch)) ! Patch loop + + if (currentPatch%area .gt. min_patch_area) then ! avoid numerical weirdness that shouldn't be happening anyway + 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 @@ -555,6 +558,11 @@ subroutine canopy_structure( currentSite ) ! write(iulog,*) 'end patch loop',currentSite%clmgcell endif + else !terminate logic to only do if patch_area_sufficiently large + write(iulog,*) 'canopy_structure: patch area too small.', currentPatch%area + end if + + currentPatch => currentPatch%younger enddo !patch From 7ac6e14ac879e4e5f7e5863ddd835aa6cea3ac9e Mon Sep 17 00:00:00 2001 From: ckoven Date: Tue, 19 Apr 2016 15:04:54 -0700 Subject: [PATCH 077/437] changed min_patch_area fusion logic to now force fusion when tiny patch is the oldest on the site --- biogeochem/EDPatchDynamicsMod.F90 | 22 +++++++++++++++------- 1 file changed, 15 insertions(+), 7 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 8e7f014e..d95607ac 100755 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -1312,7 +1312,7 @@ subroutine terminate_patches(cs_pnt) ! ! !LOCAL VARIABLES: type(ed_site_type), pointer :: currentSite - type(ed_patch_type), pointer :: currentPatch + type(ed_patch_type), pointer :: currentPatch, tmpptr real(r8) areatot ! variable for checking whether the total patch area is wrong. !--------------------------------------------------------------------- @@ -1324,14 +1324,22 @@ subroutine terminate_patches(cs_pnt) currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) if(currentPatch%area <= min_patch_area)then - if(associated(currentPatch%older).and.currentPatch%patchno /= currentSite%youngest_patch%patchno)then + if ( 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) - write(iulog,*) 'after fusion',currentPatch%area,currentPatch%seed_bank(1) - endif + if(associated(currentPatch%older) )then + write(iulog,*) 'fusing to older patch because this 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) + write(iulog,*) 'after fusion to older patch',currentPatch%area,currentPatch%seed_bank(1) + else + write(iulog,*) 'fusing to younger patch because oldest one is too small',currentPatch%area, currentPatch%lai + tmpptr => currentPatch%younger + call fuse_2_patches(currentPatch, currentPatch%younger) + write(iulog,*) 'after fusion to younger patch' + currentPatch => tmpptr + endif + endif endif currentPatch => currentPatch%older From 01b7e65726e1167309a2b162524d01e490858965 Mon Sep 17 00:00:00 2001 From: Ben Andre Date: Thu, 21 Apr 2016 16:06:21 -0600 Subject: [PATCH 078/437] 'pull clm4_5_8_r178 tags from svn' --- main/EDCLMLinkMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 5de402f3..294198c4 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -181,7 +181,7 @@ subroutine InitHistory(this, bounds) ! ! !USES: use clm_varpar , only : ndecomp_cascade_transitions, ndecomp_pools - use clm_varpar , only : nlevdecomp, nlevdecomp_full, crop_prog + use clm_varpar , only : nlevdecomp, nlevdecomp_full use clm_varcon , only : spval use histFileMod, only : hist_addfld1d, hist_addfld2d, hist_addfld_decomp ! From 1a5ef7c4498264ff7a870a9e2746151ea2e6dba7 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 29 Apr 2016 12:31:06 -0700 Subject: [PATCH 079/437] This commit introduces several new features: 1) the clm_fates API (where munging between CLM and FATES occurs). 2) the fates API (where fates presents to the clm_fates API is publically accessible bits which includes the head of its state structure sites(:) and boundary condition vectors, although the latter is not yet coded) 3) some starter work on removing ED sun/shade calculations from CLM code. Although, this still needs more work because some boundary conditions for this procedure should now be defined in the fates(nc)%fatesbc public and populated in the clm_fates munging API, yet this functionality is not yet introduced yet. *Note, there are sill many only partially introduced features. For instance: 1 the fates API is still being accessed by CLM code, and not only through the clm_fates API. 2 the fates API still has access to CLM types 3 the fates(nc)%sites(:) vector is still allocated using the bounds_clump type, and it propogates well into the FATES/ED code. Lots to do still. --- biogeophys/EDSurfaceAlbedoMod.F90 | 1807 ++++++++++++++++------------- main/EDInitMod.F90 | 96 +- main/EDRestVectorMod.F90 | 26 +- main/FatesInterfaceMod.F90 | 196 ++++ 4 files changed, 1231 insertions(+), 894 deletions(-) create mode 100644 main/FatesInterfaceMod.F90 diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index d601d5bf..a979bf00 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -1,159 +1,157 @@ -module EDSurfaceAlbedoMod +module EDSurfaceRadiationMod + + !------------------------------------------------------------------------------------- + ! EDSurfaceRadiation + ! + ! This module contains function and type definitions for all things related + ! to radiative transfer in ED modules at the land surface. + ! + !------------------------------------------------------------------------------------- #include "shr_assert.h" - - !----------------------------------------------------------------------- - ! !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 + + use EDtypesMod , only : ed_patch_type, ed_site_type + use EDtypesMod , only : numpft_ed + use EDTypesMod , only : map_clmpatch_to_edpatch + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_log_mod , only : errMsg => shr_log_errMsg + use decompMod , only : bounds_type + use clm_varpar , only : numrad, nclmax 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. - + public :: ED_SunShadeFracs + logical :: DEBUG = .false. ! for debugging this module - + real(r8), public :: albice(numrad) = & ! albedo land ice by waveband (1=vis, 2=nir) - (/ 0.80_r8, 0.55_r8 /) - ! - ! !PRIVATE MEMBER FUNCTIONS: - !----------------------------------------------------------------------- - + (/ 0.80_r8, 0.55_r8 /) + 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 + + 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 + ! in this routine in the future + 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) @@ -176,556 +174,556 @@ subroutine ED_Norman_Radiation (bounds, & ! 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(p) = 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) * & + 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(p) = 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' , & + 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 + 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)* & + !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)* & + 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 + 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) * & + 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)* & + 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)* & + 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) * & + 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)* & + 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)* & + 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 + 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) + & + 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) = 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) + & + 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 + endif + endif - end do !iv - weighted_fsun(L) = weighted_fsun(L) + currentPatch%f_sun(L,ft,currentPatch%nrad(L,ft))* & + 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) / & + ! 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)* & + 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) / & + 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)* & + 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)* & + 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) * & + 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) * & + 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 + endif + end do - weighted_dif_down(L) = weighted_dif_down(L) + Dif_dn(L,ft,currentPatch%nrad(L,ft)+1) * & + 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) * & + !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) * & + 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))) * & + !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) * & + !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) + & + 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)) + 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))/ & + 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))/ & + 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))/ & + endif + else + down_rad = down_rad + Dif_dn(L,ft,iv) * (ftweight(L,ft,1)-ftweight(L,ft,iv))/ & ftweight(L,ft,1) - endif + 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 + !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 + end do !iv - weighted_dif_down(L) = weighted_dif_down(L) + Dif_dn(L,ft,currentPatch%nrad(L,ft)+1) * & + 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) + & + 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) * & + 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))) * & + 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_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) * & + 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) + & + 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 + 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) * & + ! 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? - if (ib == 1) then ! only set the absorbed PAR for the visible light band. + 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? + if (ib == 1) then ! only set the absorbed PAR for the visible light band. do iv = 1, currentPatch%nrad(L,ft) if (radtype==1) then if ( DEBUG ) then @@ -733,15 +731,15 @@ subroutine ED_Norman_Radiation (bounds, & write(iulog,*) 'EDsurfAlb 731 ',currentPatch%fabd_sha_z(L,ft,iv),currentPatch%fabd_sun_z(L,ft,iv) endif currentPatch%fabd_sha_z(L,ft,iv) = Abs_dif_z(ft,iv) * & - (1._r8 - currentPatch%f_sun(L,ft,iv)) + (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) + 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)) + (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) + currentPatch%f_sun(L,ft,iv) endif if ( DEBUG ) then write(iulog,*) 'EDsurfAlb 740 ',currentPatch%fabd_sha_z(L,ft,iv),currentPatch%fabd_sun_z(L,ft,iv) @@ -749,201 +747,352 @@ subroutine ED_Norman_Radiation (bounds, & end do endif ! ib - !==============================================================================! - ! Sum fluxes - !==============================================================================! - ! Solar radiation absorbed by ground - iv = currentPatch%nrad(L,ft) + 1 - if (L==currentPatch%NCL_p)then - abs_rad(ib) = abs_rad(ib) + (Abs_dir_z(ft,iv) + Abs_dif_z(ft,iv)) - end if - ! Solar radiation absorbed by vegetation and sunlit/shaded leaves - do iv = 1,currentPatch%nrad(L,ft) - if (radtype == 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) * & + !==============================================================================! + ! 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) * & + 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))+ & + 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), & + 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), & + 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 + 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) * & + 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) , & + 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 - ! NO-OP - ! 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 - ! NO-OP - ! 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 - ! NO-OP - ! 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 - 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 - 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 + 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 + ! NO-OP + ! 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 + ! NO-OP + ! 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 + ! NO-OP + ! 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 + 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 + 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 + + +subroutine ED_SunShadeFracs(cpatch,forc_par_d,forc_par_i,fsun) + + + use clm_varctl , only : iulog + + ! Arguments In + + real(r8),intent(in) :: forc_par_d + real(r8),intent(in) :: forc_par_i + + ! Arguments inout + type (ed_patch_type),intent(inout), target :: cpatch ! c"urrent" patch + + + ! Arguments Out + real(r8),intent(out) :: fsun + + ! locals + real(r8) :: sunlai + real(r8) :: shalai + integer :: CL + integer :: FT + integer :: iv + + + ! zero out various datas + cpatch%ed_parsun_z(:,:,:) = 0._r8 + cpatch%ed_parsha_z(:,:,:) = 0._r8 + cpatch%ed_laisun_z(:,:,:) = 0._r8 + cpatch%ed_laisha_z(:,:,:) = 0._r8 + + fsun = 0._r8 + sunlai = 0._r8 + shalai = 0._r8 + + ! Loop over patches to calculate laisun_z and laisha_z for each layer. + ! Derive canopy laisun, laisha, and fsun from layer sums. + ! If sun/shade big leaf code, nrad=1 and fsun_z(p,1) and tlai_z(p,1) from + ! SurfaceAlbedo is canopy integrated so that layer value equals canopy value. + + ! cpatch%f_sun is calculated in the surface_albedo routine... + + do CL = 1, cpatch%NCL_p + do FT = 1,numpft_ed + do iv = 1, cpatch%nrad(CL,ft) !NORMAL CASE. + + ! FIX(SPM,040114) - existing comment + ! ** Should this be elai or tlai? Surely we only do radiation for elai? + + cpatch%ed_laisun_z(CL,ft,iv) = cpatch%elai_profile(CL,ft,iv) * & + cpatch%f_sun(CL,ft,iv) + + if ( DEBUG ) write(iulog,*) 'edsurfRad 570 ',cpatch%elai_profile(CL,ft,iv) + if ( DEBUG ) write(iulog,*) 'edsurfRad 571 ',cpatch%f_sun(CL,ft,iv) + + cpatch%ed_laisha_z(CL,ft,iv) = cpatch%elai_profile(CL,ft,iv) * & + (1._r8 - cpatch%f_sun(CL,ft,iv)) + + end do + + !needed for the VOC emissions, etc. + sunlai = sunlai + sum(cpatch%ed_laisun_z(CL,ft,1:cpatch%nrad(CL,ft))) + shalai = shalai + sum(cpatch%ed_laisha_z(CL,ft,1:cpatch%nrad(CL,ft))) + + end do + end do + + if(sunlai+shalai > 0._r8)then + fsun = sunlai / (sunlai+shalai) + else + fsun = 0._r8 + endif + + if(fsun > 1._r8)then + write(iulog,*) 'too much leaf area in profile', fsun, & + cpatch%lai,sunlai,shalai + endif + + ! Absorbed PAR profile through canopy + ! If sun/shade big leaf code, nrad=1 and fluxes from SurfaceAlbedo + ! are canopy integrated so that layer values equal big leaf values. + + if ( DEBUG ) write(iulog,*) 'edsurfRad 645 ',cpatch%NCL_p,numpft_ed + + do CL = 1, cpatch%NCL_p + do FT = 1,numpft_ed + + if ( DEBUG ) write(iulog,*) 'edsurfRad 649 ',cpatch%nrad(CL,ft) + + do iv = 1, cpatch%nrad(CL,ft) + + if ( DEBUG ) then + write(iulog,*) 'edsurfRad 653 ', cpatch%ed_parsun_z(CL,ft,iv) + write(iulog,*) 'edsurfRad 654 ', forc_par_d + write(iulog,*) 'edsurfRad 655 ', forc_par_i + write(iulog,*) 'edsurfRad 656 ', cpatch%fabd_sun_z(CL,ft,iv) + write(iulog,*) 'edsurfRad 657 ', cpatch%fabi_sun_z(CL,ft,iv) + endif + + cpatch%ed_parsun_z(CL,ft,iv) = & + forc_par_d*cpatch%fabd_sun_z(CL,ft,iv) + & + forc_par_i*cpatch%fabi_sun_z(CL,ft,iv) + + if ( DEBUG )write(iulog,*) 'edsurfRad 663 ', cpatch%ed_parsun_z(CL,ft,iv) + + cpatch%ed_parsha_z(CL,ft,iv) = & + forc_par_d*cpatch%fabd_sha_z(CL,ft,iv) + & + forc_par_i*cpatch%fabi_sha_z(CL,ft,iv) + + if ( DEBUG ) write(iulog,*) 'edsurfRad 669 ', cpatch%ed_parsha_z(CL,ft,iv) + + end do !iv + end do !FT + end do !CL + + return + + end subroutine ED_SunShadeFracs + + +! ! MOVE TO THE INTERFACE +! subroutine ED_CheckSolarBalance(g,filter_nourbanp,num_nourbanp,fsa,fsr,forc_solad,forc_solai) + + +! implicit none +! integer,intent(in),dimension(:) :: gridcell ! => gridcell index +! integer,intent(in),dimension(:) :: filter_nourbanp ! => patch filter for non-urban points +! integer, intent(in) :: num_nourbanp ! number of patches in non-urban points in patch filter +! real(r8),intent(in),dimension(:,:) :: forc_solad ! => atm2lnd_inst%forc_solad_grc, direct radiation (W/m**2 +! real(r8),intent(in),dimension(:,:) :: forc_solai ! => atm2lnd_inst%forc_solai_grc, diffuse radiation (W/m**2) +! real(r8),intent(in),dimension(:,:) :: fsa ! => solarabs_inst%fsa_patch, solar radiation absorbed (total) (W/m**2) +! real(r8),intent(in),dimension(:,:) :: fsr ! => solarabs_inst%fsr_patch, solar radiation reflected (W/m**2) + +! integer :: p +! integer :: fp +! integer :: g +! real(r8) :: errsol + +! do fp = 1,num_nourbanp +! p = filter_nourbanp(fp) +! g = gridcell(p) +! errsol = (fsa(p) + fsr(p) - (forc_solad(g,1) + forc_solad(g,2) + forc_solai(g,1) + forc_solai(g,2))) +! if(abs(errsol) > 0.1_r8)then +! write(iulog,*) 'sol error in surf rad',p,g, errsol +! endif +! end do +! return +! end subroutine ED_CheckSolarBalance + + +end module EDSurfaceRadiationMod diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 8c8f0ed4..ca485212 100755 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -20,7 +20,6 @@ module EDInitMod 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 @@ -30,7 +29,6 @@ module EDInitMod logical :: DEBUG = .false. - public :: ed_init public :: ed_init_sites public :: zero_site @@ -42,53 +40,55 @@ module EDInitMod 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 - if (DEBUG) then - write(iulog,*) 'ED: restart ? = ' ,is_restart() - write(iulog,*) 'ED_Mod.F90 :: SPITFIRE_SWITCH (use_ed_spit_fire) ', & - use_ed_spit_fire - write(iulog,*) 'ED_Mod.F90 :: cohorts_per_gcell ',cohorts_per_gcell - end if - end if - - ! - ! don't call this if we are restarting - ! - 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 + !! REMOVING INTERF-TODO (RGK) + !!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 + !! if (DEBUG) then + !! write(iulog,*) 'ED: restart ? = ' ,is_restart() + !! write(iulog,*) 'ED_Mod.F90 :: SPITFIRE_SWITCH (use_ed_spit_fire) ', & + !! use_ed_spit_fire + !! write(iulog,*) 'ED_Mod.F90 :: cohorts_per_gcell ',cohorts_per_gcell + !! end if + !! end if + + !! ! + !! ! don't call this if we are restarting + !! ! + !! 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 ) diff --git a/main/EDRestVectorMod.F90 b/main/EDRestVectorMod.F90 index c45938e5..0ca33d58 100755 --- a/main/EDRestVectorMod.F90 +++ b/main/EDRestVectorMod.F90 @@ -626,8 +626,7 @@ subroutine setVectors( this, bounds, ed_allsites_inst ) end subroutine setVectors !-------------------------------------------------------------------------------! - subroutine getVectors( this, bounds, ed_allsites_inst, ed_clm_inst, & - ed_phenology_inst, waterstate_inst, canopystate_inst) + subroutine getVectors( this, bounds, ed_allsites_inst ) ! ! !DESCRIPTION: ! implement getVectors @@ -642,10 +641,8 @@ subroutine getVectors( this, bounds, ed_allsites_inst, ed_clm_inst, & 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 @@ -665,8 +662,8 @@ subroutine getVectors( this, bounds, ed_allsites_inst, ed_clm_inst, & 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) +! 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) ) @@ -2116,26 +2113,22 @@ end subroutine convertCohortVectorToList !--------------------------------------------! !-------------------------------------------------------------------------------! - subroutine EDRest ( bounds, ncid, flag, ed_allsites_inst, ed_clm_inst, ed_phenology_inst, & - waterstate_inst, canopystate_inst ) + subroutine EDRest ( bounds, ed_allsites_inst, ncid, flag ) ! ! !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 + type(ed_site_type) , intent(inout) :: ed_allsites_inst(bounds%begg:) 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 @@ -2156,8 +2149,7 @@ subroutine EDRest ( bounds, ncid, flag, ed_allsites_inst, ed_clm_inst, ed_phenol 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) + call ervc%getVectors( bounds, ed_allsites_inst(bounds%begg:bounds%endg) ) endif call ervc%deleteEDRestartVectorClass () diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 new file mode 100644 index 00000000..26302b19 --- /dev/null +++ b/main/FatesInterfaceMod.F90 @@ -0,0 +1,196 @@ +module FatesInterfaceMod + + ! ------------------------------------------------------------------------------------ + ! This is the FATES public API + ! A host land model has defined and allocated a structure "fates" as + ! defined by fates_interface_type + ! + ! It is also likely/possible that this type is defined as a vector + ! which is allocated by thread + ! ------------------------------------------------------------------------------------ + + ! ------------------------------------------------------------------------------------ + ! Used CLM Modules + ! INTERF-TODO: NO CLM MODULES SHOULD BE ACCESSIBLE BY THE FATES + ! PUBLIC API!!!! + use decompMod , only : bounds_type + use CanopyStateType , only : canopystate_type + use atm2lndType , only : atm2lnd_type + use ncdio_pio , only : file_desc_t + use PatchType , only : patch + ! ------------------------------------------------------------------------------------ + + use EDtypesMod , only : ed_patch_type, ed_site_type, numpft_ed + use EDtypesMod , only : map_clmpatch_to_edpatch + use EDSurfaceRadiationMod , only : ED_SunShadeFracs + use EDInitMod , only : ed_init_sites + use EDMainMod , only : ed_update_site + use EDRestVectorMod , only : EDRest + + type, public :: fates_interface_type + + ! This is the root of the ED/FATES hierarchy of instantaneous state variables + ! ie the root of the linked lists. Each path list is currently associated + ! with a grid-cell, this is intended to be migrated to columns + ! prev: type(ed_site_type)::ed_allsites_inst + type(ed_site_type), allocatable :: sites(:) + + ! INTERF-TODO ADD THE DLM->FATES BOUNDARY CONDITION CLASS + ! These are boundary condition variables populated by the DLM + ! type(fates_bc_type) :: fatesbc + + contains + + ! Procedures for initializing FATES threaded memory and communicators + procedure, public :: fates_init + procedure, public :: fates_clean + procedure, public :: site_init + procedure, public :: fates_restart + procedure, public :: canopy_sunshade_fracs + + end type fates_interface_type + +contains + + subroutine fates_init(this,bounds_clump) + + implicit none + + ! Input Arguments + class(fates_interface_type), intent(inout) :: this + + ! INTERF-TODO: AS THE FATES PUBLIC API- BOUNDS CLUMP WILL NOT BE ALLOWED + ! IN HERE FOR MUCH LONGER. + type(bounds_type),intent(in) :: bounds_clump + + + ! Initialize the mapping elements between FATES and the DLM + + ! These bounds are for a single clump (thread) + allocate (this%sites(bounds_clump%begg:bounds_clump%endg)) + + return + end subroutine fates_init + + ! ------------------------------------------------------------------------------------ + + ! INTERF-TODO: THIS IS A PLACE-HOLDER ROUTINE, NOT CALLED YET... + subroutine fates_clean(this,bounds_clump) + + implicit none + + ! Input Arguments + class(fates_interface_type), intent(inout) :: this + type(bounds_type),intent(in) :: bounds_clump + + ! Incrementally walk through linked list and deallocate + + ! Deallocate the site list + deallocate (this%sites) + + return + end subroutine fates_clean + + ! ------------------------------------------------------------------------------------ + + subroutine site_init(this,bounds_clump) + + ! Input Arguments + class(fates_interface_type), intent(inout) :: this + type(bounds_type),intent(in) :: bounds_clump + + ! locals + integer :: g + + ! Initialize (INTERF-TODO THIS ROUTINE CALLS CLM STUFF-MIGRATE CODE TO HERE) + call ed_init_sites( bounds_clump, & + this%sites(bounds_clump%begg:bounds_clump%endg) ) + + ! INTERF-TODO: WHEN WE MOVE TO COLUMNS, THIS WILL BE UNNECESSARY + do g = bounds_clump%begg,bounds_clump%endg + if (this%sites(g)%istheresoil) then + call ed_update_site(this%sites(g)) + end if + end do + + return + end subroutine site_init + + ! ------------------------------------------------------------------------------------ + + subroutine fates_restart(this, bounds_clump, ncid, flag ) + + implicit none + class(fates_interface_type), intent(inout) :: this + type(bounds_type),intent(in) :: bounds_clump + type(file_desc_t) , intent(inout) :: ncid ! netcdf id + character(len=*) , intent(in) :: flag !'read' or 'write' + + call EDRest( bounds_clump, this%sites(bounds_clump%begg:bounds_clump%endg), & + ncid, flag ) + return + end subroutine fates_restart + + ! ------------------------------------------------------------------------------------ + + subroutine canopy_sunshade_fracs(this ,filter_nourbanp, num_nourbanp, & + atm2lnd_inst,canopystate_inst) + + + ! TODO-INTERF: THIS ROUTINE NEEDS TO BE WRAPPED BY A CLM_FATES CALL + ! IN THAT CALL THE BOUNDARY CONDITIONS SHOULD BE PREPPED + ! SO THAT THIS CALL DOES NOT HAVE CLM TYPES HERE + + ! This interface function is a wrapper call on ED_SunShadeFracs. The only + ! returned variable is a patch vector, fsun_patch, which describes the fraction + ! of the canopy that is exposed to sun. + + implicit none + + ! Input Arguments + class(fates_interface_type), intent(inout) :: this + + ! patch filter for non-urban points + integer, intent(in),dimension(:) :: filter_nourbanp + + ! number of patches in non-urban points in patch filter + integer, intent(in) :: num_nourbanp + + ! direct and diffuse downwelling radiation (W/m2) + type(atm2lnd_type),intent(in) :: atm2lnd_inst + + ! Input/Output Arguments to CLM + type(canopystate_type),intent(inout) :: canopystate_inst + + ! Local Variables + integer :: fp ! non-urban filter patch index + integer :: p ! patch index + integer :: g ! grid cell index + integer, parameter :: ipar = 1 ! The band index for PAR + type(ed_patch_type), pointer :: cpatch ! c"urrent" patch + + associate( forc_solad => atm2lnd_inst%forc_solad_grc, & + forc_solai => atm2lnd_inst%forc_solai_grc, & + fsun => canopystate_inst%fsun_patch) + + do fp = 1,num_nourbanp + + p = filter_nourbanp(fp) + g = patch%gridcell(p) + + if ( patch%is_veg(p) ) then + cpatch => map_clmpatch_to_edpatch(this%sites(g), p) + + call ED_SunShadeFracs(cpatch,forc_solad(g,ipar),forc_solai(g,ipar),fsun(p)) + + endif + + end do + end associate + return + end subroutine canopy_sunshade_fracs + + + + +end module FatesInterfaceMod From 5be200c5197bd587fdd3a3c950a5ef4172c868c3 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 2 May 2016 10:49:25 -0700 Subject: [PATCH 080/437] removed comments, commented code is deprecated. --- main/EDInitMod.F90 | 50 ---------------------------------------------- 1 file changed, 50 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index ca485212..534d320b 100755 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -41,56 +41,6 @@ module EDInitMod ! ============================================================================ - !! REMOVING INTERF-TODO (RGK) - !!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 - !! if (DEBUG) then - !! write(iulog,*) 'ED: restart ? = ' ,is_restart() - !! write(iulog,*) 'ED_Mod.F90 :: SPITFIRE_SWITCH (use_ed_spit_fire) ', & - !! use_ed_spit_fire - !! write(iulog,*) 'ED_Mod.F90 :: cohorts_per_gcell ',cohorts_per_gcell - !! end if - !! end if - - !! ! - !! ! don't call this if we are restarting - !! ! - !! 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: From f5a986aa1db4a7af35e3d376d7432926581596c9 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 13 May 2016 14:58:01 -0700 Subject: [PATCH 081/437] Addressed issue #4: changed vector indexing of parameter ED_val_grperc to use the PFT of the current cohort. --- biogeochem/EDPhysiologyMod.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 5fd7fc9f..2f63f7a9 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -187,13 +187,13 @@ subroutine trim_canopy( currentSite ) 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) + 1._r8) + currentCohort%leaf_cost = currentCohort%leaf_cost * (ED_val_grperc(currentCohort%pft) + 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) + 1._r8) + currentCohort%leaf_cost = currentCohort%leaf_cost * (ED_val_grperc(currentCohort%pft) + 1._r8) endif if (currentCohort%year_net_uptake(z) < currentCohort%leaf_cost)then if (currentCohort%canopy_trim > trim_limit)then From 2e68d07c6916462668c70465056caeff451113ee Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 13 May 2016 16:13:27 -0700 Subject: [PATCH 082/437] Address bug #36, effective LAI, total SAI and effective SAI were being zero'd strangely in ed_clm_link. It appears that this part of the code is responsible for zero'ing the bare-ground portion of the code. There is also the assumption that patches that are not within the perview of ED should be zero'd here too. This would be crop patches, as well as the bear-ground patches (grrr) just mentioned. --- main/EDCLMLinkMod.F90 | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 6659dc51..94c6c9f8 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -1040,12 +1040,13 @@ subroutine ed_clm_link( this, bounds, ed_allsites_inst, ed_phenology_inst, & 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 + elai(begp:endp) = 0.0_r8 + tsai(begp:endp) = 0.0_r8 + esai(begp:endp) = 0.0_r8 do g = begg,endg @@ -1056,9 +1057,9 @@ subroutine ed_clm_link( this, bounds, ed_allsites_inst, ed_phenology_inst, & ! 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 + !tlai(firstsoilpatch(g)) = 0.0_r8 ! This is redundant (test removal, RGK) + !htop(firstsoilpatch(g)) = 0.0_r8 ! This is redundant (test removal, RGK) + !hbot(firstsoilpatch(g)) = 0.0_r8 ! This is redundant (test removal, RGK) patchn = 0 total_bare_ground = 0.0_r8 From 3b0d436dcada20e60bdc26ea7788932de73853c1 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 16 May 2016 11:54:55 -0700 Subject: [PATCH 083/437] removed comments --- main/EDCLMLinkMod.F90 | 4 ---- 1 file changed, 4 deletions(-) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 94c6c9f8..bd4aff72 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -1057,10 +1057,6 @@ subroutine ed_clm_link( this, bounds, ed_allsites_inst, ed_phenology_inst, & ! Zero the bare ground tile BGC variables. ! ============================================================================ - !tlai(firstsoilpatch(g)) = 0.0_r8 ! This is redundant (test removal, RGK) - !htop(firstsoilpatch(g)) = 0.0_r8 ! This is redundant (test removal, RGK) - !hbot(firstsoilpatch(g)) = 0.0_r8 ! This is redundant (test removal, RGK) - patchn = 0 total_bare_ground = 0.0_r8 total_patch_area = 0._r8 From 224e662bbac688d3eb9bafd4ae70c4c668409cee Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 16 May 2016 13:55:59 -0700 Subject: [PATCH 084/437] Modified zeroing range during the clmed linking to only affect the soil patch and non-crop patches. FATES/ED only appears to operate on these patches, we should not be affecting the other patches, that is up to either another module, or should have a switch in a clearly defined space. --- main/EDCLMLinkMod.F90 | 33 +++++++++++++++++++-------------- 1 file changed, 19 insertions(+), 14 deletions(-) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index bd4aff72..df5bc8f3 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -986,6 +986,8 @@ subroutine ed_clm_link( this, bounds, ed_allsites_inst, ed_phenology_inst, & 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) + integer :: begp_fp, endp_fp ! Valid range of patch indices that are associated with + ! FATES (F) for each parent (P) iteration (grid/column) !---------------------------------------------------------------------- if ( DEBUG ) then @@ -1034,20 +1036,6 @@ subroutine ed_clm_link( this, bounds, ed_allsites_inst, ed_phenology_inst, & 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 - htop(begp:endp) = 0.0_r8 - hbot(begp:endp) = 0.0_r8 - elai(begp:endp) = 0.0_r8 - tsai(begp:endp) = 0.0_r8 - esai(begp:endp) = 0.0_r8 - do g = begg,endg if(firstsoilpatch(g) >= 0.and.ed_allsites_inst(g)%istheresoil)then @@ -1055,8 +1043,25 @@ subroutine ed_clm_link( this, bounds, ed_allsites_inst, ed_phenology_inst, & ! ============================================================================ ! Zero the bare ground tile BGC variables. + ! Valid Range for zero'ing here is the soil_patch and non crop patches + ! If the crops are not turned on, don't worry, they were zero'd once and should + ! not change again (RGK). + ! firstsoilpatch(g) + numpft - numcft ! ============================================================================ + begp_fp = firstsoilpatch(g) + endp_fp = firstsoilpatch(g) + numpft - numcft + + clmpatch%is_veg(begp_fp:endp_fp) = .false. + clmpatch%is_bareground(begp_fp:endp_fp) = .false. + tlai(begp_fp:endp_fp) = 0.0_r8 + htop(begp_fp:endp_fp) = 0.0_r8 + hbot(begp_fp:endp_fp) = 0.0_r8 + elai(begp_fp:endp_fp) = 0.0_r8 + tsai(begp_fp:endp_fp) = 0.0_r8 + esai(begp_fp:endp_fp) = 0.0_r8 + + patchn = 0 total_bare_ground = 0.0_r8 total_patch_area = 0._r8 From c456862bcd2a2ca4b9042227e681a32855c2775f Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 16 May 2016 18:31:02 -0700 Subject: [PATCH 085/437] Migrated calls to ecosystem dynamics into the clmfates interface, moved timing calls out of FATES code and into the interface. Evaluated udata%, which is not thread-safe, yet at the same time, all threads should be re-writing the same values. However, udata had been incrementing a cohort index number that had been used to test for identity during fusion (so a cohort doesnt fuse itself). The indices could had gotten jumbled if two threads simultaneously incremented the udata structure before assigning the index to the cohort variable. If this happened it would not had affected the fusion process, but would had been a problem if these variables were compared in output. Also, the cohort indices could start to get vary large. The variable was stored as an integer, and udata% was incrementing for every new cohort created per thread. So threads with many gridcells, and many patches, with many cohorts over a long time could generate very large number which could overfill the integer. So the index number was removed from the cohorts and from udata. Test to prevent self fusion now utilize the two argument associated() intrinsic, which tests to see if two pointers are on the same address (in a scalar). --- biogeochem/EDCohortDynamicsMod.F90 | 27 +++++---- biogeochem/EDPhysiologyMod.F90 | 12 ++-- main/EDInitMod.F90 | 2 +- main/EDMainMod.F90 | 97 +++--------------------------- main/EDRestVectorMod.F90 | 4 -- main/EDTypesMod.F90 | 7 ++- main/FatesInterfaceMod.F90 | 2 +- 7 files changed, 38 insertions(+), 113 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 9d46aca9..3cf565dd 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -10,8 +10,8 @@ module EDCohortDynamicsMod 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 + use EDTypesMod , only : fusetol, nclmax, udata + use EDtypesMod , only : ncwd, numcohortsperpatch use EDtypesMod , only : sclass_ed,nlevsclass_ed,AREA use EDtypesMod , only : min_npm2, min_nppatch, min_n_safemath ! @@ -68,7 +68,6 @@ subroutine create_cohort(patchptr, pft, nn, hite, dbh, & !---------------------------------------------------------------------- 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. @@ -77,7 +76,7 @@ subroutine create_cohort(patchptr, pft, nn, hite, dbh, & ! Define cohort state variable !**********************/ - new_cohort%indexnumber = udata%cohort_number +! new_cohort%indexnumber = udata%cohort_number new_cohort%siteptr => patchptr%siteptr new_cohort%patchptr => patchptr new_cohort%pft = pft @@ -613,7 +612,6 @@ subroutine fuse_cohorts(patchptr) iterate = 1 fusion_took_place = 0 currentPatch => patchptr - ! maxcohorts = currentPatch%NCL_p * numCohortsPerPatch maxcohorts = numCohortsPerPatch !---------------------------------------------------------------------! @@ -624,8 +622,13 @@ subroutine fuse_cohorts(patchptr) currentCohort => currentPatch%tallest - !CHANGED FROM C VERSION loop from tallest to smallest, fusing if they are similar - do while (currentCohort%indexnumber /= currentPatch%shortest%indexnumber) + ! The following logic continues the loop while the current cohort is not the shortest cohort + ! if they point to the same target (ie equivalence), then the loop ends. + ! This loop is different than the simple "continue while associated" loop in that + ! it omits the last cohort (because it has already been compared by that point) + + do while ( .not.associated(currentCohort,currentPatch%shortest) ) + nextc => currentPatch%tallest do while (associated(nextc)) @@ -636,7 +639,9 @@ subroutine fuse_cohorts(patchptr) if (diff < dynamic_fusion_tolerance) then - if (currentCohort%indexnumber /= nextc%indexnumber) then + ! Don't fuse a cohort with itself! + if (.not.associated(currentCohort,nextc) ) then +! if (currentCohort%indexnumber /= nextc%indexnumber) then if (currentCohort%pft == nextc%pft) then @@ -981,9 +986,9 @@ subroutine copy_cohort( currentCohort,copyc ) o => currentCohort n => copyc - udata%cohort_number = udata%cohort_number + 1 - n%indexnumber = udata%cohort_number - +! udata%cohort_number = udata%cohort_number + 1 + !n%indexnumber = udata%cohort_number + ! VEGETATION STRUCTURE n%pft = o%pft n%n = o%n diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 2f63f7a9..7dc3190a 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -18,7 +18,7 @@ module EDPhysiologyMod use EDCohortDynamicsMod , only : 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 : ncwd, nlevcan_ed, numpft_ed, senes use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type implicit none @@ -250,7 +250,7 @@ subroutine phenology( currentSite, ed_phenology_inst, temperature_inst, watersta use EDTypesMod, only : udata ! ! !ARGUMENTS: - type(ed_site_type) , intent(inout), pointer:: currentSite + type(ed_site_type) , intent(inout), target :: currentSite type(ed_phenology_type) , intent(in) :: ed_phenology_inst type(temperature_type) , intent(in) :: temperature_inst type(waterstate_type) , intent(in) :: waterstate_inst @@ -504,7 +504,7 @@ subroutine phenology_leafonoff(currentSite) ! !USES: ! ! !ARGUMENTS: - type(ed_site_type), intent(inout), pointer:: currentSite + type(ed_site_type), intent(inout), target :: currentSite ! ! !LOCAL VARIABLES: type(ed_patch_type) , pointer :: currentPatch @@ -771,9 +771,9 @@ subroutine Growth_Derivatives( currentCohort) ! NPP if ( DEBUG ) write(iulog,*) 'EDphys 716 ',currentCohort%npp_acc - 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 + currentCohort%npp = currentCohort%npp_acc * udata%n_sub !Link to CLM. convert from kgC/indiv/day into kgC/indiv/year + currentCohort%gpp = currentCohort%gpp_acc * udata%n_sub !Link to CLM. convert from kgC/indiv/day into kgC/indiv/year + currentCohort%resp = currentCohort%resp_acc * udata%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 diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 534d320b..a98808f9 100755 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -63,7 +63,7 @@ subroutine ed_init_sites( bounds, ed_allsites_inst ) ! INITIALISE THE SITE STRUCTURES ! ! Makes unique cohort identifiers. Needs zeroing at beginning of run. - udata%cohort_number = 0 +! udata%cohort_number = 0 do g = bounds%begg,bounds%endg ! zero the site diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index c52c6330..720f03c8 100755 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -5,7 +5,7 @@ module EDMainMod ! ============================================================================ use shr_kind_mod , only : r8 => shr_kind_r8 - use spmdMod , only : masterproc + use decompMod , only : bounds_type use clm_varctl , only : iulog use atm2lndType , only : atm2lnd_type @@ -16,7 +16,7 @@ module EDMainMod 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 : ncwd, 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 @@ -26,11 +26,11 @@ module EDMainMod ! ! !PUBLIC MEMBER FUNCTIONS: - public :: ed_driver + public :: ed_ecosystem_dynamics public :: ed_update_site ! ! !PRIVATE MEMBER FUNCTIONS: - private :: ed_ecosystem_dynamics + private :: ed_integrate_state_variables private :: ed_total_balance_check @@ -41,83 +41,6 @@ module EDMainMod 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 - - ! 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) - - if (masterproc) then - write(iulog, *) 'clm: leaving ED model', bounds%begg, bounds%endg, dayDiffInt - end if - - end subroutine ed_driver - !-------------------------------------------------------------------------------! subroutine ed_ecosystem_dynamics(currentSite, & ed_clm_inst, ed_phenology_inst, atm2lnd_inst, & @@ -127,7 +50,7 @@ subroutine ed_ecosystem_dynamics(currentSite, & ! Core of ed model, calling all subsequent vegetation dynamics routines ! ! !ARGUMENTS: - type(ed_site_type) , intent(inout), pointer :: currentSite + type(ed_site_type) , intent(inout), target :: 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 @@ -221,10 +144,10 @@ subroutine ed_integrate_state_variables(currentSite, soilstate_inst, temperature ! !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 + 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 @@ -418,7 +341,7 @@ subroutine ed_update_site( currentSite ) enddo ! FIX(RF,032414). This needs to be monthly, not annual - if((udata%time_period == N_SUB-1))then + if((udata%time_period == udata%n_sub-1))then write(iulog,*) 'calling trim canopy' call trim_canopy(currentSite) endif diff --git a/main/EDRestVectorMod.F90 b/main/EDRestVectorMod.F90 index 0ca33d58..873523c5 100755 --- a/main/EDRestVectorMod.F90 +++ b/main/EDRestVectorMod.F90 @@ -634,7 +634,6 @@ subroutine getVectors( this, bounds, ed_allsites_inst ) ! !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: @@ -662,9 +661,6 @@ subroutine getVectors( this, bounds, ed_allsites_inst ) 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) ) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 47934da6..8d1e341b 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -14,7 +14,7 @@ module EDTypesMod ! 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 @@ -438,13 +438,14 @@ module EDTypesMod !************************************ type userdata - integer :: cohort_number ! Counts up the number of cohorts which have been made. + integer :: n_sub ! num of substeps in year 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 + + type(userdata), public, target :: udata ! THIS WAS NOT THREADSAFE !-------------------------------------------------------------------------------------! public :: ed_hist_scpfmaps diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 26302b19..3f64470b 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -21,7 +21,7 @@ module FatesInterfaceMod ! ------------------------------------------------------------------------------------ use EDtypesMod , only : ed_patch_type, ed_site_type, numpft_ed - use EDtypesMod , only : map_clmpatch_to_edpatch + use EDtypesMod , only : map_clmpatch_to_edpatch, userdata use EDSurfaceRadiationMod , only : ED_SunShadeFracs use EDInitMod , only : ed_init_sites use EDMainMod , only : ed_update_site From 99e003694c21bc7ae9a99c221cdad5c639e77815 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 18 May 2016 13:52:38 -0700 Subject: [PATCH 086/437] Reverted the pre-mature removal of udata%cohort_index and cohort%cohort_index. This variable will be evaluated in a seperate issue. --- biogeochem/EDCohortDynamicsMod.F90 | 14 +++++++------- main/EDInitMod.F90 | 2 +- main/EDTypesMod.F90 | 1 + main/FatesInterfaceMod.F90 | 2 +- 4 files changed, 10 insertions(+), 9 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 3cf565dd..0443de25 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -10,8 +10,8 @@ module EDCohortDynamicsMod 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, udata - use EDtypesMod , only : ncwd, numcohortsperpatch + use EDTypesMod , only : fusetol, nclmax + use EDtypesMod , only : ncwd, numcohortsperpatch, udata use EDtypesMod , only : sclass_ed,nlevsclass_ed,AREA use EDtypesMod , only : min_npm2, min_nppatch, min_n_safemath ! @@ -68,7 +68,8 @@ subroutine create_cohort(patchptr, pft, nn, hite, dbh, & !---------------------------------------------------------------------- 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. @@ -76,7 +77,7 @@ subroutine create_cohort(patchptr, pft, nn, hite, dbh, & ! Define cohort state variable !**********************/ -! new_cohort%indexnumber = udata%cohort_number + new_cohort%indexnumber = udata%cohort_number new_cohort%siteptr => patchptr%siteptr new_cohort%patchptr => patchptr new_cohort%pft = pft @@ -641,7 +642,6 @@ subroutine fuse_cohorts(patchptr) ! Don't fuse a cohort with itself! if (.not.associated(currentCohort,nextc) ) then -! if (currentCohort%indexnumber /= nextc%indexnumber) then if (currentCohort%pft == nextc%pft) then @@ -986,8 +986,8 @@ subroutine copy_cohort( currentCohort,copyc ) o => currentCohort n => copyc -! udata%cohort_number = udata%cohort_number + 1 - !n%indexnumber = udata%cohort_number + udata%cohort_number = udata%cohort_number + 1 + n%indexnumber = udata%cohort_number ! VEGETATION STRUCTURE n%pft = o%pft diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index a98808f9..534d320b 100755 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -63,7 +63,7 @@ subroutine ed_init_sites( bounds, ed_allsites_inst ) ! INITIALISE THE SITE STRUCTURES ! ! Makes unique cohort identifiers. Needs zeroing at beginning of run. -! udata%cohort_number = 0 + udata%cohort_number = 0 do g = bounds%begg,bounds%endg ! zero the site diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 8d1e341b..50f5dc09 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -438,6 +438,7 @@ module EDTypesMod !************************************ type userdata + integer :: cohort_number ! Counts up the number of cohorts which have been made. integer :: n_sub ! num of substeps in year 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 diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 3f64470b..26302b19 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -21,7 +21,7 @@ module FatesInterfaceMod ! ------------------------------------------------------------------------------------ use EDtypesMod , only : ed_patch_type, ed_site_type, numpft_ed - use EDtypesMod , only : map_clmpatch_to_edpatch, userdata + use EDtypesMod , only : map_clmpatch_to_edpatch use EDSurfaceRadiationMod , only : ED_SunShadeFracs use EDInitMod , only : ed_init_sites use EDMainMod , only : ed_update_site From 33b22f7fb276713efe8cfbfc12d04b57610bed16 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 19 May 2016 15:21:19 -0700 Subject: [PATCH 087/437] Forced FATES initializations during clm_inst to all go through clm_fates%init(). Allocation of the fates() vector and some updated naming of subroutines accompany. --- main/FatesInterfaceMod.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 26302b19..a5558561 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -42,7 +42,7 @@ module FatesInterfaceMod contains ! Procedures for initializing FATES threaded memory and communicators - procedure, public :: fates_init + procedure, public :: init procedure, public :: fates_clean procedure, public :: site_init procedure, public :: fates_restart @@ -52,7 +52,7 @@ module FatesInterfaceMod contains - subroutine fates_init(this,bounds_clump) + subroutine init(this,bounds_clump) implicit none @@ -70,7 +70,7 @@ subroutine fates_init(this,bounds_clump) allocate (this%sites(bounds_clump%begg:bounds_clump%endg)) return - end subroutine fates_init + end subroutine init ! ------------------------------------------------------------------------------------ From 4e6e3ccf0d163bad79c247b8adbaa192c88988ee Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Fri, 20 May 2016 16:58:46 -0700 Subject: [PATCH 088/437] more removal of phenology code out of interface, and addition of GDD variable onto the ED site type --- biogeochem/EDPhenologyType.F90 | 324 --------------------------------- 1 file changed, 324 deletions(-) delete mode 100644 biogeochem/EDPhenologyType.F90 diff --git a/biogeochem/EDPhenologyType.F90 b/biogeochem/EDPhenologyType.F90 deleted file mode 100644 index d38923d7..00000000 --- a/biogeochem/EDPhenologyType.F90 +++ /dev/null @@ -1,324 +0,0 @@ -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, is_restart - ! - ! !USES: - implicit none - private - ! - type, public :: ed_phenology_type - - logical :: DEBUG = .false. - - ! - ! 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 :: restart - procedure, public :: initAccVars - procedure, public :: initAccBuffer - procedure, public :: clean - - ! Private procedures - procedure, private :: initAllocate - procedure, private :: initHistory - - end type ed_phenology_type - !------------------------------------------------------------------------------ - -contains - - !------------------------------------------------------------------------------ - - !------------------------------------------------------------------------ - subroutine Restart(this, bounds, ncid, flag) - ! - ! !DESCRIPTION: - ! Read/Write module information to/from restart file. - ! - ! !USES: - use shr_log_mod , only : errMsg => shr_log_errMsg - use spmdMod , only : masterproc - use abortutils , only : endrun - use ncdio_pio , only : file_desc_t, ncd_double - use restUtilMod - ! - ! !ARGUMENTS: - class(ed_phenology_type) :: this - type(bounds_type), intent(in) :: bounds - type(file_desc_t), intent(inout) :: ncid - character(len=*) , intent(in) :: flag - - ! - ! !LOCAL VARIABLES: - integer :: j,c ! indices - logical :: readvar ! determine if variable is on initial file - !----------------------------------------------------------------------- - - call restartvar(ncid=ncid, flag=flag, varname='ED_GDD', xtype=ncd_double, & - dim1name='pft', & - long_name='growing degree days for ED', units='ddays', & - interpinic_flag='interp', readvar=readvar, data=this%ED_GDD_patch) - - - end subroutine restart - - subroutine accumulateAndExtract( this, bounds, & - t_ref2m_patch, & - gridcell, latdeg, & - month, day, 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_GDD0 - 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() ) - - if (this%DEBUG) write(iulog,*) 'MM-DD-SSSS',month,'-',day,'-',secs - if (this%DEBUG) write(iulog,*) 'cd_status:',this%phen_cd_status_patch(:) - if (this%DEBUG) write(iulog,*) 'ED_GDD accumAndExtract ', this%ED_GDD_patch - - 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) - - if ( this%DEBUG ) then - write(iulog,*) 'ED_GDD initAccVars ',this%ED_GDD_patch(bounds%begp:bounds%endp) - endif - - deallocate(rbufslp) - - end subroutine initAccVars - -end module EDPhenologyType From 6d81821d206bd2d595d4dcd9e675fbc7bfde1a3c Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Fri, 20 May 2016 17:00:08 -0700 Subject: [PATCH 089/437] more removal of phenology code out of interface, and addition of GDD variable onto the ED site type --- biogeochem/EDPhysiologyMod.F90 | 11 +++++------ main/EDCLMLinkMod.F90 | 6 ------ main/EDInitMod.F90 | 6 +++--- main/EDMainMod.F90 | 5 ++--- main/EDRestVectorMod.F90 | 1 - main/EDTypesMod.F90 | 2 +- 6 files changed, 11 insertions(+), 20 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 7dc3190a..6ebdcb8d 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -16,7 +16,6 @@ module EDPhysiologyMod use EDEcophysContype , only : EDecophyscon use EDCohortDynamicsMod , only : allocate_live_biomass, zero_cohort use EDCohortDynamicsMod , only : 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, numpft_ed, senes use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type @@ -27,6 +26,7 @@ module EDPhysiologyMod public :: canopy_derivs public :: non_canopy_derivs public :: trim_canopy + public :: phenology_gdd_increment public :: phenology public :: phenology_leafonoff public :: Growth_Derivatives @@ -238,7 +238,7 @@ subroutine trim_canopy( currentSite ) end subroutine trim_canopy ! ============================================================================ - subroutine phenology( currentSite, ed_phenology_inst, temperature_inst, waterstate_inst) + subroutine phenology( currentSite, temperature_inst, waterstate_inst) ! ! !DESCRIPTION: ! Phenology. @@ -251,13 +251,12 @@ subroutine phenology( currentSite, ed_phenology_inst, temperature_inst, watersta ! ! !ARGUMENTS: type(ed_site_type) , intent(inout), target :: 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(:) + real(r8), pointer :: ED_GDD_site(:) integer :: g ! grid point integer :: t ! day of year integer :: ncolddays ! no days underneath the threshold for leaf drop @@ -286,7 +285,7 @@ subroutine phenology( currentSite, ed_phenology_inst, temperature_inst, watersta !------------------------------------------------------------------------ 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) + ED_GDD_site => currentSite%ED_GDD_site ! Input: [real(r8) (:)] growing deg. days base 0 deg C (ddays) g = currentSite%clmgcell @@ -358,7 +357,7 @@ subroutine phenology( currentSite, ed_phenology_inst, temperature_inst, watersta !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 (ED_GDD_site(currentSite) > gdd_threshold)then if (currentSite%status == 1) then if (currentSite%ncd >= 1) then currentSite%status = 2 !alter status of site to 'leaves on' diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index df5bc8f3..6d10850e 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -1286,8 +1286,6 @@ subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & 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: - ed_gpp_scpf => this%ed_gpp_gd_scpf , & ed_npp_totl_scpf => this%ed_npp_totl_gd_scpf , & ed_npp_leaf_scpf => this%ed_npp_leaf_gd_scpf , & @@ -1354,7 +1352,6 @@ subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & ED_bleaf(:) = 0.0_r8 ED_bstore(:) = 0.0_r8 ED_balive(:) = 0.0_r8 - phen_cd_status(:) = 2 ed_gpp_scpf(:,:) = 0.0_r8 ed_npp_totl_scpf(:,:) = 0.0_r8 @@ -1423,8 +1420,6 @@ subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & 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 c = ed_allsites_inst(g)%clmcolumn @@ -1562,7 +1557,6 @@ subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & canopy_spread(p) = currentPatch%spread(1) area_plant(p) = 1._r8 area_trees(p) = currentPatch%total_tree_area / min(currentPatch%total_canopy_area,currentPatch%area) - phen_cd_status(p) = ed_allsites_inst(g)%status if(associated(currentPatch%tallest))then trimming(p) = currentPatch%tallest%canopy_trim else diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 534d320b..a738b2fb 100755 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -124,7 +124,7 @@ subroutine zero_site( site_in ) ! 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%ED_GDD_site = 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 @@ -181,7 +181,7 @@ subroutine set_site_properties( bounds, ed_allsites_inst ) 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 + GDD(i) = 0.0_r8 leafon(i) = 0.0_r8 leafoff(i) = 0.0_r8 stat(i) = 1 @@ -194,7 +194,7 @@ subroutine set_site_properties( bounds, ed_allsites_inst ) endif do g = bounds%begg,bounds%endg - ed_allsites_inst(g)%gdd = GDD(g) + ed_allsites_inst(g)%ED_GDD_site = GDD(g) ed_allsites_inst(g)%ncd = NCD(g) ed_allsites_inst(g)%leafondate = leafon(g) ed_allsites_inst(g)%leafoffdate = leafoff(g) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 720f03c8..4aff5ad6 100755 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -43,7 +43,7 @@ module EDMainMod !-------------------------------------------------------------------------------! subroutine ed_ecosystem_dynamics(currentSite, & - ed_clm_inst, ed_phenology_inst, atm2lnd_inst, & + ed_clm_inst, atm2lnd_inst, & soilstate_inst, temperature_inst, waterstate_inst) ! ! !DESCRIPTION: @@ -51,7 +51,6 @@ subroutine ed_ecosystem_dynamics(currentSite, & ! ! !ARGUMENTS: type(ed_site_type) , intent(inout), target :: 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 @@ -71,7 +70,7 @@ subroutine ed_ecosystem_dynamics(currentSite, & call ed_total_balance_check(currentSite, 0) - call phenology(currentSite, ed_phenology_inst, temperature_inst, waterstate_inst) + call phenology(currentSite, temperature_inst, waterstate_inst) call fire_model(currentSite, atm2lnd_inst, temperature_inst) diff --git a/main/EDRestVectorMod.F90 b/main/EDRestVectorMod.F90 index 873523c5..0bf9684d 100755 --- a/main/EDRestVectorMod.F90 +++ b/main/EDRestVectorMod.F90 @@ -1762,7 +1762,6 @@ subroutine createPatchCohortStructure( this, bounds, ed_allsites_inst ) 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 diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 50f5dc09..73d1dedc 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -412,9 +412,9 @@ module EDTypesMod real(r8) :: disturbance_rate ! site total dist rate ! PHENOLOGY + real(r8) :: ED_GDD_site ! ED Phenology growing degree days. 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:- From ba93a192e879055c49432a67ebc20d9ddf74e7a5 Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Fri, 20 May 2016 17:14:01 -0700 Subject: [PATCH 090/437] yet more cleaning out of phenology code --- biogeochem/EDPhysiologyMod.F90 | 7 ++++++- main/EDCLMLinkMod.F90 | 10 +++------- main/EDInitMod.F90 | 1 - main/EDMainMod.F90 | 1 - main/EDRestVectorMod.F90 | 1 - 5 files changed, 9 insertions(+), 11 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 6ebdcb8d..d1d9941d 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -27,7 +27,6 @@ module EDPhysiologyMod public :: non_canopy_derivs public :: trim_canopy public :: phenology_gdd_increment - public :: phenology public :: phenology_leafonoff public :: Growth_Derivatives public :: recruitment @@ -352,6 +351,12 @@ subroutine phenology( currentSite, temperature_inst, waterstate_inst) endif enddo + ! Here is where we do the GDD accumulation calculation + + ! first accumulate the GDD + + ! if date corresponds to year crossing date, (Jan 1 in NH, July 1 in SH), reset GDD to zero + timesinceleafoff = modelday - currentSite%leafoffdate !LEAF ON: COLD DECIDUOUS. Needs to !1) have exceeded the growing degree day threshold diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 6d10850e..657ed69f 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -949,14 +949,13 @@ subroutine SetValues( this, bounds, val) end subroutine SetValues !----------------------------------------------------------------------- - subroutine ed_clm_link( this, bounds, ed_allsites_inst, ed_phenology_inst, & + subroutine ed_clm_link( this, bounds, ed_allsites_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 @@ -969,7 +968,6 @@ subroutine ed_clm_link( this, bounds, ed_allsites_inst, ed_phenology_inst, & 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 ! @@ -1216,7 +1214,7 @@ subroutine ed_clm_link( this, bounds, ed_allsites_inst, ed_phenology_inst, & canopystate_inst) call this%ed_update_history_variables(bounds, ed_allsites_inst(begg:endg), & - firstsoilpatch, ed_Phenology_inst, canopystate_inst) + firstsoilpatch, canopystate_inst) end associate @@ -1224,10 +1222,9 @@ end subroutine ed_clm_link !----------------------------------------------------------------------- subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & - firstsoilpatch, ed_Phenology_inst, canopystate_inst) + firstsoilpatch, canopystate_inst) ! ! !USES: - use EDPhenologyType , only : ed_phenology_type use CanopyStateType , only : canopystate_type use PatchType , only : clmpatch => patch use pftconMod , only : pftcon @@ -1238,7 +1235,6 @@ subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & 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: diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index a738b2fb..bc49c933 100755 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -15,7 +15,6 @@ module EDInitMod 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 diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 4aff5ad6..5016bb23 100755 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -18,7 +18,6 @@ module EDMainMod use SFMainMod , only : fire_model use EDtypesMod , only : ncwd, 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 diff --git a/main/EDRestVectorMod.F90 b/main/EDRestVectorMod.F90 index 0bf9684d..ed74cf0a 100755 --- a/main/EDRestVectorMod.F90 +++ b/main/EDRestVectorMod.F90 @@ -14,7 +14,6 @@ module EDRestVectorMod use EDTypesMod , only : area, cohorts_per_gcell, numpft_ed, numWaterMem, nclmax, numCohortsPerPatch use EDTypesMod , only : ncwd, invalidValue, nlevcan_ed use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type - use EDPhenologyType , only : ed_phenology_type ! implicit none private From a190de1d2e3118eda6755f21cf18b0f25e7880bd Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Mon, 23 May 2016 15:26:26 -0700 Subject: [PATCH 091/437] moved GDD calculation into edphysiology phenology and added site-level LL GDD restart variable --- biogeochem/EDPhysiologyMod.F90 | 30 +++++++++++++++++++----------- main/EDRestVectorMod.F90 | 20 +++++++++++++++++++- 2 files changed, 38 insertions(+), 12 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index d1d9941d..578e682d 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -26,7 +26,7 @@ module EDPhysiologyMod public :: canopy_derivs public :: non_canopy_derivs public :: trim_canopy - public :: phenology_gdd_increment + public :: phenology public :: phenology_leafonoff public :: Growth_Derivatives public :: recruitment @@ -274,7 +274,8 @@ subroutine phenology( currentSite, temperature_inst, waterstate_inst) 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. + integer :: ncdstart ! beginning of counting period for chilling degree days. + integer :: gddstart ! 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 @@ -284,8 +285,6 @@ subroutine phenology( currentSite, temperature_inst, waterstate_inst) !------------------------------------------------------------------------ t_veg24 => temperature_inst%t_veg24_patch ! Input: [real(r8) (:)] avg pft vegetation temperature for last 24 hrs - ED_GDD_site => currentSite%ED_GDD_site ! Input: [real(r8) (:)] growing deg. days base 0 deg C (ddays) - g = currentSite%clmgcell @@ -323,9 +322,11 @@ subroutine phenology( currentSite, temperature_inst, waterstate_inst) !Zero growing degree and chilling day counters if (currentSite%lat > 0)then - ncdstart = 270._r8; !Northern Hemisphere begining November + ncdstart = 270 !Northern Hemisphere begining November + gddstart = 1 !Northern Hemisphere begining January else - ncdstart = 120._r8; !Southern Hemisphere beginning May + ncdstart = 120 !Southern Hemisphere beginning May + gddstart = 181 !Northern Hemisphere begining July endif ! FIX(SPM,032414) - this will only work for the first year, no? @@ -352,17 +353,24 @@ subroutine phenology( currentSite, temperature_inst, waterstate_inst) enddo ! Here is where we do the GDD accumulation calculation - - ! first accumulate the GDD - - ! if date corresponds to year crossing date, (Jan 1 in NH, July 1 in SH), reset GDD to zero + ! + ! reset GDD on set dates + if (t == gddstart)then + currentSite%ED_GDD_site = 0._r8 + endif + ! + ! accumulate the GDD using daily mean temperatures + if (t_veg24(currentSite%oldest_patch%clm_pno-1) .gt. tfrz) then + currentSite%ED_GDD_site = ED_currentSite%ED_GDD_site + t_veg24(currentSite%oldest_patch%clm_pno-1) - tfrz + endif + timesinceleafoff = modelday - currentSite%leafoffdate !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_site(currentSite) > gdd_threshold)then + if (ED_currentSite%ED_GDD_site > gdd_threshold)then if (currentSite%status == 1) then if (currentSite%ncd >= 1) then currentSite%status = 2 !alter status of site to 'leaves on' diff --git a/main/EDRestVectorMod.F90 b/main/EDRestVectorMod.F90 index ed74cf0a..6ddf5b2a 100755 --- a/main/EDRestVectorMod.F90 +++ b/main/EDRestVectorMod.F90 @@ -14,6 +14,7 @@ module EDRestVectorMod use EDTypesMod , only : area, cohorts_per_gcell, numpft_ed, numWaterMem, nclmax, numCohortsPerPatch use EDTypesMod , only : ncwd, invalidValue, nlevcan_ed use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type + use EDPhenologyType , only : ed_phenology_type ! implicit none private @@ -113,6 +114,7 @@ module EDRestVectorMod real(r8), pointer :: old_stock(:) real(r8), pointer :: cd_status(:) real(r8), pointer :: dd_status(:) + real(r8), pointer :: ED_GDD_site(:) real(r8), pointer :: ncd(:) real(r8), pointer :: leafondate(:) real(r8), pointer :: leafoffdate(:) @@ -232,6 +234,7 @@ subroutine deleteEDRestartVectorClass( this ) deallocate(this%old_stock ) deallocate(this%cd_status ) deallocate(this%dd_status ) + deallocate(this%ED_GDD_site ) deallocate(this%ncd ) deallocate(this%leafondate ) deallocate(this%leafoffdate ) @@ -556,6 +559,11 @@ function newEDRestartVectorClass( bounds ) SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) new%dd_status(:) = 0_r8 + allocate(new%ED_GDD_site & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%ED_GDD_site(:) = 0_r8 + allocate(new%ncd & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) @@ -1037,7 +1045,12 @@ subroutine doVectorIO( this, ncid, flag ) interpinic_flag='interp', data=this%dd_status, & readvar=readvar) - + call restartvar(ncid=ncid, flag=flag, varname='ed_ED_GDD_site', xtype=ncd_double, & + dim1name=dimName, & + long_name='ed accumulated GDDs', units='unitless', & + interpinic_flag='interp', data=this%ED_GDD_site, & + readvar=readvar) + call restartvar(ncid=ncid, flag=flag, varname='ed_chilling_days', xtype=ncd_double, & dim1name=dimName, & long_name='ed chilling day counter', units='unitless', & @@ -1210,6 +1223,8 @@ subroutine printDataInfoVector( this ) this%cd_status(iSta:iSto) write(iulog,*) trim(methodName)//' :: dd_status', & this%cd_status(iSta:iSto) + write(iulog,*) trim(methodName)//' :: ED_GDD_site', & + this%ED_GDD_site(iSta:iSto) write(iulog,*) trim(methodName)//' :: ncd', & this%ncd(iSta:iSto) write(iulog,*) trim(methodName)//' :: leafondate', & @@ -1337,6 +1352,7 @@ subroutine printDataInfoLL( this, bounds, ed_allsites_inst ) write(iulog,*) trim(methodName)//' old_stock ' ,ed_allsites_inst(g)%old_stock write(iulog,*) trim(methodName)//' cd_status ' ,ed_allsites_inst(g)%status write(iulog,*) trim(methodName)//' dd_status ' ,ed_allsites_inst(g)%dstatus + write(iulog,*) trim(methodName)//' ED_GDD_site ' ,ed_allsites_inst(g)%ED_GDD_site write(iulog,*) trim(methodName)//' ncd ' ,ed_allsites_inst(g)%ncd write(iulog,*) trim(methodName)//' leafondate ' ,ed_allsites_inst(g)%leafondate write(iulog,*) trim(methodName)//' leafoffdate ' ,ed_allsites_inst(g)%leafoffdate @@ -1596,6 +1612,7 @@ subroutine convertCohortListToVector( this, bounds, ed_allsites_inst ) this%old_stock(incrementOffset) = ed_allsites_inst(g)%old_stock this%cd_status(incrementOffset) = ed_allsites_inst(g)%status this%dd_status(incrementOffset) = ed_allsites_inst(g)%dstatus + this%ED_GDD_site(incrementOffset) = ed_allsites_inst(g)%ED_GDD_site this%ncd(incrementOffset) = ed_allsites_inst(g)%ncd this%leafondate(incrementOffset) = ed_allsites_inst(g)%leafondate this%leafoffdate(incrementOffset) = ed_allsites_inst(g)%leafoffdate @@ -2006,6 +2023,7 @@ subroutine convertCohortVectorToList( this, bounds, ed_allsites_inst ) ed_allsites_inst(g)%old_stock = this%old_stock(incrementOffset) ed_allsites_inst(g)%status = this%cd_status(incrementOffset) ed_allsites_inst(g)%dstatus = this%dd_status(incrementOffset) + ed_allsites_inst(g)%ED_GDD_site = this%ED_GDD_site(incrementOffset) ed_allsites_inst(g)%ncd = this%ncd(incrementOffset) ed_allsites_inst(g)%leafondate = this%leafondate(incrementOffset) ed_allsites_inst(g)%leafoffdate = this%leafoffdate(incrementOffset) From 8e2c9c597ce8f51c2c2215ce24c10ae5cb04311e Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Mon, 23 May 2016 15:29:39 -0700 Subject: [PATCH 092/437] fix typos etc --- biogeochem/EDPhysiologyMod.F90 | 5 ++--- main/EDRestVectorMod.F90 | 1 - 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 578e682d..e0e3a730 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -255,7 +255,6 @@ subroutine phenology( currentSite, temperature_inst, waterstate_inst) ! ! !LOCAL VARIABLES: real(r8), pointer :: t_veg24(:) - real(r8), pointer :: ED_GDD_site(:) integer :: g ! grid point integer :: t ! day of year integer :: ncolddays ! no days underneath the threshold for leaf drop @@ -361,7 +360,7 @@ subroutine phenology( currentSite, temperature_inst, waterstate_inst) ! ! accumulate the GDD using daily mean temperatures if (t_veg24(currentSite%oldest_patch%clm_pno-1) .gt. tfrz) then - currentSite%ED_GDD_site = ED_currentSite%ED_GDD_site + t_veg24(currentSite%oldest_patch%clm_pno-1) - tfrz + currentSite%ED_GDD_site = currentSite%ED_GDD_site + t_veg24(currentSite%oldest_patch%clm_pno-1) - tfrz endif @@ -370,7 +369,7 @@ subroutine phenology( currentSite, temperature_inst, waterstate_inst) !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_currentSite%ED_GDD_site > gdd_threshold)then + if (currentSite%ED_GDD_site > gdd_threshold)then if (currentSite%status == 1) then if (currentSite%ncd >= 1) then currentSite%status = 2 !alter status of site to 'leaves on' diff --git a/main/EDRestVectorMod.F90 b/main/EDRestVectorMod.F90 index 6ddf5b2a..a88c2268 100755 --- a/main/EDRestVectorMod.F90 +++ b/main/EDRestVectorMod.F90 @@ -14,7 +14,6 @@ module EDRestVectorMod use EDTypesMod , only : area, cohorts_per_gcell, numpft_ed, numWaterMem, nclmax, numCohortsPerPatch use EDTypesMod , only : ncwd, invalidValue, nlevcan_ed use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type - use EDPhenologyType , only : ed_phenology_type ! implicit none private From 5189fde6389f585c3fdbaa4b13d322faaab68752 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 23 May 2016 18:01:54 -0700 Subject: [PATCH 093/437] partial progress (early) on columnizing sites --- main/FatesInterfaceMod.F90 | 73 ++++++++++++++++++++++++++------------ 1 file changed, 51 insertions(+), 22 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index a5558561..450f8623 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -33,6 +33,9 @@ module FatesInterfaceMod ! ie the root of the linked lists. Each path list is currently associated ! with a grid-cell, this is intended to be migrated to columns ! prev: type(ed_site_type)::ed_allsites_inst + + integer :: nsites + type(ed_site_type), allocatable :: sites(:) ! INTERF-TODO ADD THE DLM->FATES BOUNDARY CONDITION CLASS @@ -52,25 +55,24 @@ module FatesInterfaceMod contains - subroutine init(this,bounds_clump) - - implicit none - - ! Input Arguments - class(fates_interface_type), intent(inout) :: this - - ! INTERF-TODO: AS THE FATES PUBLIC API- BOUNDS CLUMP WILL NOT BE ALLOWED - ! IN HERE FOR MUCH LONGER. - type(bounds_type),intent(in) :: bounds_clump - - - ! Initialize the mapping elements between FATES and the DLM - - ! These bounds are for a single clump (thread) - allocate (this%sites(bounds_clump%begg:bounds_clump%endg)) - - return - end subroutine init +! subroutine init(this,bounds_clump) +! +! implicit none +! +! ! Input Arguments +! class(fates_interface_type), intent(inout) :: this +! +! ! INTERF-TODO: AS THE FATES PUBLIC API- BOUNDS CLUMP WILL NOT BE ALLOWED +! ! IN HERE FOR MUCH LONGER. +! type(bounds_type),intent(in) :: bounds_clump +! +! ! Initialize the mapping elements between FATES and the DLM +! +! ! These bounds are for a single clump (thread) +! allocate (this%sites(this%nsites)) +! +! return +! end subroutine init ! ------------------------------------------------------------------------------------ @@ -93,18 +95,45 @@ end subroutine fates_clean ! ------------------------------------------------------------------------------------ - subroutine site_init(this,bounds_clump) + subroutine site_init(this,fcolumn,bounds_clump) ! Input Arguments class(fates_interface_type), intent(inout) :: this type(bounds_type),intent(in) :: bounds_clump ! locals + integer :: s + integer :: c integer :: g ! Initialize (INTERF-TODO THIS ROUTINE CALLS CLM STUFF-MIGRATE CODE TO HERE) - call ed_init_sites( bounds_clump, & - this%sites(bounds_clump%begg:bounds_clump%endg) ) +! call ed_init_sites( bounds_clump, & +! this%sites(bounds_clump%begg:bounds_clump%endg) ) + + do s = 1:this%nsites + + call zero_site(this%sites(s)) + + c = fcolumn(s) + g = gridcell(c) + + this%sites(s)%lat = grc%latdeg(g) + this%sites(s)%lon = grc%londeg(g) + + end do + + 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 + + + ! INTERF-TODO: WHEN WE MOVE TO COLUMNS, THIS WILL BE UNNECESSARY do g = bounds_clump%begg,bounds_clump%endg From 51290d3b64e315867ab0daba715340d40f133ac2 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 24 May 2016 15:04:52 -0700 Subject: [PATCH 094/437] partial progress --- main/EDInitMod.F90 | 126 ++++++++++++++++++------------------- main/FatesInterfaceMod.F90 | 26 +++----- 2 files changed, 69 insertions(+), 83 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 534d320b..f73138e3 100755 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -140,84 +140,82 @@ subroutine zero_site( site_in ) end subroutine zero_site ! ============================================================================ - subroutine set_site_properties( bounds, ed_allsites_inst ) + subroutine set_site_properties( sites, nsites) ! ! !DESCRIPTION: ! ! !USES: ! ! !ARGUMENTS - type(bounds_type) , intent(in) :: bounds - type(ed_site_type) , intent(inout), target :: ed_allsites_inst( bounds%begg: ) + + type(ed_site_type) , intent(inout), target :: sites ! ! !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) + integer :: s + real(r8) :: leafon + real(r8) :: leafoff + real(r8) :: stat + real(r8) :: NCD + real(r8) :: GDD + real(r8) :: dstat + real(r8) :: acc_NI + real(r8) :: watermem + integer :: dleafoff + integer :: dleafon !---------------------------------------------------------------------- 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 + NCD = 0.0_r8 + GDD = 30.0_r8 + leafon = 100.0_r8 + leafoff = 300.0_r8 + stat = 2 + acc_NI = 0.0_r8 + dstat = 2 + dleafoff = 300 + dleafon = 100 + watermem = 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 + NCD = 1.0_r8 ! NCD should be 1 on restart + !GDD(i) = 0.0_r8 + leafon = 0.0_r8 + leafoff = 0.0_r8 + stat = 1 + acc_NI = 0.0_r8 + dstat = 2 + dleafoff = 300 + dleafon = 100 + watermem = 0.5_r8 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) + do s = 1,nsites + sites(s)%gdd = GDD + sites(s)%ncd = NCD + sites(s)%leafondate = leafon + sites(s)%leafoffdate = leafoff + sites(s)%dleafoffdate = dleafoff + sites(s)%dleafondate = dleafon if ( .not. is_restart() ) then - ed_allsites_inst(g)%water_memory(1:10) = watermem(g) + sites(s)%water_memory(1:10) = watermem end if - ed_allsites_inst(g)%status = stat(g) + sites(s)%status = stat !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 - + sites(s)%dstatus= dstat + + sites(s)%acc_NI = acc_NI(s) + sites(s)%frac_burnt = 0.0_r8 + sites(s)%old_stock = 0.0_r8 + end do + + return end subroutine set_site_properties ! ============================================================================ - subroutine init_patches( bounds, ed_allsites_inst ) + subroutine init_patches( sites, nsites) ! ! !DESCRIPTION: !initialize patches on new ground @@ -226,11 +224,10 @@ subroutine init_patches( bounds, ed_allsites_inst ) 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: ) + type(ed_site_type) , intent(inout), target :: sites ! ! !LOCAL VARIABLES: - integer :: g + integer :: s real(r8) :: cwd_ag_local(ncwd) real(r8) :: cwd_bg_local(ncwd) real(r8) :: spread_local(nclmax) @@ -250,27 +247,26 @@ subroutine init_patches( bounds, ed_allsites_inst ) age = 0.0_r8 !FIX(SPM,032414) clean this up...inits out of this loop - do g = bounds%begg,bounds%endg + do s = 1, nsites 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 + sites(s)%youngest_patch => newp + sites(s)%youngest_patch => newp + sites(s)%oldest_patch => newp ! make new patch... - call create_patch(ed_allsites_inst(g), newp, age, AREA, & + call create_patch(sites(s), 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 + enddo end subroutine init_patches diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 450f8623..ddcd69af 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -95,11 +95,12 @@ end subroutine fates_clean ! ------------------------------------------------------------------------------------ - subroutine site_init(this,fcolumn,bounds_clump) + subroutine init_coldstart(this,fcolumn) ! Input Arguments class(fates_interface_type), intent(inout) :: this - type(bounds_type),intent(in) :: bounds_clump + integer :: fcolumn(this%nsites) +! type(bounds_type),intent(in) :: bounds_clump ! locals integer :: s @@ -110,7 +111,7 @@ subroutine site_init(this,fcolumn,bounds_clump) ! call ed_init_sites( bounds_clump, & ! this%sites(bounds_clump%begg:bounds_clump%endg) ) - do s = 1:this%nsites + do s = 1,this%nsites call zero_site(this%sites(s)) @@ -122,24 +123,13 @@ subroutine site_init(this,fcolumn,bounds_clump) end do - do g = bounds%begg,bounds%endg - ! zero the site - call zero_site(ed_allsites_inst(g)) + call set_site_properties(this%sites,this%nsites) - !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 + call init_patches(this%sites, this%nsites) - - - ! INTERF-TODO: WHEN WE MOVE TO COLUMNS, THIS WILL BE UNNECESSARY - do g = bounds_clump%begg,bounds_clump%endg - if (this%sites(g)%istheresoil) then - call ed_update_site(this%sites(g)) - end if + do s = 1,this%nsites + call ed_update_site(this%sites(s)) end do return From 03bd77ffec91c71d15119cd2dde2a06fba195602 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 24 May 2016 18:19:22 -0700 Subject: [PATCH 095/437] more partial progress, most of work on subgrid decomposition for cohorts on columns hashed out. --- main/EDInitMod.F90 | 104 +++++---- main/EDRestVectorMod.F90 | 462 +++++++++++++++++++------------------ main/EDTypesMod.F90 | 9 +- main/EDVecCohortType.F90 | 6 +- main/FatesInterfaceMod.F90 | 16 +- 5 files changed, 298 insertions(+), 299 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index f73138e3..d1641f53 100755 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -41,57 +41,57 @@ module EDInitMod ! ============================================================================ - 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 - ! - ! Makes unique cohort identifiers. Needs zeroing at beginning of run. - udata%cohort_number = 0 - - 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 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 +! ! +! ! Makes unique cohort identifiers. Needs zeroing at beginning of run. +! udata%cohort_number = 0 +! +! 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 ) @@ -149,6 +149,7 @@ subroutine set_site_properties( sites, nsites) ! !ARGUMENTS type(ed_site_type) , intent(inout), target :: sites + integer, intent(in) :: nsites ! ! !LOCAL VARIABLES: integer :: s @@ -225,6 +226,7 @@ subroutine init_patches( sites, nsites) ! ! !ARGUMENTS type(ed_site_type) , intent(inout), target :: sites + integer, intent(in) :: nsites ! ! !LOCAL VARIABLES: integer :: s diff --git a/main/EDRestVectorMod.F90 b/main/EDRestVectorMod.F90 index 873523c5..62bbb7b8 100755 --- a/main/EDRestVectorMod.F90 +++ b/main/EDRestVectorMod.F90 @@ -11,7 +11,7 @@ module EDRestVectorMod 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 : area, cohorts_per_col, numpft_ed, numWaterMem, nclmax, numCohortsPerPatch use EDTypesMod , only : ncwd, invalidValue, nlevcan_ed use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type use EDPhenologyType , only : ed_phenology_type @@ -39,8 +39,8 @@ module EDRestVectorMod ! required to map cohorts and patches to/fro ! vectors/LinkedLists - integer, pointer :: cellWithPatch(:) - integer, pointer :: numPatchesPerCell(:) + integer, pointer :: colWithPatch(:) + integer, pointer :: numPatchesPerCol(:) integer, pointer :: cohortsPerPatch(:) ! ! cohort data @@ -177,8 +177,8 @@ subroutine deleteEDRestartVectorClass( this ) class(EDRestartVectorClass), intent(inout) :: this ! ! !LOCAL VARIABLES: - deallocate(this%cellWithPatch ) - deallocate(this%numPatchesPerCell ) + deallocate(this%colWithPatch ) + deallocate(this%numPatchesPerCol ) deallocate(this%cohortsPerPatch ) deallocate(this%balive ) deallocate(this%bdead ) @@ -270,15 +270,15 @@ function newEDRestartVectorClass( bounds ) ! cohort level variables that are required on restart ! - allocate(new%cellWithPatch & - (bounds%begg:bounds%endg), stat=retVal) + allocate(new%colWithPatch & + (bounds%begc:bounds%endc), stat=retVal) SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) - new%cellWithPatch(:) = 0 + new%colWithPatch(:) = 0 - allocate(new%numPatchesPerCell & - (bounds%begg:bounds%endg), stat=retVal) + allocate(new%numPatchesPerCol & + (bounds%begc:bounds%endc), stat=retVal) SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) - new%numPatchesPerCell(:) = invalidValue + new%numPatchesPerCol(:) = invalidValue allocate(new%cohortsPerPatch & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) @@ -592,7 +592,7 @@ function newEDRestartVectorClass( bounds ) end function newEDRestartVectorClass !-------------------------------------------------------------------------------! - subroutine setVectors( this, bounds, ed_allsites_inst ) + subroutine setVectors( this, bounds, sites ) ! ! !DESCRIPTION: ! implement setVectors @@ -603,7 +603,7 @@ subroutine setVectors( this, bounds, ed_allsites_inst ) ! !ARGUMENTS: class(EDRestartVectorClass) , intent(inout) :: this type(bounds_type) , intent(in) :: bounds - type(ed_site_type) , intent(in), target :: ed_allsites_inst( bounds%begg: ) + type(ed_site_type) , intent(in), target :: sites(:) ! ! !LOCAL VARIABLES: !----------------------------------------------------------------------- @@ -611,22 +611,22 @@ subroutine setVectors( this, bounds, ed_allsites_inst ) if ( masterproc ) 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) ) + ! call this%printIoInfoLL ( bounds, sites, nsites ) + ! call this%printDataInfoLL ( bounds, sites, nsites ) !end if - call this%convertCohortListToVector ( bounds, ed_allsites_inst(bounds%begg:bounds%endg) ) + call this%convertCohortListToVector ( bounds, sites ) 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) ) + call this%printIoInfoLL ( bounds, sites, nsites ) + call this%printDataInfoLL ( bounds, sites, nsites ) call this%printDataInfoVector ( ) end if end subroutine setVectors !-------------------------------------------------------------------------------! - subroutine getVectors( this, bounds, ed_allsites_inst ) + subroutine getVectors( this, bounds, sites, nsites) ! ! !DESCRIPTION: ! implement getVectors @@ -639,31 +639,30 @@ subroutine getVectors( this, bounds, ed_allsites_inst ) ! !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_site_type) , intent(inout), target :: sites(:) + integer , intent(in) :: nsites ! ! !LOCAL VARIABLES: - integer :: g + integer :: s !----------------------------------------------------------------------- if (this%DEBUG) then write(iulog,*) 'edtime getVectors ',get_nstep() end if - call this%createPatchCohortStructure ( bounds, ed_allsites_inst(bounds%begg:bounds%endg) ) + call this%createPatchCohortStructure ( bounds, sites ) - call this%convertCohortVectorToList ( bounds, ed_allsites_inst(bounds%begg:bounds%endg) ) + call this%convertCohortVectorToList ( bounds, sites ) - do g = bounds%begg,bounds%endg - if (ed_allsites_inst(g)%istheresoil) then - call ed_update_site( ed_allsites_inst(g) ) - end if + do s = 1,nsites + call ed_update_site( sites(s) ) end do 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) ) + call this%printIoInfoLL ( bounds, sites ) + call this%printDataInfoLL ( bounds, sites ) call this%printDataInfoVector ( ) end if @@ -678,7 +677,7 @@ subroutine doVectorIO( this, ncid, flag ) ! !USES: use ncdio_pio , only : file_desc_t, ncd_int, ncd_double use restUtilMod, only : restartvar - use clm_varcon, only : nameg, nameCohort + use clm_varcon, only : namec, nameCohort use spmdMod, only : iam ! ! !ARGUMENTS: @@ -694,21 +693,21 @@ subroutine doVectorIO( this, ncid, flag ) ! ! 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, & + call restartvar(ncid=ncid, flag=flag, varname='ed_io_colWithPatch', xtype=ncd_int, & + dim1name=namec, & + long_name='1 if a column has a patch', units='1=true,0=false', & + interpinic_flag='interp', data=this%colWithPatch, & 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, & + call restartvar(ncid=ncid, flag=flag, varname='ed_io_numPatchesPerCol', xtype=ncd_int, & + dim1name=namec, & + long_name='works with ed_colWithPatch. num patches per column', units='unitless', & + interpinic_flag='interp', data=this%numPatchesPerCol, & 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', & + long_name='list of cohorts per patch. indexed by numPatchesPerCol', units='unitless', & interpinic_flag='interp', data=this%cohortsPerPatch, & readvar=readvar) @@ -1227,7 +1226,7 @@ subroutine printDataInfoVector( this ) end subroutine printDataInfoVector !-------------------------------------------------------------------------------! - subroutine printDataInfoLL( this, bounds, ed_allsites_inst ) + subroutine printDataInfoLL( this, bounds, sites, nsites ) ! ! !DESCRIPTION: ! counts the total number of cohorts over all p levels (ed_patch_type) so we @@ -1238,12 +1237,13 @@ subroutine printDataInfoLL( this, bounds, ed_allsites_inst ) ! !ARGUMENTS: class(EDRestartVectorClass) , intent(inout) :: this type(bounds_type) , intent(in) :: bounds - type(ed_site_type) , intent(in), target :: ed_allsites_inst( bounds%begg: ) + type(ed_site_type) , intent(in), target :: sites + integer , intent(in) :: nsites ! ! !LOCAL VARIABLES: type (ed_patch_type), pointer :: currentPatch type (ed_cohort_type), pointer :: currentCohort - integer :: g + integer :: s integer :: totalCohorts integer :: numCohort integer :: numPatches,totPatchCount @@ -1255,11 +1255,9 @@ subroutine printDataInfoLL( this, bounds, ed_allsites_inst ) write(iulog,*) 'vecLenStart ',this%vectorLengthStart - g = bounds%begg - do while(g <= bounds%endg) + do s = 1,nsites - if (ed_allsites_inst(g)%istheresoil) then - currentPatch => ed_allsites_inst(g)%oldest_patch + currentPatch => sites(s)%oldest_patch numPatches = 1 @@ -1289,20 +1287,20 @@ subroutine printDataInfoLL( this, bounds, ed_allsites_inst ) 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)//' gpp ' ,totalCohorts,currentCohort%gpp - write(iulog,*) trim(methodName)//' npp ' ,totalCohorts,currentCohort%npp - write(iulog,*) trim(methodName)//' npp_leaf ' ,totalCohorts,currentCohort%npp_leaf - write(iulog,*) trim(methodName)//' npp_froot ' ,totalCohorts,currentCohort%npp_froot + write(iulog,*) trim(methodName)//' gpp ' ,totalCohorts,currentCohort%gpp + write(iulog,*) trim(methodName)//' npp ' ,totalCohorts,currentCohort%npp + write(iulog,*) trim(methodName)//' npp_leaf ' ,totalCohorts,currentCohort%npp_leaf + write(iulog,*) trim(methodName)//' npp_froot ' ,totalCohorts,currentCohort%npp_froot write(iulog,*) trim(methodName)//' npp_bsw ' ,totalCohorts,currentCohort%npp_bsw - write(iulog,*) trim(methodName)//' npp_bdead ' ,totalCohorts,currentCohort%npp_bdead - write(iulog,*) trim(methodName)//' npp_bseed ' ,totalCohorts,currentCohort%npp_bseed - write(iulog,*) trim(methodName)//' npp_store ' ,totalCohorts,currentCohort%npp_store - write(iulog,*) trim(methodName)//' bmort ' ,totalCohorts,currentCohort%bmort - write(iulog,*) trim(methodName)//' hmort ' ,totalCohorts,currentCohort%hmort - write(iulog,*) trim(methodName)//' cmort ' ,totalCohorts,currentCohort%cmort - write(iulog,*) trim(methodName)//' imort ' ,totalCohorts,currentCohort%imort - write(iulog,*) trim(methodName)//' fmort ' ,totalCohorts,currentCohort%fmort - write(iulog,*) trim(methodName)//' ddbhdt ' ,totalCohorts,currentCohort%ddbhdt + write(iulog,*) trim(methodName)//' npp_bdead ' ,totalCohorts,currentCohort%npp_bdead + write(iulog,*) trim(methodName)//' npp_bseed ' ,totalCohorts,currentCohort%npp_bseed + write(iulog,*) trim(methodName)//' npp_store ' ,totalCohorts,currentCohort%npp_store + write(iulog,*) trim(methodName)//' bmort ' ,totalCohorts,currentCohort%bmort + write(iulog,*) trim(methodName)//' hmort ' ,totalCohorts,currentCohort%hmort + write(iulog,*) trim(methodName)//' cmort ' ,totalCohorts,currentCohort%cmort + write(iulog,*) trim(methodName)//' imort ' ,totalCohorts,currentCohort%imort + write(iulog,*) trim(methodName)//' fmort ' ,totalCohorts,currentCohort%fmort + write(iulog,*) trim(methodName)//' ddbhdt ' ,totalCohorts,currentCohort%ddbhdt 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 @@ -1313,8 +1311,8 @@ subroutine printDataInfoLL( this, bounds, ed_allsites_inst ) currentCohort => currentCohort%taller enddo ! currentCohort do while - write(iulog,*) trim(methodName)//': numpatches for gcell ',& - ed_allsites_inst(g)%clmgcell, numPatches + write(iulog,*) trim(methodName)//': numpatches for col ',& + numPatches write(iulog,*) trim(methodName)//': patches and cohorts ',& totPatchCount,numCohort @@ -1335,15 +1333,15 @@ subroutine printDataInfoLL( this, bounds, ed_allsites_inst ) write(iulog,*) trim(methodName)//' fabi_sun_z (sum) ' ,sum(currentPatch%fabi_sun_z) write(iulog,*) trim(methodName)//' fabd_sha_z (sum) ' ,sum(currentPatch%fabd_sha_z) write(iulog,*) trim(methodName)//' fabi_sha_z (sum) ' ,sum(currentPatch%fabi_sha_z) - write(iulog,*) trim(methodName)//' old_stock ' ,ed_allsites_inst(g)%old_stock - write(iulog,*) trim(methodName)//' cd_status ' ,ed_allsites_inst(g)%status - write(iulog,*) trim(methodName)//' dd_status ' ,ed_allsites_inst(g)%dstatus - write(iulog,*) trim(methodName)//' ncd ' ,ed_allsites_inst(g)%ncd - write(iulog,*) trim(methodName)//' leafondate ' ,ed_allsites_inst(g)%leafondate - write(iulog,*) trim(methodName)//' leafoffdate ' ,ed_allsites_inst(g)%leafoffdate - write(iulog,*) trim(methodName)//' dleafondate ' ,ed_allsites_inst(g)%dleafondate - write(iulog,*) trim(methodName)//' dleafoffdate ' ,ed_allsites_inst(g)%dleafoffdate - write(iulog,*) trim(methodName)//' acc_NI' ,ed_allsites_inst(g)%acc_NI + write(iulog,*) trim(methodName)//' old_stock ' ,sites(s)%old_stock + write(iulog,*) trim(methodName)//' cd_status ' ,sites(s)%status + write(iulog,*) trim(methodName)//' dd_status ' ,sites(s)%dstatus + write(iulog,*) trim(methodName)//' ncd ' ,sites(s)%ncd + write(iulog,*) trim(methodName)//' leafondate ' ,sites(s)%leafondate + write(iulog,*) trim(methodName)//' leafoffdate ' ,sites(s)%leafoffdate + write(iulog,*) trim(methodName)//' dleafondate ' ,sites(s)%dleafondate + write(iulog,*) trim(methodName)//' dleafoffdate ' ,sites(s)%dleafoffdate + write(iulog,*) trim(methodName)//' acc_NI' ,sites(s)%acc_NI currentPatch => currentPatch%younger @@ -1351,10 +1349,8 @@ subroutine printDataInfoLL( this, bounds, ed_allsites_inst ) totPatchCount = totPatchCount + 1 numPatches = numPatches + 1 enddo ! currentPatch do while - endif - write(iulog,*) trim(methodName)//' water_memory ',ed_allsites_inst(g)%water_memory(1) - g = g + 1 + write(iulog,*) trim(methodName)//' water_memory ',sites(s)%water_memory(1) enddo @@ -1363,7 +1359,7 @@ subroutine printDataInfoLL( this, bounds, ed_allsites_inst ) end subroutine printDataInfoLL !-------------------------------------------------------------------------------! - subroutine printIoInfoLL( this, bounds, ed_allsites_inst ) + subroutine printIoInfoLL( this, bounds, sites, nsites, fcolumn ) !! ! !DESCRIPTION: ! for debugging. prints some IO info regarding cohorts/patches @@ -1374,12 +1370,14 @@ subroutine printIoInfoLL( this, bounds, ed_allsites_inst ) ! !ARGUMENTS: class(EDRestartVectorClass) , intent(inout) :: this type(bounds_type) , intent(in) :: bounds - type(ed_site_type) , intent(in), target :: ed_allsites_inst( bounds%begg: ) + type(ed_site_type) , intent(in), target :: sites + integer , intent(in) :: nsites + integer, intent(in) :: fcolumn(this%nsites) ! ! !LOCAL VARIABLES: type (ed_patch_type), pointer :: currentPatch type (ed_cohort_type), pointer :: currentCohort - integer g + integer s integer totalCohorts integer numCohort integer numPatches,totPatchCount @@ -1391,79 +1389,76 @@ subroutine printIoInfoLL( this, bounds, ed_allsites_inst ) 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 + do s=1,nsites + + currentPatch => sites(s)%oldest_patch - 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)//' gpp ',currentCohort%gpp - write(iulog,*) trim(methodName)//' npp ',currentCohort%npp - write(iulog,*) trim(methodName)//' npp_leaf ',currentCohort%npp_leaf - write(iulog,*) trim(methodName)//' npp_froot ',currentCohort%npp_froot - write(iulog,*) trim(methodName)//' npp_bsw ',currentCohort%npp_bsw - write(iulog,*) trim(methodName)//' npp_bdead ',currentCohort%npp_bdead - write(iulog,*) trim(methodName)//' npp_bseed ',currentCohort%npp_bseed - write(iulog,*) trim(methodName)//' npp_store ',currentCohort%npp_store - write(iulog,*) trim(methodName)//' bmort ',currentCohort%bmort - write(iulog,*) trim(methodName)//' hmort ',currentCohort%hmort - write(iulog,*) trim(methodName)//' cmort ',currentCohort%cmort - write(iulog,*) trim(methodName)//' imort ',currentCohort%imort - write(iulog,*) trim(methodName)//' fmort ',currentCohort%fmort - write(iulog,*) trim(methodName)//' ddbhdt ',currentCohort%ddbhdt - 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 - write(iulog,*) trim(methodName)//' isnew ',currentCohort%isnew - - currentCohort => currentCohort%taller - enddo ! currentCohort do while + numPatches = 1 - write(iulog,*) trim(methodName)//': numpatches for gcell ',ed_allsites_inst(g)%clmgcell, numPatches - write(iulog,*) trim(methodName)//': patches and cohorts ',totPatchCount,numCohort + do while(associated(currentPatch)) + currentCohort => currentPatch%shortest + + write(iulog,*) trim(methodName)//': found column with patch(s) ',fcolumn(s) + + 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)//' gpp ',currentCohort%gpp + write(iulog,*) trim(methodName)//' npp ',currentCohort%npp + write(iulog,*) trim(methodName)//' npp_leaf ',currentCohort%npp_leaf + write(iulog,*) trim(methodName)//' npp_froot ',currentCohort%npp_froot + write(iulog,*) trim(methodName)//' npp_bsw ',currentCohort%npp_bsw + write(iulog,*) trim(methodName)//' npp_bdead ',currentCohort%npp_bdead + write(iulog,*) trim(methodName)//' npp_bseed ',currentCohort%npp_bseed + write(iulog,*) trim(methodName)//' npp_store ',currentCohort%npp_store + write(iulog,*) trim(methodName)//' bmort ',currentCohort%bmort + write(iulog,*) trim(methodName)//' hmort ',currentCohort%hmort + write(iulog,*) trim(methodName)//' cmort ',currentCohort%cmort + write(iulog,*) trim(methodName)//' imort ',currentCohort%imort + write(iulog,*) trim(methodName)//' fmort ',currentCohort%fmort + write(iulog,*) trim(methodName)//' ddbhdt ',currentCohort%ddbhdt + 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 + write(iulog,*) trim(methodName)//' isnew ',currentCohort%isnew + + currentCohort => currentCohort%taller + enddo ! currentCohort do while + + write(iulog,*) trim(methodName)//': numpatches for column ',numPatches + write(iulog,*) trim(methodName)//': patches and cohorts ',totPatchCount,numCohort - currentPatch => currentPatch%younger + currentPatch => currentPatch%younger - totPatchCount = totPatchCount + 1 - numPatches = numPatches + 1 - enddo ! currentPatch do while - endif - g = g + 1 + totPatchCount = totPatchCount + 1 + numPatches = numPatches + 1 + enddo ! currentPatch do while enddo - + + return end subroutine printIoInfoLL !-------------------------------------------------------------------------------! - subroutine convertCohortListToVector( this, bounds, ed_allsites_inst ) + subroutine convertCohortListToVector( this, bounds, sites, nsites, fcolumn ) ! ! !DESCRIPTION: ! counts the total number of cohorts over all p levels (ed_patch_type) so we @@ -1475,12 +1470,14 @@ subroutine convertCohortListToVector( this, bounds, ed_allsites_inst ) ! !ARGUMENTS: class(EDRestartVectorClass) , intent(inout) :: this type(bounds_type) , intent(in) :: bounds - type(ed_site_type) , intent(in), target :: ed_allsites_inst( bounds%begg: ) + type(ed_site_type) , intent(in), target :: sites(nsites) + integer , intent(in) :: nsites + integer , intent(in) :: fcolumn(nsites) ! ! !LOCAL VARIABLES: type (ed_patch_type), pointer :: currentPatch type (ed_cohort_type), pointer :: currentCohort - integer :: g + integer :: s integer :: totalCohorts ! number of cohorts starting from 1 integer :: countCohort ! number of cohorts starting from ! vectorLengthStart @@ -1506,80 +1503,88 @@ subroutine convertCohortListToVector( this, bounds, ed_allsites_inst ) countWaterMem = this%vectorLengthStart countSunZ = 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,*) 'CLTV countCohort ', countCohort - write(iulog,*) 'CLTV vecLenStart ', this%vectorLengthStart - write(iulog,*) 'CLTV vecLenStop ', 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%gpp(countCohort) = currentCohort%gpp - this%npp(countCohort) = currentCohort%npp - this%npp_leaf(countCohort) = currentCohort%npp_leaf - this%npp_froot(countCohort) = currentCohort%npp_froot - this%npp_bsw(countCohort) = currentCohort%npp_bsw - this%npp_bdead(countCohort) = currentCohort%npp_bdead - this%npp_bseed(countCohort) = currentCohort%npp_bseed - this%npp_store(countCohort) = currentCohort%npp_store - this%bmort(countCohort) = currentCohort%bmort - this%hmort(countCohort) = currentCohort%hmort - this%cmort(countCohort) = currentCohort%cmort - this%imort(countCohort) = currentCohort%imort - this%fmort(countCohort) = currentCohort%fmort - this%ddbhdt(countCohort) = currentCohort%ddbhdt - this%resp_clm(countCohort) = currentCohort%resp_clm - this%pft(countCohort) = currentCohort%pft - this%status_coh(countCohort) = currentCohort%status_coh - if ( currentCohort%isnew ) then - this%isnew(countCohort) = new_cohort - else - this%isnew(countCohort) = old_cohort - endif - - if (this%DEBUG) then - write(iulog,*) 'CLTV offsetNumCohorts II ',countCohort, & - numCohort - endif + do s = 1,nsites + + ! Calculate the offsets + + incrementOffset = this%vectorLengthStart + (fcolumn(s)-1)*cohorts_per_col + countCohort = this%vectorLengthStart + (fcolumn(s)-1)*cohorts_per_col + countPft = this%vectorLengthStart + (fcolumn(s)-1)*cohorts_per_col + countNcwd = this%vectorLengthStart + (fcolumn(s)-1)*cohorts_per_col + countNclmax = this%vectorLengthStart + (fcolumn(s)-1)*cohorts_per_col + countWaterMem = this%vectorLengthStart + (fcolumn(s)-1)*cohorts_per_col + countSunZ = this%vectorLengthStart + (fcolumn(s)-1)*cohorts_per_col + + currentPatch => sites(s)%oldest_patch + + ! new column, 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,*) 'CLTV countCohort ', countCohort + write(iulog,*) 'CLTV vecLenStart ', this%vectorLengthStart + write(iulog,*) 'CLTV vecLenStop ', 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%gpp(countCohort) = currentCohort%gpp + this%npp(countCohort) = currentCohort%npp + this%npp_leaf(countCohort) = currentCohort%npp_leaf + this%npp_froot(countCohort) = currentCohort%npp_froot + this%npp_bsw(countCohort) = currentCohort%npp_bsw + this%npp_bdead(countCohort) = currentCohort%npp_bdead + this%npp_bseed(countCohort) = currentCohort%npp_bseed + this%npp_store(countCohort) = currentCohort%npp_store + this%bmort(countCohort) = currentCohort%bmort + this%hmort(countCohort) = currentCohort%hmort + this%cmort(countCohort) = currentCohort%cmort + this%imort(countCohort) = currentCohort%imort + this%fmort(countCohort) = currentCohort%fmort + this%ddbhdt(countCohort) = currentCohort%ddbhdt + this%resp_clm(countCohort) = currentCohort%resp_clm + this%pft(countCohort) = currentCohort%pft + this%status_coh(countCohort) = currentCohort%status_coh + if ( currentCohort%isnew ) then + this%isnew(countCohort) = new_cohort + else + this%isnew(countCohort) = old_cohort + endif + + if (this%DEBUG) then + write(iulog,*) 'CLTV offsetNumCohorts II ',countCohort, & + numCohort + endif countCohort = countCohort + 1 @@ -1610,7 +1615,7 @@ subroutine convertCohortListToVector( this, bounds, ed_allsites_inst ) if (this%DEBUG) then write(iulog,*) 'offsetNumCohorts III ' & - ,countCohort,cohorts_per_gcell, numCohort + ,countCohort,cohorts_per_col, numCohort endif ! ! deal with patch level fields of arrays here @@ -1657,7 +1662,7 @@ subroutine convertCohortListToVector( this, bounds, ed_allsites_inst ) if (this%DEBUG) write(iulog,*) 'CLTV countSunZ 2 ',countSunZ ! set numpatches for this gcell - this%numPatchesPerCell( ed_allsites_inst(g)%clmgcell ) = numPatches + this%numPatchesPerCol( ed_allsites_inst(g)%clmgcell ) = numPatches incrementOffset = incrementOffset + numCohortsPerPatch @@ -1672,7 +1677,7 @@ subroutine convertCohortListToVector( this, bounds, ed_allsites_inst ) if (this%DEBUG) then write(iulog,*) 'CLTV incrementOffset ', incrementOffset - write(iulog,*) 'CLTV cohorts_per_gcell ', cohorts_per_gcell + write(iulog,*) 'CLTV cohorts_per_col ', cohorts_per_col write(iulog,*) 'CLTV numCohort ', numCohort write(iulog,*) 'CLTV totalCohorts ', totalCohorts end if @@ -1682,7 +1687,7 @@ subroutine convertCohortListToVector( this, bounds, ed_allsites_inst ) enddo ! currentPatch do while ! set which gridcells have patches/cohorts - this%cellWithPatch( ed_allsites_inst(g)%clmgcell ) = 1 + this%colWithPatch( ed_allsites_inst(g)%clmgcell ) = 1 do i = 1,numWaterMem ! numWaterMem currently 10 this%water_memory( countWaterMem ) = ed_allsites_inst(g)%water_memory(i) @@ -1751,7 +1756,7 @@ subroutine createPatchCohortStructure( this, bounds, ed_allsites_inst ) do g = bounds%begg, bounds%endg if (this%DEBUG) then - write(iulog,*) 'cellWithPatch ',this%cellWithPatch(g),this%numPatchesPerCell(g) + write(iulog,*) 'colWithPatch ',this%colWithPatch(g),this%numPatchesPerCol(g) end if call zero_site( ed_allsites_inst(g) ) @@ -1766,7 +1771,7 @@ subroutine createPatchCohortStructure( this, bounds, ed_allsites_inst ) ed_allsites_inst(g)%ncd = 0.0_r8 ! then this site has soil and should be set here - do patchIdx = 1,this%numPatchesPerCell(g) + do patchIdx = 1,this%numPatchesPerCol(g) if (this%DEBUG) then write(iulog,*) 'create patch ',patchIdx @@ -2019,7 +2024,7 @@ subroutine convertCohortVectorToList( this, bounds, ed_allsites_inst ) if (this%DEBUG) then write(iulog,*) 'CVTL III ' & - ,countCohort,cohorts_per_gcell, numCohort + ,countCohort,cohorts_per_col, numCohort endif ! ! deal with patch level fields of arrays here @@ -2076,7 +2081,7 @@ subroutine convertCohortVectorToList( this, bounds, ed_allsites_inst ) if (this%DEBUG) then write(iulog,*) 'CVTL incrementOffset ', incrementOffset - write(iulog,*) 'CVTL cohorts_per_gcell ', cohorts_per_gcell + write(iulog,*) 'CVTL cohorts_per_col ', cohorts_per_col write(iulog,*) 'CVTL numCohort ', numCohort write(iulog,*) 'CVTL totalCohorts ', totalCohorts end if @@ -2109,7 +2114,7 @@ end subroutine convertCohortVectorToList !--------------------------------------------! !-------------------------------------------------------------------------------! - subroutine EDRest ( bounds, ed_allsites_inst, ncid, flag ) + subroutine EDRest ( bounds, sites, nsites, ncid, flag ) ! ! !DESCRIPTION: ! Read/write ED restart data @@ -2123,7 +2128,8 @@ subroutine EDRest ( bounds, ed_allsites_inst, ncid, flag ) ! !ARGUMENTS: type(bounds_type) , intent(in) :: bounds ! bounds type(file_desc_t) , intent(inout) :: ncid ! netcdf id - type(ed_site_type) , intent(inout) :: ed_allsites_inst(bounds%begg:) + type(ed_site_type) , intent(inout) :: sites ! The site vector + integer , intent(in) :: nsites ! Size of the site vector character(len=*) , intent(in) :: flag !'read' or 'write' ! ! !LOCAL VARIABLES: @@ -2139,13 +2145,13 @@ subroutine EDRest ( bounds, ed_allsites_inst, ncid, flag ) end if if ( flag == 'write' ) then - call ervc%setVectors( bounds, ed_allsites_inst(bounds%begg:bounds%endg) ) + call ervc%setVectors( bounds, sites) ) endif call ervc%doVectorIO( ncid, flag ) if ( flag == 'read' ) then - call ervc%getVectors( bounds, ed_allsites_inst(bounds%begg:bounds%endg) ) + call ervc%getVectors( bounds, sites, nsites ) endif call ervc%deleteEDRestartVectorClass () diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 50f5dc09..03209c5d 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -24,9 +24,9 @@ module EDTypesMod ! for setting number of patches per gridcell and number of cohorts per patch ! for I/O and converting to a vector - integer, parameter :: numPatchesPerGridCell = 10 ! + integer, parameter :: numPatchesPerGridCol = 10 ! integer, parameter :: numCohortsPerPatch = 160 ! - integer, parameter :: cohorts_per_gcell = 1600 ! This is the max number of individual items one can store per + integer, parameter :: cohorts_per_col = 1600 ! This is the max number of individual items one can store per ! each grid cell and effects the striding in the ED restart ! data as some fields are arrays where each array is @@ -233,7 +233,7 @@ module EDTypesMod !INDICES integer :: patchno ! unique number given to each new patch created for tracking - integer :: clm_pno ! clm patch number (index of p vector) +! integer :: clm_pno ! clm patch number (index of p vector) ! PATCH INFO real(r8) :: age ! average patch age: years @@ -396,9 +396,6 @@ module EDTypesMod ! 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 diff --git a/main/EDVecCohortType.F90 b/main/EDVecCohortType.F90 index 96dc04e9..feefd135 100644 --- a/main/EDVecCohortType.F90 +++ b/main/EDVecCohortType.F90 @@ -12,8 +12,8 @@ module EDVecCohortType public ! type, public :: ed_vec_cohort_type - integer :: cohorts_per_gridcell - integer , pointer :: gridcell(:) !index into gridcell level quantities + integer :: cohorts_per_column + integer , pointer :: column(:) !index into column level quantities contains procedure, public :: Init end type ed_vec_cohort_type @@ -35,7 +35,7 @@ subroutine Init(this, beg, end) ! FIX(SPM,032414) pull this out and put in own ED source - allocate(this%gridcell(beg:end)) + allocate(this%column(beg:end)) end subroutine Init diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index ddcd69af..f3b21b78 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -99,18 +99,13 @@ subroutine init_coldstart(this,fcolumn) ! Input Arguments class(fates_interface_type), intent(inout) :: this - integer :: fcolumn(this%nsites) -! type(bounds_type),intent(in) :: bounds_clump + integer, intent(in) :: fcolumn(this%nsites) ! locals integer :: s integer :: c integer :: g - ! Initialize (INTERF-TODO THIS ROUTINE CALLS CLM STUFF-MIGRATE CODE TO HERE) -! call ed_init_sites( bounds_clump, & -! this%sites(bounds_clump%begg:bounds_clump%endg) ) - do s = 1,this%nsites call zero_site(this%sites(s)) @@ -127,17 +122,16 @@ subroutine init_coldstart(this,fcolumn) call init_patches(this%sites, this%nsites) - do s = 1,this%nsites call ed_update_site(this%sites(s)) end do return - end subroutine site_init + end subroutine init_coldstart ! ------------------------------------------------------------------------------------ - subroutine fates_restart(this, bounds_clump, ncid, flag ) + subroutine init_restart(this, bounds_clump, ncid, flag ) implicit none class(fates_interface_type), intent(inout) :: this @@ -145,10 +139,10 @@ subroutine fates_restart(this, bounds_clump, ncid, flag ) type(file_desc_t) , intent(inout) :: ncid ! netcdf id character(len=*) , intent(in) :: flag !'read' or 'write' - call EDRest( bounds_clump, this%sites(bounds_clump%begg:bounds_clump%endg), & + call EDRest( bounds_clump, this%sites, this%nsites, ncid, flag ) return - end subroutine fates_restart + end subroutine init_restart ! ------------------------------------------------------------------------------------ From b81fab5409897836023d4303a1c8f6fc4ba7ff0c Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 24 May 2016 20:09:10 -0700 Subject: [PATCH 096/437] more partial progress, working through restart list to vector and vector to list procedures. Currently on convertCohortVectorToList(). --- main/EDRestVectorMod.F90 | 371 +++++++++++++++++++------------------ main/FatesInterfaceMod.F90 | 3 +- 2 files changed, 195 insertions(+), 179 deletions(-) diff --git a/main/EDRestVectorMod.F90 b/main/EDRestVectorMod.F90 index 62bbb7b8..840eb634 100755 --- a/main/EDRestVectorMod.F90 +++ b/main/EDRestVectorMod.F90 @@ -592,7 +592,7 @@ function newEDRestartVectorClass( bounds ) end function newEDRestartVectorClass !-------------------------------------------------------------------------------! - subroutine setVectors( this, bounds, sites ) + subroutine setVectors( this, bounds, sites, nsites, fcolumn ) ! ! !DESCRIPTION: ! implement setVectors @@ -603,7 +603,9 @@ subroutine setVectors( this, bounds, sites ) ! !ARGUMENTS: class(EDRestartVectorClass) , intent(inout) :: this type(bounds_type) , intent(in) :: bounds - type(ed_site_type) , intent(in), target :: sites(:) + type(ed_site_type) , intent(in), target :: sites(nsites) + integer , intent(in) :: nsites + integer , intent(in) :: fcolumn(nsites) ! ! !LOCAL VARIABLES: !----------------------------------------------------------------------- @@ -615,10 +617,10 @@ subroutine setVectors( this, bounds, sites ) ! call this%printDataInfoLL ( bounds, sites, nsites ) !end if - call this%convertCohortListToVector ( bounds, sites ) + call this%convertCohortListToVector ( bounds, sites, nsites, fcolumn ) if (this%DEBUG) then - call this%printIoInfoLL ( bounds, sites, nsites ) + call this%printIoInfoLL ( bounds, sites, nsites, fcolumn ) call this%printDataInfoLL ( bounds, sites, nsites ) call this%printDataInfoVector ( ) end if @@ -626,7 +628,7 @@ subroutine setVectors( this, bounds, sites ) end subroutine setVectors !-------------------------------------------------------------------------------! - subroutine getVectors( this, bounds, sites, nsites) + subroutine getVectors( this, bounds, sites, nsites, fcolumn) ! ! !DESCRIPTION: ! implement getVectors @@ -639,8 +641,9 @@ subroutine getVectors( this, bounds, sites, nsites) ! !ARGUMENTS: class(EDRestartVectorClass) , intent(inout) :: this type(bounds_type) , intent(in) :: bounds - type(ed_site_type) , intent(inout), target :: sites(:) + type(ed_site_type) , intent(inout), target :: sites(nsites) integer , intent(in) :: nsites + integer , intent(in) :: fcolumn(nsites) ! @@ -652,7 +655,7 @@ subroutine getVectors( this, bounds, sites, nsites) write(iulog,*) 'edtime getVectors ',get_nstep() end if - call this%createPatchCohortStructure ( bounds, sites ) + call this%createPatchCohortStructure ( bounds, sites, nsites ) call this%convertCohortVectorToList ( bounds, sites ) @@ -661,8 +664,8 @@ subroutine getVectors( this, bounds, sites, nsites) end do if (this%DEBUG) then - call this%printIoInfoLL ( bounds, sites ) - call this%printDataInfoLL ( bounds, sites ) + call this%printIoInfoLL ( bounds, sites, nsites, fcolumn ) + call this%printDataInfoLL ( bounds, sites, nsites ) call this%printDataInfoVector ( ) end if @@ -1237,7 +1240,7 @@ subroutine printDataInfoLL( this, bounds, sites, nsites ) ! !ARGUMENTS: class(EDRestartVectorClass) , intent(inout) :: this type(bounds_type) , intent(in) :: bounds - type(ed_site_type) , intent(in), target :: sites + type(ed_site_type) , intent(in), target :: sites(nsites) integer , intent(in) :: nsites ! ! !LOCAL VARIABLES: @@ -1370,9 +1373,9 @@ subroutine printIoInfoLL( this, bounds, sites, nsites, fcolumn ) ! !ARGUMENTS: class(EDRestartVectorClass) , intent(inout) :: this type(bounds_type) , intent(in) :: bounds - type(ed_site_type) , intent(in), target :: sites + type(ed_site_type) , intent(in), target :: sites(nsites) integer , intent(in) :: nsites - integer, intent(in) :: fcolumn(this%nsites) + integer , intent(in) :: fcolumn(nsites) ! ! !LOCAL VARIABLES: type (ed_patch_type), pointer :: currentPatch @@ -1495,27 +1498,28 @@ subroutine convertCohortListToVector( this, bounds, sites, nsites, fcolumn ) totalCohorts = 0 - incrementOffset = this%vectorLengthStart - countCohort = this%vectorLengthStart - countPft = this%vectorLengthStart - countNcwd = this%vectorLengthStart - countNclmax = this%vectorLengthStart - countWaterMem = this%vectorLengthStart - countSunZ = this%vectorLengthStart - + if(fcolumn(1).eq.bounds%begc .and. & + (fcolumn(1)-1)*cohorts_per_col.ne.(bounds%begCohort-1)) then + write(iulog,*) 'fcolumn(1) in this clump points to the first column of the clump' + write(iulog,*) 'but the assumption on first cohort index does not jive' + call endrun(msg=errMsg(__FILE__, __LINE__)) + end if do s = 1,nsites - + ! Calculate the offsets + ! fcolumn is the global column index of the current site. + ! For the first site, if that site aligns with the first column index + ! in the clump, than the offset should be be equal to begCohort + + incrementOffset = (fcolumn(s)-1)*cohorts_per_col + 1 + countCohort = (fcolumn(s)-1)*cohorts_per_col + 1 + countPft = (fcolumn(s)-1)*cohorts_per_col + 1 + countNcwd = (fcolumn(s)-1)*cohorts_per_col + 1 + countNclmax = (fcolumn(s)-1)*cohorts_per_col + 1 + countWaterMem = (fcolumn(s)-1)*cohorts_per_col + 1 + countSunZ = (fcolumn(s)-1)*cohorts_per_col + 1 - incrementOffset = this%vectorLengthStart + (fcolumn(s)-1)*cohorts_per_col - countCohort = this%vectorLengthStart + (fcolumn(s)-1)*cohorts_per_col - countPft = this%vectorLengthStart + (fcolumn(s)-1)*cohorts_per_col - countNcwd = this%vectorLengthStart + (fcolumn(s)-1)*cohorts_per_col - countNclmax = this%vectorLengthStart + (fcolumn(s)-1)*cohorts_per_col - countWaterMem = this%vectorLengthStart + (fcolumn(s)-1)*cohorts_per_col - countSunZ = this%vectorLengthStart + (fcolumn(s)-1)*cohorts_per_col - currentPatch => sites(s)%oldest_patch ! new column, reset num patches @@ -1585,131 +1589,128 @@ subroutine convertCohortListToVector( this, bounds, sites, nsites, fcolumn ) write(iulog,*) 'CLTV offsetNumCohorts II ',countCohort, & numCohort endif - - countCohort = countCohort + 1 - - currentCohort => currentCohort%taller - - enddo ! currentCohort do while - - - ! - ! 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 - this%cd_status(incrementOffset) = ed_allsites_inst(g)%status - this%dd_status(incrementOffset) = ed_allsites_inst(g)%dstatus - this%ncd(incrementOffset) = ed_allsites_inst(g)%ncd - this%leafondate(incrementOffset) = ed_allsites_inst(g)%leafondate - this%leafoffdate(incrementOffset) = ed_allsites_inst(g)%leafoffdate - this%dleafondate(incrementOffset) = ed_allsites_inst(g)%dleafondate - this%dleafoffdate(incrementOffset)= ed_allsites_inst(g)%dleafoffdate - this%acc_NI(incrementOffset) = ed_allsites_inst(g)%acc_NI + countCohort = countCohort + 1 - ! set cohorts per patch for IO - this%cohortsPerPatch( incrementOffset ) = numCohort - - if (this%DEBUG) then - write(iulog,*) 'offsetNumCohorts III ' & - ,countCohort,cohorts_per_col, 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 - - if (this%DEBUG) write(iulog,*) 'CLTV countSunZ 1 ',countSunZ - - if (this%DEBUG) write(iulog,*) 'CLTV 1186 ',nlevcan_ed,numpft_ed,nclmax + currentCohort => currentCohort%taller + + enddo ! currentCohort do while - do k = 1,nlevcan_ed ! nlevcan_ed currently 40 - do j = 1,numpft_ed ! numpft_ed currently 2 - do i = 1,nclmax ! nclmax currently 2 - this%f_sun(countSunZ) = currentPatch%f_sun(i,j,k) - this%fabd_sun_z(countSunZ) = currentPatch%fabd_sun_z(i,j,k) - this%fabi_sun_z(countSunZ) = currentPatch%fabi_sun_z(i,j,k) - this%fabd_sha_z(countSunZ) = currentPatch%fabd_sha_z(i,j,k) - this%fabi_sha_z(countSunZ) = currentPatch%fabi_sha_z(i,j,k) - countSunZ = countSunZ + 1 - end do + ! + ! 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) = sites(s)%old_stock + this%cd_status(incrementOffset) = sites(s)%status + this%dd_status(incrementOffset) = sites(s)%dstatus + this%ncd(incrementOffset) = sites(s)%ncd + this%leafondate(incrementOffset) = sites(s)%leafondate + this%leafoffdate(incrementOffset) = sites(s)%leafoffdate + this%dleafondate(incrementOffset) = sites(s)%dleafondate + this%dleafoffdate(incrementOffset)= sites(s)%dleafoffdate + this%acc_NI(incrementOffset) = sites(s)%acc_NI + + + ! set cohorts per patch for IO + this%cohortsPerPatch( incrementOffset ) = numCohort + + if (this%DEBUG) then + write(iulog,*) 'offsetNumCohorts III ' & + ,countCohort,cohorts_per_col, 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 + 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 + + if (this%DEBUG) write(iulog,*) 'CLTV countSunZ 1 ',countSunZ + + if (this%DEBUG) write(iulog,*) 'CLTV 1186 ',nlevcan_ed,numpft_ed,nclmax + + do k = 1,nlevcan_ed ! nlevcan_ed currently 40 + do j = 1,numpft_ed ! numpft_ed currently 2 + do i = 1,nclmax ! nclmax currently 2 + this%f_sun(countSunZ) = currentPatch%f_sun(i,j,k) + this%fabd_sun_z(countSunZ) = currentPatch%fabd_sun_z(i,j,k) + this%fabi_sun_z(countSunZ) = currentPatch%fabi_sun_z(i,j,k) + this%fabd_sha_z(countSunZ) = currentPatch%fabd_sha_z(i,j,k) + this%fabi_sha_z(countSunZ) = currentPatch%fabi_sha_z(i,j,k) + countSunZ = countSunZ + 1 end do end do - - if (this%DEBUG) write(iulog,*) 'CLTV countSunZ 2 ',countSunZ - - ! set numpatches for this gcell - this%numPatchesPerCol( 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 - countSunZ = incrementOffset - - if (this%DEBUG) then - write(iulog,*) 'CLTV incrementOffset ', incrementOffset - write(iulog,*) 'CLTV cohorts_per_col ', cohorts_per_col - write(iulog,*) 'CLTV numCohort ', numCohort - write(iulog,*) 'CLTV totalCohorts ', totalCohorts - end if - - currentPatch => currentPatch%younger - - enddo ! currentPatch do while - - ! set which gridcells have patches/cohorts - this%colWithPatch( 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 - - countWaterMem = incrementOffset - - endif ! is there soil check - - g = g + 1 - + + if (this%DEBUG) write(iulog,*) 'CLTV countSunZ 2 ',countSunZ + + 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 + countSunZ = incrementOffset + + if (this%DEBUG) then + write(iulog,*) 'CLTV incrementOffset ', incrementOffset + write(iulog,*) 'CLTV cohorts_per_col ', cohorts_per_col + write(iulog,*) 'CLTV numCohort ', numCohort + write(iulog,*) 'CLTV totalCohorts ', totalCohorts + end if + + currentPatch => currentPatch%younger + + enddo ! currentPatch do while + + ! set numpatches for this gcell + this%numPatchesPerCol(fcolumn(s)) = numPatches + + ! set which columns have patches/cohorts (seems redundant given numPatchesPerCol) + this%colWithPatch(fcolumn(s)) = 1 + + do i = 1,numWaterMem ! numWaterMem currently 10 + this%water_memory( countWaterMem ) = sites(s)%water_memory(i) + countWaterMem = countWaterMem + 1 + end do + + countWaterMem = incrementOffset + enddo - + if (this%DEBUG) then write(iulog,*) 'CLTV total cohorts ',totalCohorts end if - - end subroutine convertCohortListToVector + + return + end subroutine convertCohortListToVector !-------------------------------------------------------------------------------! - subroutine createPatchCohortStructure( this, bounds, ed_allsites_inst ) + subroutine createPatchCohortStructure( this, bounds, sites, nsites, fcolumn ) ! ! !DESCRIPTION: ! counts the total number of cohorts over all p levels (ed_patch_type) so we @@ -1723,11 +1724,14 @@ subroutine createPatchCohortStructure( this, bounds, ed_allsites_inst ) use EDParamsMod , only : ED_val_maxspread use EDPatchDynamicsMod , only : create_patch use GridcellType , only : grc + use ColumnType , only : col ! ! !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_site_type) , intent(inout), target :: sites(nsites) + integer , intent(in) :: nsites + integer , intent(in) :: fcolumn(nsites) ! ! !LOCAL VARIABLES: type (ed_patch_type) , pointer :: newp @@ -1737,10 +1741,13 @@ subroutine createPatchCohortStructure( this, bounds, ed_allsites_inst ) real(r8) :: seed_bank_local(numpft_ed) real(r8) :: age !notional age of this patch integer :: cohortstatus - integer :: g,patchIdx,currIdx, fto, ft + integer :: s ! site index + integer :: c ! column index + integer :: g ! grid index + integer :: 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 @@ -1753,25 +1760,29 @@ subroutine createPatchCohortStructure( this, bounds, ed_allsites_inst ) ! loop over model grid cells and create patch/cohort structure based on ! restart data ! - do g = bounds%begg, bounds%endg + do s = 1,nsites + + c = fcolumn(s) + g = col%gridcell(c) + + currIdx = (c-1)*cohorts_per_col + 1 ! global cohort index at the head of the column if (this%DEBUG) then - write(iulog,*) 'colWithPatch ',this%colWithPatch(g),this%numPatchesPerCol(g) + write(iulog,*) 'colWithPatch ',this%colWithPatch(c),this%numPatchesPerCol(c) end if - call zero_site( ed_allsites_inst(g) ) + call zero_site( sites(s) ) ! ! 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 + sites(s)%lat = grc%latdeg(g) + sites(s)%lon = grc%londeg(g) + sites(s)%gdd = 0.0_r8 + sites(s)%ncd = 0.0_r8 ! then this site has soil and should be set here - do patchIdx = 1,this%numPatchesPerCol(g) + do patchIdx = 1,this%numPatchesPerCol(c) if (this%DEBUG) then write(iulog,*) 'create patch ',patchIdx @@ -1783,11 +1794,11 @@ subroutine createPatchCohortStructure( this, bounds, ed_allsites_inst ) call zero_patch(newp) ! make new patch - call create_patch(ed_allsites_inst(g), newp, age, area, & + call create_patch(sites(s), 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) + newp%siteptr => sites(s) ! give this patch a unique patch number newp%patchno = patchIdx @@ -1840,31 +1851,31 @@ subroutine createPatchCohortStructure( this, bounds, ed_allsites_inst ) if (this%DEBUG) write(iulog,*) 'patchIdx = 1 ',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() + sites(s)%youngest_patch => newp + sites(s)%oldest_patch => newp + sites(s)%youngest_patch%younger => null() + sites(s)%youngest_patch%older => null() + sites(s)%oldest_patch%younger => null() + sites(s)%oldest_patch%older => null() else if (patchIdx == 2) then ! add second patch to list if (this%DEBUG) write(iulog,*) 'patchIdx = 2 ',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() + sites(s)%youngest_patch => newp + sites(s)%youngest_patch%younger => null() + sites(s)%youngest_patch%older => sites(s)%oldest_patch + sites(s)%oldest_patch%younger => sites(s)%youngest_patch + sites(s)%oldest_patch%older => null() else ! more than 2 patches, insert patch into youngest slot if (this%DEBUG) write(iulog,*) 'patchIdx > 2 ',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 + newp%older => sites(s)%youngest_patch + sites(s)%youngest_patch%younger => newp + newp%younger => null() + sites(s)%youngest_patch => newp endif @@ -1872,12 +1883,12 @@ subroutine createPatchCohortStructure( this, bounds, ed_allsites_inst ) enddo ! ends loop over patchIdx - enddo ! ends loop over g + enddo ! ends loop over s end subroutine createPatchCohortStructure !-------------------------------------------------------------------------------! - subroutine convertCohortVectorToList( this, bounds, ed_allsites_inst ) + subroutine convertCohortVectorToList( this, bounds, sites, nsites, fcolumn ) ! ! !DESCRIPTION: ! counts the total number of cohorts over all p levels (ed_patch_type) so we @@ -1889,7 +1900,10 @@ subroutine convertCohortVectorToList( this, bounds, ed_allsites_inst ) ! !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_site_type) , intent(inout), target :: sites(nsites) + integer , intent(in) :: nsites + integer , intent(in) :: fcolumn(nsites) + ! ! !LOCAL VARIABLES: type (ed_patch_type), pointer :: currentPatch @@ -2114,7 +2128,7 @@ end subroutine convertCohortVectorToList !--------------------------------------------! !-------------------------------------------------------------------------------! - subroutine EDRest ( bounds, sites, nsites, ncid, flag ) + subroutine EDRest ( bounds, sites, nsites, fcolumn, ncid, flag ) ! ! !DESCRIPTION: ! Read/write ED restart data @@ -2128,8 +2142,9 @@ subroutine EDRest ( bounds, sites, nsites, ncid, flag ) ! !ARGUMENTS: type(bounds_type) , intent(in) :: bounds ! bounds type(file_desc_t) , intent(inout) :: ncid ! netcdf id - type(ed_site_type) , intent(inout) :: sites ! The site vector - integer , intent(in) :: nsites ! Size of the site vector + type(ed_site_type) , intent(inout) :: sites(nsites) ! The site vector + integer , intent(in) :: nsites + integer , intent(in) :: fcolumn(nsites) character(len=*) , intent(in) :: flag !'read' or 'write' ! ! !LOCAL VARIABLES: @@ -2145,7 +2160,7 @@ subroutine EDRest ( bounds, sites, nsites, ncid, flag ) end if if ( flag == 'write' ) then - call ervc%setVectors( bounds, sites) ) + call ervc%setVectors( bounds, sites, nsites, fcolumn ) endif call ervc%doVectorIO( ncid, flag ) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index f3b21b78..a7457058 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -18,6 +18,7 @@ module FatesInterfaceMod use atm2lndType , only : atm2lnd_type use ncdio_pio , only : file_desc_t use PatchType , only : patch + use ColumnType , only : col ! ------------------------------------------------------------------------------------ use EDtypesMod , only : ed_patch_type, ed_site_type, numpft_ed @@ -111,7 +112,7 @@ subroutine init_coldstart(this,fcolumn) call zero_site(this%sites(s)) c = fcolumn(s) - g = gridcell(c) + g = col%gridcell(c) ! TODO-INTERF: col% and grc% should not be accessible here this%sites(s)%lat = grc%latdeg(g) this%sites(s)%lon = grc%londeg(g) From d522948842aed04b63af011f2347730482de7e67 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 25 May 2016 15:20:18 -0700 Subject: [PATCH 097/437] first pass complete at converting EDRestVectorMod to columns. Variable colWithPatch was removed because it is offers no information beyond what is provided by numPatchesPerCol (which is more information rich. Also, old_stock,cd_status,dd_status,ncd,leafondate,leafoffdat,dleafondate,dleafoffdate and acc_NI are stored in the restart as column indexed, as they are site level variables. If these variables are converted to patch-scale, then they need large restart vector allocations. --- main/EDRestVectorMod.F90 | 673 +++++++++++++++++++-------------------- 1 file changed, 335 insertions(+), 338 deletions(-) diff --git a/main/EDRestVectorMod.F90 b/main/EDRestVectorMod.F90 index 840eb634..1bdffb37 100755 --- a/main/EDRestVectorMod.F90 +++ b/main/EDRestVectorMod.F90 @@ -8,13 +8,10 @@ module EDRestVectorMod use clm_varctl , only : iulog use spmdMod , only : masterproc use decompMod , only : bounds_type - use CanopyStateType , only : canopystate_type - use WaterStateType , only : waterstate_type use pftconMod , only : pftcon use EDTypesMod , only : area, cohorts_per_col, numpft_ed, numWaterMem, nclmax, numCohortsPerPatch use EDTypesMod , only : ncwd, invalidValue, nlevcan_ed use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type - use EDPhenologyType , only : ed_phenology_type ! implicit none private @@ -39,7 +36,6 @@ module EDRestVectorMod ! required to map cohorts and patches to/fro ! vectors/LinkedLists - integer, pointer :: colWithPatch(:) integer, pointer :: numPatchesPerCol(:) integer, pointer :: cohortsPerPatch(:) ! @@ -177,7 +173,6 @@ subroutine deleteEDRestartVectorClass( this ) class(EDRestartVectorClass), intent(inout) :: this ! ! !LOCAL VARIABLES: - deallocate(this%colWithPatch ) deallocate(this%numPatchesPerCol ) deallocate(this%cohortsPerPatch ) deallocate(this%balive ) @@ -266,19 +261,64 @@ function newEDRestartVectorClass( bounds ) new%vectorLengthStart = bounds%begCohort new%vectorLengthStop = bounds%endCohort - ! - ! cohort level variables that are required on restart - ! + ! Column level variables + + allocate(new%numPatchesPerCol & + (bounds%begc:bounds%endc), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%numPatchesPerCol(:) = invalidValue - allocate(new%colWithPatch & + + allocate(new%old_stock & (bounds%begc:bounds%endc), stat=retVal) SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) - new%colWithPatch(:) = 0 + new%old_stock(:) = 0.0_r8 - allocate(new%numPatchesPerCol & + allocate(new%cd_status & (bounds%begc:bounds%endc), stat=retVal) SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) - new%numPatchesPerCol(:) = invalidValue + new%cd_status(:) = 0_r8 + + allocate(new%dd_status & + (bounds%begc:bounds%endc), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%dd_status(:) = 0_r8 + + allocate(new%ncd & + (bounds%begc:bounds%endc), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%ncd(:) = 0_r8 + + + allocate(new%leafondate & + (bounds%begc:bounds%endc), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%leafondate(:) = 0_r8 + + allocate(new%leafoffdate & + (bounds%begc:bounds%endc), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%leafoffdate(:) = 0_r8 + + allocate(new%dleafondate & + (bounds%begc:bounds%endc), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%dleafondate(:) = 0_r8 + + allocate(new%dleafoffdate & + (bounds%begc:bounds%endc), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%dleafoffdate(:) = 0_r8 + + allocate(new%acc_NI & + (bounds%begc:bounds%endc), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%acc_NI(:) = 0_r8 + + + ! cohort level variables + + allocate(new%cohortsPerPatch & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) @@ -534,58 +574,16 @@ function newEDRestartVectorClass( bounds ) new%fabi_sha_z(:) = 0.0_r8 ! - ! site level variable + ! Site level variable stored with cohort indexing + ! (to accomodate the second dimension) ! 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 - - allocate(new%cd_status & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) - new%cd_status(:) = 0_r8 - - allocate(new%dd_status & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) - new%dd_status(:) = 0_r8 - - allocate(new%ncd & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) - new%ncd(:) = 0_r8 - - allocate(new%leafondate & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) - new%leafondate(:) = 0_r8 - - allocate(new%leafoffdate & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) - new%leafoffdate(:) = 0_r8 - - allocate(new%dleafondate & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) - new%dleafondate(:) = 0_r8 - - allocate(new%dleafoffdate & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) - new%dleafoffdate(:) = 0_r8 - - allocate(new%acc_NI & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) - new%acc_NI(:) = 0_r8 end associate @@ -693,21 +691,78 @@ subroutine doVectorIO( this, ncid, flag ) character(len=16) :: dimName = trim(nameCohort) !----------------------------------------------------------------------- - ! - ! cohort level vars - ! - call restartvar(ncid=ncid, flag=flag, varname='ed_io_colWithPatch', xtype=ncd_int, & + call restartvar(ncid=ncid, flag=flag, varname='ed_io_numPatchesPerCol', xtype=ncd_int, & dim1name=namec, & - long_name='1 if a column has a patch', units='1=true,0=false', & - interpinic_flag='interp', data=this%colWithPatch, & + long_name='Num patches per column', units='unitless', & + interpinic_flag='interp', data=this%numPatchesPerCol, & readvar=readvar) - call restartvar(ncid=ncid, flag=flag, varname='ed_io_numPatchesPerCol', xtype=ncd_int, & + call restartvar(ncid=ncid, flag=flag, varname='ed_old_stock', xtype=ncd_double, & dim1name=namec, & - long_name='works with ed_colWithPatch. num patches per column', units='unitless', & - interpinic_flag='interp', data=this%numPatchesPerCol, & + long_name='ed cohort - old_stock', units='unitless', & + interpinic_flag='interp', data=this%old_stock, & readvar=readvar) + call restartvar(ncid=ncid, flag=flag, varname='ed_cd_status', xtype=ncd_double, & + dim1name=namec, & + long_name='ed cold dec status', units='unitless', & + interpinic_flag='interp', data=this%cd_status, & + readvar=readvar) + + + call restartvar(ncid=ncid, flag=flag, varname='ed_dd_status', xtype=ncd_double, & + dim1name=namec, & + long_name='ed drought dec status', units='unitless', & + interpinic_flag='interp', data=this%dd_status, & + readvar=readvar) + + + call restartvar(ncid=ncid, flag=flag, varname='ed_chilling_days', xtype=ncd_double, & + dim1name=namec, & + long_name='ed chilling day counter', units='unitless', & + interpinic_flag='interp', data=this%ncd, & + readvar=readvar) + + + call restartvar(ncid=ncid, flag=flag, varname='ed_leafondate', xtype=ncd_double, & + dim1name=namec, & + long_name='ed leafondate', units='unitless', & + interpinic_flag='interp', data=this%leafondate, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_leafoffdate', xtype=ncd_double, & + dim1name=namec, & + long_name='ed leafoffdate', units='unitless', & + interpinic_flag='interp', data=this%leafoffdate, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_dleafondate', xtype=ncd_double, & + dim1name=namec, & + long_name='ed dleafondate', units='unitless', & + interpinic_flag='interp', data=this%dleafondate, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_dleafoffdate', xtype=ncd_double, & + dim1name=namec, & + long_name='ed dleafoffdate', units='unitless', & + interpinic_flag='interp', data=this%dleafoffdate, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_acc_NI', xtype=ncd_double, & + dim1name=namec, & + long_name='ed nesterov index', units='unitless', & + interpinic_flag='interp', data=this%acc_NI, & + readvar=readvar) + + + + ! + ! cohort level vars + ! + + + + call restartvar(ncid=ncid, flag=flag, varname='ed_io_cohortsPerPatch', xtype=ncd_int, & dim1name=dimName, & long_name='list of cohorts per patch. indexed by numPatchesPerCol', units='unitless', & @@ -1021,61 +1076,9 @@ subroutine doVectorIO( this, ncid, flag ) 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) - - call restartvar(ncid=ncid, flag=flag, varname='ed_cd_status', xtype=ncd_double, & - dim1name=dimName, & - long_name='ed cold dec status', units='unitless', & - interpinic_flag='interp', data=this%cd_status, & - readvar=readvar) - - call restartvar(ncid=ncid, flag=flag, varname='ed_dd_status', xtype=ncd_double, & - dim1name=dimName, & - long_name='ed drought dec status', units='unitless', & - interpinic_flag='interp', data=this%dd_status, & - readvar=readvar) - - call restartvar(ncid=ncid, flag=flag, varname='ed_chilling_days', xtype=ncd_double, & - dim1name=dimName, & - long_name='ed chilling day counter', units='unitless', & - interpinic_flag='interp', data=this%ncd, & - readvar=readvar) - - call restartvar(ncid=ncid, flag=flag, varname='ed_leafondate', xtype=ncd_double, & - dim1name=dimName, & - long_name='ed leafondate', units='unitless', & - interpinic_flag='interp', data=this%leafondate, & - readvar=readvar) - - call restartvar(ncid=ncid, flag=flag, varname='ed_leafoffdate', xtype=ncd_double, & - dim1name=dimName, & - long_name='ed leafoffdate', units='unitless', & - interpinic_flag='interp', data=this%leafoffdate, & - readvar=readvar) - call restartvar(ncid=ncid, flag=flag, varname='ed_dleafondate', xtype=ncd_double, & - dim1name=dimName, & - long_name='ed dleafondate', units='unitless', & - interpinic_flag='interp', data=this%dleafondate, & - readvar=readvar) - - call restartvar(ncid=ncid, flag=flag, varname='ed_dleafoffdate', xtype=ncd_double, & - dim1name=dimName, & - long_name='ed dleafoffdate', units='unitless', & - interpinic_flag='interp', data=this%dleafoffdate, & - readvar=readvar) - - call restartvar(ncid=ncid, flag=flag, varname='ed_acc_NI', xtype=ncd_double, & - dim1name=dimName, & - long_name='ed nesterov index', units='unitless', & - interpinic_flag='interp', data=this%acc_NI, & - readvar=readvar) end subroutine doVectorIO @@ -1094,6 +1097,9 @@ subroutine printDataInfoVector( this ) integer :: iSta, iSto !----------------------------------------------------------------------- + ! RGK: changed the vector end-point on column variables to match the start point + ! this avoids exceeding bounds on the last column of the dataset + iSta = this%vectorLengthStart iSto = iSta + 1 @@ -1207,24 +1213,25 @@ subroutine printDataInfoVector( this ) this%fabi_sha_z(iSta:iSto) write(iulog,*) trim(methodName)//' :: water_memory ', & this%water_memory(iSta:iSto) - write(iulog,*) trim(methodName)//' :: old_stock ', & - this%old_stock(iSta:iSto) + + write(iulog,*) trim(methodName)//' :: old_stock ', & + this%old_stock(iSta:iSta) write(iulog,*) trim(methodName)//' :: cd_status', & - this%cd_status(iSta:iSto) + this%cd_status(iSta:iSta) write(iulog,*) trim(methodName)//' :: dd_status', & - this%cd_status(iSta:iSto) + this%cd_status(iSta:iSta) write(iulog,*) trim(methodName)//' :: ncd', & - this%ncd(iSta:iSto) + this%ncd(iSta:iSta) write(iulog,*) trim(methodName)//' :: leafondate', & - this%leafondate(iSta:iSto) + this%leafondate(iSta:iSta) write(iulog,*) trim(methodName)//' :: leafoffdate', & - this%leafoffdate(iSta:iSto) + this%leafoffdate(iSta:iSta) write(iulog,*) trim(methodName)//' :: dleafondate', & - this%dleafondate(iSta:iSto) + this%dleafondate(iSta:iSta) write(iulog,*) trim(methodName)//' :: dleafoffdate', & - this%dleafoffdate(iSta:iSto) + this%dleafoffdate(iSta:iSta) write(iulog,*) trim(methodName)//' :: acc_NI', & - this%acc_NI(iSta:iSto) + this%acc_NI(iSta:iSta) end subroutine printDataInfoVector @@ -1480,7 +1487,7 @@ subroutine convertCohortListToVector( this, bounds, sites, nsites, fcolumn ) ! !LOCAL VARIABLES: type (ed_patch_type), pointer :: currentPatch type (ed_cohort_type), pointer :: currentCohort - integer :: s + integer :: s, c integer :: totalCohorts ! number of cohorts starting from 1 integer :: countCohort ! number of cohorts starting from ! vectorLengthStart @@ -1511,14 +1518,16 @@ subroutine convertCohortListToVector( this, bounds, sites, nsites, fcolumn ) ! fcolumn is the global column index of the current site. ! For the first site, if that site aligns with the first column index ! in the clump, than the offset should be be equal to begCohort + + c = fcolumn(s) - incrementOffset = (fcolumn(s)-1)*cohorts_per_col + 1 - countCohort = (fcolumn(s)-1)*cohorts_per_col + 1 - countPft = (fcolumn(s)-1)*cohorts_per_col + 1 - countNcwd = (fcolumn(s)-1)*cohorts_per_col + 1 - countNclmax = (fcolumn(s)-1)*cohorts_per_col + 1 - countWaterMem = (fcolumn(s)-1)*cohorts_per_col + 1 - countSunZ = (fcolumn(s)-1)*cohorts_per_col + 1 + incrementOffset = (c-1)*cohorts_per_col + 1 + countCohort = (c-1)*cohorts_per_col + 1 + countPft = (c-1)*cohorts_per_col + 1 + countNcwd = (c-1)*cohorts_per_col + 1 + countNclmax = (c-1)*cohorts_per_col + 1 + countWaterMem = (c-1)*cohorts_per_col + 1 + countSunZ = (c-1)*cohorts_per_col + 1 currentPatch => sites(s)%oldest_patch @@ -1603,15 +1612,7 @@ subroutine convertCohortListToVector( this, bounds, sites, nsites, fcolumn ) this%age(incrementOffset) = currentPatch%age this%areaRestart(incrementOffset) = currentPatch%area - this%old_stock(incrementOffset) = sites(s)%old_stock - this%cd_status(incrementOffset) = sites(s)%status - this%dd_status(incrementOffset) = sites(s)%dstatus - this%ncd(incrementOffset) = sites(s)%ncd - this%leafondate(incrementOffset) = sites(s)%leafondate - this%leafoffdate(incrementOffset) = sites(s)%leafoffdate - this%dleafondate(incrementOffset) = sites(s)%dleafondate - this%dleafoffdate(incrementOffset)= sites(s)%dleafoffdate - this%acc_NI(incrementOffset) = sites(s)%acc_NI + ! set cohorts per patch for IO @@ -1686,20 +1687,25 @@ subroutine convertCohortListToVector( this, bounds, sites, nsites, fcolumn ) currentPatch => currentPatch%younger enddo ! currentPatch do while + + this%old_stock(c) = sites(s)%old_stock + this%cd_status(c) = sites(s)%status + this%dd_status(c) = sites(s)%dstatus + this%ncd(c) = sites(s)%ncd + this%leafondate(c) = sites(s)%leafondate + this%leafoffdate(c) = sites(s)%leafoffdate + this%dleafondate(c) = sites(s)%dleafondate + this%dleafoffdate(c) = sites(s)%dleafoffdate + this%acc_NI(c) = sites(s)%acc_NI - ! set numpatches for this gcell - this%numPatchesPerCol(fcolumn(s)) = numPatches - - ! set which columns have patches/cohorts (seems redundant given numPatchesPerCol) - this%colWithPatch(fcolumn(s)) = 1 + ! set numpatches for this column + this%numPatchesPerCol(c) = numPatches do i = 1,numWaterMem ! numWaterMem currently 10 this%water_memory( countWaterMem ) = sites(s)%water_memory(i) countWaterMem = countWaterMem + 1 end do - countWaterMem = incrementOffset - enddo if (this%DEBUG) then @@ -1767,10 +1773,6 @@ subroutine createPatchCohortStructure( this, bounds, sites, nsites, fcolumn ) currIdx = (c-1)*cohorts_per_col + 1 ! global cohort index at the head of the column - if (this%DEBUG) then - write(iulog,*) 'colWithPatch ',this%colWithPatch(c),this%numPatchesPerCol(c) - end if - call zero_site( sites(s) ) ! ! set a few items that are necessary on restart for ED but not on the @@ -1908,7 +1910,7 @@ subroutine convertCohortVectorToList( this, bounds, sites, nsites, fcolumn ) ! !LOCAL VARIABLES: type (ed_patch_type), pointer :: currentPatch type (ed_cohort_type),pointer :: currentCohort - integer :: g + integer :: g, c, s integer :: totalCohorts ! number of cohorts starting from 0 integer :: countCohort ! number of cohorts starting from ! vectorLengthStart @@ -1924,197 +1926,192 @@ subroutine convertCohortVectorToList( this, bounds, sites, nsites, fcolumn ) !----------------------------------------------------------------------- totalCohorts = 0 + + do s = 1,nsites + + c = fcolumn(s) + g = col%gridcell(c) - incrementOffset = this%vectorLengthStart - countCohort = this%vectorLengthStart - countPft = this%vectorLengthStart - countNcwd = this%vectorLengthStart - countNclmax = this%vectorLengthStart - countWaterMem = this%vectorLengthStart - countSunZ = 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%gpp = this%gpp(countCohort) - currentCohort%npp = this%npp(countCohort) - currentCohort%npp_leaf = this%npp_leaf(countCohort) - currentCohort%npp_froot = this%npp_froot(countCohort) - currentCohort%npp_bsw = this%npp_bsw(countCohort) - currentCohort%npp_bdead = this%npp_bdead(countCohort) - currentCohort%npp_bseed = this%npp_bseed(countCohort) - currentCohort%npp_store = this%npp_store(countCohort) - currentCohort%bmort = this%bmort(countCohort) - currentCohort%hmort = this%hmort(countCohort) - currentCohort%cmort = this%cmort(countCohort) - currentCohort%imort = this%imort(countCohort) - currentCohort%fmort = this%fmort(countCohort) - currentCohort%ddbhdt = this%ddbhdt(countCohort) - currentCohort%resp_clm = this%resp_clm(countCohort) - currentCohort%pft = this%pft(countCohort) - currentCohort%status_coh = this%status_coh(countCohort) - currentCohort%isnew = ( this%isnew(countCohort) .eq. new_cohort ) - - if (this%DEBUG) then - write(iulog,*) 'CVTL II ',countCohort, & - numCohort - endif - - countCohort = countCohort + 1 + incrementOffset = (c-1)*cohorts_per_col + 1 + countCohort = (c-1)*cohorts_per_col + 1 + countPft = (c-1)*cohorts_per_col + 1 + countNcwd = (c-1)*cohorts_per_col + 1 + countNclmax = (c-1)*cohorts_per_col + 1 + countWaterMem = (c-1)*cohorts_per_col + 1 + countSunZ = (c-1)*cohorts_per_col + 1 - currentCohort => currentCohort%taller + currentPatch => sites(s)%oldest_patch + + ! new grid cell, reset num patches + numPatches = 0 - enddo ! currentPatch do while - - - ! 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) - ed_allsites_inst(g)%status = this%cd_status(incrementOffset) - ed_allsites_inst(g)%dstatus = this%dd_status(incrementOffset) - ed_allsites_inst(g)%ncd = this%ncd(incrementOffset) - ed_allsites_inst(g)%leafondate = this%leafondate(incrementOffset) - ed_allsites_inst(g)%leafoffdate = this%leafoffdate(incrementOffset) - ed_allsites_inst(g)%dleafondate = this%dleafondate(incrementOffset) - ed_allsites_inst(g)%dleafoffdate = this%dleafoffdate(incrementOffset) - ed_allsites_inst(g)%acc_NI = this%acc_NI(incrementOffset) - - ! set cohorts per patch for IO + 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 III ' & - ,countCohort,cohorts_per_col, numCohort + write(iulog,*) 'CVTL countCohort ',countCohort, this%vectorLengthStart, this%vectorLengthStop 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 - - if (this%DEBUG) write(iulog,*) 'CVTL countSunZ 1 ',countSunZ - - do k = 1,nlevcan_ed ! nlevcan_ed currently 40 - do j = 1,numpft_ed ! numpft_ed currently 2 - do i = 1,nclmax ! nclmax currently 2 - currentPatch%f_sun(i,j,k) = this%f_sun(countSunZ) - currentPatch%fabd_sun_z(i,j,k) = this%fabd_sun_z(countSunZ) - currentPatch%fabi_sun_z(i,j,k) = this%fabi_sun_z(countSunZ) - currentPatch%fabd_sha_z(i,j,k) = this%fabd_sha_z(countSunZ) - currentPatch%fabi_sha_z(i,j,k) = this%fabi_sha_z(countSunZ) - countSunZ = countSunZ + 1 - end do + + 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%gpp = this%gpp(countCohort) + currentCohort%npp = this%npp(countCohort) + currentCohort%npp_leaf = this%npp_leaf(countCohort) + currentCohort%npp_froot = this%npp_froot(countCohort) + currentCohort%npp_bsw = this%npp_bsw(countCohort) + currentCohort%npp_bdead = this%npp_bdead(countCohort) + currentCohort%npp_bseed = this%npp_bseed(countCohort) + currentCohort%npp_store = this%npp_store(countCohort) + currentCohort%bmort = this%bmort(countCohort) + currentCohort%hmort = this%hmort(countCohort) + currentCohort%cmort = this%cmort(countCohort) + currentCohort%imort = this%imort(countCohort) + currentCohort%fmort = this%fmort(countCohort) + currentCohort%ddbhdt = this%ddbhdt(countCohort) + currentCohort%resp_clm = this%resp_clm(countCohort) + currentCohort%pft = this%pft(countCohort) + currentCohort%status_coh = this%status_coh(countCohort) + currentCohort%isnew = ( this%isnew(countCohort) .eq. new_cohort ) + + if (this%DEBUG) then + write(iulog,*) 'CVTL II ',countCohort, & + numCohort + endif + + countCohort = countCohort + 1 + + currentCohort => currentCohort%taller + + enddo ! current cohort do while + + + ! 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) + + + + ! set cohorts per patch for IO + + if (this%DEBUG) then + write(iulog,*) 'CVTL III ' & + ,countCohort,cohorts_per_col, 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 + + if (this%DEBUG) write(iulog,*) 'CVTL countSunZ 1 ',countSunZ + + do k = 1,nlevcan_ed ! nlevcan_ed currently 40 + do j = 1,numpft_ed ! numpft_ed currently 2 + do i = 1,nclmax ! nclmax currently 2 + currentPatch%f_sun(i,j,k) = this%f_sun(countSunZ) + currentPatch%fabd_sun_z(i,j,k) = this%fabd_sun_z(countSunZ) + currentPatch%fabi_sun_z(i,j,k) = this%fabi_sun_z(countSunZ) + currentPatch%fabd_sha_z(i,j,k) = this%fabd_sha_z(countSunZ) + currentPatch%fabi_sha_z(i,j,k) = this%fabi_sha_z(countSunZ) + countSunZ = countSunZ + 1 end do end do - - if (this%DEBUG) write(iulog,*) 'CVTL countSunZ 2 ',countSunZ - - incrementOffset = incrementOffset + numCohortsPerPatch - - ! reset counters so that they are all advanced evenly. Currently - ! the offset must be > 160, nlevcan_ed*numpft_ed*nclmax - ! and the number of allowed cohorts per patch (currently 200) - countPft = incrementOffset - countNcwd = incrementOffset - countNclmax = incrementOffset - countCohort = incrementOffset - countSunZ = incrementOffset - - if (this%DEBUG) then - write(iulog,*) 'CVTL incrementOffset ', incrementOffset - write(iulog,*) 'CVTL cohorts_per_col ', cohorts_per_col - write(iulog,*) 'CVTL numCohort ', numCohort - write(iulog,*) 'CVTL totalCohorts ', totalCohorts - end if - - 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 (this%DEBUG) write(iulog,*) 'CVTL countSunZ 2 ',countSunZ + + incrementOffset = incrementOffset + numCohortsPerPatch - countWaterMem = incrementOffset - - endif ! is there soil check - - g = g + 1 + ! and the number of allowed cohorts per patch (currently 200) + countPft = incrementOffset + countNcwd = incrementOffset + countNclmax = incrementOffset + countCohort = incrementOffset + countSunZ = incrementOffset + + if (this%DEBUG) then + write(iulog,*) 'CVTL incrementOffset ', incrementOffset + write(iulog,*) 'CVTL cohorts_per_col ', cohorts_per_col + write(iulog,*) 'CVTL numCohort ', numCohort + write(iulog,*) 'CVTL totalCohorts ', totalCohorts + end if + + currentPatch => currentPatch%younger + + enddo ! currentPatch do while + + do i = 1,numWaterMem + sites(s)%water_memory(i) = this%water_memory( countWaterMem ) + countWaterMem = countWaterMem + 1 + end do + + sites(s)%old_stock = this%old_stock(c) + sites(s)%status = this%cd_status(c) + sites(s)%dstatus = this%dd_status(c) + sites(s)%ncd = this%ncd(c) + sites(s)%leafondate = this%leafondate(c) + sites(s)%leafoffdate = this%leafoffdate(c) + sites(s)%dleafondate = this%dleafondate(c) + sites(s)%dleafoffdate = this%dleafoffdate(c) + sites(s)%acc_NI = this%acc_NI(c) + enddo if (this%DEBUG) then @@ -2166,7 +2163,7 @@ subroutine EDRest ( bounds, sites, nsites, fcolumn, ncid, flag ) call ervc%doVectorIO( ncid, flag ) if ( flag == 'read' ) then - call ervc%getVectors( bounds, sites, nsites ) + call ervc%getVectors( bounds, sites, nsites, fcolumn ) endif call ervc%deleteEDRestartVectorClass () From dcc1c56d8f42cfd7faad99b5f2f5a37d0174bc88 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 25 May 2016 17:41:47 -0700 Subject: [PATCH 098/437] modified call sequence to restart initialization, passed clm_fates%f2hmap(nc)%fcolumn --- main/EDRestVectorMod.F90 | 28 ++++++++++++++++++++++------ main/FatesInterfaceMod.F90 | 5 ++--- 2 files changed, 24 insertions(+), 9 deletions(-) diff --git a/main/EDRestVectorMod.F90 b/main/EDRestVectorMod.F90 index 1bdffb37..b7f31403 100755 --- a/main/EDRestVectorMod.F90 +++ b/main/EDRestVectorMod.F90 @@ -12,6 +12,7 @@ module EDRestVectorMod use EDTypesMod , only : area, cohorts_per_col, numpft_ed, numWaterMem, nclmax, numCohortsPerPatch use EDTypesMod , only : ncwd, invalidValue, nlevcan_ed use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type + use abortutils , only : endrun ! implicit none private @@ -267,7 +268,6 @@ function newEDRestartVectorClass( bounds ) (bounds%begc:bounds%endc), stat=retVal) SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) new%numPatchesPerCol(:) = invalidValue - allocate(new%old_stock & (bounds%begc:bounds%endc), stat=retVal) @@ -1399,7 +1399,7 @@ subroutine printIoInfoLL( this, bounds, sites, nsites, fcolumn ) write(iulog,*) 'vecLenStart ',this%vectorLengthStart - do s=1,nsites + do s = 1,nsites currentPatch => sites(s)%oldest_patch @@ -1506,8 +1506,8 @@ subroutine convertCohortListToVector( this, bounds, sites, nsites, fcolumn ) totalCohorts = 0 if(fcolumn(1).eq.bounds%begc .and. & - (fcolumn(1)-1)*cohorts_per_col.ne.(bounds%begCohort-1)) then - write(iulog,*) 'fcolumn(1) in this clump points to the first column of the clump' + (fcolumn(1)-1)*cohorts_per_col+1.ne.bounds%begCohort) then + write(iulog,*) 'fcolumn(1) in this clump, points to the first column of the clump' write(iulog,*) 'but the assumption on first cohort index does not jive' call endrun(msg=errMsg(__FILE__, __LINE__)) end if @@ -1783,7 +1783,23 @@ subroutine createPatchCohortStructure( this, bounds, sites, nsites, fcolumn ) sites(s)%gdd = 0.0_r8 sites(s)%ncd = 0.0_r8 - ! then this site has soil and should be set here + if (this%numPatchesPerCol(c)<0 .or. this%numPatchesPerCol(c)>10000) then + write(iulog,*) 'a column was expected to contain a valid number of patches' + write(iulog,*) '0 is a valid number, but this column seems uninitialized',this%numPatchesPerCol(c) + call endrun(msg=errMsg(__FILE__, __LINE__)) + end if + + ! This site may have some patches on it, but lets initialize it with null pointers + ! just in-case there are no patches + + sites(s)%youngest_patch => null() + sites(s)%oldest_patch => null() + sites(s)%youngest_patch%younger => null() + sites(s)%youngest_patch%older => null() + sites(s)%oldest_patch%younger => null() + sites(s)%oldest_patch%older => null() + + do patchIdx = 1,this%numPatchesPerCol(c) if (this%DEBUG) then @@ -1887,7 +1903,7 @@ subroutine createPatchCohortStructure( this, bounds, sites, nsites, fcolumn ) enddo ! ends loop over s - end subroutine createPatchCohortStructure + end subroutine createPatchCohortStructure !-------------------------------------------------------------------------------! subroutine convertCohortVectorToList( this, bounds, sites, nsites, fcolumn ) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index a7457058..9617826d 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -132,7 +132,7 @@ end subroutine init_coldstart ! ------------------------------------------------------------------------------------ - subroutine init_restart(this, bounds_clump, ncid, flag ) + subroutine init_restart(this, bounds_clump, ncid, flag, fcolumn ) implicit none class(fates_interface_type), intent(inout) :: this @@ -140,8 +140,7 @@ subroutine init_restart(this, bounds_clump, ncid, flag ) type(file_desc_t) , intent(inout) :: ncid ! netcdf id character(len=*) , intent(in) :: flag !'read' or 'write' - call EDRest( bounds_clump, this%sites, this%nsites, - ncid, flag ) + call EDRest( bounds_clump, this%sites, this%nsites, fcolumn, ncid, flag ) return end subroutine init_restart From a246d0f9603f203474c5eae491b153d745fe9d80 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 25 May 2016 19:08:28 -0700 Subject: [PATCH 099/437] starting conversion of EDCLMLink to columns. --- main/EDCLMLinkMod.F90 | 245 +++++++++++++++++++++--------------------- 1 file changed, 122 insertions(+), 123 deletions(-) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index df5bc8f3..90bf514a 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -91,35 +91,35 @@ module EDCLMLinkMod real(r8), pointer, private :: maint_resp_patch (:) ! (gC/m2/s) patch maintenance respiration real(r8), pointer, private :: growth_resp_patch (:) ! (gC/m2/s) patch growth respiration - real(r8), pointer :: ed_gpp_gd_scpf (:,:) ! [kg/m2/yr] gross primary production - real(r8), pointer :: ed_npp_totl_gd_scpf (:,:) ! [kg/m2/yr] net primary production (npp) - real(r8), pointer :: ed_npp_leaf_gd_scpf (:,:) ! [kg/m2/yr] npp flux into leaf pool - real(r8), pointer :: ed_npp_seed_gd_scpf (:,:) ! [kg/m2/yr] npp flux into flower,fruit,nut,seed - real(r8), pointer :: ed_npp_fnrt_gd_scpf (:,:) ! [kg/m2/yr] npp flux into fine roots - real(r8), pointer :: ed_npp_bgsw_gd_scpf (:,:) ! [kg/m2/yr] npp flux into below ground sapwood - real(r8), pointer :: ed_npp_bgdw_gd_scpf (:,:) ! [kg/m2/yr] npp flux into below ground structural (dead) wood - real(r8), pointer :: ed_npp_agsw_gd_scpf (:,:) ! [kg/m2/yr] npp flux into above ground sapwood - real(r8), pointer :: ed_npp_agdw_gd_scpf (:,:) ! [kg/m2/yr] npp flux into below ground structural (dead) wood - real(r8), pointer :: ed_npp_stor_gd_scpf (:,:) ! [kg/m2/yr] npp flux through the storage pool - real(r8), pointer :: ed_litt_leaf_gd_scpf (:,:) ! [kg/m2/yr] carbon flux of live leaves to litter - real(r8), pointer :: ed_litt_fnrt_gd_scpf (:,:) ! [kg/m2/yr] carbon flux of fine roots to litter - real(r8), pointer :: ed_litt_sawd_gd_scpf (:,:) ! [kg/m2/yr] carbon flux of sapwood to litter (above+below) - real(r8), pointer :: ed_litt_ddwd_gd_scpf (:,:) ! [kg/m2/yr] carbon flux of dead wood (above+below) to litter - real(r8), pointer :: ed_r_leaf_gd_scpf (:,:) ! [kg/m2/yr] total leaf respiration - real(r8), pointer :: ed_r_stem_gd_scpf (:,:) ! [kg/m2/yr] total above ground live wood (stem) respiration - real(r8), pointer :: ed_r_root_gd_scpf (:,:) ! [kg/m2/yr] total below ground live wood (root) respiration - real(r8), pointer :: ed_r_stor_gd_scpf (:,:) ! [kg/m2/yr] total storage respiration + real(r8), pointer :: ed_gpp_col_scpf (:,:) ! [kg/m2/yr] gross primary production + real(r8), pointer :: ed_npp_totl_col_scpf (:,:) ! [kg/m2/yr] net primary production (npp) + real(r8), pointer :: ed_npp_leaf_col_scpf (:,:) ! [kg/m2/yr] npp flux into leaf pool + real(r8), pointer :: ed_npp_seed_col_scpf (:,:) ! [kg/m2/yr] npp flux into flower,fruit,nut,seed + real(r8), pointer :: ed_npp_fnrt_col_scpf (:,:) ! [kg/m2/yr] npp flux into fine roots + real(r8), pointer :: ed_npp_bgsw_col_scpf (:,:) ! [kg/m2/yr] npp flux into below ground sapwood + real(r8), pointer :: ed_npp_bgdw_col_scpf (:,:) ! [kg/m2/yr] npp flux into below ground structural (dead) wood + real(r8), pointer :: ed_npp_agsw_col_scpf (:,:) ! [kg/m2/yr] npp flux into above ground sapwood + real(r8), pointer :: ed_npp_agdw_col_scpf (:,:) ! [kg/m2/yr] npp flux into below ground structural (dead) wood + real(r8), pointer :: ed_npp_stor_col_scpf (:,:) ! [kg/m2/yr] npp flux through the storage pool + real(r8), pointer :: ed_litt_leaf_col_scpf (:,:) ! [kg/m2/yr] carbon flux of live leaves to litter + real(r8), pointer :: ed_litt_fnrt_col_scpf (:,:) ! [kg/m2/yr] carbon flux of fine roots to litter + real(r8), pointer :: ed_litt_sawd_col_scpf (:,:) ! [kg/m2/yr] carbon flux of sapwood to litter (above+below) + real(r8), pointer :: ed_litt_ddwd_col_scpf (:,:) ! [kg/m2/yr] carbon flux of dead wood (above+below) to litter + real(r8), pointer :: ed_r_leaf_col_scpf (:,:) ! [kg/m2/yr] total leaf respiration + real(r8), pointer :: ed_r_stem_col_scpf (:,:) ! [kg/m2/yr] total above ground live wood (stem) respiration + real(r8), pointer :: ed_r_root_col_scpf (:,:) ! [kg/m2/yr] total below ground live wood (root) respiration + real(r8), pointer :: ed_r_stor_col_scpf (:,:) ! [kg/m2/yr] total storage respiration ! Carbon State Variables for direct comparison to inventory - dimensions: (disturbance patch, pft x size) - real(r8), pointer :: ed_ddbh_gd_scpf (:,:) ! [cm/yr] diameter increment - real(r8), pointer :: ed_ba_gd_scpf (:,:) ! [m2/ha] basal area - real(r8), pointer :: ed_np_gd_scpf (:,:) ! [/m2] number of plants - real(r8), pointer :: ed_m1_gd_scpf (:,:) ! [Stems/ha/yr] Mean Background Mortality - real(r8), pointer :: ed_m2_gd_scpf (:,:) ! [Stems/ha/yr] Mean Hydraulic Mortaliry - real(r8), pointer :: ed_m3_gd_scpf (:,:) ! [Stems/ha/yr] Mean Carbon Starvation Mortality - real(r8), pointer :: ed_m4_gd_scpf (:,:) ! [Stems/ha/yr] Mean Impact Mortality - real(r8), pointer :: ed_m5_gd_scpf (:,:) ! [Stems/ha/yr] Mean Fire Mortality + real(r8), pointer :: ed_ddbh_col_scpf (:,:) ! [cm/yr] diameter increment + real(r8), pointer :: ed_ba_col_scpf (:,:) ! [m2/ha] basal area + real(r8), pointer :: ed_np_col_scpf (:,:) ! [/m2] number of plants + real(r8), pointer :: ed_m1_col_scpf (:,:) ! [Stems/ha/yr] Mean Background Mortality + real(r8), pointer :: ed_m2_col_scpf (:,:) ! [Stems/ha/yr] Mean Hydraulic Mortaliry + real(r8), pointer :: ed_m3_col_scpf (:,:) ! [Stems/ha/yr] Mean Carbon Starvation Mortality + real(r8), pointer :: ed_m4_col_scpf (:,:) ! [Stems/ha/yr] Mean Impact Mortality + real(r8), pointer :: ed_m5_col_scpf (:,:) ! [Stems/ha/yr] Mean Fire Mortality ! litterfall fluxes of C from ED patches to BGC columns real(r8), pointer, public :: ED_c_to_litr_lab_c_col(:,:) !total labile litter coming from ED. gC/m3/s @@ -228,7 +228,6 @@ subroutine InitAllocate(this, bounds) begp = bounds%begp; endp = bounds%endp begc = bounds%begc; endc = bounds%endc - begg = bounds%begg; endg = bounds%endg allocate(this%trimming_patch (begp:endp)) ; this%trimming_patch (:) = 0.0_r8 @@ -318,34 +317,34 @@ subroutine InitAllocate(this, bounds) allocate(this%ed_npatches_col (begc:endc)) ; this%ed_npatches_col (:) = nan allocate(this%ed_ncohorts_col (begc:endc)) ; this%ed_ncohorts_col (:) = nan - allocate(this%ed_gpp_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)); this%ed_gpp_gd_scpf (:,:) = 0.0_r8 - allocate(this%ed_npp_totl_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)); this%ed_npp_totl_gd_scpf (:,:) = 0.0_r8 - allocate(this%ed_npp_leaf_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)); this%ed_npp_leaf_gd_scpf (:,:) = 0.0_r8 - allocate(this%ed_npp_seed_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)); this%ed_npp_seed_gd_scpf (:,:) = 0.0_r8 - allocate(this%ed_npp_fnrt_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)); this%ed_npp_fnrt_gd_scpf (:,:) = 0.0_r8 - allocate(this%ed_npp_bgsw_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)); this%ed_npp_bgsw_gd_scpf (:,:) = 0.0_r8 - allocate(this%ed_npp_bgdw_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)); this%ed_npp_bgdw_gd_scpf (:,:) = 0.0_r8 - allocate(this%ed_npp_agsw_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)); this%ed_npp_agsw_gd_scpf (:,:) = 0.0_r8 - allocate(this%ed_npp_agdw_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)); this%ed_npp_agdw_gd_scpf (:,:) = 0.0_r8 - allocate(this%ed_npp_stor_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)); this%ed_npp_stor_gd_scpf (:,:) = 0.0_r8 - allocate(this%ed_litt_leaf_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)); this%ed_litt_leaf_gd_scpf (:,:) = 0.0_r8 - allocate(this%ed_litt_fnrt_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)); this%ed_litt_fnrt_gd_scpf (:,:) = 0.0_r8 - allocate(this%ed_litt_sawd_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)); this%ed_litt_sawd_gd_scpf (:,:) = 0.0_r8 - allocate(this%ed_litt_ddwd_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)); this%ed_litt_ddwd_gd_scpf (:,:) = 0.0_r8 - allocate(this%ed_r_leaf_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)); this%ed_r_leaf_gd_scpf (:,:) = 0.0_r8 - allocate(this%ed_r_stem_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)); this%ed_r_stem_gd_scpf (:,:) = 0.0_r8 - allocate(this%ed_r_root_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)); this%ed_r_root_gd_scpf (:,:) = 0.0_r8 - allocate(this%ed_r_stor_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)); this%ed_r_stor_gd_scpf (:,:) = 0.0_r8 + allocate(this%ed_gpp_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_gpp_col_scpf (:,:) = 0.0_r8 + allocate(this%ed_npp_totl_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_npp_totl_col_scpf (:,:) = 0.0_r8 + allocate(this%ed_npp_leaf_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_npp_leaf_col_scpf (:,:) = 0.0_r8 + allocate(this%ed_npp_seed_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_npp_seed_col_scpf (:,:) = 0.0_r8 + allocate(this%ed_npp_fnrt_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_npp_fnrt_col_scpf (:,:) = 0.0_r8 + allocate(this%ed_npp_bgsw_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_npp_bgsw_col_scpf (:,:) = 0.0_r8 + allocate(this%ed_npp_bgdw_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_npp_bgdw_col_scpf (:,:) = 0.0_r8 + allocate(this%ed_npp_agsw_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_npp_agsw_col_scpf (:,:) = 0.0_r8 + allocate(this%ed_npp_agdw_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_npp_agdw_col_scpf (:,:) = 0.0_r8 + allocate(this%ed_npp_stor_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_npp_stor_col_scpf (:,:) = 0.0_r8 + allocate(this%ed_litt_leaf_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_litt_leaf_col_scpf (:,:) = 0.0_r8 + allocate(this%ed_litt_fnrt_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_litt_fnrt_col_scpf (:,:) = 0.0_r8 + allocate(this%ed_litt_sawd_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_litt_sawd_col_scpf (:,:) = 0.0_r8 + allocate(this%ed_litt_ddwd_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_litt_ddwd_col_scpf (:,:) = 0.0_r8 + allocate(this%ed_r_leaf_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_r_leaf_col_scpf (:,:) = 0.0_r8 + allocate(this%ed_r_stem_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_r_stem_col_scpf (:,:) = 0.0_r8 + allocate(this%ed_r_root_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_r_root_col_scpf (:,:) = 0.0_r8 + allocate(this%ed_r_stor_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_r_stor_col_scpf (:,:) = 0.0_r8 ! Carbon State Variables for direct comparison to inventory - dimensions: (disturbance patch, pft x size) - allocate(this%ed_ddbh_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)) ; this%ed_ddbh_gd_scpf (:,:) = 0.0_r8 - allocate(this%ed_ba_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)) ; this%ed_ba_gd_scpf (:,:) = 0.0_r8 - allocate(this%ed_np_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)) ; this%ed_np_gd_scpf (:,:) = 0.0_r8 - allocate(this%ed_m1_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)) ; this%ed_m1_gd_scpf (:,:) = 0.0_r8 - allocate(this%ed_m2_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)) ; this%ed_m2_gd_scpf (:,:) = 0.0_r8 - allocate(this%ed_m3_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)) ; this%ed_m3_gd_scpf (:,:) = 0.0_r8 - allocate(this%ed_m4_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)) ; this%ed_m4_gd_scpf (:,:) = 0.0_r8 - allocate(this%ed_m5_gd_scpf (begg:endg,1:nlevsclass_ed*mxpft)) ; this%ed_m5_gd_scpf (:,:) = 0.0_r8 + allocate(this%ed_ddbh_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)) ; this%ed_ddbh_col_scpf (:,:) = 0.0_r8 + allocate(this%ed_ba_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)) ; this%ed_ba_col_scpf (:,:) = 0.0_r8 + allocate(this%ed_np_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)) ; this%ed_np_col_scpf (:,:) = 0.0_r8 + allocate(this%ed_m1_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)) ; this%ed_m1_col_scpf (:,:) = 0.0_r8 + allocate(this%ed_m2_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)) ; this%ed_m2_col_scpf (:,:) = 0.0_r8 + allocate(this%ed_m3_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)) ; this%ed_m3_col_scpf (:,:) = 0.0_r8 + allocate(this%ed_m4_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)) ; this%ed_m4_col_scpf (:,:) = 0.0_r8 + allocate(this%ed_m5_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)) ; this%ed_m5_col_scpf (:,:) = 0.0_r8 end subroutine InitAllocate @@ -631,73 +630,73 @@ subroutine InitHistory(this, bounds) ! Carbon Flux (grid dimension x scpf) ! ============================================================== - call hist_addfld2d (fname='ED_GPP_GD_SCPF',units='kgC/m2/yr',type2d='levscpf',& + call hist_addfld2d (fname='ED_GPP_COL_SCPF',units='kgC/m2/yr',type2d='levscpf',& avgflag='A', long_name='gross primary production', & - ptr_gcell=this%ed_gpp_gd_scpf,default='inactive') + ptr_gcell=this%ed_gpp_col_scpf,default='inactive') - call hist_addfld2d (fname='ED_NPP_LEAF_GD_SCPF',units='kgC/m2/yr',type2d='levscpf',& + call hist_addfld2d (fname='ED_NPP_LEAF_COL_SCPF',units='kgC/m2/yr',type2d='levscpf',& avgflag='A', long_name='NPP flux into leaves', & - ptr_gcell=this%ed_npp_leaf_gd_scpf,default='inactive') + ptr_gcell=this%ed_npp_leaf_col_scpf,default='inactive') - call hist_addfld2d (fname='ED_NPP_SEED_GD_SCPF',units='kgC/m2/yr',type2d='levscpf',& + call hist_addfld2d (fname='ED_NPP_SEED_COL_SCPF',units='kgC/m2/yr',type2d='levscpf',& avgflag='A', long_name='NPP flux into seeds', & - ptr_gcell=this%ed_npp_seed_gd_scpf,default='inactive') + ptr_gcell=this%ed_npp_seed_col_scpf,default='inactive') - call hist_addfld2d (fname='ED_NPP_FNRT_GD_SCPF',units='kgC/m2/yr',type2d='levscpf',& + call hist_addfld2d (fname='ED_NPP_FNRT_COL_SCPF',units='kgC/m2/yr',type2d='levscpf',& avgflag='A', long_name='NPP flux into fine roots', & - ptr_gcell=this%ed_npp_fnrt_gd_scpf,default='inactive') + ptr_gcell=this%ed_npp_fnrt_col_scpf,default='inactive') - call hist_addfld2d (fname='ED_NPP_BGSW_GD_SCPF',units='kgC/m2/yr',type2d='levscpf',& + call hist_addfld2d (fname='ED_NPP_BGSW_COL_SCPF',units='kgC/m2/yr',type2d='levscpf',& avgflag='A', long_name='NPP flux into below-ground sapwood', & - ptr_gcell=this%ed_npp_bgsw_gd_scpf,default='inactive') + ptr_gcell=this%ed_npp_bgsw_col_scpf,default='inactive') - call hist_addfld2d (fname='ED_NPP_BGDW_GD_SCPF',units='kgC/m2/yr',type2d='levscpf',& + call hist_addfld2d (fname='ED_NPP_BGDW_COL_SCPF',units='kgC/m2/yr',type2d='levscpf',& avgflag='A', long_name='NPP flux into below-ground deadwood', & - ptr_gcell=this%ed_npp_bgdw_gd_scpf,default='inactive') + ptr_gcell=this%ed_npp_bgdw_col_scpf,default='inactive') - call hist_addfld2d (fname='ED_NPP_AGSW_GD_SCPF',units='kgC/m2/yr',type2d='levscpf',& + call hist_addfld2d (fname='ED_NPP_AGSW_COL_SCPF',units='kgC/m2/yr',type2d='levscpf',& avgflag='A', long_name='NPP flux into above-ground sapwood', & - ptr_gcell=this%ed_npp_agsw_gd_scpf,default='inactive') + ptr_gcell=this%ed_npp_agsw_col_scpf,default='inactive') - call hist_addfld2d ( fname = 'ED_NPP_AGDW_GD_SCPF', units='kgC/m2/yr',type2d='levscpf',& + call hist_addfld2d ( fname = 'ED_NPP_AGDW_COL_SCPF', units='kgC/m2/yr',type2d='levscpf',& avgflag='A', long_name='NPP flux into above-ground deadwood', & - ptr_gcell=this%ed_npp_agdw_gd_scpf,default='inactive') + ptr_gcell=this%ed_npp_agdw_col_scpf,default='inactive') - call hist_addfld2d ( fname = 'ED_NPP_STOR_GD_SCPF', units='kgC/m2/yr',type2d='levscpf',& + call hist_addfld2d ( fname = 'ED_NPP_STOR_COL_SCPF', units='kgC/m2/yr',type2d='levscpf',& avgflag='A', long_name='NPP flux into storage', & - ptr_gcell=this%ed_npp_stor_gd_scpf,default='inactive') + ptr_gcell=this%ed_npp_stor_col_scpf,default='inactive') - call hist_addfld2d (fname='ED_DDBH_GD_SCPF', units = 'cm/yr/ha', type2d = 'levscpf', & + call hist_addfld2d (fname='ED_DDBH_COL_SCPF', units = 'cm/yr/ha', type2d = 'levscpf', & avgflag='A', long_name='diameter growth increment and pft/size', & - ptr_gcell=this%ed_ddbh_gd_scpf, default='inactive') + ptr_gcell=this%ed_ddbh_col_scpf, default='inactive') - call hist_addfld2d (fname='ED_BA_GD_SCPF',units = 'm2/ha', type2d = 'levscpf', & + call hist_addfld2d (fname='ED_BA_COL_SCPF',units = 'm2/ha', type2d = 'levscpf', & avgflag='A', long_name='basal area by patch and pft/size', & - ptr_gcell=this%ed_ba_gd_scpf, default='inactive') + ptr_gcell=this%ed_ba_col_scpf, default='inactive') - call hist_addfld2d (fname='ED_NPLANT_GD_SCPF',units = 'N/ha', type2d = 'levscpf', & + call hist_addfld2d (fname='ED_NPLANT_COL_SCPF',units = 'N/ha', type2d = 'levscpf', & avgflag='A', long_name='stem number density by patch and pft/size', & - ptr_gcell=this%ed_np_gd_scpf, default='inactive') + ptr_gcell=this%ed_np_col_scpf, default='inactive') - call hist_addfld2d (fname='ED_M1_GD_SCPF',units = 'N/ha/yr', type2d = 'levscpf', & + call hist_addfld2d (fname='ED_M1_COL_SCPF',units = 'N/ha/yr', type2d = 'levscpf', & avgflag='A', long_name='background mortality count by patch and pft/size', & - ptr_gcell=this%ed_m1_gd_scpf, default='inactive') + ptr_gcell=this%ed_m1_col_scpf, default='inactive') - call hist_addfld2d (fname='ED_M2_GD_SCPF',units = 'N/ha/yr', type2d = 'levscpf', & + call hist_addfld2d (fname='ED_M2_COL_SCPF',units = 'N/ha/yr', type2d = 'levscpf', & avgflag='A', long_name='hydraulic mortality count by patch and pft/size', & - ptr_gcell=this%ed_m2_gd_scpf, default='inactive') + ptr_gcell=this%ed_m2_col_scpf, default='inactive') - call hist_addfld2d (fname='ED_M3_GD_SCPF',units = 'N/ha/yr', type2d = 'levscpf', & + call hist_addfld2d (fname='ED_M3_COL_SCPF',units = 'N/ha/yr', type2d = 'levscpf', & avgflag='A', long_name='carbon starvation mortality count by patch and pft/size', & - ptr_gcell=this%ed_m3_gd_scpf, default='inactive') + ptr_gcell=this%ed_m3_col_scpf, default='inactive') - call hist_addfld2d (fname='ED_M4_GD_SCPF',units = 'N/ha/yr', type2d = 'levscpf', & + call hist_addfld2d (fname='ED_M4_COL_SCPF',units = 'N/ha/yr', type2d = 'levscpf', & avgflag='A', long_name='impact mortality count by patch and pft/size', & - ptr_gcell=this%ed_m4_gd_scpf, default='inactive') + ptr_gcell=this%ed_m4_col_scpf, default='inactive') - call hist_addfld2d (fname='ED_M5_GD_SCPF',units = 'N/ha/yr', type2d = 'levscpf', & + call hist_addfld2d (fname='ED_M5_COL_SCPF',units = 'N/ha/yr', type2d = 'levscpf', & avgflag='A', long_name='fire mortality count by patch and pft/size', & - ptr_gcell=this%ed_m5_gd_scpf, default='inactive') + ptr_gcell=this%ed_m5_col_scpf, default='inactive') this%ed_npatches_col(begc:endc) = spval call hist_addfld1d (fname='ED_NPATCHES', units='unitless', & @@ -949,7 +948,7 @@ subroutine SetValues( this, bounds, val) end subroutine SetValues !----------------------------------------------------------------------- - subroutine ed_clm_link( this, bounds, ed_allsites_inst, ed_phenology_inst, & + subroutine ed_clm_link( this, bounds, sites, nsites, fcolumn, ed_phenology_inst, & waterstate_inst, canopystate_inst) ! ! !USES: @@ -1288,28 +1287,28 @@ subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & phen_cd_status => ed_phenology_inst%phen_cd_status_patch , & ! InOut: - ed_gpp_scpf => this%ed_gpp_gd_scpf , & - ed_npp_totl_scpf => this%ed_npp_totl_gd_scpf , & - ed_npp_leaf_scpf => this%ed_npp_leaf_gd_scpf , & - ed_npp_seed_scpf => this%ed_npp_seed_gd_scpf , & - ed_npp_fnrt_scpf => this%ed_npp_fnrt_gd_scpf , & - ed_npp_bgsw_scpf => this%ed_npp_bgsw_gd_scpf , & - ed_npp_bgdw_scpf => this%ed_npp_bgdw_gd_scpf , & - ed_npp_agsw_scpf => this%ed_npp_agsw_gd_scpf , & - ed_npp_agdw_scpf => this%ed_npp_agdw_gd_scpf , & - ed_npp_stor_scpf => this%ed_npp_stor_gd_scpf , & + ed_gpp_scpf => this%ed_gpp_col_scpf , & + ed_npp_totl_scpf => this%ed_npp_totl_col_scpf , & + ed_npp_leaf_scpf => this%ed_npp_leaf_col_scpf , & + ed_npp_seed_scpf => this%ed_npp_seed_col_scpf , & + ed_npp_fnrt_scpf => this%ed_npp_fnrt_col_scpf , & + ed_npp_bgsw_scpf => this%ed_npp_bgsw_col_scpf , & + ed_npp_bgdw_scpf => this%ed_npp_bgdw_col_scpf , & + ed_npp_agsw_scpf => this%ed_npp_agsw_col_scpf , & + ed_npp_agdw_scpf => this%ed_npp_agdw_col_scpf , & + ed_npp_stor_scpf => this%ed_npp_stor_col_scpf , & ed_npatches => this%ed_npatches_col , & ed_ncohorts => this%ed_ncohorts_col , & - ed_ddbh_gd_scpf => this%ed_ddbh_gd_scpf , & - ed_ba_gd_scpf => this%ed_ba_gd_scpf , & - ed_np_gd_scpf => this%ed_np_gd_scpf , & - ed_m1_gd_scpf => this%ed_m1_gd_scpf , & - ed_m2_gd_scpf => this%ed_m2_gd_scpf , & - ed_m3_gd_scpf => this%ed_m3_gd_scpf , & - ed_m4_gd_scpf => this%ed_m4_gd_scpf , & - ed_m5_gd_scpf => this%ed_m5_gd_scpf , & + ed_ddbh_col_scpf => this%ed_ddbh_col_scpf , & + ed_ba_col_scpf => this%ed_ba_col_scpf , & + ed_np_col_scpf => this%ed_np_col_scpf , & + ed_m1_col_scpf => this%ed_m1_col_scpf , & + ed_m2_col_scpf => this%ed_m2_col_scpf , & + ed_m3_col_scpf => this%ed_m3_col_scpf , & + ed_m4_col_scpf => this%ed_m4_col_scpf , & + ed_m5_col_scpf => this%ed_m5_col_scpf , & tlai => canopystate_inst%tlai_patch , & ! InOut: elai => canopystate_inst%elai_patch , & ! InOut: @@ -1367,14 +1366,14 @@ subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & ed_npp_agdw_scpf(:,:) = 0.0_r8 ed_npp_stor_scpf(:,:) = 0.0_r8 - ed_ddbh_gd_scpf(:,:) = 0.0_r8 - ed_ba_gd_scpf(:,:) = 0.0_r8 - ed_np_gd_scpf(:,:) = 0.0_r8 - ed_m1_gd_scpf(:,:) = 0.0_r8 - ed_m2_gd_scpf(:,:) = 0.0_r8 - ed_m3_gd_scpf(:,:) = 0.0_r8 - ed_m4_gd_scpf(:,:) = 0.0_r8 - ed_m5_gd_scpf(:,:) = 0.0_r8 + ed_ddbh_col_scpf(:,:) = 0.0_r8 + ed_ba_col_scpf(:,:) = 0.0_r8 + ed_np_col_scpf(:,:) = 0.0_r8 + ed_m1_col_scpf(:,:) = 0.0_r8 + ed_m2_col_scpf(:,:) = 0.0_r8 + ed_m3_col_scpf(:,:) = 0.0_r8 + ed_m4_col_scpf(:,:) = 0.0_r8 + ed_m5_col_scpf(:,:) = 0.0_r8 ed_npatches(:) = 0._r8 ed_ncohorts(:) = 0._r8 @@ -1503,25 +1502,25 @@ subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & ! Woody State Variables (basal area and number density and mortality) if (pftcon%woody(ft) == 1) then - ed_m1_gd_scpf(g,scpf) = ed_m1_gd_scpf(g,scpf) + currentcohort%bmort*n_perm2*AREA - ed_m2_gd_scpf(g,scpf) = ed_m2_gd_scpf(g,scpf) + currentcohort%hmort*n_perm2*AREA - ed_m3_gd_scpf(g,scpf) = ed_m3_gd_scpf(g,scpf) + currentcohort%cmort*n_perm2*AREA - ed_m4_gd_scpf(g,scpf) = ed_m4_gd_scpf(g,scpf) + currentcohort%imort*n_perm2*AREA - ed_m5_gd_scpf(g,scpf) = ed_m5_gd_scpf(g,scpf) + currentcohort%fmort*n_perm2*AREA + ed_m1_col_scpf(g,scpf) = ed_m1_col_scpf(g,scpf) + currentcohort%bmort*n_perm2*AREA + ed_m2_col_scpf(g,scpf) = ed_m2_col_scpf(g,scpf) + currentcohort%hmort*n_perm2*AREA + ed_m3_col_scpf(g,scpf) = ed_m3_col_scpf(g,scpf) + currentcohort%cmort*n_perm2*AREA + ed_m4_col_scpf(g,scpf) = ed_m4_col_scpf(g,scpf) + currentcohort%imort*n_perm2*AREA + ed_m5_col_scpf(g,scpf) = ed_m5_col_scpf(g,scpf) + currentcohort%fmort*n_perm2*AREA ! basal area [m2/ha] - ed_ba_gd_scpf(g,scpf) = ed_ba_gd_scpf(g,scpf) + & + ed_ba_col_scpf(g,scpf) = ed_ba_col_scpf(g,scpf) + & 0.25*3.14159*((dbh/100.0)**2.0)*n_perm2*AREA ! number density [/ha] - ed_np_gd_scpf(g,scpf) = ed_np_gd_scpf(g,scpf) + AREA*n_perm2 + ed_np_col_scpf(g,scpf) = ed_np_col_scpf(g,scpf) + AREA*n_perm2 ! Growth Incrments must have NaN check and woody check if(currentCohort%ddbhdt == currentCohort%ddbhdt) then - ed_ddbh_gd_scpf(g,scpf) = ed_ddbh_gd_scpf(g,scpf) + & + ed_ddbh_col_scpf(g,scpf) = ed_ddbh_col_scpf(g,scpf) + & currentCohort%ddbhdt*n_perm2*AREA else - ed_ddbh_gd_scpf(g,scpf) = -999.9 + ed_ddbh_col_scpf(g,scpf) = -999.9 end if end if From f4771aaf7deff6a91d30475639ab499deb82fe2a Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 25 May 2016 19:55:15 -0700 Subject: [PATCH 100/437] first pass changing the clm_ed_link to column indexed. --- main/EDCLMLinkMod.F90 | 87 +++++++++++++++++++++++++------------------ 1 file changed, 50 insertions(+), 37 deletions(-) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 87a34f70..5739084c 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -966,7 +966,9 @@ subroutine ed_clm_link( this, bounds, sites, nsites, fcolumn, waterstate_inst, c ! !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_site_type) , intent(inout), target :: sites(nsites) + integer , intent(in) :: nsites + integer , intent(in) :: fcolumn(nsites) type(waterstate_type) , intent(inout) :: waterstate_inst type(canopystate_type) , intent(inout) :: canopystate_inst ! @@ -1008,36 +1010,37 @@ subroutine ed_clm_link( this, bounds, sites, nsites, fcolumn, waterstate_inst, c ! 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 - +! 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 +! do g = begg,endg +! if(firstsoilpatch(g) >= 0.and.ed_allsites_inst(g)%istheresoil)then +! ed_allsites_inst(g)%clmcolumn = sitecolumn(g) - 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 - do g = begg,endg + do s = 1,nsites - if(firstsoilpatch(g) >= 0.and.ed_allsites_inst(g)%istheresoil)then - ed_allsites_inst(g)%clmcolumn = sitecolumn(g) + c = fcolumn(s) + ! ============================================================================ ! Zero the bare ground tile BGC variables. ! Valid Range for zero'ing here is the soil_patch and non crop patches @@ -1046,8 +1049,8 @@ subroutine ed_clm_link( this, bounds, sites, nsites, fcolumn, waterstate_inst, c ! firstsoilpatch(g) + numpft - numcft ! ============================================================================ - begp_fp = firstsoilpatch(g) - endp_fp = firstsoilpatch(g) + numpft - numcft + begp_fp = col%patchi(c) + endp_fp = col%patchi(c) + numpft - numcft clmpatch%is_veg(begp_fp:endp_fp) = .false. clmpatch%is_bareground(begp_fp:endp_fp) = .false. @@ -1063,16 +1066,23 @@ subroutine ed_clm_link( this, bounds, sites, nsites, fcolumn, waterstate_inst, c total_bare_ground = 0.0_r8 total_patch_area = 0._r8 - currentPatch => ed_allsites_inst(g)%oldest_patch + currentPatch => sites(s)%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... + currentPatch%clm_pno = col%patchi(c) + patchn !the first 'soil' patch is unvegetated... + + ! INTERF-TODO: currentPatch%clm_pno should be removed (FATES internal variable with CLM iformation) + p = currentPatch%clm_pno - c = clmpatch%column(p) + + if(c .ne. clmpatch%column(p))then + ! ERROR AND EXIT() + end if + clmpatch%is_veg(p) = .true. !this .is. a tile filled with vegetation... call currentPatch%set_root_fraction() @@ -1171,36 +1181,39 @@ subroutine ed_clm_link( this, bounds, sites, nsites, fcolumn, waterstate_inst, c ! 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. + ! INTERF-TODO: clmpatch%wt_ed should also be removed, and perhaps replaced with something + ! like clm_fates%xxxx(p) + 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) - + if ( DEBUG ) then write(iulog, *) 'EDCLMLinkMod bare frac', currentPatch%bare_frac_area end if 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 + do p = col%patchi(c)+patchn+1,col%patchi(c)+numpft clmpatch%wt_ed(p) = 0.0_r8 enddo !set the area of the bare ground patch. - p = firstsoilpatch(g) + p = col%patchi(c) clmpatch%wt_ed(p) = total_bare_ground clmpatch%is_bareground = .true. endif ! are there any soil patches? From 9a818c4c128a61d35613c188c04be394fcb44339 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 26 May 2016 18:52:50 -0700 Subject: [PATCH 101/437] working through the lai profile subroutines, adding some checks too. --- main/EDCLMLinkMod.F90 | 460 ++++++++++++++++++++---------------------- 1 file changed, 220 insertions(+), 240 deletions(-) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 5739084c..547ff3e2 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -20,6 +20,7 @@ module EDCLMLinkMod use SoilBiogeochemCarbonStatetype , only : soilbiogeochem_carbonstate_type use clm_time_manager , only : is_beg_curr_day, get_step_size, get_nstep use shr_const_mod, only: SHR_CONST_CDAY + use abortutils , only : endrun ! implicit none @@ -978,13 +979,10 @@ subroutine ed_clm_link( this, bounds, sites, nsites, fcolumn, waterstate_inst, c 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) integer :: begp_fp, endp_fp ! Valid range of patch indices that are associated with ! FATES (F) for each parent (P) iteration (grid/column) !---------------------------------------------------------------------- @@ -1008,225 +1006,196 @@ subroutine ed_clm_link( this, bounds, sites, nsites, fcolumn, waterstate_inst, c 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 -! do g = begg,endg -! if(firstsoilpatch(g) >= 0.and.ed_allsites_inst(g)%istheresoil)then -! ed_allsites_inst(g)%clmcolumn = sitecolumn(g) - do s = 1,nsites - c = fcolumn(s) - ! ============================================================================ - ! Zero the bare ground tile BGC variables. - ! Valid Range for zero'ing here is the soil_patch and non crop patches - ! If the crops are not turned on, don't worry, they were zero'd once and should - ! not change again (RGK). - ! firstsoilpatch(g) + numpft - numcft - ! ============================================================================ + ! ============================================================================ + ! Zero the bare ground tile BGC variables. + ! Valid Range for zero'ing here is the soil_patch and non crop patches + ! If the crops are not turned on, don't worry, they were zero'd once and should + ! not change again (RGK). + ! firstsoilpatch(g) + numpft - numcft + ! ============================================================================ + + begp_fp = col%patchi(c) + endp_fp = col%patchi(c) + numpft - numcft + + clmpatch%is_veg(begp_fp:endp_fp) = .false. + clmpatch%is_bareground(begp_fp:endp_fp) = .false. + + tlai(begp_fp:endp_fp) = 0.0_r8 + htop(begp_fp:endp_fp) = 0.0_r8 + hbot(begp_fp:endp_fp) = 0.0_r8 + elai(begp_fp:endp_fp) = 0.0_r8 + tsai(begp_fp:endp_fp) = 0.0_r8 + esai(begp_fp:endp_fp) = 0.0_r8 + + + patchn = 0 + total_bare_ground = 0.0_r8 + total_patch_area = 0._r8 - begp_fp = col%patchi(c) - endp_fp = col%patchi(c) + numpft - numcft + currentPatch => sites(s)%oldest_patch + do while(associated(currentPatch)) + patchn = patchn + 1 + currentPatch%patchno = patchn - clmpatch%is_veg(begp_fp:endp_fp) = .false. - clmpatch%is_bareground(begp_fp:endp_fp) = .false. - tlai(begp_fp:endp_fp) = 0.0_r8 - htop(begp_fp:endp_fp) = 0.0_r8 - hbot(begp_fp:endp_fp) = 0.0_r8 - elai(begp_fp:endp_fp) = 0.0_r8 - tsai(begp_fp:endp_fp) = 0.0_r8 - esai(begp_fp:endp_fp) = 0.0_r8 - - - patchn = 0 - total_bare_ground = 0.0_r8 - total_patch_area = 0._r8 - - currentPatch => sites(s)%oldest_patch - do while(associated(currentPatch)) - patchn = patchn + 1 - currentPatch%patchno = patchn + if (patchn <= numpft - numcft)then !don't expand into crop patches. - if (patchn <= numpft - numcft)then !don't expand into crop patches. + currentPatch%clm_pno = col%patchi(c) + patchn !the first 'soil' patch is unvegetated... + + ! INTERF-TODO: currentPatch%clm_pno should be removed (FATES internal variable with CLM iformation) + + p = col%patchi(c) + patchn + + if(c .ne. clmpatch%column(p))then + write(iulog,*) ' fcolumn(s) does not match clmpatch%column(p)' + call endrun(msg=errMsg(__FILE__, __LINE__)) + end if - currentPatch%clm_pno = col%patchi(c) + patchn !the first 'soil' patch is unvegetated... + clmpatch%is_veg(p) = .true. !this .is. a tile filled with vegetation... + + call currentPatch%set_root_fraction() - ! INTERF-TODO: currentPatch%clm_pno should be removed (FATES internal variable with CLM iformation) + !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 - p = currentPatch%clm_pno + !update cohort quantitie s + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + + ft = currentCohort%pft + currentCohort%livestemn = currentCohort%bsw / pftcon%leafcn(currentCohort%pft) + + currentCohort%livecrootn = 0.0_r8 - if(c .ne. clmpatch%column(p))then - ! ERROR AND EXIT() + if (pftcon%woody(ft) == 1) then + coarse_wood_frac = 0.5_r8 + else + coarse_wood_frac = 0.0_r8 end if - - 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) - - currentCohort%livecrootn = 0.0_r8 - - if (pftcon%woody(ft) == 1) then - coarse_wood_frac = 0.5_r8 - else - coarse_wood_frac = 0.0_r8 - end if - - if ( DEBUG ) then - write(iulog,*) 'EDCLMLink 618 ',currentCohort%livecrootn - write(iulog,*) 'EDCLMLink 619 ',currentCohort%br - write(iulog,*) 'EDCLMLink 620 ',coarse_wood_frac - write(iulog,*) 'EDCLMLink 621 ',pftcon%leafcn(ft) - endif - - currentCohort%livecrootn = currentCohort%br * coarse_wood_frac / pftcon%leafcn(ft) - - if ( DEBUG ) write(iulog,*) 'EDCLMLink 625 ',currentCohort%livecrootn + if ( DEBUG ) then + write(iulog,*) 'EDCLMLink 618 ',currentCohort%livecrootn + write(iulog,*) 'EDCLMLink 619 ',currentCohort%br + write(iulog,*) 'EDCLMLink 620 ',coarse_wood_frac + write(iulog,*) 'EDCLMLink 621 ',pftcon%leafcn(ft) + endif - 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) + currentCohort%livecrootn = currentCohort%br * coarse_wood_frac / pftcon%leafcn(ft) - 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 + if ( DEBUG ) write(iulog,*) 'EDCLMLink 625 ',currentCohort%livecrootn - ! 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 + 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 - - currentCohort => currentCohort%taller - - enddo ! ends 'do while(associated(currentCohort)) - - if ( currentPatch%total_canopy_area-currentPatch%area > 0.000001_r8 ) then - write(iulog,*) 'ED: 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 + ! 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 - hbot(p) = max(0._r8, min(0.2_r8, htop(p)- 1.0_r8)) + currentCohort => currentCohort%taller + + enddo ! ends 'do while(associated(currentCohort)) - ! 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-currentPatch%area > 0.000001_r8 ) then + write(iulog,*) 'ED: canopy area bigger than area',currentPatch%total_canopy_area ,currentPatch%area + currentPatch%total_canopy_area = currentPatch%area + endif - if(currentPatch%total_canopy_area > 0)then; - tlai(p) = canopy_leaf_area/currentPatch%total_canopy_area - else - tlai(p) = 0.0_r8 - 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 - ! 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. + ! 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. - ! INTERF-TODO: clmpatch%wt_ed should also be removed, and perhaps replaced with something - ! like clm_fates%xxxx(p) - 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) + 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) - if ( DEBUG ) then - write(iulog, *) 'EDCLMLinkMod bare frac', currentPatch%bare_frac_area - end if - 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 + if ( DEBUG ) then + write(iulog, *) 'EDCLMLinkMod bare frac', currentPatch%bare_frac_area + end if + + total_patch_area = total_patch_area + clmpatch%wt_ed(p) + currentPatch%bare_frac_area + total_bare_ground = total_bare_ground + currentPatch%bare_frac_area - else - write(iulog,*) 'ED: too many patches' - end if ! patchn<15 + else + write(iulog,*) 'ED: too many patches' + end if ! patchn<15 - currentPatch => currentPatch%younger - end do !patch loop + 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 + 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 = col%patchi(c)+patchn+1,col%patchi(c)+numpft - clmpatch%wt_ed(p) = 0.0_r8 - enddo - - !set the area of the bare ground patch. - p = col%patchi(c) - 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%flux_into_litter_pools(bounds, ed_allsites_inst(begg:endg), firstsoilpatch, & - canopystate_inst) + ! loop round all and zero the remaining empty vegetation patches + ! while ED's domain of influence only extends to non-crop patches + ! wt_ed should not be non-zero anwhere but ED patches, so this loop is ok + do p = col%patchi(c)+patchn+1,col%patchi(c)+numpft + clmpatch%wt_ed(p) = 0.0_r8 + enddo + + !set the area of the bare ground patch. + p = col%patchi(c) + clmpatch%wt_ed(p) = total_bare_ground + clmpatch%is_bareground = .true. + + call this%ed_clm_leaf_area_profile(sites(s), c, waterstate_inst, canopystate_inst ) + + end do ! column loop - call this%ed_update_history_variables(bounds, ed_allsites_inst(begg:endg), & - firstsoilpatch, canopystate_inst) + call this%flux_into_litter_pools(bounds, sites(:), fcolumns(:), firstsoilpatch, canopystate_inst) + + call this%ed_update_history_variables(bounds, sites(:), fcolumns(:), firstsoilpatch, canopystate_inst) end associate @@ -1586,7 +1555,7 @@ subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & end subroutine ed_update_history_variables !------------------------------------------------------------------------ - subroutine ed_clm_leaf_area_profile( this, currentSite, waterstate_inst, canopystate_inst ) + subroutine ed_clm_leaf_area_profile( this, currentSite, colindex, waterstate_inst, canopystate_inst ) ! ! !DESCRIPTION: ! Load LAI in each layer into array to send to CLM @@ -1602,6 +1571,7 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, waterstate_inst, canopys ! !ARGUMENTS class(ed_clm_type) :: this type(ed_site_type) , intent(inout) :: currentSite + integer , intent(in) :: c ! ALM/CLM column index of this site type(waterstate_type) , intent(inout) :: waterstate_inst type(canopystate_type) , intent(inout) :: canopystate_inst ! @@ -1613,8 +1583,8 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, waterstate_inst, canopys 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 + integer :: p ! clm patch 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 ! @@ -1652,55 +1622,54 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, waterstate_inst, canopys ! 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 = col%patchi(c) ! CLM/ALM equivalent patch + + do while(associated(currentPatch)) + p = p + 1 ! First CLM/ALM patch is non-veg + + !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) - 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 + !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 - ! 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 + + 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. @@ -1721,7 +1690,9 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, waterstate_inst, canopys maxh(iv) = (iv)*dh endif enddo - c = clmpatch%column(currentPatch%clm_pno) + + !c = clmpatch%column(currentPatch%clm_pno) + currentCohort => currentPatch%shortest do while(associated(currentCohort)) ft = currentCohort%pft @@ -1825,7 +1796,16 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, waterstate_inst, canopys if(currentCohort%NV > currentPatch%nrad(L,ft))then write(iulog,*) 'ED: issue with NV',currentCohort%NV,currentCohort%pft,currentCohort%canopy_layer endif - c = clmpatch%column(currentPatch%clm_pno) + + ! c = clmpatch%column(currentPatch%clm_pno) + ! INTERF-TODO: REMOVE THIS AT SOME POINT, THIS SANITY CHECK IS NOT NEEDED WHEN THE + ! COLUMNIZATION IS COMPLETE + if( clmpatch%column(currentPatch%clm_pno) .ne. c .or. currentPatch%clm_pno .ne. p )then + ! ERROR + write(iulog,*) ' clmpatch%column(currentPatch%clm_pno) .ne. c .or. currentPatch%clm_pno .ne. p ' + call endrun(msg=errMsg(__FILE__, __LINE__)) + end if + !Whole layers. Make a weighted average of the leaf area in each layer before dividing it by the total area. !fill up layer for whole layers. FIX(RF,032414)- for debugging jan 2012 From 1750efa47385da965bc82d5ee65482c8e8d371d0 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 27 May 2016 13:57:16 -0700 Subject: [PATCH 102/437] working through litter-flux linking, column migration --- main/EDCLMLinkMod.F90 | 250 ++++++++++++++++++++++-------------------- 1 file changed, 130 insertions(+), 120 deletions(-) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 547ff3e2..89efd344 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -1016,7 +1016,7 @@ subroutine ed_clm_link( this, bounds, sites, nsites, fcolumn, waterstate_inst, c ! Valid Range for zero'ing here is the soil_patch and non crop patches ! If the crops are not turned on, don't worry, they were zero'd once and should ! not change again (RGK). - ! firstsoilpatch(g) + numpft - numcft + ! col%patchi(c) + numpft - numcft ! ============================================================================ begp_fp = col%patchi(c) @@ -1193,9 +1193,9 @@ subroutine ed_clm_link( this, bounds, sites, nsites, fcolumn, waterstate_inst, c end do ! column loop - call this%flux_into_litter_pools(bounds, sites(:), fcolumns(:), firstsoilpatch, canopystate_inst) + call this%flux_into_litter_pools(bounds, sites(:), nsites, fcolumns(:), canopystate_inst) - call this%ed_update_history_variables(bounds, sites(:), fcolumns(:), firstsoilpatch, canopystate_inst) + call this%ed_update_history_variables(bounds, sites(:), nsites, fcolumns(:), canopystate_inst) end associate @@ -1555,6 +1555,11 @@ subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & end subroutine ed_update_history_variables !------------------------------------------------------------------------ + + ! INTERF-TODO: THIS ROUTINE COULD BE SPLIT. IT CALCULATES BOTH FATES/ED INTERNALS + ! AS WELL AS VARIABLES FOR CLM/ALM. + + subroutine ed_clm_leaf_area_profile( this, currentSite, colindex, waterstate_inst, canopystate_inst ) ! ! !DESCRIPTION: @@ -1626,7 +1631,7 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, colindex, waterstate_ins p = col%patchi(c) ! CLM/ALM equivalent patch do while(associated(currentPatch)) - p = p + 1 ! First CLM/ALM patch is non-veg + p = p + 1 ! First CLM/ALM patch is non-veg, increment at loop start !Calculate tree and canopy areas. currentPatch%canopy_area = 0._r8 @@ -1671,7 +1676,7 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, colindex, waterstate_ins enddo !currentCohort currentPatch%nrad = currentPatch%ncan - if(smooth_leaf_distribution == 1)then + 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 @@ -1952,7 +1957,8 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, colindex, waterstate_ins enddo enddo - p = currentPatch%clm_pno + ! This should not had changed +! p = currentPatch%clm_pno if(abs(tlai(p)-tlai_temp) > 0.0001_r8) then write(iulog,*) 'ED: error with tlai calcs',& @@ -2041,14 +2047,12 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, colindex, waterstate_ins enddo !patch - endif !is there soil? - - end associate + end associate end subroutine ed_clm_leaf_area_profile - subroutine flux_into_litter_pools(this, bounds, ed_allsites_inst, firstsoilpatch, canopystate_inst) + subroutine flux_into_litter_pools(this, bounds, sites, nsites, fcolumns, canopystate_inst) ! Created by Charlie Koven and Rosie Fisher, 2014-2015 ! take the flux out of the fragmenting litter pools and port into the decomposing litter pools. ! in this implementation, decomposing pools are assumed to be humus and non-flammable, whereas fragmenting pools @@ -2080,16 +2084,17 @@ subroutine flux_into_litter_pools(this, bounds, ed_allsites_inst, firstsoilpatch ! ! !ARGUMENTS class(ed_clm_type) :: this - type(bounds_type) , intent(in) :: bounds - type(ed_site_type) , intent(inout), target :: ed_allsites_inst( bounds%begg: ) - integer :: firstsoilpatch(bounds%begg:bounds%endg) ! the first patch in this gridcell that is soil and thus bare... + type(bounds_type) , intent(in) :: bounds + type(ed_site_type) , intent(inout), target :: sites(nsites) + integer , intent(in) :: nsites + integer , intent(in) :: fcolumn(nsites) type(canopystate_type) , intent(inout) :: canopystate_inst ! ! !LOCAL VARIABLES: type (ed_patch_type) , pointer :: currentPatch type (ed_cohort_type) , pointer :: currentCohort type(ed_site_type), pointer :: cs - integer c,p,cc,j,g + integer c,p,ci,j,g real(r8) time_convert ! from year to seconds real(r8) mass_convert ! ED uses kg, CLM uses g integer :: begp,endp @@ -2130,6 +2135,7 @@ subroutine flux_into_litter_pools(this, bounds, ed_allsites_inst, firstsoilpatch ! (2) a fine root profile, which is indexed by both column and pft, differs for each pft and also from one column to the next to avoid inputting any C into permafrost ! (3) a coarse root profile, which is the root-biomass=weighted average of the fine root profiles !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + if (use_vertsoilc) then ! define a single shallow surface profile for surface additions (leaves, stems, and N deposition) @@ -2285,119 +2291,123 @@ subroutine flux_into_litter_pools(this, bounds, ed_allsites_inst, firstsoilpatch !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! now disaggregate the inputs vertically, using the vertical profiles !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + do s = 1,nsites + + ! do g = bounds%begg,bounds%endg + ! if (firstsoilpatch(g) >= 0 .and. ed_allsites_inst(g)%istheresoil) then + c = fcolumn(s) + currentPatch => sites(s)%oldest_patch + + do while(associated(currentPatch)) - do g = bounds%begg,bounds%endg - if (firstsoilpatch(g) >= 0 .and. ed_allsites_inst(g)%istheresoil) then - currentPatch => ed_allsites_inst(g)%oldest_patch + ! cs => currentpatch%siteptr + ! cc = cs%clmcolumn - do while(associated(currentPatch)) - - cs => currentpatch%siteptr - cc = cs%clmcolumn - - ! the CWD pools lose information about which PFT they came from; for the stems this doesn't matter as they all have the same profile, - ! however for the coarse roots they may have different profiles. to approximately recover this information, loop over all cohorts in patch - ! to calculate the total root biomass in that patch of each pft, and then rescale the croot_prof as the weighted average of the froot_prof - biomass_bg_ft(1:numpft_ed) = 0._r8 - currentCohort => currentPatch%tallest - do while(associated(currentCohort)) - biomass_bg_ft(currentCohort%pft) = biomass_bg_ft(currentCohort%pft) + currentCohort%b * (currentCohort%n / currentPatch%area) * (1.0_r8-ED_val_ag_biomass) - currentCohort => currentCohort%shorter - enddo !currentCohort - ! - biomass_bg_tot = 0._r8 - do ft = 1,numpft_ed - biomass_bg_tot = biomass_bg_tot + biomass_bg_ft(ft) - end do - ! - do j = 1, nlevdecomp - ! zero this for each patch - croot_prof_perpatch(j) = 0._r8 - end do - ! - if ( biomass_bg_tot .gt. 0._r8) then - do ft = 1,numpft_ed - do j = 1, nlevdecomp - croot_prof_perpatch(j) = croot_prof_perpatch(j) + froot_prof(cc,ft,j) * biomass_bg_ft(ft) / biomass_bg_tot - end do - end do - else ! no biomass - croot_prof_perpatch(1) = 1./dzsoi_decomp(1) - end if - ! - ! add croot_prof as weighted average (weighted by patch area) of croot_prof_perpatch - do j = 1, nlevdecomp - croot_prof(cc, j) = croot_prof(cc, j) + croot_prof_perpatch(j) * currentPatch%area / AREA - end do - ! - ! now disaggregate, vertically and by decomposition substrate type, the actual fluxes from CWD and litter pools - ! - ! do c = 1, ncwd - ! write(iulog,*)'cdk CWD_AG_out', c, currentpatch%CWD_AG_out(c), cwd_fcel_ed, currentpatch%area/AREA - ! write(iulog,*)'cdk CWD_BG_out', c, currentpatch%CWD_BG_out(c), cwd_fcel_ed, currentpatch%area/AREA - ! end do - ! do ft = 1,numpft_ed - ! write(iulog,*)'cdk leaf_litter_out', ft, currentpatch%leaf_litter_out(ft), cwd_fcel_ed, currentpatch%area/AREA - ! write(iulog,*)'cdk root_litter_out', ft, currentpatch%root_litter_out(ft), cwd_fcel_ed, currentpatch%area/AREA - ! end do - ! ! - ! CWD pools fragmenting into decomposing litter pools. - do c = 1, ncwd - do j = 1, nlevdecomp - ED_c_to_litr_cel_c(cc,j) = ED_c_to_litr_cel_c(cc,j) + currentpatch%CWD_AG_out(c) * cwd_fcel_ed * currentpatch%area/AREA * stem_prof(cc,j) - ED_c_to_litr_lig_c(cc,j) = ED_c_to_litr_lig_c(cc,j) + currentpatch%CWD_AG_out(c) * cwd_flig_ed * currentpatch%area/AREA * stem_prof(cc,j) - ! - ED_c_to_litr_cel_c(cc,j) = ED_c_to_litr_cel_c(cc,j) + currentpatch%CWD_BG_out(c) * cwd_fcel_ed * currentpatch%area/AREA * croot_prof_perpatch(j) - ED_c_to_litr_lig_c(cc,j) = ED_c_to_litr_lig_c(cc,j) + currentpatch%CWD_BG_out(c) * cwd_flig_ed * currentpatch%area/AREA * croot_prof_perpatch(j) - end do - end do - - ! leaf and fine root pools. - do ft = 1,numpft_ed - do j = 1, nlevdecomp - ED_c_to_litr_lab_c(cc,j) = ED_c_to_litr_lab_c(cc,j) + currentpatch%leaf_litter_out(ft) * pftcon%lf_flab(ft) * currentpatch%area/AREA * leaf_prof(cc,j) - ED_c_to_litr_cel_c(cc,j) = ED_c_to_litr_cel_c(cc,j) + currentpatch%leaf_litter_out(ft) * pftcon%lf_fcel(ft) * currentpatch%area/AREA * leaf_prof(cc,j) - ED_c_to_litr_lig_c(cc,j) = ED_c_to_litr_lig_c(cc,j) + currentpatch%leaf_litter_out(ft) * pftcon%lf_flig(ft) * currentpatch%area/AREA * leaf_prof(cc,j) - ! - ED_c_to_litr_lab_c(cc,j) = ED_c_to_litr_lab_c(cc,j) + currentpatch%root_litter_out(ft) * pftcon%fr_flab(ft) * currentpatch%area/AREA * froot_prof(cc,ft,j) - ED_c_to_litr_cel_c(cc,j) = ED_c_to_litr_cel_c(cc,j) + currentpatch%root_litter_out(ft) * pftcon%fr_fcel(ft) * currentpatch%area/AREA * froot_prof(cc,ft,j) - ED_c_to_litr_lig_c(cc,j) = ED_c_to_litr_lig_c(cc,j) + currentpatch%root_litter_out(ft) * pftcon%fr_flig(ft) * currentpatch%area/AREA * froot_prof(cc,ft,j) - ! - !! and seed_decay too. for now, use the same lability fractions as for leaf litter - ED_c_to_litr_lab_c(cc,j) = ED_c_to_litr_lab_c(cc,j) + currentpatch%seed_decay(ft) * pftcon%lf_flab(ft) * currentpatch%area/AREA * leaf_prof(cc,j) - ED_c_to_litr_cel_c(cc,j) = ED_c_to_litr_cel_c(cc,j) + currentpatch%seed_decay(ft) * pftcon%lf_fcel(ft) * currentpatch%area/AREA * leaf_prof(cc,j) - ED_c_to_litr_lig_c(cc,j) = ED_c_to_litr_lig_c(cc,j) + currentpatch%seed_decay(ft) * pftcon%lf_flig(ft) * currentpatch%area/AREA * leaf_prof(cc,j) - ! - enddo - end do + ! the CWD pools lose information about which PFT they came from; for the stems this doesn't matter as they all have the same profile, + ! however for the coarse roots they may have different profiles. to approximately recover this information, loop over all cohorts in patch + ! to calculate the total root biomass in that patch of each pft, and then rescale the croot_prof as the weighted average of the froot_prof + biomass_bg_ft(1:numpft_ed) = 0._r8 + currentCohort => currentPatch%tallest + do while(associated(currentCohort)) + biomass_bg_ft(currentCohort%pft) = biomass_bg_ft(currentCohort%pft) + currentCohort%b * (currentCohort%n / currentPatch%area) * (1.0_r8-ED_val_ag_biomass) + currentCohort => currentCohort%shorter + enddo !currentCohort + ! + biomass_bg_tot = 0._r8 + do ft = 1,numpft_ed + biomass_bg_tot = biomass_bg_tot + biomass_bg_ft(ft) + end do + ! + do j = 1, nlevdecomp + ! zero this for each patch + croot_prof_perpatch(j) = 0._r8 + end do + ! + if ( biomass_bg_tot .gt. 0._r8) then + do ft = 1,numpft_ed + do j = 1, nlevdecomp + croot_prof_perpatch(j) = croot_prof_perpatch(j) + froot_prof(c,ft,j) * biomass_bg_ft(ft) / biomass_bg_tot + end do + end do + else ! no biomass + croot_prof_perpatch(1) = 1./dzsoi_decomp(1) + end if + + ! + ! add croot_prof as weighted average (weighted by patch area) of croot_prof_perpatch + do j = 1, nlevdecomp + croot_prof(c, j) = croot_prof(c, j) + croot_prof_perpatch(j) * currentPatch%area / AREA + end do + ! + ! now disaggregate, vertically and by decomposition substrate type, the actual fluxes from CWD and litter pools + ! + ! do c = 1, ncwd + ! write(iulog,*)'cdk CWD_AG_out', c, currentpatch%CWD_AG_out(c), cwd_fcel_ed, currentpatch%area/AREA + ! write(iulog,*)'cdk CWD_BG_out', c, currentpatch%CWD_BG_out(c), cwd_fcel_ed, currentpatch%area/AREA + ! end do + ! do ft = 1,numpft_ed + ! write(iulog,*)'cdk leaf_litter_out', ft, currentpatch%leaf_litter_out(ft), cwd_fcel_ed, currentpatch%area/AREA + ! write(iulog,*)'cdk root_litter_out', ft, currentpatch%root_litter_out(ft), cwd_fcel_ed, currentpatch%area/AREA + ! end do + ! ! + ! CWD pools fragmenting into decomposing litter pools. + do ci = 1, ncwd + do j = 1, nlevdecomp + ED_c_to_litr_cel_c(c,j) = ED_c_to_litr_cel_c(c,j) + currentpatch%CWD_AG_out(ci) * cwd_fcel_ed * currentpatch%area/AREA * stem_prof(c,j) + ED_c_to_litr_lig_c(c,j) = ED_c_to_litr_lig_c(c,j) + currentpatch%CWD_AG_out(ci) * cwd_flig_ed * currentpatch%area/AREA * stem_prof(c,j) + ! + ED_c_to_litr_cel_c(c,j) = ED_c_to_litr_cel_c(c,j) + currentpatch%CWD_BG_out(ci) * cwd_fcel_ed * currentpatch%area/AREA * croot_prof_perpatch(j) + ED_c_to_litr_lig_c(c,j) = ED_c_to_litr_lig_c(c,j) + currentpatch%CWD_BG_out(ci) * cwd_flig_ed * currentpatch%area/AREA * croot_prof_perpatch(j) + end do + end do + + ! leaf and fine root pools. + do ft = 1,numpft_ed + do j = 1, nlevdecomp + ED_c_to_litr_lab_c(c,j) = ED_c_to_litr_lab_c(c,j) + currentpatch%leaf_litter_out(ft) * pftcon%lf_flab(ft) * currentpatch%area/AREA * leaf_prof(c,j) + ED_c_to_litr_cel_c(c,j) = ED_c_to_litr_cel_c(c,j) + currentpatch%leaf_litter_out(ft) * pftcon%lf_fcel(ft) * currentpatch%area/AREA * leaf_prof(c,j) + ED_c_to_litr_lig_c(c,j) = ED_c_to_litr_lig_c(c,j) + currentpatch%leaf_litter_out(ft) * pftcon%lf_flig(ft) * currentpatch%area/AREA * leaf_prof(c,j) + ! + ED_c_to_litr_lab_c(c,j) = ED_c_to_litr_lab_c(c,j) + currentpatch%root_litter_out(ft) * pftcon%fr_flab(ft) * currentpatch%area/AREA * froot_prof(c,ft,j) + ED_c_to_litr_cel_c(c,j) = ED_c_to_litr_cel_c(c,j) + currentpatch%root_litter_out(ft) * pftcon%fr_fcel(ft) * currentpatch%area/AREA * froot_prof(c,ft,j) + ED_c_to_litr_lig_c(c,j) = ED_c_to_litr_lig_c(c,j) + currentpatch%root_litter_out(ft) * pftcon%fr_flig(ft) * currentpatch%area/AREA * froot_prof(c,ft,j) + ! + !! and seed_decay too. for now, use the same lability fractions as for leaf litter + ED_c_to_litr_lab_c(c,j) = ED_c_to_litr_lab_c(c,j) + currentpatch%seed_decay(ft) * pftcon%lf_flab(ft) * currentpatch%area/AREA * leaf_prof(c,j) + ED_c_to_litr_cel_c(c,j) = ED_c_to_litr_cel_c(c,j) + currentpatch%seed_decay(ft) * pftcon%lf_fcel(ft) * currentpatch%area/AREA * leaf_prof(c,j) + ED_c_to_litr_lig_c(c,j) = ED_c_to_litr_lig_c(c,j) + currentpatch%seed_decay(ft) * pftcon%lf_flig(ft) * currentpatch%area/AREA * leaf_prof(c,j) + ! + enddo + end do currentPatch => currentPatch%younger end do !currentPatch - end if - end do + + end do - do cc = bounds%begc,bounds%endc - do j = 1, nlevdecomp - ! time unit conversion - ED_c_to_litr_lab_c(cc,j)=ED_c_to_litr_lab_c(cc,j) * mass_convert / time_convert - ED_c_to_litr_cel_c(cc,j)=ED_c_to_litr_cel_c(cc,j) * mass_convert / time_convert - ED_c_to_litr_lig_c(cc,j)=ED_c_to_litr_lig_c(cc,j) * mass_convert / time_convert - + do c = bounds%begc,bounds%endc + do j = 1, nlevdecomp + ! time unit conversion + ED_c_to_litr_lab_c(c,j)=ED_c_to_litr_lab_c(c,j) * mass_convert / time_convert + ED_c_to_litr_cel_c(c,j)=ED_c_to_litr_cel_c(c,j) * mass_convert / time_convert + ED_c_to_litr_lig_c(c,j)=ED_c_to_litr_lig_c(c,j) * mass_convert / time_convert + + end do end do - end do - - ! write(iulog,*)'cdk ED_c_to_litr_lab_c: ', ED_c_to_litr_lab_c - ! write(iulog,*)'cdk ED_c_to_litr_cel_c: ', ED_c_to_litr_cel_c - ! write(iulog,*)'cdk ED_c_to_litr_lig_c: ', ED_c_to_litr_lig_c - ! write(iulog,*)'cdk nlevdecomp_full, bounds%begc, bounds%endc: ', nlevdecomp_full, bounds%begc, bounds%endc - ! write(iulog,*)'cdk leaf_prof: ', leaf_prof - ! write(iulog,*)'cdk stem_prof: ', stem_prof - ! write(iulog,*)'cdk froot_prof: ', froot_prof - ! write(iulog,*)'cdk croot_prof_perpatch: ', croot_prof_perpatch - ! write(iulog,*)'cdk croot_prof: ', croot_prof - - end associate - end subroutine flux_into_litter_pools + + ! write(iulog,*)'cdk ED_c_to_litr_lab_c: ', ED_c_to_litr_lab_c + ! write(iulog,*)'cdk ED_c_to_litr_cel_c: ', ED_c_to_litr_cel_c + ! write(iulog,*)'cdk ED_c_to_litr_lig_c: ', ED_c_to_litr_lig_c + ! write(iulog,*)'cdk nlevdecomp_full, bounds%begc, bounds%endc: ', nlevdecomp_full, bounds%begc, bounds%endc + ! write(iulog,*)'cdk leaf_prof: ', leaf_prof + ! write(iulog,*)'cdk stem_prof: ', stem_prof + ! write(iulog,*)'cdk froot_prof: ', froot_prof + ! write(iulog,*)'cdk croot_prof_perpatch: ', croot_prof_perpatch + ! write(iulog,*)'cdk croot_prof: ', croot_prof + + end associate + end subroutine flux_into_litter_pools !------------------------------------------------------------------------ subroutine SummarizeProductivityFluxes(this, bounds, ed_allsites_inst) From 5afc8812ce70fa0821a0ce23035e6542a13f6fcc Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 27 May 2016 15:52:58 -0700 Subject: [PATCH 103/437] finished first pass through EDCLMLinkMod --- main/EDCLMLinkMod.F90 | 584 +++++++++++++++++++++--------------------- 1 file changed, 290 insertions(+), 294 deletions(-) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 89efd344..2dde2fa5 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -963,7 +963,7 @@ subroutine ed_clm_link( this, bounds, sites, nsites, fcolumn, waterstate_inst, c 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 @@ -1193,16 +1193,16 @@ subroutine ed_clm_link( this, bounds, sites, nsites, fcolumn, waterstate_inst, c end do ! column loop - call this%flux_into_litter_pools(bounds, sites(:), nsites, fcolumns(:), canopystate_inst) + call this%flux_into_litter_pools(bounds, sites(:), nsites, fcolumn(:), canopystate_inst) - call this%ed_update_history_variables(bounds, sites(:), nsites, fcolumns(:), canopystate_inst) + call this%ed_update_history_variables(bounds, sites(:), nsites, fcolumn(:), canopystate_inst) end associate end subroutine ed_clm_link !----------------------------------------------------------------------- - subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & + subroutine ed_update_history_variables( this, bounds, sites, nsites, fcolumn, firstsoilpatch, canopystate_inst) ! ! !USES: @@ -1213,14 +1213,16 @@ subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & ! !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_site_type) , intent(inout), target :: sites(nsites) + integer , intent(in) :: nsites + integer , intent(in) :: fcolumn(nsites) type(ed_patch_type) , pointer :: currentPatch type(ed_cohort_type) , pointer :: currentCohort type(canopystate_type) , intent(inout) :: canopystate_inst ! ! !LOCAL VARIABLES: - integer :: G,p,ft,c - integer :: firstsoilpatch(bounds%begg:bounds%endg) + integer :: p,ft,c +! integer :: firstsoilpatch(bounds%begg:bounds%endg) real(r8) :: n_density ! individual of cohort per m2. real(r8) :: n_perm2 ! individuals per m2 for the whole column real(r8) :: patch_scaling_scalar ! ratio of canopy to patch area for counteracting patch scaling @@ -1353,206 +1355,215 @@ subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & ed_npatches(:) = 0._r8 ed_ncohorts(:) = 0._r8 - 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 - 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 - - c = ed_allsites_inst(g)%clmcolumn - - 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 - - ed_npatches(c) = ed_npatches(c) + 1._r8 - - currentCohort => currentPatch%shortest - do while(associated(currentCohort)) - !accumulate into history variables. - ft = currentCohort%pft - - ed_ncohorts(c) = ed_ncohorts(c) + 1._r8 - - if ((currentPatch%area .gt. 0._r8) .and. (currentPatch%total_canopy_area .gt. 0._r8)) then - - ! for quantities that are at the CLM patch level, because of the way that CLM patches are weighted for radiative purposes - ! this # density needs to be over either ED patch canopy area or ED patch total area, whichever is less - n_density = currentCohort%n/min(currentPatch%area,currentPatch%total_canopy_area) - - ! for quantities that are natively at column level, calculate plant density using whole area - n_perm2 = currentCohort%n/AREA - - else - n_density = 0.0_r8 - n_perm2 = 0.0_r8 - endif + do s = 1,nsites - if ( DEBUG ) then - write(iulog,*) 'EDCLMLinkMod I ',currentCohort%bstore - write(iulog,*) 'EDCLMLinkMod II ',p,ED_bstore(p) - endif + c = fcolumn(s) - ED_bleaf(p) = ED_bleaf(p) + n_density * currentCohort%bl * 1.e3_r8 - ED_bstore(p) = ED_bstore(p) + n_density * currentCohort%bstore * 1.e3_r8 - ED_biomass(p) = ED_biomass(p) + n_density * currentCohort%b * 1.e3_r8 - ED_bdead(p) = ED_bdead(p) + n_density * currentCohort%bdead * 1.e3_r8 - ED_balive(p) = ED_balive(p) + n_density * currentCohort%balive * 1.e3_r8 - PFTbiomass(p,ft) = PFTbiomass(p,ft) + n_density * currentCohort%b * 1.e3_r8 - PFTleafbiomass(p,ft) = PFTleafbiomass(p,ft) + n_density * currentCohort%bl * 1.e3_r8 - PFTstorebiomass(p,ft) = PFTstorebiomass(p,ft) + n_density * currentCohort%bstore * 1.e3_r8 - PFTnindivs(p,ft) = PFTnindivs(p,ft) + currentCohort%n - - dbh = currentCohort%dbh !-0.5*(1./365.25)*currentCohort%ddbhdt - sc = count(dbh-sclass_ed.ge.0.0) - scpf = (ft-1)*nlevsclass_ed+sc - - ! Flux Variables (must pass a NaN check on growth increment and not be recruits) - if( .not.(currentCohort%isnew) ) then - ed_gpp_scpf(g,scpf) = ed_gpp_scpf(g,scpf) + n_perm2*currentCohort%gpp ! [kgC/m2/yr] - ed_npp_totl_scpf(g,scpf) = ed_npp_totl_scpf(g,scpf) + currentcohort%npp*n_perm2 - ed_npp_leaf_scpf(g,scpf) = ed_npp_leaf_scpf(g,scpf) + currentcohort%npp_leaf*n_perm2 - ed_npp_fnrt_scpf(g,scpf) = ed_npp_fnrt_scpf(g,scpf) + currentcohort%npp_froot*n_perm2 - ed_npp_bgsw_scpf(g,scpf) = ed_npp_bgsw_scpf(g,scpf) + currentcohort%npp_bsw*(1._r8-ED_val_ag_biomass)*n_perm2 - ed_npp_agsw_scpf(g,scpf) = ed_npp_agsw_scpf(g,scpf) + currentcohort%npp_bsw*ED_val_ag_biomass*n_perm2 - ed_npp_bgdw_scpf(g,scpf) = ed_npp_bgdw_scpf(g,scpf) + currentcohort%npp_bdead*(1._r8-ED_val_ag_biomass)*n_perm2 - ed_npp_agdw_scpf(g,scpf) = ed_npp_agdw_scpf(g,scpf) + currentcohort%npp_bdead*ED_val_ag_biomass*n_perm2 - ed_npp_seed_scpf(g,scpf) = ed_npp_seed_scpf(g,scpf) + currentcohort%npp_bseed*n_perm2 - ed_npp_stor_scpf(g,scpf) = ed_npp_stor_scpf(g,scpf) + currentcohort%npp_store*n_perm2 - if( abs(currentcohort%npp-(currentcohort%npp_leaf+currentcohort%npp_froot+ & - currentcohort%npp_bsw+currentcohort%npp_bdead+ & - currentcohort%npp_bseed+currentcohort%npp_store))>1.e-9) then - write(iulog,*) 'NPP Partitions are not balancing' - write(iulog,*) 'Fractional Error: ',abs(currentcohort%npp-(currentcohort%npp_leaf+currentcohort%npp_froot+ & - currentcohort%npp_bsw+currentcohort%npp_bdead+ & - currentcohort%npp_bseed+currentcohort%npp_store))/currentcohort%npp - write(iulog,*) 'Terms: ',currentcohort%npp,currentcohort%npp_leaf,currentcohort%npp_froot, & - currentcohort%npp_bsw,currentcohort%npp_bdead, & - currentcohort%npp_bseed,currentcohort%npp_store - stop - end if - ! Woody State Variables (basal area and number density and mortality) - if (pftcon%woody(ft) == 1) then - - ed_m1_col_scpf(g,scpf) = ed_m1_col_scpf(g,scpf) + currentcohort%bmort*n_perm2*AREA - ed_m2_col_scpf(g,scpf) = ed_m2_col_scpf(g,scpf) + currentcohort%hmort*n_perm2*AREA - ed_m3_col_scpf(g,scpf) = ed_m3_col_scpf(g,scpf) + currentcohort%cmort*n_perm2*AREA - ed_m4_col_scpf(g,scpf) = ed_m4_col_scpf(g,scpf) + currentcohort%imort*n_perm2*AREA - ed_m5_col_scpf(g,scpf) = ed_m5_col_scpf(g,scpf) + currentcohort%fmort*n_perm2*AREA - - ! basal area [m2/ha] - ed_ba_col_scpf(g,scpf) = ed_ba_col_scpf(g,scpf) + & - 0.25*3.14159*((dbh/100.0)**2.0)*n_perm2*AREA - - ! number density [/ha] - ed_np_col_scpf(g,scpf) = ed_np_col_scpf(g,scpf) + AREA*n_perm2 - - ! Growth Incrments must have NaN check and woody check - if(currentCohort%ddbhdt == currentCohort%ddbhdt) then - ed_ddbh_col_scpf(g,scpf) = ed_ddbh_col_scpf(g,scpf) + & - currentCohort%ddbhdt*n_perm2*AREA - else - ed_ddbh_col_scpf(g,scpf) = -999.9 - end if - end if + ! ============================================================================ + ! Zero the bare ground tile BGC variables. + ! ============================================================================ + + p = col%patchi(c) + + ! INTERF-TODO: THIS ZERO'ING IS REDUNDANT, THE WHOLE PATCH CLUMP IS ALREADY ZERO'D + + trimming(p) = 1.0_r8 + canopy_spread(p) = 0.0_r8 + PFTbiomass(p,:) = 0.0_r8 + PFTleafbiomass(p,:) = 0.0_r8 + PFTstorebiomass(p,:) = 0.0_r8 + PFTnindivs(p,:) = 0.0_r8 + area_plant(p) = 0.0_r8 + area_trees(p) = 0.0_r8 + nesterov_fire_danger(p) = 0.0_r8 + spitfire_ROS(p) = 0.0_r8 + TFC_ROS(p) = 0.0_r8 + effect_wspeed(p) = 0.0_r8 + fire_intensity(p) = 0.0_r8 + fire_area(p) = 0.0_r8 + scorch_height(p) = 0.0_r8 + fire_fuel_bulkd(p) = 0.0_r8 + fire_fuel_eff_moist(p) = 0.0_r8 + fire_fuel_sav(p) = 0.0_r8 + fire_fuel_mef(p) = 0.0_r8 + litter_in(p) = 0.0_r8 + litter_out(p) = 0.0_r8 + seed_bank(p) = 0.0_r8 + seeds_in(p) = 0.0_r8 + seed_decay(p) = 0.0_r8 + seed_germination(p) = 0.0_r8 + ED_biomass(p) = 0.0_r8 + ED_balive(p) = 0.0_r8 + ED_bdead(p) = 0.0_r8 + ED_bstore(p) = 0.0_r8 + ED_bleaf(p) = 0.0_r8 + elai(p) = 0.0_r8 + tlai(p) = 0.0_r8 + tsai(p) = 0.0_r8 + esai(p) = 0.0_r8 + ED_bleaf(p) = 0.0_r8 + sum_fuel(p) = 0.0_r8 - end if + currentPatch => sites(s)%oldest_patch + do while(associated(currentPatch)) - currentCohort => currentCohort%taller - enddo ! cohort loop + ! INTERF-TODO: THIS LOGIC SHOULDN'T BE NECESSARY, SHOULD BE CHECKED AT THE BEGINNING + ! OF LINKING, ONCE - !Patch specific variables that are already calculated + ! %patchno is the local index of the ED/FATES patches, starting at 1 + if(currentPatch%patchno <= numpft - numcft)then !don't expand into crop patches. - !These things are all duplicated. Should they all be converted to LL or array structures RF? + ! Increment CLM/ALM patch index, first was non-veg, these are veg + p = p + 1 + + ed_npatches(c) = ed_npatches(c) + 1._r8 + + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + !accumulate into history variables. + ft = currentCohort%pft - ! define scalar to counteract the patch albedo scaling logic for conserved quantities - if (currentPatch%area .gt. 0._r8) then - patch_scaling_scalar = min(1._r8, currentPatch%area / currentPatch%total_canopy_area) + ed_ncohorts(c) = ed_ncohorts(c) + 1._r8 + + if ((currentPatch%area .gt. 0._r8) .and. (currentPatch%total_canopy_area .gt. 0._r8)) then + + ! for quantities that are at the CLM patch level, because of the way that CLM patches are weighted for radiative purposes + ! this # density needs to be over either ED patch canopy area or ED patch total area, whichever is less + n_density = currentCohort%n/min(currentPatch%area,currentPatch%total_canopy_area) + + ! for quantities that are natively at column level, calculate plant density using whole area + n_perm2 = currentCohort%n/AREA + else - patch_scaling_scalar = 0._r8 + n_density = 0.0_r8 + n_perm2 = 0.0_r8 endif - 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 * 1.e3_r8 * patch_scaling_scalar - litter_in(p) = (sum(currentPatch%CWD_AG_in) +sum(currentPatch%leaf_litter_in)) * 1.e3_r8 * 365.0_r8 * SHR_CONST_CDAY * patch_scaling_scalar - litter_out(p) = (sum(currentPatch%CWD_AG_out)+sum(currentPatch%leaf_litter_out)) * 1.e3_r8 * 365.0_r8 * SHR_CONST_CDAY * patch_scaling_scalar - seed_bank(p) = sum(currentPatch%seed_bank) * 1.e3_r8 * patch_scaling_scalar - seeds_in(p) = sum(currentPatch%seeds_in) * 1.e3_r8 * 365.0_r8 * SHR_CONST_CDAY * patch_scaling_scalar - seed_decay(p) = sum(currentPatch%seed_decay) * 1.e3_r8 * 365.0_r8 * SHR_CONST_CDAY * patch_scaling_scalar - seed_germination(p) = sum(currentPatch%seed_germination) * 1.e3_r8 * 365.0_r8 * SHR_CONST_CDAY * patch_scaling_scalar - canopy_spread(p) = currentPatch%spread(1) - area_plant(p) = 1._r8 - area_trees(p) = currentPatch%total_tree_area / min(currentPatch%total_canopy_area,currentPatch%area) - if(associated(currentPatch%tallest))then - trimming(p) = currentPatch%tallest%canopy_trim - else - trimming(p) = 0.0_r8 + if ( DEBUG ) then + write(iulog,*) 'EDCLMLinkMod I ',currentCohort%bstore + write(iulog,*) 'EDCLMLinkMod II ',p,ED_bstore(p) endif + ED_bleaf(p) = ED_bleaf(p) + n_density * currentCohort%bl * 1.e3_r8 + ED_bstore(p) = ED_bstore(p) + n_density * currentCohort%bstore * 1.e3_r8 + ED_biomass(p) = ED_biomass(p) + n_density * currentCohort%b * 1.e3_r8 + ED_bdead(p) = ED_bdead(p) + n_density * currentCohort%bdead * 1.e3_r8 + ED_balive(p) = ED_balive(p) + n_density * currentCohort%balive * 1.e3_r8 + PFTbiomass(p,ft) = PFTbiomass(p,ft) + n_density * currentCohort%b * 1.e3_r8 + PFTleafbiomass(p,ft) = PFTleafbiomass(p,ft) + n_density * currentCohort%bl * 1.e3_r8 + PFTstorebiomass(p,ft) = PFTstorebiomass(p,ft) + n_density * currentCohort%bstore * 1.e3_r8 + PFTnindivs(p,ft) = PFTnindivs(p,ft) + currentCohort%n + + dbh = currentCohort%dbh !-0.5*(1./365.25)*currentCohort%ddbhdt + sc = count(dbh-sclass_ed.ge.0.0) + scpf = (ft-1)*nlevsclass_ed+sc + + ! Flux Variables (must pass a NaN check on growth increment and not be recruits) + if( .not.(currentCohort%isnew) ) then + ed_gpp_scpf(c,scpf) = ed_gpp_scpf(c,scpf) + n_perm2*currentCohort%gpp ! [kgC/m2/yr] + ed_npp_totl_scpf(c,scpf) = ed_npp_totl_scpf(c,scpf) + currentcohort%npp*n_perm2 + ed_npp_leaf_scpf(c,scpf) = ed_npp_leaf_scpf(c,scpf) + currentcohort%npp_leaf*n_perm2 + ed_npp_fnrt_scpf(c,scpf) = ed_npp_fnrt_scpf(c,scpf) + currentcohort%npp_froot*n_perm2 + ed_npp_bgsw_scpf(c,scpf) = ed_npp_bgsw_scpf(c,scpf) + currentcohort%npp_bsw*(1._r8-ED_val_ag_biomass)*n_perm2 + ed_npp_agsw_scpf(c,scpf) = ed_npp_agsw_scpf(c,scpf) + currentcohort%npp_bsw*ED_val_ag_biomass*n_perm2 + ed_npp_bgdw_scpf(c,scpf) = ed_npp_bgdw_scpf(c,scpf) + currentcohort%npp_bdead*(1._r8-ED_val_ag_biomass)*n_perm2 + ed_npp_agdw_scpf(c,scpf) = ed_npp_agdw_scpf(c,scpf) + currentcohort%npp_bdead*ED_val_ag_biomass*n_perm2 + ed_npp_seed_scpf(c,scpf) = ed_npp_seed_scpf(c,scpf) + currentcohort%npp_bseed*n_perm2 + ed_npp_stor_scpf(c,scpf) = ed_npp_stor_scpf(c,scpf) + currentcohort%npp_store*n_perm2 + if( abs(currentcohort%npp-(currentcohort%npp_leaf+currentcohort%npp_froot+ & + currentcohort%npp_bsw+currentcohort%npp_bdead+ & + currentcohort%npp_bseed+currentcohort%npp_store))>1.e-9) then + write(iulog,*) 'NPP Partitions are not balancing' + write(iulog,*) 'Fractional Error: ',abs(currentcohort%npp-(currentcohort%npp_leaf+currentcohort%npp_froot+ & + currentcohort%npp_bsw+currentcohort%npp_bdead+ & + currentcohort%npp_bseed+currentcohort%npp_store))/currentcohort%npp + write(iulog,*) 'Terms: ',currentcohort%npp,currentcohort%npp_leaf,currentcohort%npp_froot, & + currentcohort%npp_bsw,currentcohort%npp_bdead, & + currentcohort%npp_bseed,currentcohort%npp_store + write(iulog,*) ' NPP components during FATES-HLM linking does not balance ' + call endrun(msg=errMsg(__FILE__, __LINE__)) + end if + + ! Woody State Variables (basal area and number density and mortality) + if (pftcon%woody(ft) == 1) then + + ed_m1_col_scpf(c,scpf) = ed_m1_col_scpf(c,scpf) + currentcohort%bmort*n_perm2*AREA + ed_m2_col_scpf(c,scpf) = ed_m2_col_scpf(c,scpf) + currentcohort%hmort*n_perm2*AREA + ed_m3_col_scpf(c,scpf) = ed_m3_col_scpf(c,scpf) + currentcohort%cmort*n_perm2*AREA + ed_m4_col_scpf(c,scpf) = ed_m4_col_scpf(c,scpf) + currentcohort%imort*n_perm2*AREA + ed_m5_col_scpf(c,scpf) = ed_m5_col_scpf(c,scpf) + currentcohort%fmort*n_perm2*AREA + + ! basal area [m2/ha] + ed_ba_col_scpf(c,scpf) = ed_ba_col_scpf(c,scpf) + & + 0.25*3.14159*((dbh/100.0)**2.0)*n_perm2*AREA + + ! number density [/ha] + ed_np_col_scpf(c,scpf) = ed_np_col_scpf(c,scpf) + AREA*n_perm2 + + ! Growth Incrments must have NaN check and woody check + if(currentCohort%ddbhdt == currentCohort%ddbhdt) then + ed_ddbh_col_scpf(c,scpf) = ed_ddbh_col_scpf(c,scpf) + & + currentCohort%ddbhdt*n_perm2*AREA + else + ed_ddbh_col_scpf(c,scpf) = -999.9 + end if + end if + + end if + + 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? + + ! define scalar to counteract the patch albedo scaling logic for conserved quantities + if (currentPatch%area .gt. 0._r8) then + patch_scaling_scalar = min(1._r8, currentPatch%area / currentPatch%total_canopy_area) else - write(iulog,*) 'ED: too many patches' - end if ! patchn<15 + patch_scaling_scalar = 0._r8 + endif - currentPatch => currentPatch%younger - end do !patch loop + 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 * 1.e3_r8 * patch_scaling_scalar + litter_in(p) = (sum(currentPatch%CWD_AG_in) +sum(currentPatch%leaf_litter_in)) * 1.e3_r8 * 365.0_r8 * SHR_CONST_CDAY * patch_scaling_scalar + litter_out(p) = (sum(currentPatch%CWD_AG_out)+sum(currentPatch%leaf_litter_out)) * 1.e3_r8 * 365.0_r8 * SHR_CONST_CDAY * patch_scaling_scalar + seed_bank(p) = sum(currentPatch%seed_bank) * 1.e3_r8 * patch_scaling_scalar + seeds_in(p) = sum(currentPatch%seeds_in) * 1.e3_r8 * 365.0_r8 * SHR_CONST_CDAY * patch_scaling_scalar + seed_decay(p) = sum(currentPatch%seed_decay) * 1.e3_r8 * 365.0_r8 * SHR_CONST_CDAY * patch_scaling_scalar + seed_germination(p) = sum(currentPatch%seed_germination) * 1.e3_r8 * 365.0_r8 * SHR_CONST_CDAY * patch_scaling_scalar + canopy_spread(p) = currentPatch%spread(1) + area_plant(p) = 1._r8 + area_trees(p) = currentPatch%total_tree_area / min(currentPatch%total_canopy_area,currentPatch%area) + 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 + enddo ! site loop end associate - end subroutine ed_update_history_variables + end subroutine ed_update_history_variables !------------------------------------------------------------------------ @@ -2052,7 +2063,7 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, colindex, waterstate_ins end subroutine ed_clm_leaf_area_profile - subroutine flux_into_litter_pools(this, bounds, sites, nsites, fcolumns, canopystate_inst) + subroutine flux_into_litter_pools(this, bounds, sites, nsites, fcolumn, canopystate_inst) ! Created by Charlie Koven and Rosie Fisher, 2014-2015 ! take the flux out of the fragmenting litter pools and port into the decomposing litter pools. ! in this implementation, decomposing pools are assumed to be humus and non-flammable, whereas fragmenting pools @@ -2384,7 +2395,7 @@ subroutine flux_into_litter_pools(this, bounds, sites, nsites, fcolumns, canopys currentPatch => currentPatch%younger end do !currentPatch - end do + end do ! do sites(s) do c = bounds%begc,bounds%endc do j = 1, nlevdecomp @@ -2410,7 +2421,7 @@ subroutine flux_into_litter_pools(this, bounds, sites, nsites, fcolumns, canopys end subroutine flux_into_litter_pools !------------------------------------------------------------------------ - subroutine SummarizeProductivityFluxes(this, bounds, ed_allsites_inst) + subroutine SummarizeProductivityFluxes(this, bounds, sites, nsites) ! Summarize the fast production inputs from fluxes per ED individual to fluxes per CLM patch and column ! Must be called between calculation of productivity fluxes and daily ED calls @@ -2429,11 +2440,12 @@ subroutine SummarizeProductivityFluxes(this, bounds, ed_allsites_inst) ! !ARGUMENTS class(ed_clm_type) :: this type(bounds_type) , intent(in) :: bounds - type(ed_site_type) , intent(in), target :: ed_allsites_inst( bounds%begg: ) + type(ed_site_type) , intent(in), target :: sites(nsites) + integer , intent(in) :: nsites ! ! !LOCAL VARIABLES: real(r8) :: dt ! radiation time step (seconds) - integer :: c, g, cc, fc, l, p, pp + integer :: c, fc, l, p type (ed_patch_type) , pointer :: currentPatch type (ed_cohort_type) , pointer :: currentCohort integer :: firstsoilpatch(bounds%begg:bounds%endg) ! the first patch in this gridcell that is soil and thus bare... @@ -2470,72 +2482,65 @@ subroutine SummarizeProductivityFluxes(this, bounds, ed_allsites_inst) ! retrieve the first soil patch associated with each gridcell. ! make sure we only get the first patch value for places which have soil. - firstsoilpatch(bounds%begg:bounds%endg) = -999 - do c = bounds%begc,bounds%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) - endif - enddo - - do g = bounds%begg,bounds%endg - if (firstsoilpatch(g) >= 0 .and. ed_allsites_inst(g)%istheresoil) then - cc = ed_allsites_inst(g)%clmcolumn - - currentPatch => ed_allsites_inst(g)%oldest_patch - do while(associated(currentPatch)) - - pp = currentPatch%clm_pno - currentCohort => currentPatch%tallest - do while(associated(currentCohort)) - - if ((currentPatch%area .gt. 0._r8) .and. (currentPatch%total_canopy_area .gt. 0._r8)) then - - ! for quantities that are at the CLM patch level, because of the way that CLM patches are weighted for radiative purposes - ! this # density needs to be over either ED patch canopy area or ED patch total area, whichever is less - n_density = currentCohort%n/min(currentPatch%area,currentPatch%total_canopy_area) - - ! for quantities that are natively at column level or higher, calculate plant density using whole area (for grid cell averages) - n_perm2 = currentCohort%n/AREA - - else - n_density = 0.0_r8 - n_perm2 = 0.0_r8 - endif + do s = 1,nsites + + c = fcolumn(s) + p = col%patchi(c) + + currentPatch => sites(s)%oldest_patch + do while(associated(currentPatch)) + + p = p + 1 + + currentCohort => currentPatch%tallest + do while(associated(currentCohort)) + + if ((currentPatch%area .gt. 0._r8) .and. (currentPatch%total_canopy_area .gt. 0._r8)) then - if ( .not. currentCohort%isnew ) then - - ! map ed cohort-level fluxes to clm patch fluxes - npp(pp) = npp(pp) + currentCohort%npp_clm * 1.e3_r8 * n_density / dt - gpp(pp) = gpp(pp) + currentCohort%gpp_clm * 1.e3_r8 * n_density / dt - ar(pp) = ar(pp) + currentCohort%resp_clm * 1.e3_r8 * n_density / dt - growth_resp(pp) = growth_resp(pp) + currentCohort%resp_g * 1.e3_r8 * n_density / dt - maint_resp(pp) = maint_resp(pp) + currentCohort%resp_m * 1.e3_r8 * n_density / dt - - ! map ed cohort-level npp fluxes to clm column fluxes - npp_col(cc) = npp_col(cc) + currentCohort%npp_clm * n_perm2 * 1.e3_r8 /dt - - endif + ! for quantities that are at the CLM patch level, because of the way that CLM patches are weighted for radiative purposes + ! this # density needs to be over either ED patch canopy area or ED patch total area, whichever is less + n_density = currentCohort%n/min(currentPatch%area,currentPatch%total_canopy_area) - currentCohort => currentCohort%shorter - enddo !currentCohort - currentPatch => currentPatch%younger - end do !currentPatch - end if - end do - + ! for quantities that are natively at column level or higher, calculate plant density using whole area (for grid cell averages) + n_perm2 = currentCohort%n/AREA + + else + n_density = 0.0_r8 + n_perm2 = 0.0_r8 + endif + + if ( .not. currentCohort%isnew ) then + + ! map ed cohort-level fluxes to clm patch fluxes + npp(p) = npp(p) + currentCohort%npp_clm * 1.e3_r8 * n_density / dt + gpp(p) = gpp(p) + currentCohort%gpp_clm * 1.e3_r8 * n_density / dt + ar(p) = ar(pp) + currentCohort%resp_clm * 1.e3_r8 * n_density / dt + growth_resp(p) = growth_resp(p) + currentCohort%resp_g * 1.e3_r8 * n_density / dt + maint_resp(p) = maint_resp(p) + currentCohort%resp_m * 1.e3_r8 * n_density / dt + + ! map ed cohort-level npp fluxes to clm column fluxes + npp_col(c) = npp_col(c) + currentCohort%npp_clm * n_perm2 * 1.e3_r8 /dt + + endif + + currentCohort => currentCohort%shorter + enddo !currentCohort + currentPatch => currentPatch%younger + end do !currentPatch + + end do ! site loop + ! leaving this as a comment here. it should produce same answer for npp_col as above, ! so it may be useful to try as a check to make sure machinery is working proerly !call p2c(bounds,num_soilc, filter_soilc, npp(bounds%begp:bounds%endp), npp_col(bounds%begc:bounds%endc)) - + end associate - end subroutine SummarizeProductivityFluxes +end subroutine SummarizeProductivityFluxes !------------------------------------------------------------------------ subroutine SummarizeNetFluxes(this, bounds, num_soilc, filter_soilc, & - ed_allsites_inst, soilbiogeochem_carbonflux_inst, & + sites, nsites, fcolumn, soilbiogeochem_carbonflux_inst, & soilbiogeochem_carbonstate_inst) ! Summarize the combined production and decomposition fluxes into net fluxes @@ -2556,7 +2561,9 @@ subroutine SummarizeNetFluxes(this, bounds, num_soilc, filter_soilc, & type(bounds_type) , intent(in) :: bounds integer , intent(in) :: num_soilc ! number of soil columns in filter integer , intent(in) :: filter_soilc(:) ! filter for soil columns - type(ed_site_type) , intent(in), target :: ed_allsites_inst( bounds%begg: ) + type(ed_site_type) , intent(in), target :: sites(nsites) + integer , intent(in) :: nsites + integer , intent(in) :: fcolumn(nsites) type(soilbiogeochem_carbonflux_type) , intent(inout) :: soilbiogeochem_carbonflux_inst type(soilbiogeochem_carbonstate_type) , intent(inout) :: soilbiogeochem_carbonstate_inst ! @@ -2566,7 +2573,7 @@ subroutine SummarizeNetFluxes(this, bounds, num_soilc, filter_soilc, & type(ed_site_type), pointer :: cs type (ed_patch_type) , pointer :: currentPatch type (ed_cohort_type) , pointer :: currentCohort - integer :: firstsoilpatch(bounds%begg:bounds%endg) ! the first patch in this gridcell that is soil and thus bare... +! integer :: firstsoilpatch(bounds%begg:bounds%endg) ! the first patch in this gridcell that is soil and thus bare... real(r8) :: n_perm2 ! individuals per m2 of the whole column associate(& @@ -2597,7 +2604,7 @@ subroutine SummarizeNetFluxes(this, bounds, num_soilc, filter_soilc, & do c = bounds%begc,bounds%endc ! summary flux variables fire_c_to_atm(c) = 0._r8 - + ! summary stock variables ed_litter_stock(c) = 0._r8 cwd_stock(c) = 0._r8 @@ -2605,54 +2612,43 @@ subroutine SummarizeNetFluxes(this, bounds, num_soilc, filter_soilc, & biomass_stock(c) = 0._r8 end do - ! retrieve the first soil patch associated with each gridcell. - ! make sure we only get the first patch value for places which have soil. - firstsoilpatch(bounds%begg:bounds%endg) = -999 - do c = bounds%begc,bounds%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) - endif - enddo - - do g = bounds%begg,bounds%endg - if (firstsoilpatch(g) >= 0 .and. ed_allsites_inst(g)%istheresoil) then - cc = ed_allsites_inst(g)%clmcolumn + do s = 1, nsites - ! map ed site-level fire fluxes to clm column fluxes - fire_c_to_atm(cc) = ed_allsites_inst(g)%total_burn_flux_to_atm / ( AREA * SHR_CONST_CDAY * 1.e3_r8) + c = fcolumn(s) + p = col%patchi(c) - currentPatch => ed_allsites_inst(g)%oldest_patch - do while(associated(currentPatch)) + ! map ed site-level fire fluxes to clm column fluxes + fire_c_to_atm(c) = sites(s)%total_burn_flux_to_atm / ( AREA * SHR_CONST_CDAY * 1.e3_r8) - pp = currentPatch%clm_pno + currentPatch => sites(s)%oldest_patch + do while(associated(currentPatch)) - ! map litter, CWD, and seed pools to column level - cwd_stock(cc) = cwd_stock(cc) + (currentPatch%area / AREA) * (sum(currentPatch%cwd_ag)+ & - sum(currentPatch%cwd_bg)) * 1.e3_r8 - ed_litter_stock(cc) = ed_litter_stock(cc) + (currentPatch%area / AREA) * & - (sum(currentPatch%leaf_litter)+sum(currentPatch%root_litter)) * 1.e3_r8 - seed_stock(cc) = seed_stock(cc) + (currentPatch%area / AREA) * sum(currentPatch%seed_bank) * 1.e3_r8 + p = p + 1 - currentCohort => currentPatch%tallest - do while(associated(currentCohort)) - - ! for quantities that are natively at column level or higher, calculate plant density using whole area (for grid cell averages) - n_perm2 = currentCohort%n/AREA + ! map litter, CWD, and seed pools to column level + cwd_stock(c) = cwd_stock(c) + (currentPatch%area / AREA) * (sum(currentPatch%cwd_ag)+ & + sum(currentPatch%cwd_bg)) * 1.e3_r8 + ed_litter_stock(c) = ed_litter_stock(c) + (currentPatch%area / AREA) * & + (sum(currentPatch%leaf_litter)+sum(currentPatch%root_litter)) * 1.e3_r8 + seed_stock(c) = seed_stock(c) + (currentPatch%area / AREA) * sum(currentPatch%seed_bank) * 1.e3_r8 + + currentCohort => currentPatch%tallest + do while(associated(currentCohort)) - ! map biomass pools to column level - biomass_stock(cc) = biomass_stock(cc) + (currentCohort%bdead + currentCohort%balive + & - currentCohort%bstore) * n_perm2 * 1.e3_r8 + ! for quantities that are natively at column level or higher, calculate plant density using whole area (for grid cell averages) + n_perm2 = currentCohort%n/AREA + + ! map biomass pools to column level + biomass_stock(c) = biomass_stock(c) + (currentCohort%bdead + currentCohort%balive + & + currentCohort%bstore) * n_perm2 * 1.e3_r8 - currentCohort => currentCohort%shorter - enddo !currentCohort - currentPatch => currentPatch%younger - end do !currentPatch - end if - end do + currentCohort => currentCohort%shorter + enddo !currentCohort + currentPatch => currentPatch%younger + end do ! patch loop + end do ! site loop - ! calculate NEP and NBP fluxes. + ! calculate NEP and NBP fluxes. ????? do fc = 1,num_soilc c = filter_soilc(fc) nep(c) = npp_col(c) - hr(c) @@ -2849,7 +2845,7 @@ subroutine ED_BGC_Carbon_Balancecheck(this, bounds, num_soilc, filter_soilc, soi hr_timeintegrated(c) = 0._r8 end do - endif + endif end associate From 20a40a1acabc0116362b12f8668c0b315ea8cf95 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 27 May 2016 17:10:55 -0700 Subject: [PATCH 104/437] finished pass on EDCLMLinkMod, finished pass on EDBGCDynMod, working on EDAlbedoMod --- biogeophys/EDSurfaceAlbedoMod.F90 | 8 +++++--- main/EDTypesMod.F90 | 4 +++- 2 files changed, 8 insertions(+), 4 deletions(-) diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index a979bf00..b485aa70 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -33,7 +33,7 @@ module EDSurfaceRadiationMod subroutine ED_Norman_Radiation (bounds, & filter_vegsol, num_vegsol, filter_nourbanp, num_nourbanp, & - coszen, ed_allsites_inst, surfalb_inst) + coszen, sites, nsites, fcolumn, surfalb_inst) ! ! !DESCRIPTION: ! Two-stream fluxes for canopy radiative transfer @@ -62,7 +62,9 @@ subroutine ED_Norman_Radiation (bounds, & 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(ed_site_type) , intent(inout), target :: sites(nsites) ! FATES site vector + integer , intent(in) :: nsites + integer , intent(in) :: fcolumn(nsites) type(surfalb_type) , intent(inout) :: surfalb_inst ! ! !LOCAL VARIABLES: @@ -70,7 +72,7 @@ subroutine ED_Norman_Radiation (bounds, & ! ED/NORMAN RADIATION DECS ! ============================================================================ type (ed_patch_type) , pointer :: currentPatch - integer :: radtype, L, ft, g ,j + integer :: radtype, L, ft, j integer :: iter ! Iteration index integer :: irep ! Flag to exit iteration loop real(r8) :: sb diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 611bdd90..50f8d553 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -233,7 +233,9 @@ module EDTypesMod !INDICES integer :: patchno ! unique number given to each new patch created for tracking -! integer :: clm_pno ! clm patch number (index of p vector) + + ! INTERF-TODO: THIS VARIABLE SHOULD BE REMOVED + integer :: clm_pno ! clm patch number (index of p vector) ! PATCH INFO real(r8) :: age ! average patch age: years From 8c60f9ac3e696cd921d75089db78851de8035370 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 30 May 2016 13:59:19 -0700 Subject: [PATCH 105/437] columnization on some patch routines. --- biogeochem/EDCohortDynamicsMod.F90 | 46 ++++++++++++++-------------- biogeochem/EDPatchDynamicsMod.F90 | 20 ++++++------ biogeophys/EDSurfaceAlbedoMod.F90 | 28 +++++++++-------- main/EDCLMLinkMod.F90 | 49 ++++++++++++++---------------- 4 files changed, 70 insertions(+), 73 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 0443de25..c6967878 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -1137,46 +1137,46 @@ function count_cohorts( currentPatch ) result ( backcount ) end function count_cohorts !-------------------------------------------------------------------------------------! - function countCohorts( bounds, ed_allsites_inst ) result ( totNumCohorts ) +! 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 +! use decompMod, only : bounds_type ! ! !ARGUMENTS - type(bounds_type) , intent(in) :: bounds - type(ed_site_type) , intent(inout), target :: ed_allsites_inst( bounds%begg: ) +! 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 +! type (ed_patch_type) , pointer :: currentPatch +! type (ed_cohort_type) , pointer :: currentCohort +! integer :: g, totNumCohorts +! logical :: error !---------------------------------------------------------------------- - totNumCohorts = 0 +! totNumCohorts = 0 - do g = bounds%begg,bounds%endg +! do g = bounds%begg,bounds%endg - if (ed_allsites_inst(g)%istheresoil) then +! if (ed_allsites_inst(g)%istheresoil) then - currentPatch => ed_allsites_inst(g)%oldest_patch - do while(associated(currentPatch)) +! 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 +! 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 if +! end do - end function countCohorts +! end function countCohorts end module EDCohortDynamicsMod diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index d95607ac..29a00bb4 100755 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -1427,7 +1427,7 @@ subroutine patch_pft_size_profile(cp_pnt) end subroutine patch_pft_size_profile ! ============================================================================ - function countPatches( bounds, ed_allsites_inst ) result ( totNumPatches ) + function countPatches( bounds, sites, nsites ) result ( totNumPatches ) ! ! !DESCRIPTION: ! Loop over all Patches to count how many there are @@ -1439,24 +1439,22 @@ function countPatches( bounds, ed_allsites_inst ) result ( totNumPatches ) ! ! !ARGUMENTS: type(bounds_type) , intent(in) :: bounds - type(ed_site_type) , intent(inout), target :: ed_allsites_inst( bounds%begg: ) + type(ed_site_type) , intent(inout), target :: sites(nsites) + integer, intent(in) :: nsites ! ! !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 + do s = 1,nsites + currentPatch => sites(s)%oldest_patch + do while(associated(currentPatch)) + totNumPatches = totNumPatches + 1 + currentPatch => currentPatch%younger + enddo enddo end function countPatches diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index b485aa70..4008dca3 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -33,7 +33,7 @@ module EDSurfaceRadiationMod subroutine ED_Norman_Radiation (bounds, & filter_vegsol, num_vegsol, filter_nourbanp, num_nourbanp, & - coszen, sites, nsites, fcolumn, surfalb_inst) + coszen, sites, nsites, fcolumn, hsites, surfalb_inst) ! ! !DESCRIPTION: ! Two-stream fluxes for canopy radiative transfer @@ -56,16 +56,17 @@ subroutine ED_Norman_Radiation (bounds, & 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(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 :: sites(nsites) ! FATES site vector integer , intent(in) :: nsites integer , intent(in) :: fcolumn(nsites) - type(surfalb_type) , intent(inout) :: surfalb_inst + integer , intent(in) :: hsites(bounds_clump%begc:bounds_clump%endc) + type(surfalb_type) , intent(inout) :: surfalb_inst ! ! !LOCAL VARIABLES: ! ============================================================================ @@ -158,8 +159,9 @@ subroutine ED_Norman_Radiation (bounds, & 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) + c = patch%column(p) + s = hsites(c) + currentPatch => map_clmpatch_to_edpatch(sites(s), p) currentPatch%f_sun (:,:,:) = 0._r8 currentPatch%fabd_sun_z (:,:,:) = 0._r8 currentPatch%fabd_sha_z (:,:,:) = 0._r8 @@ -179,7 +181,6 @@ subroutine ED_Norman_Radiation (bounds, & 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 @@ -203,7 +204,10 @@ subroutine ED_Norman_Radiation (bounds, & if (patch%is_veg(p)) then ! We have vegetation... - currentPatch => map_clmpatch_to_edpatch(ed_allsites_inst(g), p) + + ! INTERF-TODO: + s = hsites(c) + currentPatch => map_clmpatch_to_edpatch(sites(s), p) if (associated(currentPatch))then !zero all of the matrices used here to reduce potential for errors. diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 2dde2fa5..facde802 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -1525,7 +1525,7 @@ subroutine ed_update_history_variables( this, bounds, sites, nsites, fcolumn, patch_scaling_scalar = 0._r8 endif - nesterov_fire_danger(p) = ed_allsites_inst(g)%acc_NI + nesterov_fire_danger(p) = sites(s)%acc_NI spitfire_ROS(p) = currentPatch%ROS_front TFC_ROS(p) = currentPatch%TFC_ROS effect_wspeed(p) = currentPatch%effect_wspeed @@ -2670,36 +2670,31 @@ subroutine SummarizeNetFluxes(this, bounds, num_soilc, filter_soilc, & ! calculate the total ED -> BGC flux and keep track of the last day's info for balance checking purposes if ( is_beg_curr_day() ) then ! - do g = bounds%begg,bounds%endg - if (firstsoilpatch(g) >= 0 .and. ed_allsites_inst(g)%istheresoil) then - cc = ed_allsites_inst(g)%clmcolumn - ed_to_bgc_last_edts(cc) = ed_to_bgc_this_edts(cc) - endif + do s = 1,nsites + c = fcolumn(s) + ed_to_bgc_last_edts(c) = ed_to_bgc_this_edts(c) end do ! - do g = bounds%begg,bounds%endg - if (firstsoilpatch(g) >= 0 .and. ed_allsites_inst(g)%istheresoil) then - cc = ed_allsites_inst(g)%clmcolumn - ed_to_bgc_this_edts(cc) = 0._r8 - seed_rain_flux(cc) = 0._r8 - endif + do s = 1,nsites + c = fcolumn(s) + ed_to_bgc_this_edts(c) = 0._r8 + seed_rain_flux(c) = 0._r8 end do ! - do g = bounds%begg,bounds%endg - if (firstsoilpatch(g) >= 0 .and. ed_allsites_inst(g)%istheresoil) then - cc = ed_allsites_inst(g)%clmcolumn - currentPatch => ed_allsites_inst(g)%oldest_patch - do while(associated(currentPatch)) - ! - ed_to_bgc_this_edts(cc) = ed_to_bgc_this_edts(cc) + (sum(currentPatch%CWD_AG_out) + sum(currentPatch%CWD_BG_out) + & - + sum(currentPatch%seed_decay) + sum(currentPatch%leaf_litter_out) + sum(currentPatch%root_litter_out)) & - * ( currentPatch%area/AREA ) * 1.e3_r8 / ( 365.0_r8*SHR_CONST_CDAY ) - ! - seed_rain_flux(cc) = seed_rain_flux(cc) + sum(currentPatch%seed_rain_flux) * 1.e3_r8 / ( 365.0_r8*SHR_CONST_CDAY ) - ! - currentPatch => currentPatch%younger - end do !currentPatch - end if + do s = 1,nsites + c = fcolumn(s) + + currentPatch => sites(s)%oldest_patch + do while(associated(currentPatch)) + ! + ed_to_bgc_this_edts(c) = ed_to_bgc_this_edts(c) + (sum(currentPatch%CWD_AG_out) + sum(currentPatch%CWD_BG_out) + & + + sum(currentPatch%seed_decay) + sum(currentPatch%leaf_litter_out) + sum(currentPatch%root_litter_out)) & + * ( currentPatch%area/AREA ) * 1.e3_r8 / ( 365.0_r8*SHR_CONST_CDAY ) + ! + seed_rain_flux(c) = seed_rain_flux(c) + sum(currentPatch%seed_rain_flux) * 1.e3_r8 / ( 365.0_r8*SHR_CONST_CDAY ) + ! + currentPatch => currentPatch%younger + end do !currentPatch end do endif From 0a64b45b3ec3e1b4c2f23a637d1c5c1eac51d778 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 31 May 2016 15:27:16 -0700 Subject: [PATCH 106/437] completed first pass of code for columnization. WOrking through compiler errors --- biogeochem/EDCohortDynamicsMod.F90 | 2 +- biogeochem/EDPatchDynamicsMod.F90 | 7 +-- biogeochem/EDPhysiologyMod.F90 | 21 +++++--- biogeophys/EDAccumulateFluxesMod.F90 | 16 ++++-- biogeophys/EDBtranMod.F90 | 13 +++-- biogeophys/EDPhotosynthesisMod.F90 | 18 ++++--- biogeophys/EDSurfaceAlbedoMod.F90 | 10 ++-- fire/SFMainMod.F90 | 13 ++++- main/EDCLMLinkMod.F90 | 69 ++++++++++++------------- main/EDInitMod.F90 | 75 ++++------------------------ main/EDMainMod.F90 | 39 +++++++-------- main/EDRestVectorMod.F90 | 7 ++- main/EDTypesMod.F90 | 2 +- main/FatesInterfaceMod.F90 | 2 +- 14 files changed, 130 insertions(+), 164 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index c6967878..beb2d106 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -27,7 +27,7 @@ module EDCohortDynamicsMod public :: sort_cohorts public :: copy_cohort public :: count_cohorts - public :: countCohorts +! public :: countCohorts public :: allocate_live_biomass logical, parameter :: DEBUG = .false. ! local debug flag diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 29a00bb4..edea8544 100755 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -9,7 +9,7 @@ module EDPatchDynamicsMod 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, numPatchesPerGridCell + use EDtypesMod , only : ncwd, n_dbh_bins, ntol, numpft_ed, area, dbhmax, numPatchesPerCol use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type, udata use EDTypesMod , only : min_patch_area ! @@ -1014,7 +1014,7 @@ subroutine fuse_patches( csite ) !--------------------------------------------------------------------- !maxpatch = 4 - maxpatch = numPatchesPerGridCell + maxpatch = numPatchesPerCol currentSite => csite @@ -1353,7 +1353,7 @@ subroutine terminate_patches(cs_pnt) 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 + write(iulog,*) 'ED: areatot too large. end terminate', areatot endif enddo @@ -1445,6 +1445,7 @@ function countPatches( bounds, sites, nsites ) result ( totNumPatches ) ! !LOCAL VARIABLES: type (ed_patch_type), pointer :: currentPatch integer :: totNumPatches ! total number of patches. + integer :: s !--------------------------------------------------------------------- totNumPatches = 0 diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index e0e3a730..c5aff001 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -247,6 +247,7 @@ subroutine phenology( currentSite, temperature_inst, waterstate_inst) use clm_time_manager, only : get_days_per_year, get_curr_date use clm_time_manager, only : get_ref_date, timemgr_datediff use EDTypesMod, only : udata + use PatchType , only : patch ! ! !ARGUMENTS: type(ed_site_type) , intent(inout), target :: currentSite @@ -255,7 +256,6 @@ subroutine phenology( currentSite, temperature_inst, waterstate_inst) ! ! !LOCAL VARIABLES: real(r8), pointer :: t_veg24(:) - 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 @@ -268,6 +268,8 @@ subroutine phenology( currentSite, temperature_inst, waterstate_inst) integer :: mon ! month (1, ..., 12) integer :: day ! day of month (1, ..., 31) integer :: sec ! seconds of the day + integer :: patchi ! the first CLM/ALM patch index of the associated column + integer :: coli ! the CLM/ALM column index of the associated site real(r8) :: gdd_threshold real(r8) :: a,b,c ! params of leaf-pn model from botta et al. 2000. @@ -283,10 +285,13 @@ subroutine phenology( currentSite, temperature_inst, waterstate_inst) !------------------------------------------------------------------------ - t_veg24 => temperature_inst%t_veg24_patch ! Input: [real(r8) (:)] avg pft vegetation temperature for last 24 hrs + ! INTERF-TODO: THIS IS A BAND-AID, AS I WAS HOPING TO REMOVE CLM_PNO + ! ALREADY REMOVED currentSite%clmcolumn, hence the need for these - g = currentSite%clmgcell + patchi = currentSite%oldest_patch%clm_pno-1 + coli = patch%column(patchi) + t_veg24 => temperature_inst%t_veg24_patch ! Input: [real(r8) (:)] avg pft vegetation temperature for last 24 hrs call get_curr_date(yr, mon, day, sec) curdate = yr*10000 + mon*100 + day @@ -315,7 +320,7 @@ subroutine phenology( currentSite, temperature_inst, waterstate_inst) cold_t = 7.5_r8 ! ed_ph_coldtemp t = udata%time_period - temp_in_C = t_veg24(currentSite%oldest_patch%clm_pno-1) - tfrz + temp_in_C = t_veg24(patchi) - tfrz !-----------------Cold Phenology--------------------! @@ -359,7 +364,7 @@ subroutine phenology( currentSite, temperature_inst, waterstate_inst) endif ! ! accumulate the GDD using daily mean temperatures - if (t_veg24(currentSite%oldest_patch%clm_pno-1) .gt. tfrz) then + if (t_veg24(patchi) .gt. tfrz) then currentSite%ED_GDD_site = currentSite%ED_GDD_site + t_veg24(currentSite%oldest_patch%clm_pno-1) - tfrz endif @@ -437,7 +442,7 @@ subroutine phenology( currentSite, temperature_inst, waterstate_inst) ! distinction actually matter??).... !Accumulate surface water memory of last 10 days. - currentSite%water_memory(1) = waterstate_inst%h2osoi_vol_col(currentSite%clmcolumn,1) + currentSite%water_memory(1) = waterstate_inst%h2osoi_vol_col(coli,1) do i = 1,9 !shift memory along one currentSite%water_memory(11-i) = currentSite%water_memory(10-i) enddo @@ -1140,6 +1145,7 @@ subroutine fragmentation_scaler( currentPatch, temperature_inst ) ! !USES: use shr_const_mod , only : SHR_CONST_PI, SHR_CONST_TKFRZ use EDSharedParamsMod , only : EDParamsShareInst + use PatchType , only : patch ! ! !ARGUMENTS type(ed_patch_type) , intent(inout) :: currentPatch @@ -1165,8 +1171,9 @@ subroutine fragmentation_scaler( currentPatch, temperature_inst ) catanf_30 = catanf(30._r8) - c = currentPatch%siteptr%clmcolumn +! c = currentPatch%siteptr%clmcolumn p = currentPatch%clm_pno + c = patch%column(p) ! set "froz_q10" parameter froz_q10 = EDParamsShareInst%froz_q10 diff --git a/biogeophys/EDAccumulateFluxesMod.F90 b/biogeophys/EDAccumulateFluxesMod.F90 index 07464781..ad32348c 100644 --- a/biogeophys/EDAccumulateFluxesMod.F90 +++ b/biogeophys/EDAccumulateFluxesMod.F90 @@ -20,7 +20,7 @@ module EDAccumulateFluxesMod contains !------------------------------------------------------------------------------ - subroutine AccumulateFluxes_ED(bounds, p, ed_allsites_inst, photosyns_inst) + subroutine AccumulateFluxes_ED(bounds, p, sites, nsites, hsites , photosyns_inst) ! ! !DESCRIPTION: ! see above @@ -36,14 +36,18 @@ subroutine AccumulateFluxes_ED(bounds, p, ed_allsites_inst, photosyns_inst) ! !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(ed_site_type) , intent(inout), target :: sites(nsites) + integer , intent(in) :: nsites + integer , intent(in) :: hsites(bounds%begc:bounds%endc) + 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 + integer :: c ! clm/alm column + integer :: s ! ed site !---------------------------------------------------------------------- associate(& @@ -55,8 +59,10 @@ subroutine AccumulateFluxes_ED(bounds, p, ed_allsites_inst, photosyns_inst) if (patch%is_veg(p)) then - g = patch%gridcell(p) - currentPatch => map_clmpatch_to_edpatch(ed_allsites_inst(g), p) + c = patch%column(p) + s = hsites(c) + + currentPatch => map_clmpatch_to_edpatch(sites(s), p) currentCohort => currentPatch%shortest do while(associated(currentCohort)) diff --git a/biogeophys/EDBtranMod.F90 b/biogeophys/EDBtranMod.F90 index 5cfb93c7..9c547505 100644 --- a/biogeophys/EDBtranMod.F90 +++ b/biogeophys/EDBtranMod.F90 @@ -25,7 +25,7 @@ module EDBtranMod contains !------------------------------------------------------------------------------ - subroutine btran_ed( bounds, p, ed_allsites_inst, & + subroutine btran_ed( bounds, p, sites, nsites, hsites, & soilstate_inst, waterstate_inst, temperature_inst, energyflux_inst) ! ! !DESCRIPTION: @@ -49,7 +49,9 @@ subroutine btran_ed( bounds, p, ed_allsites_inst, & ! !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(ed_site_type) , intent(inout), target :: sites(nsites) + integer , intent(in) :: nsites + integer , intent(in) :: hsites(bounds%begc:bounds%endc) type(soilstate_type) , intent(inout) :: soilstate_inst type(waterstate_type) , intent(in) :: waterstate_inst type(temperature_type) , intent(in) :: temperature_inst @@ -57,7 +59,7 @@ subroutine btran_ed( bounds, p, ed_allsites_inst, & ! ! !LOCAL VARIABLES: integer :: iv !leaf layer - integer :: g !gridcell + integer :: s !site integer :: c !column integer :: j !soil layer integer :: ft ! plant functional type index @@ -140,9 +142,10 @@ subroutine btran_ed( bounds, p, ed_allsites_inst, & if (patch%is_veg(p)) then c = patch%column(p) - g = patch%gridcell(p) + s = hsites(c) - currentPatch => map_clmpatch_to_edpatch(ed_allsites_inst(g), p) + currentPatch => map_clmpatch_to_edpatch(sites(s), p) + do FT = 1,numpft_ed currentPatch%btran_ft(FT) = 0.0_r8 do j = 1,nlevgrnd diff --git a/biogeophys/EDPhotosynthesisMod.F90 b/biogeophys/EDPhotosynthesisMod.F90 index 6bf500cc..058cbc74 100644 --- a/biogeophys/EDPhotosynthesisMod.F90 +++ b/biogeophys/EDPhotosynthesisMod.F90 @@ -20,7 +20,7 @@ module EDPhotosynthesisMod !--------------------------------------------------------- subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & - rb, dayl_factor, ed_allsites_inst, & + rb, dayl_factor, sites, nsites, hsites, & atm2lnd_inst, temperature_inst, canopystate_inst, photosyns_inst) ! ! !DESCRIPTION: @@ -61,7 +61,9 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & 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(ed_site_type) , intent(inout), target :: sites(nsites) + integer , intent(in) :: nsites + integer , intent(in) :: hsites(bounds%begc:bounds%endc) type(atm2lnd_type) , intent(in) :: atm2lnd_inst type(temperature_type) , intent(in) :: temperature_inst type(canopystate_type) , intent(inout) :: canopystate_inst @@ -145,7 +147,7 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & 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 :: c,CL,f,s,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] @@ -323,10 +325,11 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & gccanopy(p) = 0._r8 if (patch%is_veg(p)) then - g = patch%gridcell(p) + c = patch%column(p) + s = hsites(c) - currentPatch => map_clmpatch_to_edpatch(ed_allsites_inst(g), p) + currentPatch => map_clmpatch_to_edpatch(sites(s), p) currentPatch%ncan(:,:) = 0 !redo the canopy structure algorithm to get round a bug that is happening for site 125, FT13. @@ -401,10 +404,11 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & do f = 1,fn p = filterp(f) c = patch%column(p) + s = hsites(c) if (patch%is_veg(p)) then - g = patch%gridcell(p) - currentPatch => map_clmpatch_to_edpatch(ed_allsites_inst(g), p) + + currentPatch => map_clmpatch_to_edpatch(sites(s), p) do FT = 1,numpft_ed if (nint(c3psn(FT)) == 1)then diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index 4008dca3..3110bd63 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -65,7 +65,7 @@ subroutine ED_Norman_Radiation (bounds, & type(ed_site_type) , intent(inout), target :: sites(nsites) ! FATES site vector integer , intent(in) :: nsites integer , intent(in) :: fcolumn(nsites) - integer , intent(in) :: hsites(bounds_clump%begc:bounds_clump%endc) + integer , intent(in) :: hsites(bounds%begc:bounds%endc) type(surfalb_type) , intent(inout) :: surfalb_inst ! ! !LOCAL VARIABLES: @@ -113,7 +113,7 @@ subroutine ED_Norman_Radiation (bounds, & real(r8) :: denom real(r8) :: lai_reduction(2) - integer :: fp,p,c,iv ! array indices + integer :: fp,p,c,iv,s ! 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 @@ -245,7 +245,7 @@ subroutine ED_Norman_Radiation (bounds, & end do !iv end do !ft end do !L - g = currentPatch%siteptr%clmgcell +! 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 @@ -822,7 +822,7 @@ subroutine ED_Norman_Radiation (bounds, & 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), & + write(iulog,*)'dir ground absorption error',p,c,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), & @@ -837,7 +837,7 @@ subroutine ED_Norman_Radiation (bounds, & 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) , & + write(iulog,*)'dif ground absorption error',p,c,currentPatch%sabs_dif(ib) , & (currentPatch%tr_soil_dif(ib)* & (1.0_r8-albgri(c,ib))),currentPatch%NCL_p,ib,sum(ftweight(1,:,1)) endif diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index 60194c17..d9d56b35 100755 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -640,6 +640,7 @@ subroutine area_burnt ( currentSite ) use domainMod, only : ldomain use EDParamsMod, only : ED_val_nfires + use PatchType, only : patch type(ed_site_type), intent(inout), target :: currentSite @@ -650,7 +651,7 @@ subroutine area_burnt ( currentSite ) real db !distance fire has travelled backward real(r8) gridarea real(r8) size_of_fire - integer g + integer g, p currentSite%frac_burnt = 0.0_r8 @@ -683,9 +684,17 @@ subroutine area_burnt ( currentSite ) ! --- calculate area burnt--- if(lb > 0.0_r8) then - g = currentSite%clmgcell + + p = currentPatch%clm_pno + g = patch%gridcell(p) + ! g = currentSite%clmgcell (DEPRECATED VARIABLE) + + ! INTERF-TODO: + ! THIS SHOULD HAVE THE COLUMN AND LU AREA WEIGHT ALSO, NO? + 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. diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index facde802..00907091 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -10,7 +10,7 @@ module EDCLMLinkMod use decompMod , only : bounds_type use clm_varpar , only : nclmax, nlevcan_ed, numpft, numcft, mxpft use clm_varctl , only : iulog - + use ColumnType , only : col use EDtypesMod , only : ed_site_type, ed_cohort_type, ed_patch_type, ncwd use EDtypesMod , only : sclass_ed, nlevsclass_ed, AREA use CanopyStateType , only : canopystate_type @@ -21,6 +21,7 @@ module EDCLMLinkMod use clm_time_manager , only : is_beg_curr_day, get_step_size, get_nstep use shr_const_mod, only: SHR_CONST_CDAY use abortutils , only : endrun + use shr_log_mod , only : errMsg => shr_log_errMsg ! implicit none @@ -958,7 +959,6 @@ subroutine ed_clm_link( this, bounds, sites, nsites, fcolumn, waterstate_inst, c use EDEcophysConType , only : EDecophyscon 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 @@ -976,7 +976,7 @@ subroutine ed_clm_link( this, bounds, sites, nsites, fcolumn, waterstate_inst, c ! !LOCAL VARIABLES: type (ed_patch_type) , pointer :: currentPatch type (ed_cohort_type) , pointer :: currentCohort - integer :: g,l,p,c + integer :: g,l,p,c,s integer :: ft ! plant functional type integer :: patchn ! identification number for each patch. real(r8) :: total_bare_ground ! sum of the bare fraction in all pfts. @@ -1202,13 +1202,13 @@ subroutine ed_clm_link( this, bounds, sites, nsites, fcolumn, waterstate_inst, c end subroutine ed_clm_link !----------------------------------------------------------------------- - subroutine ed_update_history_variables( this, bounds, sites, nsites, fcolumn, - firstsoilpatch, canopystate_inst) + subroutine ed_update_history_variables( this, bounds, sites, nsites, fcolumn, canopystate_inst) ! ! !USES: use CanopyStateType , only : canopystate_type use PatchType , only : clmpatch => patch use pftconMod , only : pftcon + ! ! !ARGUMENTS: class(ed_clm_type) :: this @@ -1221,7 +1221,7 @@ subroutine ed_update_history_variables( this, bounds, sites, nsites, fcolumn, type(canopystate_type) , intent(inout) :: canopystate_inst ! ! !LOCAL VARIABLES: - integer :: p,ft,c + integer :: p,ft,c,s ! integer :: firstsoilpatch(bounds%begg:bounds%endg) real(r8) :: n_density ! individual of cohort per m2. real(r8) :: n_perm2 ! individuals per m2 for the whole column @@ -1587,7 +1587,7 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, colindex, waterstate_ins ! !ARGUMENTS class(ed_clm_type) :: this type(ed_site_type) , intent(inout) :: currentSite - integer , intent(in) :: c ! ALM/CLM column index of this site + integer , intent(in) :: colindex ! ALM/CLM column index of this site type(waterstate_type) , intent(inout) :: waterstate_inst type(canopystate_type) , intent(inout) :: canopystate_inst ! @@ -1639,7 +1639,8 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, colindex, waterstate_ins ! Each leaf is defined by how deep in the canopy it is, in terms of LAI units. (FIX(RF,032414), GB) currentPatch => currentSite%oldest_patch ! ed patch - p = col%patchi(c) ! CLM/ALM equivalent patch + p = col%patchi(colindex) ! first patch of the column of interest, for vegetated + ! columns this is the non-veg patch do while(associated(currentPatch)) p = p + 1 ! First CLM/ALM patch is non-veg, increment at loop start @@ -1738,15 +1739,15 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, colindex, waterstate_ins !snow burial fraction_exposed = 1.0_r8 !default. - snowdp(c) = snow_depth(c) * frac_sno_eff(c) - if(snowdp(c) > maxh(iv))then + snowdp(colindex) = snow_depth(colindex) * frac_sno_eff(colindex) + if(snowdp(colindex) > maxh(iv))then fraction_exposed = 0._r8 endif - if(snowdp(c) < minh(iv))then + if(snowdp(colindex) < 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))) + if(snowdp(colindex) >= minh(iv).and.snowdp(colindex) <= maxh(iv))then !only partly hidden... + fraction_exposed = max(0._r8,(min(1.0_r8,(snowdp(colindex)-minh(iv))/dh))) endif ! no m2 of leaf per m2 of ground in each height class @@ -1816,9 +1817,9 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, colindex, waterstate_ins ! c = clmpatch%column(currentPatch%clm_pno) ! INTERF-TODO: REMOVE THIS AT SOME POINT, THIS SANITY CHECK IS NOT NEEDED WHEN THE ! COLUMNIZATION IS COMPLETE - if( clmpatch%column(currentPatch%clm_pno) .ne. c .or. currentPatch%clm_pno .ne. p )then + if( clmpatch%column(currentPatch%clm_pno) .ne. colindex .or. currentPatch%clm_pno .ne. p )then ! ERROR - write(iulog,*) ' clmpatch%column(currentPatch%clm_pno) .ne. c .or. currentPatch%clm_pno .ne. p ' + write(iulog,*) ' clmpatch%column(currentPatch%clm_pno) .ne. colindex .or. currentPatch%clm_pno .ne. p ' call endrun(msg=errMsg(__FILE__, __LINE__)) end if @@ -1841,15 +1842,15 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, colindex, waterstate_ins 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 + snowdp(colindex) = snow_depth(colindex) * frac_sno_eff(colindex) + if(snowdp(colindex) > layer_top_hite)then fraction_exposed = 0._r8 endif - if(snowdp(c) <= layer_bottom_hite)then + if(snowdp(colindex) <= 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)/ & + if(snowdp(colindex) > layer_bottom_hite.and.snowdp(colindex) <= layer_top_hite)then !only partly hidden... + fraction_exposed = max(0._r8,(min(1.0_r8,(snowdp(colindex)-layer_bottom_hite)/ & (layer_top_hite-layer_bottom_hite )))) endif @@ -1874,14 +1875,14 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, colindex, waterstate_ins fraction_exposed = 1.0_r8 !default. fraction_exposed = 1.0_r8 !default. - if(snowdp(c) > layer_top_hite)then + if(snowdp(colindex) > layer_top_hite)then fraction_exposed = 0._r8 endif - if(snowdp(c) <= layer_bottom_hite)then + if(snowdp(colindex) <= 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) / & + if(snowdp(colindex) > layer_bottom_hite.and.snowdp(colindex) <= layer_top_hite)then !only partly hidden... + fraction_exposed = max(0._r8,(min(1.0_r8,(snowdp(colindex)-layer_bottom_hite) / & (layer_top_hite-layer_bottom_hite )))) endif @@ -1973,7 +1974,7 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, colindex, waterstate_ins if(abs(tlai(p)-tlai_temp) > 0.0001_r8) then write(iulog,*) 'ED: error with tlai calcs',& - NC,currentSite%clmgcell, abs(tlai(p)-tlai_temp), tlai_temp,tlai(p) + NC,colindex, abs(tlai(p)-tlai_temp), tlai_temp,tlai(p) do L = 1,currentPatch%NCL_p write(iulog,*) 'ED: carea profile',L,currentPatch%canopy_area_profile(L,1,1:currentPatch%nrad(L,1)) @@ -2024,7 +2025,7 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, colindex, waterstate_ins if(abs(sum(currentPatch%canopy_area_profile(L,1:numpft_ed,1))) > 1.00001)then write(iulog,*) 'ED: canopy-area-profile wrong',sum(currentPatch%canopy_area_profile(L,1:numpft_ed,1)), & - currentSite%clmgcell,currentPatch%patchno,L + colindex,currentPatch%patchno,L write(iulog,*) 'ED: areas',currentPatch%canopy_area_profile(L,1:2,1),currentPatch%patchno currentCohort => currentPatch%shortest @@ -2086,9 +2087,6 @@ subroutine flux_into_litter_pools(this, bounds, sites, nsites, fcolumn, canopyst use pftconMod, only : pftcon use clm_varcon, only : zisoi, dzsoi_decomp, zsoi - use ColumnType , only : col - use abortutils , only : endrun - use shr_log_mod , only : errMsg => shr_log_errMsg use EDParamsMod, only : ED_val_ag_biomass ! implicit none @@ -2105,7 +2103,7 @@ subroutine flux_into_litter_pools(this, bounds, sites, nsites, fcolumn, canopyst type (ed_patch_type) , pointer :: currentPatch type (ed_cohort_type) , pointer :: currentCohort type(ed_site_type), pointer :: cs - integer c,p,ci,j,g + integer c,p,ci,j,s real(r8) time_convert ! from year to seconds real(r8) mass_convert ! ED uses kg, CLM uses g integer :: begp,endp @@ -2421,7 +2419,7 @@ subroutine flux_into_litter_pools(this, bounds, sites, nsites, fcolumn, canopyst end subroutine flux_into_litter_pools !------------------------------------------------------------------------ - subroutine SummarizeProductivityFluxes(this, bounds, sites, nsites) + subroutine SummarizeProductivityFluxes(this, bounds, sites, nsites, fcolumn) ! Summarize the fast production inputs from fluxes per ED individual to fluxes per CLM patch and column ! Must be called between calculation of productivity fluxes and daily ED calls @@ -2430,7 +2428,6 @@ subroutine SummarizeProductivityFluxes(this, bounds, sites, nsites) ! Written By Charlie Koven, April 2016 ! ! !USES: - use ColumnType , only : col use LandunitType , only : lun use landunit_varcon , only : istsoil !use subgridAveMod , only : p2c @@ -2442,10 +2439,11 @@ subroutine SummarizeProductivityFluxes(this, bounds, sites, nsites) type(bounds_type) , intent(in) :: bounds type(ed_site_type) , intent(in), target :: sites(nsites) integer , intent(in) :: nsites + integer , intent(in) :: fcolumn(nsites) ! ! !LOCAL VARIABLES: real(r8) :: dt ! radiation time step (seconds) - integer :: c, fc, l, p + integer :: c, fc, l, p, s type (ed_patch_type) , pointer :: currentPatch type (ed_cohort_type) , pointer :: currentCohort integer :: firstsoilpatch(bounds%begg:bounds%endg) ! the first patch in this gridcell that is soil and thus bare... @@ -2515,7 +2513,7 @@ subroutine SummarizeProductivityFluxes(this, bounds, sites, nsites) ! map ed cohort-level fluxes to clm patch fluxes npp(p) = npp(p) + currentCohort%npp_clm * 1.e3_r8 * n_density / dt gpp(p) = gpp(p) + currentCohort%gpp_clm * 1.e3_r8 * n_density / dt - ar(p) = ar(pp) + currentCohort%resp_clm * 1.e3_r8 * n_density / dt + ar(p) = ar(p) + currentCohort%resp_clm * 1.e3_r8 * n_density / dt growth_resp(p) = growth_resp(p) + currentCohort%resp_g * 1.e3_r8 * n_density / dt maint_resp(p) = maint_resp(p) + currentCohort%resp_m * 1.e3_r8 * n_density / dt @@ -2550,7 +2548,6 @@ subroutine SummarizeNetFluxes(this, bounds, num_soilc, filter_soilc, & ! Written by Charlie Koven, Feb 2016 ! ! !USES: - use ColumnType , only : col use LandunitType , only : lun use landunit_varcon , only : istsoil ! @@ -2569,7 +2566,7 @@ subroutine SummarizeNetFluxes(this, bounds, num_soilc, filter_soilc, & ! ! !LOCAL VARIABLES: real(r8) :: dt ! radiation time step (seconds) - integer :: c, g, cc, fc, l, p, pp + integer :: c, s, cc, fc, l, p, pp type(ed_site_type), pointer :: cs type (ed_patch_type) , pointer :: currentPatch type (ed_cohort_type) , pointer :: currentCohort diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 83b457e7..50379314 100755 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -20,7 +20,7 @@ module EDInitMod use EDCohortDynamicsMod , only : create_cohort, fuse_cohorts, sort_cohorts use EDPatchDynamicsMod , only : create_patch use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type, area - use EDTypesMod , only : cohorts_per_gcell, ncwd, numpft_ed, udata + use EDTypesMod , only : cohorts_per_col, ncwd, numpft_ed, udata use EDCLMLinkMod , only : ed_clm_type implicit none @@ -28,11 +28,10 @@ module EDInitMod logical :: DEBUG = .false. - public :: ed_init_sites public :: zero_site - - private :: set_site_properties - private :: init_patches + public :: init_patches + public :: set_site_properties + private :: init_cohorts ! ============================================================================ @@ -40,59 +39,6 @@ module EDInitMod ! ============================================================================ -! 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 -! ! -! ! Makes unique cohort identifiers. Needs zeroing at beginning of run. -! udata%cohort_number = 0 -! -! 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: @@ -112,9 +58,6 @@ subroutine zero_site( site_in ) ! 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. @@ -147,7 +90,7 @@ subroutine set_site_properties( sites, nsites) ! ! !ARGUMENTS - type(ed_site_type) , intent(inout), target :: sites + type(ed_site_type) , intent(inout), target :: sites(nsites) integer, intent(in) :: nsites ! ! !LOCAL VARIABLES: @@ -176,11 +119,11 @@ subroutine set_site_properties( sites, nsites) dleafoff = 300 dleafon = 100 watermem = 0.5_r8 - enddo + else ! assignements for restarts NCD = 1.0_r8 ! NCD should be 1 on restart - GDD(i) = 0.0_r8 + GDD = 0.0_r8 leafon = 0.0_r8 leafoff = 0.0_r8 stat = 1 @@ -207,7 +150,7 @@ subroutine set_site_properties( sites, nsites) !start off with leaves off to initialise sites(s)%dstatus= dstat - sites(s)%acc_NI = acc_NI(s) + sites(s)%acc_NI = acc_NI sites(s)%frac_burnt = 0.0_r8 sites(s)%old_stock = 0.0_r8 end do @@ -225,7 +168,7 @@ subroutine init_patches( sites, nsites) use EDParamsMod , only : ED_val_maxspread ! ! !ARGUMENTS - type(ed_site_type) , intent(inout), target :: sites + type(ed_site_type) , intent(inout), target :: sites(nsites) integer, intent(in) :: nsites ! ! !LOCAL VARIABLES: diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 5016bb23..5d37d4f2 100755 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -166,7 +166,7 @@ subroutine ed_integrate_state_variables(currentSite, soilstate_inst, temperature 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, & + write(iulog,*) 'negative patch age?',currentPatch%age, & currentPatch%patchno,currentPatch%area endif @@ -384,28 +384,25 @@ subroutine ed_total_balance_check (currentSite, call_index ) 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 => currentSite%oldest_patch + do while(associated(currentPatch)) - currentPatch => currentPatch%younger + 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 - enddo !end patch loop + currentPatch => currentPatch%younger - endif + enddo !end patch loop total_stock = biomass_stock + seed_stock +litter_stock change_in_stock = total_stock - currentSite%old_stock @@ -423,6 +420,6 @@ subroutine ed_total_balance_check (currentSite, call_index ) currentSite%flux_out = 0.0_r8 currentSite%old_stock = total_stock - end subroutine ed_total_balance_check + end subroutine ed_total_balance_check end module EDMainMod diff --git a/main/EDRestVectorMod.F90 b/main/EDRestVectorMod.F90 index b1699d12..96584694 100755 --- a/main/EDRestVectorMod.F90 +++ b/main/EDRestVectorMod.F90 @@ -660,9 +660,9 @@ subroutine getVectors( this, bounds, sites, nsites, fcolumn) write(iulog,*) 'edtime getVectors ',get_nstep() end if - call this%createPatchCohortStructure ( bounds, sites, nsites ) + call this%createPatchCohortStructure ( bounds, sites, nsites, fcolumn ) - call this%convertCohortVectorToList ( bounds, sites ) + call this%convertCohortVectorToList ( bounds, sites , nsites, fcolumn) do s = 1,nsites call ed_update_site( sites(s) ) @@ -1928,7 +1928,7 @@ subroutine convertCohortVectorToList( this, bounds, sites, nsites, fcolumn ) ! !LOCAL VARIABLES: type (ed_patch_type), pointer :: currentPatch type (ed_cohort_type),pointer :: currentCohort - integer :: g, c, s + integer :: c, s integer :: totalCohorts ! number of cohorts starting from 0 integer :: countCohort ! number of cohorts starting from ! vectorLengthStart @@ -1948,7 +1948,6 @@ subroutine convertCohortVectorToList( this, bounds, sites, nsites, fcolumn ) do s = 1,nsites c = fcolumn(s) - g = col%gridcell(c) incrementOffset = (c-1)*cohorts_per_col + 1 countCohort = (c-1)*cohorts_per_col + 1 diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 50f8d553..e167744a 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -24,7 +24,7 @@ module EDTypesMod ! for setting number of patches per gridcell and number of cohorts per patch ! for I/O and converting to a vector - integer, parameter :: numPatchesPerGridCol = 10 ! + integer, parameter :: numPatchesPerCol = 10 ! integer, parameter :: numCohortsPerPatch = 160 ! integer, parameter :: cohorts_per_col = 1600 ! This is the max number of individual items one can store per diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 9617826d..d5dd5313 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -19,12 +19,12 @@ module FatesInterfaceMod use ncdio_pio , only : file_desc_t use PatchType , only : patch use ColumnType , only : col + use GridCellType , only : grc ! ------------------------------------------------------------------------------------ use EDtypesMod , only : ed_patch_type, ed_site_type, numpft_ed use EDtypesMod , only : map_clmpatch_to_edpatch use EDSurfaceRadiationMod , only : ED_SunShadeFracs - use EDInitMod , only : ed_init_sites use EDMainMod , only : ed_update_site use EDRestVectorMod , only : EDRest From 141b7745a034f1ee7497b0a56234d61235c2fcaf Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 31 May 2016 22:56:07 -0700 Subject: [PATCH 107/437] columnization first pass, build success --- main/FatesInterfaceMod.F90 | 29 +++++++++++++++-------------- 1 file changed, 15 insertions(+), 14 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index d5dd5313..fb1a9a0e 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -27,6 +27,7 @@ module FatesInterfaceMod use EDSurfaceRadiationMod , only : ED_SunShadeFracs use EDMainMod , only : ed_update_site use EDRestVectorMod , only : EDRest + use EDInitMod , only : zero_site, set_site_properties, init_patches type, public :: fates_interface_type @@ -46,10 +47,9 @@ module FatesInterfaceMod contains ! Procedures for initializing FATES threaded memory and communicators - procedure, public :: init procedure, public :: fates_clean - procedure, public :: site_init - procedure, public :: fates_restart + procedure, public :: init_coldstart +! procedure, public :: init_restart procedure, public :: canopy_sunshade_fracs end type fates_interface_type @@ -132,17 +132,18 @@ end subroutine init_coldstart ! ------------------------------------------------------------------------------------ - subroutine init_restart(this, bounds_clump, ncid, flag, fcolumn ) - - implicit none - class(fates_interface_type), intent(inout) :: this - type(bounds_type),intent(in) :: bounds_clump - type(file_desc_t) , intent(inout) :: ncid ! netcdf id - character(len=*) , intent(in) :: flag !'read' or 'write' - - call EDRest( bounds_clump, this%sites, this%nsites, fcolumn, ncid, flag ) - return - end subroutine init_restart +! subroutine init_restart(this, bounds_clump, ncid, flag, fcolumn ) +! +! implicit none +! class(fates_interface_type), intent(inout) :: this +! type(bounds_type),intent(in) :: bounds_clump +! type(file_desc_t) , intent(inout) :: ncid ! netcdf id +! integer , intent(in) :: fcolumn(this%nsites) +! character(len=*) , intent(in) :: flag !'read' or 'write' +! +! call EDRest( bounds_clump, this%sites, this%nsites, fcolumn, ncid, flag ) +! return +! end subroutine init_restart ! ------------------------------------------------------------------------------------ From 6a3c432116e29f3b50c576b75ec6719d22935bd9 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 1 Jun 2016 18:09:21 -0700 Subject: [PATCH 108/437] rectifying how to allocate ed-sites with the potential of dynamic column status. 1x1br cold-starts running with what appears to be non-nonsense results. --- main/EDCLMLinkMod.F90 | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 00907091..12703640 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -1409,7 +1409,6 @@ subroutine ed_update_history_variables( this, bounds, sites, nsites, fcolumn, ca ! INTERF-TODO: THIS LOGIC SHOULDN'T BE NECESSARY, SHOULD BE CHECKED AT THE BEGINNING ! OF LINKING, ONCE - ! %patchno is the local index of the ED/FATES patches, starting at 1 if(currentPatch%patchno <= numpft - numcft)then !don't expand into crop patches. @@ -1421,6 +1420,7 @@ subroutine ed_update_history_variables( this, bounds, sites, nsites, fcolumn, ca currentCohort => currentPatch%shortest do while(associated(currentCohort)) !accumulate into history variables. + ft = currentCohort%pft ed_ncohorts(c) = ed_ncohorts(c) + 1._r8 @@ -1517,9 +1517,9 @@ subroutine ed_update_history_variables( this, bounds, sites, nsites, fcolumn, ca !Patch specific variables that are already calculated !These things are all duplicated. Should they all be converted to LL or array structures RF? - ! define scalar to counteract the patch albedo scaling logic for conserved quantities - if (currentPatch%area .gt. 0._r8) then + + if (currentPatch%area .gt. 0._r8 .and. currentPatch%total_canopy_area .gt.0 ) then patch_scaling_scalar = min(1._r8, currentPatch%area / currentPatch%total_canopy_area) else patch_scaling_scalar = 0._r8 @@ -1545,7 +1545,11 @@ subroutine ed_update_history_variables( this, bounds, sites, nsites, fcolumn, ca seed_germination(p) = sum(currentPatch%seed_germination) * 1.e3_r8 * 365.0_r8 * SHR_CONST_CDAY * patch_scaling_scalar canopy_spread(p) = currentPatch%spread(1) area_plant(p) = 1._r8 - area_trees(p) = currentPatch%total_tree_area / min(currentPatch%total_canopy_area,currentPatch%area) + if (min(currentPatch%total_canopy_area,currentPatch%area)>0.0_r8) then + area_trees(p) = currentPatch%total_tree_area / min(currentPatch%total_canopy_area,currentPatch%area) + else + area_trees(p) = 0.0_r8 + end if if(associated(currentPatch%tallest))then trimming(p) = currentPatch%tallest%canopy_trim else From 96c0759f02afa028fbe780c3f62f3c93cb29bc5e Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Sun, 5 Jun 2016 12:30:52 -0700 Subject: [PATCH 109/437] moved init_coldstart from FATES public to clm_fates, also added conditional to prevent prevent passing of unallocated arrays --- main/EDInitMod.F90 | 1 + main/EDMainMod.F90 | 8 ++++++-- main/FatesInterfaceMod.F90 | 36 ------------------------------------ 3 files changed, 7 insertions(+), 38 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 50379314..60fce0d3 100755 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -132,6 +132,7 @@ subroutine set_site_properties( sites, nsites) dleafoff = 300 dleafon = 100 watermem = 0.5_r8 + endif do s = 1,nsites diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 5d37d4f2..29a97ec2 100755 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -410,8 +410,12 @@ subroutine ed_total_balance_check (currentSite, call_index ) 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,*) 'total error: call index: ',call_index, & + 'in: ',currentSite%flux_in, & + 'out: ',currentSite%flux_out, & + 'net: ',net_flux, & + 'dstock: ',change_in_stock, & + 'error=net_flux-dstock:', error write(iulog,*) 'biomass,litter,seeds', biomass_stock,litter_stock,seed_stock write(iulog,*) 'lat lon',currentSite%lat,currentSite%lon endif diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index fb1a9a0e..d1c23d79 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -96,42 +96,6 @@ end subroutine fates_clean ! ------------------------------------------------------------------------------------ - subroutine init_coldstart(this,fcolumn) - - ! Input Arguments - class(fates_interface_type), intent(inout) :: this - integer, intent(in) :: fcolumn(this%nsites) - - ! locals - integer :: s - integer :: c - integer :: g - - do s = 1,this%nsites - - call zero_site(this%sites(s)) - - c = fcolumn(s) - g = col%gridcell(c) ! TODO-INTERF: col% and grc% should not be accessible here - - this%sites(s)%lat = grc%latdeg(g) - this%sites(s)%lon = grc%londeg(g) - - end do - - call set_site_properties(this%sites,this%nsites) - - call init_patches(this%sites, this%nsites) - - do s = 1,this%nsites - call ed_update_site(this%sites(s)) - end do - - return - end subroutine init_coldstart - - ! ------------------------------------------------------------------------------------ - ! subroutine init_restart(this, bounds_clump, ncid, flag, fcolumn ) ! ! implicit none From b08b42ea4b612fc8d0011a8a6bc0e21a947b4372 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Sun, 5 Jun 2016 12:50:56 -0700 Subject: [PATCH 110/437] removed procedure declaration of init_coldstart from the Fates public (bug from previous commit). Updated CanopySunShadeFracs to be called from clm_fates, and also fixed how that function accesses the correct site. --- main/FatesInterfaceMod.F90 | 60 +------------------------------------- 1 file changed, 1 insertion(+), 59 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index d1c23d79..3506e7bc 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -47,10 +47,7 @@ module FatesInterfaceMod contains ! Procedures for initializing FATES threaded memory and communicators - procedure, public :: fates_clean - procedure, public :: init_coldstart -! procedure, public :: init_restart - procedure, public :: canopy_sunshade_fracs +! procedure, public :: fates_clean end type fates_interface_type @@ -111,62 +108,7 @@ end subroutine fates_clean ! ------------------------------------------------------------------------------------ - subroutine canopy_sunshade_fracs(this ,filter_nourbanp, num_nourbanp, & - atm2lnd_inst,canopystate_inst) - - - ! TODO-INTERF: THIS ROUTINE NEEDS TO BE WRAPPED BY A CLM_FATES CALL - ! IN THAT CALL THE BOUNDARY CONDITIONS SHOULD BE PREPPED - ! SO THAT THIS CALL DOES NOT HAVE CLM TYPES HERE - ! This interface function is a wrapper call on ED_SunShadeFracs. The only - ! returned variable is a patch vector, fsun_patch, which describes the fraction - ! of the canopy that is exposed to sun. - - implicit none - - ! Input Arguments - class(fates_interface_type), intent(inout) :: this - - ! patch filter for non-urban points - integer, intent(in),dimension(:) :: filter_nourbanp - - ! number of patches in non-urban points in patch filter - integer, intent(in) :: num_nourbanp - - ! direct and diffuse downwelling radiation (W/m2) - type(atm2lnd_type),intent(in) :: atm2lnd_inst - - ! Input/Output Arguments to CLM - type(canopystate_type),intent(inout) :: canopystate_inst - - ! Local Variables - integer :: fp ! non-urban filter patch index - integer :: p ! patch index - integer :: g ! grid cell index - integer, parameter :: ipar = 1 ! The band index for PAR - type(ed_patch_type), pointer :: cpatch ! c"urrent" patch - - associate( forc_solad => atm2lnd_inst%forc_solad_grc, & - forc_solai => atm2lnd_inst%forc_solai_grc, & - fsun => canopystate_inst%fsun_patch) - - do fp = 1,num_nourbanp - - p = filter_nourbanp(fp) - g = patch%gridcell(p) - - if ( patch%is_veg(p) ) then - cpatch => map_clmpatch_to_edpatch(this%sites(g), p) - - call ED_SunShadeFracs(cpatch,forc_solad(g,ipar),forc_solai(g,ipar),fsun(p)) - - endif - - end do - end associate - return - end subroutine canopy_sunshade_fracs From 34a3beefdca4fc12b826adf1f0fbecbcbe97c0aa Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Sun, 5 Jun 2016 13:33:34 -0700 Subject: [PATCH 111/437] various bug and syntatical fixes for previous two commits --- main/FatesInterfaceMod.F90 | 61 ++++---------------------------------- 1 file changed, 5 insertions(+), 56 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 3506e7bc..e62a9d75 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -13,21 +13,10 @@ module FatesInterfaceMod ! Used CLM Modules ! INTERF-TODO: NO CLM MODULES SHOULD BE ACCESSIBLE BY THE FATES ! PUBLIC API!!!! - use decompMod , only : bounds_type - use CanopyStateType , only : canopystate_type - use atm2lndType , only : atm2lnd_type - use ncdio_pio , only : file_desc_t - use PatchType , only : patch - use ColumnType , only : col - use GridCellType , only : grc ! ------------------------------------------------------------------------------------ - use EDtypesMod , only : ed_patch_type, ed_site_type, numpft_ed - use EDtypesMod , only : map_clmpatch_to_edpatch - use EDSurfaceRadiationMod , only : ED_SunShadeFracs - use EDMainMod , only : ed_update_site - use EDRestVectorMod , only : EDRest - use EDInitMod , only : zero_site, set_site_properties, init_patches + use EDtypesMod , only : ed_site_type + type, public :: fates_interface_type @@ -53,64 +42,24 @@ module FatesInterfaceMod contains -! subroutine init(this,bounds_clump) -! -! implicit none -! -! ! Input Arguments -! class(fates_interface_type), intent(inout) :: this -! -! ! INTERF-TODO: AS THE FATES PUBLIC API- BOUNDS CLUMP WILL NOT BE ALLOWED -! ! IN HERE FOR MUCH LONGER. -! type(bounds_type),intent(in) :: bounds_clump -! -! ! Initialize the mapping elements between FATES and the DLM -! -! ! These bounds are for a single clump (thread) -! allocate (this%sites(this%nsites)) -! -! return -! end subroutine init - ! ------------------------------------------------------------------------------------ ! INTERF-TODO: THIS IS A PLACE-HOLDER ROUTINE, NOT CALLED YET... - subroutine fates_clean(this,bounds_clump) + subroutine fates_clean(this) implicit none ! Input Arguments class(fates_interface_type), intent(inout) :: this - type(bounds_type),intent(in) :: bounds_clump ! Incrementally walk through linked list and deallocate + + ! Deallocate the site list deallocate (this%sites) return end subroutine fates_clean - ! ------------------------------------------------------------------------------------ - -! subroutine init_restart(this, bounds_clump, ncid, flag, fcolumn ) -! -! implicit none -! class(fates_interface_type), intent(inout) :: this -! type(bounds_type),intent(in) :: bounds_clump -! type(file_desc_t) , intent(inout) :: ncid ! netcdf id -! integer , intent(in) :: fcolumn(this%nsites) -! character(len=*) , intent(in) :: flag !'read' or 'write' -! -! call EDRest( bounds_clump, this%sites, this%nsites, fcolumn, ncid, flag ) -! return -! end subroutine init_restart - - ! ------------------------------------------------------------------------------------ - - - - - - end module FatesInterfaceMod From 5592785d4c9d35efdde9887447f7f2c09c6032cd Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 6 Jun 2016 11:18:39 -0700 Subject: [PATCH 112/437] added a check to see if any unallocated site vectors exist --- main/EDCLMLinkMod.F90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 12703640..e8648ccd 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -1194,9 +1194,8 @@ subroutine ed_clm_link( this, bounds, sites, nsites, fcolumn, waterstate_inst, c end do ! column loop call this%flux_into_litter_pools(bounds, sites(:), nsites, fcolumn(:), canopystate_inst) - call this%ed_update_history_variables(bounds, sites(:), nsites, fcolumn(:), canopystate_inst) - + end associate end subroutine ed_clm_link From 8a7dc59eae9df375395f4f86bdf6c63e9e9cf7a4 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 7 Jun 2016 12:33:00 -0700 Subject: [PATCH 113/437] fixed a bug where site to patch pointers were being flushed, but by accident I got all excited and started flushing patch pointers before patches had been initialized. I de-wronged it. --- main/EDRestVectorMod.F90 | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/main/EDRestVectorMod.F90 b/main/EDRestVectorMod.F90 index 96584694..e4704819 100755 --- a/main/EDRestVectorMod.F90 +++ b/main/EDRestVectorMod.F90 @@ -1792,15 +1792,9 @@ subroutine createPatchCohortStructure( this, bounds, sites, nsites, fcolumn ) call endrun(msg=errMsg(__FILE__, __LINE__)) end if - ! This site may have some patches on it, but lets initialize it with null pointers - ! just in-case there are no patches - + ! Initialize the site pointers to null sites(s)%youngest_patch => null() sites(s)%oldest_patch => null() - sites(s)%youngest_patch%younger => null() - sites(s)%youngest_patch%older => null() - sites(s)%oldest_patch%younger => null() - sites(s)%oldest_patch%older => null() do patchIdx = 1,this%numPatchesPerCol(c) From 4b974a86411f4728bf623f67ea1d6a27c01b31b2 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 14 Jun 2016 14:01:35 -0700 Subject: [PATCH 114/437] 1) removed hard-coded stomatal slopes (mbbopt), and pushed bb_slope to be used directly instead of mbb, which was a redundant variable. 2) removed redundant conductance and interstitial co2 calculations. --- biogeophys/EDPhotosynthesisMod.F90 | 39 ++++++++++++------------------ 1 file changed, 15 insertions(+), 24 deletions(-) diff --git a/biogeophys/EDPhotosynthesisMod.F90 b/biogeophys/EDPhotosynthesisMod.F90 index 058cbc74..c5691b08 100644 --- a/biogeophys/EDPhotosynthesisMod.F90 +++ b/biogeophys/EDPhotosynthesisMod.F90 @@ -95,10 +95,12 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & 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) + + ! --------------------------------------------------------------- + ! TO-DO: bbbopt is slated to be transferred to the parameter file + ! ---------------------------------------------------------------- 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) @@ -306,12 +308,11 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & 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) @@ -355,17 +356,6 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & 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 ! @@ -410,25 +400,24 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & currentPatch => map_clmpatch_to_edpatch(sites(s), p) - do FT = 1,numpft_ed + NCL_p = currentPatch%NCL_p + + do FT = 1,numpft_ed !calculate patch and pft specific propserties at canopy top. + 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) + ! THIS CALL APPEARS TO BE REDUNDANT WITH LINE 650 (RGK) 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)) @@ -647,6 +636,8 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & je = min(r1,r2) ! Iterative loop for ci beginning with initial guess + ! THIS CALL APPEARS TO BE REDUNDANT WITH LINE 423 (RGK) + if (nint(c3psn(FT)) == 1)then ci(cl,ft,iv) = 0.7_r8 * cair(p) else @@ -719,8 +710,8 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & 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)) + bquad = cs*(gb_mol - bbb(FT)) - bb_slope(ft)*an(cl,ft,iv)*forc_pbot(c) + cquad = -gb_mol*(cs*bbb(FT) + bb_slope(ft)*an(cl,ft,iv)*forc_pbot(c)*ceair/esat_tv(p)) call quadratic (aquad, bquad, cquad, r1, r2) gs_mol = max(r1,r2) @@ -788,7 +779,7 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & ! 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) + gs_mol_err = bb_slope(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:' From 9393283264580d134615f0ea4c8675e566d5534e Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 14 Jun 2016 14:05:07 -0700 Subject: [PATCH 115/437] moved calculation of c_area to happen before its used. --- main/EDCLMLinkMod.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index e8648ccd..71a131f4 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -1093,10 +1093,10 @@ subroutine ed_clm_link( this, bounds, sites, nsites, fcolumn, waterstate_inst, c 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) + canopy_leaf_area = canopy_leaf_area + currentCohort%treelai *currentCohort%c_area + if(currentCohort%canopy_layer==1)then currentPatch%total_canopy_area = currentPatch%total_canopy_area + currentCohort%c_area From d04b83e4664b162ce5fea2694535554f8c299ba2 Mon Sep 17 00:00:00 2001 From: Rosie Fisher Date: Wed, 15 Jun 2016 16:29:19 -0600 Subject: [PATCH 116/437] Commit appears to fix snow fraction restart errors by moving the elai_profile and esai_profile calculations INTO SurfaceRadiationMod. This means that we now need a new array to track the mean height in m of each of the (CL,FT,iv) layers, so that the SR routine knows whether they are buried in snow. The new calculation is simpler (each layer is either buried or not) but can be extended. The important point is that the calculations occur with updated snow fields. This should pass 6/2x3 day restart tests. There is a lot of redundant code in the EDCLMLINK pertaining to snow and elai that still needs removing. --- main/EDCLMLinkMod.F90 | 127 ++++++++++++++++++++++++------------------ main/EDTypesMod.F90 | 2 +- 2 files changed, 73 insertions(+), 56 deletions(-) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 5257751e..16397196 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -1264,7 +1264,9 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, waterstate_inst, canopys 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 + real(r8) :: snow_depth_col ! averaged snow over whole columb integer :: NC ! number of cohorts, for bug fixing. + !---------------------------------------------------------------------- smooth_leaf_distribution = 0 @@ -1383,19 +1385,18 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, waterstate_inst, canopys 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 +!write(*,*) 'calc snow' + snow_depth_col = snow_depth(c) * frac_sno_eff(c) + if(snow_depth_col > maxh(iv))then fraction_exposed = 0._r8 endif - if(snowdp(c) < minh(iv))then - fraction_exposed = 1._r8 + if(snow_depth_col < 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))) + if(snow_depth_col>= minh(iv).and.snow_depth_col <= maxh(iv))then !only partly hidden... + fraction_exposed = max(0._r8,(min(1.0_r8,(snow_depth_col-minh(iv))/dh))) endif - + fraction_exposed = 1.0_r8 ! no m2 of leaf per m2 of ground in each height class ! FIX(SPM,032414) these should be uncommented this and double check @@ -1434,7 +1435,8 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, waterstate_inst, canopys currentPatch%tlai_profile = 0._r8 currentPatch%tsai_profile = 0._r8 currentPatch%elai_profile = 0._r8 - currentPatch%esai_profile = 0._r8 + currentPatch%esai_profile = 0._r8 + currentPatch%layer_height_profile = 0._r8 currentPatch%canopy_area_profile(:,:,:) = 0._r8 currentPatch%ncan(:,:) = 0 currentPatch%nrad(:,:) = 0 @@ -1465,13 +1467,6 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, waterstate_inst, canopys !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 * & @@ -1479,28 +1474,43 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, waterstate_inst, canopys 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 - if ( DEBUG ) write(iulog,*) 'EDCLMLink 1246 ', currentPatch%elai_profile(1,ft,iv) + + write(*,*) 'calc snow 2', c, snow_depth(c) , frac_sno_eff(c) + + ! snow_depth_col = snow_depth(c) ! * frac_sno_eff(c) + ! if(snow_depth_col > layer_top_hite)then + ! fraction_exposed = 0._r8 + ! endif + ! if(snow_depth_col < layer_bottom_hite)then + ! fraction_exposed = 1._r8 + ! endif + ! if(snow_depth_col>= layer_bottom_hite.and.snow_depth_col <= layer_top_hite)then !only partly hidden... + ! fraction_exposed = max(0._r8,(min(1.0_r8,(snow_depth_col-layer_bottom_hite)/ & + ! (layer_top_hite-layer_bottom_hite )))) + ! endif +fraction_exposed =1.0_r8 - currentPatch%elai_profile(L,ft,iv) = currentPatch%tlai_profile(L,ft,iv) *fraction_exposed - - if ( DEBUG ) write(iulog,*) 'EDCLMLink 1250 ', currentPatch%elai_profile(1,ft,iv) + currentPatch%tlai_profile(L,ft,iv) = currentPatch%tlai_profile(L,ft,iv)+ dinc_ed * fleaf * & + currentCohort%c_area/currentPatch%total_canopy_area + currentPatch%elai_profile(L,ft,iv) = currentPatch%elai_profile(L,ft,iv)+ dinc_ed * fleaf * & + currentCohort%c_area/currentPatch%total_canopy_area * fraction_exposed + + 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%esai_profile(L,ft,iv) = currentPatch%esai_profile(L,ft,iv)+ dinc_ed * (1._r8 - fleaf) * & + currentCohort%c_area/currentPatch%total_canopy_area * 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) + currentPatch%layer_height_profile(L,ft,iv) = currentPatch%layer_height_profile(L,ft,iv) + (dinc_ed * fleaf * & + currentCohort%c_area/currentPatch%total_canopy_area *(layer_top_hite+layer_bottom_hite)/2.0_r8) !average height of layer. + + write(*,*) 'LHP', currentPatch%layer_height_profile(L,ft,iv) + if ( DEBUG ) write(iulog,*) 'EDCLMLink 1246 ', currentPatch%elai_profile(1,ft,iv) - !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. @@ -1511,17 +1521,22 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, waterstate_inst, canopys 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 +!write(*,*) 'calc snow 3', snow_depth(c) , frac_sno_eff(c) + + snow_depth_col = snow_depth(c) * frac_sno_eff(c) + if(snow_depth_col > layer_top_hite)then + fraction_exposed = 0._r8 + endif + if(snow_depth_col < layer_bottom_hite)then + fraction_exposed = 1._r8 + + endif + if(snow_depth_col>= layer_bottom_hite.and.snow_depth_col <= layer_top_hite)then !only partly hidden... + fraction_exposed = max(0._r8,(min(1.0_r8,(snow_depth_col-layer_bottom_hite)/ & + (layer_top_hite-layer_bottom_hite )))) + endif +fraction_exposed= 1.0_r8 + remainder = (currentCohort%treelai + currentCohort%treesai) - (dinc_ed*(currentCohort%NV-1)) if(remainder > 1.0_r8)then @@ -1532,20 +1547,20 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, waterstate_inst, canopys currentPatch%tlai_profile(L,ft,iv) = currentPatch%tlai_profile(L,ft,iv)+ remainder * fleaf * & currentCohort%c_area/currentPatch%total_canopy_area - + currentPatch%elai_profile(L,ft,iv) = currentPatch%elai_profile(L,ft,iv) + remainder * fleaf * & + currentCohort%c_area/currentPatch%total_canopy_area * fraction_exposed !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 - - if ( DEBUG ) write(iulog,*) 'EDCLMLink 1293 ', currentPatch%elai_profile(L,ft,iv) - - 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%esai_profile(L,ft,iv) = currentPatch%esai_profile(L,ft,iv)+ remainder * & + (1.0_r8-fleaf) * currentCohort%c_area/currentPatch%total_canopy_area * 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) - + currentPatch%layer_height_profile(L,ft,iv) = currentPatch%layer_height_profile(L,ft,iv) + (remainder * fleaf * & + currentCohort%c_area/currentPatch%total_canopy_area*(layer_top_hite+layer_bottom_hite)/2.0_r8) + write(*,*) 'LHP', currentPatch%layer_height_profile(L,ft,iv) 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 @@ -1575,13 +1590,15 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, waterstate_inst, canopys 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) + currentPatch%layer_height_profile(L,ft,iv) = currentPatch%layer_height_profile(L,ft,iv) & + /currentPatch%tlai_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 diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index ab816a9d..a937d975 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -247,7 +247,7 @@ module EDTypesMod 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) :: layer_height_profile(nclmax,numpft_ed,nlevcan_ed) 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? From 230e3a8159759a9f47bf5f7324006d4d74a365ad Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 16 Jun 2016 14:58:52 -0700 Subject: [PATCH 117/437] pruned unnecessary variables from EDBtran, removed some confusing redundant calls to zeroing and initializing energyflux_inst%btran_patch in EDBtran --- biogeophys/EDBtranMod.F90 | 7 ------- 1 file changed, 7 deletions(-) diff --git a/biogeophys/EDBtranMod.F90 b/biogeophys/EDBtranMod.F90 index 9c547505..030eb4f2 100644 --- a/biogeophys/EDBtranMod.F90 +++ b/biogeophys/EDBtranMod.F90 @@ -121,10 +121,7 @@ subroutine btran_ed( bounds, p, sites, nsites, hsites, & 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 @@ -135,7 +132,6 @@ subroutine btran_ed( bounds, p, sites, nsites, hsites, & 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) ) @@ -172,8 +168,6 @@ subroutine btran_ed( bounds, p, sites, nsites, hsites, & 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 @@ -196,7 +190,6 @@ subroutine btran_ed( bounds, p, sites, nsites, hsites, & 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) From 86e4bd38fb612973e556592b501157a75384152c Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 20 Jun 2016 17:32:53 -0700 Subject: [PATCH 118/437] First pass of adding the bc_in and bc_out memory structures. Prototyped on sun/shade fraction call. Compiled, untested. --- biogeochem/EDPhysiologyMod.F90 | 17 +-- biogeophys/EDAccumulateFluxesMod.F90 | 5 + biogeophys/EDPhotosynthesisMod.F90 | 2 +- biogeophys/EDSurfaceAlbedoMod.F90 | 199 +++++++++++++++------------ main/EDMainMod.F90 | 9 +- main/FatesInterfaceMod.F90 | 143 +++++++++++++++++-- 6 files changed, 256 insertions(+), 119 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index c5aff001..4f00de3b 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -70,7 +70,7 @@ subroutine canopy_derivs( currentPatch ) end subroutine canopy_derivs ! ============================================================================ - subroutine non_canopy_derivs( currentPatch, temperature_inst, soilstate_inst, waterstate_inst) + subroutine non_canopy_derivs( currentPatch, temperature_inst ) ! ! !DESCRIPTION: ! Returns time differentials of the state vector @@ -80,8 +80,6 @@ subroutine non_canopy_derivs( currentPatch, temperature_inst, soilstate_inst, wa ! !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 @@ -108,7 +106,7 @@ subroutine non_canopy_derivs( currentPatch, temperature_inst, soilstate_inst, wa ! update fragmenting pool fluxes call cwd_input(currentPatch) - call cwd_out( currentPatch, temperature_inst, soilstate_inst, waterstate_inst) + call cwd_out( currentPatch, temperature_inst) do p = 1,numpft_ed currentPatch%dseed_dt(p) = currentPatch%seeds_in(p) - currentPatch%seed_decay(p) - currentPatch%seed_germination(p) @@ -244,7 +242,7 @@ subroutine phenology( currentSite, temperature_inst, waterstate_inst) ! ! !USES: use clm_varcon, only : tfrz - use clm_time_manager, only : get_days_per_year, get_curr_date + use clm_time_manager, only : get_curr_date use clm_time_manager, only : get_ref_date, timemgr_datediff use EDTypesMod, only : udata use PatchType , only : patch @@ -1145,7 +1143,7 @@ subroutine fragmentation_scaler( currentPatch, temperature_inst ) ! !USES: use shr_const_mod , only : SHR_CONST_PI, SHR_CONST_TKFRZ use EDSharedParamsMod , only : EDParamsShareInst - use PatchType , only : patch + ! ! !ARGUMENTS type(ed_patch_type) , intent(inout) :: currentPatch @@ -1154,7 +1152,7 @@ subroutine fragmentation_scaler( currentPatch, temperature_inst ) ! !LOCAL VARIABLES: logical :: use_century_tfunc = .false. type(ed_site_type), pointer :: currentSite - integer :: c,p,j + integer :: p,j real(r8) :: t_scalar real(r8) :: w_scalar real(r8) :: catanf ! hyperbolic temperature function from CENTURY @@ -1173,7 +1171,6 @@ subroutine fragmentation_scaler( currentPatch, temperature_inst ) ! c = currentPatch%siteptr%clmcolumn p = currentPatch%clm_pno - c = patch%column(p) ! set "froz_q10" parameter froz_q10 = EDParamsShareInst%froz_q10 @@ -1204,7 +1201,7 @@ subroutine fragmentation_scaler( currentPatch, temperature_inst ) end subroutine fragmentation_scaler ! ============================================================================ - subroutine cwd_out( currentPatch, temperature_inst, soilstate_inst, waterstate_inst) + subroutine cwd_out( currentPatch, temperature_inst ) ! ! !DESCRIPTION: ! Simple CWD fragmentation Model @@ -1217,8 +1214,6 @@ subroutine cwd_out( currentPatch, temperature_inst, soilstate_inst, waterstate_i ! !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 diff --git a/biogeophys/EDAccumulateFluxesMod.F90 b/biogeophys/EDAccumulateFluxesMod.F90 index ad32348c..006a0353 100644 --- a/biogeophys/EDAccumulateFluxesMod.F90 +++ b/biogeophys/EDAccumulateFluxesMod.F90 @@ -55,6 +55,11 @@ subroutine AccumulateFluxes_ED(bounds, p, sites, nsites, hsites , photosyns_inst psncanopy => photosyns_inst%psncanopy_patch & ! Output: [real(r8) (:,:)] canopy scale photosynthesis umol CO2 /m**2/ s ) + + ! INTERF-TODO: WHY IS THIS BEING UPDATED? + ! IT IS JUST GOING TO BE ZEROED A THE END OF THE FUNCTION + ! THAT CALLS THIS SUBROUTINE (CANOPYFLUXES), AND IT WON'T + ! BE USED BETWEEN NOW AND THEN fpsn(p) = psncanopy(p) if (patch%is_veg(p)) then diff --git a/biogeophys/EDPhotosynthesisMod.F90 b/biogeophys/EDPhotosynthesisMod.F90 index 058cbc74..f4f9b644 100644 --- a/biogeophys/EDPhotosynthesisMod.F90 +++ b/biogeophys/EDPhotosynthesisMod.F90 @@ -59,7 +59,7 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & 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) :: 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 :: sites(nsites) integer , intent(in) :: nsites diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index 3110bd63..d9b84bd5 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -17,7 +17,9 @@ module EDSurfaceRadiationMod use shr_log_mod , only : errMsg => shr_log_errMsg use decompMod , only : bounds_type use clm_varpar , only : numrad, nclmax - + use FatesInterfaceMod , only : bc_in_type, & + bc_out_type + implicit none private @@ -28,7 +30,11 @@ module EDSurfaceRadiationMod real(r8), public :: albice(numrad) = & ! albedo land ice by waveband (1=vis, 2=nir) (/ 0.80_r8, 0.55_r8 /) - + + ! INTERF-TODO: THIS NEEDS SOME CONSISTENCY AND SHOULD BE SET IN THE INTERFACE + ! WITH OTHER DIMENSIONS + integer, parameter :: ipar = 1 ! The band index for PAR + contains subroutine ED_Norman_Radiation (bounds, & @@ -950,85 +956,93 @@ subroutine ED_Norman_Radiation (bounds, & end associate end subroutine ED_Norman_Radiation - -subroutine ED_SunShadeFracs(cpatch,forc_par_d,forc_par_i,fsun) - - - use clm_varctl , only : iulog - - ! Arguments In - - real(r8),intent(in) :: forc_par_d - real(r8),intent(in) :: forc_par_i - - ! Arguments inout - type (ed_patch_type),intent(inout), target :: cpatch ! c"urrent" patch - - - ! Arguments Out - real(r8),intent(out) :: fsun - - ! locals - real(r8) :: sunlai - real(r8) :: shalai - integer :: CL - integer :: FT - integer :: iv - - - ! zero out various datas - cpatch%ed_parsun_z(:,:,:) = 0._r8 - cpatch%ed_parsha_z(:,:,:) = 0._r8 - cpatch%ed_laisun_z(:,:,:) = 0._r8 - cpatch%ed_laisha_z(:,:,:) = 0._r8 - - fsun = 0._r8 - sunlai = 0._r8 - shalai = 0._r8 - - ! Loop over patches to calculate laisun_z and laisha_z for each layer. - ! Derive canopy laisun, laisha, and fsun from layer sums. - ! If sun/shade big leaf code, nrad=1 and fsun_z(p,1) and tlai_z(p,1) from - ! SurfaceAlbedo is canopy integrated so that layer value equals canopy value. - - ! cpatch%f_sun is calculated in the surface_albedo routine... - - do CL = 1, cpatch%NCL_p - do FT = 1,numpft_ed - do iv = 1, cpatch%nrad(CL,ft) !NORMAL CASE. - - ! FIX(SPM,040114) - existing comment - ! ** Should this be elai or tlai? Surely we only do radiation for elai? - - cpatch%ed_laisun_z(CL,ft,iv) = cpatch%elai_profile(CL,ft,iv) * & - cpatch%f_sun(CL,ft,iv) - - if ( DEBUG ) write(iulog,*) 'edsurfRad 570 ',cpatch%elai_profile(CL,ft,iv) - if ( DEBUG ) write(iulog,*) 'edsurfRad 571 ',cpatch%f_sun(CL,ft,iv) - - cpatch%ed_laisha_z(CL,ft,iv) = cpatch%elai_profile(CL,ft,iv) * & - (1._r8 - cpatch%f_sun(CL,ft,iv)) - - end do - - !needed for the VOC emissions, etc. - sunlai = sunlai + sum(cpatch%ed_laisun_z(CL,ft,1:cpatch%nrad(CL,ft))) - shalai = shalai + sum(cpatch%ed_laisha_z(CL,ft,1:cpatch%nrad(CL,ft))) - - end do - end do - - if(sunlai+shalai > 0._r8)then - fsun = sunlai / (sunlai+shalai) - else - fsun = 0._r8 - endif - - if(fsun > 1._r8)then - write(iulog,*) 'too much leaf area in profile', fsun, & - cpatch%lai,sunlai,shalai - endif - + ! ====================================================================================== + + subroutine ED_SunShadeFracs(sites,nsites,bc_in,bc_out) + + use clm_varctl , only : iulog + + ! Arguments + + type(ed_site_type),intent(inout),target :: sites(nsites) + integer,intent(in) :: nsites + type(bc_in_type),intent(in) :: bc_in(nsites) + type(bc_out_type),intent(out) :: bc_out(nsites) + + + ! locals + + type (ed_patch_type),pointer :: cpatch ! c"urrent" patch + real(r8) :: sunlai + real(r8) :: shalai + integer :: CL + integer :: FT + integer :: iv + integer :: s + integer :: ifp + + + do s = 1,nsites + + ifp = 0 + cpatch => sites(s)%oldest_patch + do while (associated(cpatch)) + + ifp=ifp+1 + + ! zero out various datas + cpatch%ed_parsun_z(:,:,:) = 0._r8 + cpatch%ed_parsha_z(:,:,:) = 0._r8 + cpatch%ed_laisun_z(:,:,:) = 0._r8 + cpatch%ed_laisha_z(:,:,:) = 0._r8 + + bc_out(s)%fsun_pa(ifp) = 0._r8 + sunlai = 0._r8 + shalai = 0._r8 + + ! Loop over patches to calculate laisun_z and laisha_z for each layer. + ! Derive canopy laisun, laisha, and fsun from layer sums. + ! If sun/shade big leaf code, nrad=1 and fsun_z(p,1) and tlai_z(p,1) from + ! SurfaceAlbedo is canopy integrated so that layer value equals canopy value. + + ! cpatch%f_sun is calculated in the surface_albedo routine... + + do CL = 1, cpatch%NCL_p + do FT = 1,numpft_ed + do iv = 1, cpatch%nrad(CL,ft) !NORMAL CASE. + + ! FIX(SPM,040114) - existing comment + ! ** Should this be elai or tlai? Surely we only do radiation for elai? + + cpatch%ed_laisun_z(CL,ft,iv) = cpatch%elai_profile(CL,ft,iv) * & + cpatch%f_sun(CL,ft,iv) + + if ( DEBUG ) write(iulog,*) 'edsurfRad 570 ',cpatch%elai_profile(CL,ft,iv) + if ( DEBUG ) write(iulog,*) 'edsurfRad 571 ',cpatch%f_sun(CL,ft,iv) + + cpatch%ed_laisha_z(CL,ft,iv) = cpatch%elai_profile(CL,ft,iv) * & + (1._r8 - cpatch%f_sun(CL,ft,iv)) + + end do + + !needed for the VOC emissions, etc. + sunlai = sunlai + sum(cpatch%ed_laisun_z(CL,ft,1:cpatch%nrad(CL,ft))) + shalai = shalai + sum(cpatch%ed_laisha_z(CL,ft,1:cpatch%nrad(CL,ft))) + + end do + end do + + if(sunlai+shalai > 0._r8)then + bc_out(s)%fsun_pa(ifp) = sunlai / (sunlai+shalai) + else + bc_out(s)%fsun_pa(ifp) = 0._r8 + endif + + if(bc_out(s)%fsun_pa(ifp) > 1._r8)then + write(iulog,*) 'too much leaf area in profile', bc_out(s)%fsun_pa(ifp), & + cpatch%lai,sunlai,shalai + endif + ! Absorbed PAR profile through canopy ! If sun/shade big leaf code, nrad=1 and fluxes from SurfaceAlbedo ! are canopy integrated so that layer values equal big leaf values. @@ -1044,21 +1058,21 @@ subroutine ED_SunShadeFracs(cpatch,forc_par_d,forc_par_i,fsun) if ( DEBUG ) then write(iulog,*) 'edsurfRad 653 ', cpatch%ed_parsun_z(CL,ft,iv) - write(iulog,*) 'edsurfRad 654 ', forc_par_d - write(iulog,*) 'edsurfRad 655 ', forc_par_i + write(iulog,*) 'edsurfRad 654 ', bc_in(s)%solad_pa(ifp,ipar) + write(iulog,*) 'edsurfRad 655 ', bc_in(s)%solai_pa(ifp,ipar) write(iulog,*) 'edsurfRad 656 ', cpatch%fabd_sun_z(CL,ft,iv) write(iulog,*) 'edsurfRad 657 ', cpatch%fabi_sun_z(CL,ft,iv) endif cpatch%ed_parsun_z(CL,ft,iv) = & - forc_par_d*cpatch%fabd_sun_z(CL,ft,iv) + & - forc_par_i*cpatch%fabi_sun_z(CL,ft,iv) + bc_in(s)%solad_pa(ifp,ipar)*cpatch%fabd_sun_z(CL,ft,iv) + & + bc_in(s)%solai_pa(ifp,ipar)*cpatch%fabi_sun_z(CL,ft,iv) if ( DEBUG )write(iulog,*) 'edsurfRad 663 ', cpatch%ed_parsun_z(CL,ft,iv) cpatch%ed_parsha_z(CL,ft,iv) = & - forc_par_d*cpatch%fabd_sha_z(CL,ft,iv) + & - forc_par_i*cpatch%fabi_sha_z(CL,ft,iv) + bc_in(s)%solad_pa(ifp,ipar)*cpatch%fabd_sha_z(CL,ft,iv) + & + bc_in(s)%solai_pa(ifp,ipar)*cpatch%fabi_sha_z(CL,ft,iv) if ( DEBUG ) write(iulog,*) 'edsurfRad 669 ', cpatch%ed_parsha_z(CL,ft,iv) @@ -1066,9 +1080,14 @@ subroutine ED_SunShadeFracs(cpatch,forc_par_d,forc_par_i,fsun) end do !FT end do !CL - return - - end subroutine ED_SunShadeFracs + cpatch => cpatch%younger + enddo + + + enddo + return + +end subroutine ED_SunShadeFracs ! ! MOVE TO THE INTERFACE diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 29a97ec2..f920f397 100755 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -6,7 +6,6 @@ module EDMainMod 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 @@ -77,7 +76,7 @@ subroutine ed_ecosystem_dynamics(currentSite, & 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) + call ed_integrate_state_variables(currentSite, temperature_inst ) !****************************************************************************** ! Reproduction, Recruitment and Cohort Dynamics : controls cohort organisation @@ -134,7 +133,7 @@ subroutine ed_ecosystem_dynamics(currentSite, & end subroutine ed_ecosystem_dynamics !-------------------------------------------------------------------------------! - subroutine ed_integrate_state_variables(currentSite, soilstate_inst, temperature_inst, waterstate_inst) + subroutine ed_integrate_state_variables(currentSite, temperature_inst ) ! ! !DESCRIPTION: ! FIX(SPM,032414) refactor so everything goes through interface @@ -143,9 +142,7 @@ subroutine ed_integrate_state_variables(currentSite, soilstate_inst, temperature ! ! !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 @@ -217,7 +214,7 @@ subroutine ed_integrate_state_variables(currentSite, soilstate_inst, temperature write(6,*)'DEBUG18: calling non_canopy_derivs with pno= ',currentPatch%clm_pno endif - call non_canopy_derivs( currentPatch, temperature_inst, soilstate_inst, waterstate_inst ) + call non_canopy_derivs( currentPatch, temperature_inst ) !update state variables simultaneously according to derivatives for this time period. do p = 1,numpft_ed diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index e62a9d75..deb69ef1 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -15,34 +15,107 @@ module FatesInterfaceMod ! PUBLIC API!!!! ! ------------------------------------------------------------------------------------ - use EDtypesMod , only : ed_site_type + use EDtypesMod , only : ed_site_type, & + numPatchesPerCol + use shr_kind_mod , only : r8 => shr_kind_r8 ! INTERF-TODO: REMOVE THIS + ! ------------------------------------------------------------------------------------ + ! Certain dimension information used by FATES is dictated by the the driver + ! or the host model, or perhaps may be some compromise between what FATES will want + ! in a best-case scenario and what space the driver/host will allow based on its + ! memory constraints (most-likely due to IO) + ! ------------------------------------------------------------------------------------ + + type, private :: fates_dims_type + + integer :: numSWBands ! Maximum number of broad-bands in the short-wave radiation + ! specturm to track + ! (typically 2 as a default, VIS/NIR, in ED variants <2016) + + + end type fates_dims_type + + + + ! ------------------------------------------------------------------------------------ + ! Notes on types + ! For floating point arrays, it is sometimes the convention to define the arrays as + ! POINTER instead of ALLOCATABLE. This usually achieves the same result with subtle + ! differences. POINTER arrays can point to scalar values, discontinuous array slices + ! or alias other variables, ALLOCATABLES cannnot. According to S. Lionel + ! (Intel-Forum Post), ALLOCATABLES are better perfomance wise as long as they point + ! to contiguous memory spaces and do not alias other variables, the case here. + ! ------------------------------------------------------------------------------------ + + type, public :: bc_in_type + + ! The actual number of FATES' ED patches + integer :: npatches + + ! Downwelling direct beam radiation (patch,broad-band) [W/m2?] + real(r8),allocatable :: solad_pa(:,:) + + ! Downwelling diffuse (I-ndirect) radiation (patch,broad-band) [W/m2] + real(r8),allocatable :: solai_pa(:,:) + + + end type bc_in_type + + + type, public :: bc_out_type + + ! Sunlit fraction of the canopy for this patch [0-1] + real(r8),allocatable :: fsun_pa(:) + + end type bc_out_type + + type, public :: fates_interface_type ! This is the root of the ED/FATES hierarchy of instantaneous state variables - ! ie the root of the linked lists. Each path list is currently associated - ! with a grid-cell, this is intended to be migrated to columns - ! prev: type(ed_site_type)::ed_allsites_inst + ! ie the root of the linked lists. Each path list is currently associated with a + ! grid-cell, this is intended to be migrated to columns integer :: nsites type(ed_site_type), allocatable :: sites(:) + + ! These are boundary conditions that the FATES models are required to be filled. + ! These values are filled by the driver or HLM. Once filled, these have an + ! intent(in) status. Each site has a derived type structure, which may include + ! a scalar for site level data, a patch vector, potentially cohort vectors (but + ! not yet atm) and other dimensions such as soil-depth or pft. These vectors + ! are initialized by maximums, and the allocations are static in time to avoid + ! having to allocate/de-allocate memory + + type(bc_in_type), allocatable :: bc_in(:) + + ! These are the boundary conditions that the FATES model returns to its HLM or + ! driver. It has the same allocation strategy and similar vector types. - ! INTERF-TODO ADD THE DLM->FATES BOUNDARY CONDITION CLASS - ! These are boundary condition variables populated by the DLM - ! type(fates_bc_type) :: fatesbc - + type(bc_out_type), allocatable :: bc_out(:) + contains - ! Procedures for initializing FATES threaded memory and communicators -! procedure, public :: fates_clean + procedure, public :: allocate_bcs + procedure, public :: zero_bcs end type fates_interface_type + ! ------------------------------------------------------------------------------------ + ! Dimension information is independent of which clump it is on + ! and since these are typically read only variables and never updated on the clump + ! we need not attach these to the threaded instances of the fates_interface_type + ! ------------------------------------------------------------------------------------ + + type(fates_dims_type) :: fates_dims + + + contains - ! ------------------------------------------------------------------------------------ + ! ==================================================================================== ! INTERF-TODO: THIS IS A PLACE-HOLDER ROUTINE, NOT CALLED YET... subroutine fates_clean(this) @@ -62,4 +135,52 @@ subroutine fates_clean(this) return end subroutine fates_clean + + ! ==================================================================================== + + + subroutine allocate_bcs(this,s) + + ! --------------------------------------------------------------------------------- + ! Allocate and Initialze the FATES boundary condition vectors + ! --------------------------------------------------------------------------------- + + implicit none + class(fates_interface_type), intent(inout) :: this + integer, intent(in) :: s + + ! Allocate input boundaries + + allocate(this%bc_in(s)%solad_pa(numPatchesPerCol,fates_dims%numSWBands)) + allocate(this%bc_in(s)%solai_pa(numPatchesPerCol,fates_dims%numSWBands)) + + ! Allocate output boundaries + + allocate(this%bc_out(s)%fsun_pa(numPatchesPerCol)) + + return + end subroutine allocate_bcs + + ! ==================================================================================== + + subroutine zero_bcs(this,s) + + implicit none + class(fates_interface_type), intent(inout) :: this + integer, intent(in) :: s + + ! Input boundaries + + this%bc_in(s)%solad_pa(:,:) = 0.0_r8 + this%bc_in(s)%solai_pa(:,:) = 0.0_r8 + + ! Output boundaries + + this%bc_out(s)%fsun_pa(:) = 0.0_r8 + + + return + end subroutine zero_bcs + + end module FatesInterfaceMod From 91ff6e51191e2508b654363aaba7fc784c0e2825 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 21 Jun 2016 18:43:55 -0700 Subject: [PATCH 119/437] incremental changes to bc passing, mostly related to btran --- biogeophys/EDBtranMod.F90 | 172 +++++++++++++++++++++++-------------- main/FatesInterfaceMod.F90 | 57 +++++++++--- 2 files changed, 154 insertions(+), 75 deletions(-) diff --git a/biogeophys/EDBtranMod.F90 b/biogeophys/EDBtranMod.F90 index 030eb4f2..e24ce418 100644 --- a/biogeophys/EDBtranMod.F90 +++ b/biogeophys/EDBtranMod.F90 @@ -1,22 +1,18 @@ module EDBtranMod + + !------------------------------------------------------------------------------------- + ! Description: + ! + ! ------------------------------------------------------------------------------------ - !------------------------------------------------------------------------------ - ! !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 + + public :: btran_ed ! type(ed_cohort_type), pointer :: currentCohort ! current cohort type(ed_patch_type) , pointer :: currentPatch ! current patch @@ -25,37 +21,21 @@ module EDBtranMod contains !------------------------------------------------------------------------------ - subroutine btran_ed( bounds, p, sites, nsites, hsites, & - soilstate_inst, waterstate_inst, temperature_inst, energyflux_inst) - ! - ! !DESCRIPTION: - ! - ! !USES: + subroutine btran_ed( sites, nsites, bc_in, bc_out) + + 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 :: sites(nsites) - integer , intent(in) :: nsites - integer , intent(in) :: hsites(bounds%begc:bounds%endc) - 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 + use EDtypesMod , only : ed_patch_type, ed_site_type + use FatesInterfaceMod , only : bc_in_type, & + bc_out_type + + ! Arguments + + type(ed_site_type),intent(inout),target :: sites(nsites) + integer,intent(in) :: nsites + type(bc_in_type),intent(in) :: bc_in(nsites) + type(bc_out_type),intent(out) :: bc_out(nsites) + ! ! !LOCAL VARIABLES: integer :: iv !leaf layer @@ -63,6 +43,11 @@ subroutine btran_ed( bounds, p, sites, nsites, hsites, & integer :: c !column integer :: j !soil layer integer :: ft ! plant functional type index + + + ! The root effective root fraction for different pfts and soil layers + real(r8) :: rootr(numpft_ed,nlevgrnd) + !---------------------------------------------------------------------- ! Inputs to model from CLM. To be read in through an input file for the purposes of this program. @@ -113,38 +98,94 @@ subroutine btran_ed( bounds, p, sites, nsites, hsites, & 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) + do s = 1,nsites + + ifp = 0 + cpatch => sites(s)%oldest_patch + do while (associated(cpatch)) + ifp=ifp+1 + + do FT = 1,numpft_ed + currentPatch%btran_ft(FT) = 0.0_r8 + do j = 1,nlevgrnd + + if(bc_in(s)%smp_sl(j) > -900.0_r8 ) then ! The flag for frozen or no water is -999 + + smp_node = max(smpsc(FT), bc_in(s)%smp_sl(j)) + + rresis_ft = min( (bc_in(s)%eff_porosity_sl(j)/bc_in(s)%watsat(j))* & + (smp_node - smpsc(FT)) / (smpso(FT) - smpsc(FT)), 1._r8) + + + currentPatch%rootr_ft(FT,j) = currentPatch%rootfr_ft(FT,j)*rresis_ft + + ! 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) + + else + currentPatch%rootr_ft(FT,j) = 0._r8 + end if - 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) - bsw => soilstate_inst%bsw_col , & ! Input: [real(r8) (:,:) ] Clapp and Hornberger "b" - 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 + end do !j - 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) + ! 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 - t_soisno => temperature_inst%t_soisno_col , & ! Input: [real(r8) (:,:) ] soil temperature (Kelvin) + end do !PFT - btran => energyflux_inst%btran_patch , & ! Output: [real(r8) (:) ] transpiration wetness factor (0 to 1) - rresis => energyflux_inst%rresis_patch & ! Output: [real(r8) (:,:) ] root resistance by layer (0-1) (nlevgrnd) - ) - - if (patch%is_veg(p)) then + ! 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 + + + ! Process the boundary output, this is necessary for calculating the soil-moisture + ! sink term across the different layers in driver/host. Photosynthesis will + ! pass the host a total transpiration for the patch. This needs rootr to be + ! distributed over the soil layers. - c = patch%column(p) - s = hsites(c) + do j = 1,nlevgrnd + bc_out(s)%rootr_pa(ifp,j) = 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) + bc_out(s)%rootr_pa(ifp,j) = bc_out(s)%rootr_pa(ifp,j) + & + currentPatch%rootr_ft(FT,j) * pftgs(ft)/sum(pftgs) + else + bc_out(s)%rootr_pa(ifp,j) = bc_out(s)%rootr_pa(ifp,j) + & + currentPatch%rootr_ft(FT,j) * 1./numpft_ed + end if + enddo + enddo - currentPatch => map_clmpatch_to_edpatch(sites(s), p) - do FT = 1,numpft_ed - currentPatch%btran_ft(FT) = 0.0_r8 - do j = 1,nlevgrnd + + cpatch => cpatch%younger + end do + + end do + + + + + + 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)) @@ -199,6 +240,7 @@ subroutine btran_ed( bounds, p, sites, nsites, hsites, & end if enddo enddo + !--------------------------------------------------------------------------------------- diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index deb69ef1..200271e8 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -18,7 +18,7 @@ module FatesInterfaceMod use EDtypesMod , only : ed_site_type, & numPatchesPerCol use shr_kind_mod , only : r8 => shr_kind_r8 ! INTERF-TODO: REMOVE THIS - + use clm_varpar , only : nlevgrnd ! ------------------------------------------------------------------------------------ ! Certain dimension information used by FATES is dictated by the the driver @@ -32,8 +32,7 @@ module FatesInterfaceMod integer :: numSWBands ! Maximum number of broad-bands in the short-wave radiation ! specturm to track ! (typically 2 as a default, VIS/NIR, in ED variants <2016) - - + end type fates_dims_type @@ -53,12 +52,20 @@ module FatesInterfaceMod ! The actual number of FATES' ED patches integer :: npatches - ! Downwelling direct beam radiation (patch,broad-band) [W/m2?] - real(r8),allocatable :: solad_pa(:,:) + ! Downwelling direct beam radiation (patch,broad-band) [W/m2] + real(r8), allocatable :: solad_pa(:,:) ! Downwelling diffuse (I-ndirect) radiation (patch,broad-band) [W/m2] - real(r8),allocatable :: solai_pa(:,:) + real(r8), allocatable :: solai_pa(:,:) + ! Soil suction potential of layers in each site, negative, [mm] + real(r8), allocatable :: smp_sl(:) + + ! Effective porosity = porosity - vol_ic, of layers in each site [-] + real(r8), allocatable :: eff_porosity_sl(:) + + ! volumetric soil water at saturation (porosity) + real(r8), allocatable :: watsat_sl(:) end type bc_in_type @@ -68,6 +75,18 @@ module FatesInterfaceMod ! Sunlit fraction of the canopy for this patch [0-1] real(r8),allocatable :: fsun_pa(:) + ! Root soil water stress (resistance) by layer + ! (diagnostic, should not be used by HLM) + real(r8),allocatable :: rresis_pa(:,:) + + ! Effective fraction of roots in each soil layer + ! (diagnostic, should not be used by HLM) + real(r8), allocatable :: rootr_pa(:,:) + + ! Integrated (vertically) transpiration wetness factor (0 to 1) + ! (diagnostic, should not be used by HLM) + real(r8), allocatable :: btran_pa(:) + end type bc_out_type @@ -151,12 +170,25 @@ subroutine allocate_bcs(this,s) ! Allocate input boundaries + ! Radiation allocate(this%bc_in(s)%solad_pa(numPatchesPerCol,fates_dims%numSWBands)) allocate(this%bc_in(s)%solai_pa(numPatchesPerCol,fates_dims%numSWBands)) + + ! Hydrology + allocate(this%bc_in(s)%smp_sl(nlevgrnd)) + allocate(this%bc_in(s)%eff_porosity_sl(nlevgrnd)) + allocate(this%bc_in(s)%watsat_sl(nlevgrnd)) ! Allocate output boundaries - + + ! Radiation allocate(this%bc_out(s)%fsun_pa(numPatchesPerCol)) + + ! Hydrology + allocate(this%bc_out(s)%rresis_pa(numPatchesPerCol,nlevgrnd)) + allocate(this%bc_out(s)%rootr_pa(numPatchesPerCol,nlevgrnd)) + allocate(this%bc_out(s)%btran_pa(numPatchesPerCol)) + return end subroutine allocate_bcs @@ -171,13 +203,18 @@ subroutine zero_bcs(this,s) ! Input boundaries - this%bc_in(s)%solad_pa(:,:) = 0.0_r8 - this%bc_in(s)%solai_pa(:,:) = 0.0_r8 + this%bc_in(s)%solad_pa(:,:) = 0.0_r8 + this%bc_in(s)%solai_pa(:,:) = 0.0_r8 + this%bc_in(s)%smp_sl(:) = 0.0_r8 + this%bc_in(s)%eff_porosity_sl(:) = 0.0_r8 + this%bc_in(s)%watsat_sl(:) = 0.0_r8 ! Output boundaries this%bc_out(s)%fsun_pa(:) = 0.0_r8 - + this%bc_out(s)%rresis_pa(:) = 0.0_r8 + this%bc_out(s)%rootr_pa(:) = 0.0_r8 + this%bc_out(s)%btran_pa(:) = 0.0_r8 return end subroutine zero_bcs From ff2d1ff7f9e1406da20b2f77222695317b98de9f Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 28 Jun 2016 08:52:22 -0700 Subject: [PATCH 120/437] boundary condition work on Fates: prototype working for 1) allocation of bc structures, 2) use of bc structures in sunshade_fracs and btran, and 3) use of control parameters sent from host through a dictionary to allocate bc structures --- biogeophys/EDBtranMod.F90 | 625 +++++++++++++----------------- biogeophys/EDSurfaceAlbedoMod.F90 | 19 +- main/EDTypesMod.F90 | 22 ++ main/FatesInterfaceMod.F90 | 191 ++++++--- 4 files changed, 438 insertions(+), 419 deletions(-) diff --git a/biogeophys/EDBtranMod.F90 b/biogeophys/EDBtranMod.F90 index e24ce418..d9f5b464 100644 --- a/biogeophys/EDBtranMod.F90 +++ b/biogeophys/EDBtranMod.F90 @@ -4,384 +4,291 @@ module EDBtranMod ! Description: ! ! ------------------------------------------------------------------------------------ - - 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 - !------------------------------------------------------------------------------ + + use pftconMod , only : pftcon + use EDTypesMod , only : ed_site_type, & + ed_patch_type, & + ed_cohort_type, & + numpft_ed, & + ctrl_parms + use shr_kind_mod , only : r8 => shr_kind_r8 + use FatesInterfaceMod , only : bc_in_type, & + bc_out_type + use clm_varctl , only : iulog !INTERF-TODO: THIS SHOULD BE MOVED + + ! + 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( sites, nsites, bc_in, bc_out) - - - use shr_kind_mod , only : r8 => shr_kind_r8 - use EDtypesMod , only : ed_patch_type, ed_site_type - use FatesInterfaceMod , only : bc_in_type, & - bc_out_type - - ! Arguments - - type(ed_site_type),intent(inout),target :: sites(nsites) - integer,intent(in) :: nsites - type(bc_in_type),intent(in) :: bc_in(nsites) - type(bc_out_type),intent(out) :: bc_out(nsites) - - ! - ! !LOCAL VARIABLES: - integer :: iv !leaf layer - integer :: s !site - integer :: c !column - integer :: j !soil layer - integer :: ft ! plant functional type index - - - ! The root effective root fraction for different pfts and soil layers - real(r8) :: rootr(numpft_ed,nlevgrnd) - - !---------------------------------------------------------------------- - - ! 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 - !------------------------------------------------------------------------------ - - - do s = 1,nsites - - ifp = 0 - cpatch => sites(s)%oldest_patch - do while (associated(cpatch)) - ifp=ifp+1 - - do FT = 1,numpft_ed - currentPatch%btran_ft(FT) = 0.0_r8 - do j = 1,nlevgrnd - - if(bc_in(s)%smp_sl(j) > -900.0_r8 ) then ! The flag for frozen or no water is -999 - - smp_node = max(smpsc(FT), bc_in(s)%smp_sl(j)) - - rresis_ft = min( (bc_in(s)%eff_porosity_sl(j)/bc_in(s)%watsat(j))* & - (smp_node - smpsc(FT)) / (smpso(FT) - smpsc(FT)), 1._r8) - - - currentPatch%rootr_ft(FT,j) = currentPatch%rootfr_ft(FT,j)*rresis_ft - - ! 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) - - else - currentPatch%rootr_ft(FT,j) = 0._r8 - end if - - end do !j - - ! 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 - - - ! Process the boundary output, this is necessary for calculating the soil-moisture - ! sink term across the different layers in driver/host. Photosynthesis will - ! pass the host a total transpiration for the patch. This needs rootr to be - ! distributed over the soil layers. - - do j = 1,nlevgrnd - bc_out(s)%rootr_pa(ifp,j) = 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) - bc_out(s)%rootr_pa(ifp,j) = bc_out(s)%rootr_pa(ifp,j) + & - currentPatch%rootr_ft(FT,j) * pftgs(ft)/sum(pftgs) - else - bc_out(s)%rootr_pa(ifp,j) = bc_out(s)%rootr_pa(ifp,j) + & - currentPatch%rootr_ft(FT,j) * 1./numpft_ed - end if - enddo - enddo - - - - cpatch => cpatch%younger - end do - - end do - - - - - 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 - - ! 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 - 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 - - + ! ==================================================================================== + + subroutine btran_ed( sites, nsites, bc_in, bc_out) + + ! --------------------------------------------------------------------------------- + ! Calculate the transpiration wetness function (BTRAN) and the root uptake + ! distribution (ROOTR). + ! Boundary conditions in: bc_in(s)%eff_porosity_sl(j) unfrozen porosity + ! bc_in(s)%watsat_sl(j) porosity + ! bc_in(s)%active_uptake_sl(j) frozen/not frozen + ! bc_in(s)%smp_sl(j) suction + ! Boundary conditions out: bc_out(s)%rootr_pa root uptake distribution + ! bc_out(s)%btran_pa wetness factor + ! --------------------------------------------------------------------------------- + + + + ! Arguments + + type(ed_site_type),intent(inout),target :: sites(nsites) + integer,intent(in) :: nsites + type(bc_in_type),intent(in) :: bc_in(nsites) + type(bc_out_type),intent(inout) :: bc_out(nsites) + + ! + ! !LOCAL VARIABLES: + type(ed_patch_type),pointer :: cpatch ! Current Patch Pointer + integer :: s ! site + integer :: j ! soil layer + integer :: ifp ! patch vector index for the site + integer :: ft ! plant functional type index + real(r8) :: smp_node ! matrix potential + real(r8) :: rresis ! suction limitation to transpiration independent + ! of root density + real(r8) :: pftgs(numpft_ed) ! pft weighted stomatal conductance s/m + real(r8) :: temprootr + !------------------------------------------------------------------------------ + + associate( & + numlevgrnd => ctrl_parms%numlevgrnd , & + smpsc => pftcon%smpsc , & ! INTERF-TODO: THESE SHOULD BE FATES PARAMETERS + smpso => pftcon%smpso & ! INTERF-TODO: THESE SHOULD BE FATES PARAMETERS + ) + + do s = 1,nsites + + ifp = 0 + cpatch => sites(s)%oldest_patch + do while (associated(cpatch)) + ifp=ifp+1 + + ! THIS SHOULD REALLY BE A COHORT LOOP ONCE WE HAVE rootfr_ft FOR COHORTS (RGK) + + do ft = 1,numpft_ed + cpatch%btran_ft(ft) = 0.0_r8 + do j = 1,numlevgrnd + + ! Calculations are only relevant where liquid water exists + ! see clm_fates%wrap_btran for calculation with CLM/ALM + + if( bc_in(s)%active_uptake_sl(j) ) then + + smp_node = max(smpsc(ft), bc_in(s)%smp_sl(j)) + + rresis = min( (bc_in(s)%eff_porosity_sl(j)/bc_in(s)%watsat_sl(j))* & + (smp_node - smpsc(ft)) / (smpso(ft) - smpsc(ft)), 1._r8) + + cpatch%rootr_ft(ft,j) = cpatch%rootfr_ft(ft,j)*rresis + + ! root water uptake is not linearly proportional to root density, + ! to allow proper deep root funciton. Replace with equations from SPA/Newman. FIX(RF,032414) + ! cpatch%rootr_ft(ft,j) = cpatch%rootfr_ft(ft,j)**0.3*rresis_ft(ft,j)/ & + ! sum(cpatch%rootfr_ft(ft,1:nlevgrnd)**0.3) + cpatch%btran_ft(ft) = cpatch%btran_ft(ft) + cpatch%rootr_ft(ft,j) + + else + cpatch%rootr_ft(ft,j) = 0._r8 + end if + + end do !j + + ! Normalize root resistances to get layer contribution to ET + do j = 1,numlevgrnd + if (cpatch%btran_ft(ft) > 0.0_r8) then + cpatch%rootr_ft(ft,j) = cpatch%rootr_ft(ft,j)/cpatch%btran_ft(ft) + else + cpatch%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 => cpatch%tallest + do while(associated(currentCohort)) + pftgs(currentCohort%pft) = pftgs(currentCohort%pft) + currentCohort%gscan * currentCohort%n + currentCohort => currentCohort%shorter + enddo + + ! Process the boundary output, this is necessary for calculating the soil-moisture + ! sink term across the different layers in driver/host. Photosynthesis will + ! pass the host a total transpiration for the patch. This needs rootr to be + ! distributed over the soil layers. + + do j = 1,numlevgrnd + bc_out(s)%rootr_pa(ifp,j) = 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) + bc_out(s)%rootr_pa(ifp,j) = bc_out(s)%rootr_pa(ifp,j) + & + cpatch%rootr_ft(ft,j) * pftgs(ft)/sum(pftgs) + else + bc_out(s)%rootr_pa(ifp,j) = bc_out(s)%rootr_pa(ifp,j) + & + cpatch%rootr_ft(ft,j) * 1./numpft_ed + end if + enddo + enddo + + !weight patch level output BTRAN for the + bc_out(s)%btran_pa(ifp) = 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) + bc_out(s)%btran_pa(ifp) = bc_out(s)%btran_pa(ifp) + cpatch%btran_ft(ft) * pftgs(ft)/sum(pftgs) + else + bc_out(s)%btran_pa(ifp) = bc_out(s)%btran_pa(ifp) + cpatch%btran_ft(ft) * 1./numpft_ed + end if + enddo + + + + temprootr = sum(bc_out(s)%rootr_pa(ifp,:)) + if(temprootr /= 1.0_r8)then + write(iulog,*) 'error with rootr in canopy fluxes',temprootr + if(temprootr > 0._r8)then + do j = 1,numlevgrnd + bc_out(s)%rootr_pa(ifp,j) = bc_out(s)%rootr_pa(ifp,j)/temprootr + enddo + end if + end if + + cpatch => cpatch%younger + end do + end do + + end associate + + end subroutine btran_ed + + ! ========================================================================================= !--------------------------------------------------------------------------------------- ! 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 +! 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) * cpatch%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.cpatch%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 +! 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) +! 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 +! 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 ! +! 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 +! +! cpatch%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/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index d9b84bd5..a8df5e60 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -962,16 +962,16 @@ subroutine ED_SunShadeFracs(sites,nsites,bc_in,bc_out) use clm_varctl , only : iulog + implicit none + ! Arguments - type(ed_site_type),intent(inout),target :: sites(nsites) integer,intent(in) :: nsites type(bc_in_type),intent(in) :: bc_in(nsites) - type(bc_out_type),intent(out) :: bc_out(nsites) + type(bc_out_type),intent(inout) :: bc_out(nsites) ! locals - type (ed_patch_type),pointer :: cpatch ! c"urrent" patch real(r8) :: sunlai real(r8) :: shalai @@ -983,20 +983,24 @@ subroutine ED_SunShadeFracs(sites,nsites,bc_in,bc_out) do s = 1,nsites - + ifp = 0 cpatch => sites(s)%oldest_patch + do while (associated(cpatch)) ifp=ifp+1 - + + if( DEBUG ) write(iulog,*) 'edsurfRad_5600',ifp,s,cpatch%NCL_p,numpft_ed + ! zero out various datas cpatch%ed_parsun_z(:,:,:) = 0._r8 cpatch%ed_parsha_z(:,:,:) = 0._r8 cpatch%ed_laisun_z(:,:,:) = 0._r8 cpatch%ed_laisha_z(:,:,:) = 0._r8 - + bc_out(s)%fsun_pa(ifp) = 0._r8 + sunlai = 0._r8 shalai = 0._r8 @@ -1009,6 +1013,9 @@ subroutine ED_SunShadeFracs(sites,nsites,bc_in,bc_out) do CL = 1, cpatch%NCL_p do FT = 1,numpft_ed + + if( DEBUG ) write(iulog,*) 'edsurfRad_5601',CL,FT,cpatch%nrad(CL,ft) + do iv = 1, cpatch%nrad(CL,ft) !NORMAL CASE. ! FIX(SPM,040114) - existing comment diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index e167744a..5dd71ff2 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -106,6 +106,28 @@ module EDTypesMod integer , allocatable :: pft_levscpf_ed(:) integer , allocatable :: scls_levscpf_ed(:) + + + type, private :: ctrl_parms_type + + + ! These parameters are dictated by FATES internals + + + + + ! These parameters are dictated by the host model or driver + + integer :: numSWBands ! Maximum number of broad-bands in the short-wave radiation + ! specturm to track + ! (typically 2 as a default, VIS/NIR, in ED variants <2016) + + integer :: numlevgrnd ! Number of soil layers + + end type ctrl_parms_type + + type(ctrl_parms_type), public :: ctrl_parms + !************************************ !** COHORT type structure ** diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 200271e8..ef10b388 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -16,26 +16,12 @@ module FatesInterfaceMod ! ------------------------------------------------------------------------------------ use EDtypesMod , only : ed_site_type, & - numPatchesPerCol + numPatchesPerCol, & + ctrl_parms + use shr_kind_mod , only : r8 => shr_kind_r8 ! INTERF-TODO: REMOVE THIS use clm_varpar , only : nlevgrnd - ! ------------------------------------------------------------------------------------ - ! Certain dimension information used by FATES is dictated by the the driver - ! or the host model, or perhaps may be some compromise between what FATES will want - ! in a best-case scenario and what space the driver/host will allow based on its - ! memory constraints (most-likely due to IO) - ! ------------------------------------------------------------------------------------ - - type, private :: fates_dims_type - - integer :: numSWBands ! Maximum number of broad-bands in the short-wave radiation - ! specturm to track - ! (typically 2 as a default, VIS/NIR, in ED variants <2016) - - end type fates_dims_type - - ! ------------------------------------------------------------------------------------ ! Notes on types @@ -67,6 +53,11 @@ module FatesInterfaceMod ! volumetric soil water at saturation (porosity) real(r8), allocatable :: watsat_sl(:) + ! If there is no liquid volume of water in a soil layer, or + ! if the layer is 2 degrees below freezing, the layer will not + ! be deemed active for water uptake via transpiration and photosynthesis + logical, allocatable :: active_uptake_sl(:) + end type bc_in_type @@ -77,7 +68,8 @@ module FatesInterfaceMod ! Root soil water stress (resistance) by layer ! (diagnostic, should not be used by HLM) - real(r8),allocatable :: rresis_pa(:,:) +! real(r8),allocatable :: rresis_pa(:,:) ! not used by host, not calculated + ! yet by FATES ! Effective fraction of roots in each soil layer ! (diagnostic, should not be used by HLM) @@ -117,19 +109,12 @@ module FatesInterfaceMod contains - procedure, public :: allocate_bcs procedure, public :: zero_bcs end type fates_interface_type - ! ------------------------------------------------------------------------------------ - ! Dimension information is independent of which clump it is on - ! and since these are typically read only variables and never updated on the clump - ! we need not attach these to the threaded instances of the fates_interface_type - ! ------------------------------------------------------------------------------------ - - type(fates_dims_type) :: fates_dims - + + public :: set_fates_ctrlparms contains @@ -158,40 +143,49 @@ end subroutine fates_clean ! ==================================================================================== - subroutine allocate_bcs(this,s) + subroutine allocate_bcin(bc_in) ! --------------------------------------------------------------------------------- ! Allocate and Initialze the FATES boundary condition vectors ! --------------------------------------------------------------------------------- - + implicit none - class(fates_interface_type), intent(inout) :: this - integer, intent(in) :: s + type(bc_in_type), intent(inout) :: bc_in ! Allocate input boundaries ! Radiation - allocate(this%bc_in(s)%solad_pa(numPatchesPerCol,fates_dims%numSWBands)) - allocate(this%bc_in(s)%solai_pa(numPatchesPerCol,fates_dims%numSWBands)) - + allocate(bc_in%solad_pa(numPatchesPerCol,ctrl_parms%numSWBands)) + allocate(bc_in%solai_pa(numPatchesPerCol,ctrl_parms%numSWBands)) + ! Hydrology - allocate(this%bc_in(s)%smp_sl(nlevgrnd)) - allocate(this%bc_in(s)%eff_porosity_sl(nlevgrnd)) - allocate(this%bc_in(s)%watsat_sl(nlevgrnd)) + allocate(bc_in%smp_sl(ctrl_parms%numlevgrnd)) + allocate(bc_in%eff_porosity_sl(ctrl_parms%numlevgrnd)) + allocate(bc_in%watsat_sl(ctrl_parms%numlevgrnd)) + allocate(bc_in%active_uptake_sl(ctrl_parms%numlevgrnd)) - ! Allocate output boundaries + return + end subroutine allocate_bcin + + subroutine allocate_bcout(bc_out) + ! --------------------------------------------------------------------------------- + ! Allocate and Initialze the FATES boundary condition vectors + ! --------------------------------------------------------------------------------- + + implicit none + type(bc_out_type), intent(inout) :: bc_out + + ! Radiation - allocate(this%bc_out(s)%fsun_pa(numPatchesPerCol)) + allocate(bc_out%fsun_pa(numPatchesPerCol)) ! Hydrology - allocate(this%bc_out(s)%rresis_pa(numPatchesPerCol,nlevgrnd)) - allocate(this%bc_out(s)%rootr_pa(numPatchesPerCol,nlevgrnd)) - allocate(this%bc_out(s)%btran_pa(numPatchesPerCol)) - - + allocate(bc_out%rootr_pa(numPatchesPerCol,ctrl_parms%numlevgrnd)) + allocate(bc_out%btran_pa(numPatchesPerCol)) + return - end subroutine allocate_bcs + end subroutine allocate_bcout ! ==================================================================================== @@ -203,21 +197,110 @@ subroutine zero_bcs(this,s) ! Input boundaries - this%bc_in(s)%solad_pa(:,:) = 0.0_r8 - this%bc_in(s)%solai_pa(:,:) = 0.0_r8 - this%bc_in(s)%smp_sl(:) = 0.0_r8 - this%bc_in(s)%eff_porosity_sl(:) = 0.0_r8 - this%bc_in(s)%watsat_sl(:) = 0.0_r8 + this%bc_in(s)%solad_pa(:,:) = 0.0_r8 + this%bc_in(s)%solai_pa(:,:) = 0.0_r8 + this%bc_in(s)%smp_sl(:) = 0.0_r8 + this%bc_in(s)%eff_porosity_sl(:) = 0.0_r8 + this%bc_in(s)%watsat_sl(:) = 0.0_r8 + this%bc_in(s)%active_uptake_sl(:) = .false. ! Output boundaries - this%bc_out(s)%fsun_pa(:) = 0.0_r8 - this%bc_out(s)%rresis_pa(:) = 0.0_r8 - this%bc_out(s)%rootr_pa(:) = 0.0_r8 - this%bc_out(s)%btran_pa(:) = 0.0_r8 + this%bc_out(s)%fsun_pa(:) = 0.0_r8 + this%bc_out(s)%rootr_pa(:,:) = 0.0_r8 + this%bc_out(s)%btran_pa(:) = 0.0_r8 return end subroutine zero_bcs + + ! ==================================================================================== + + subroutine set_fates_ctrlparms(tag,dimval) + + ! --------------------------------------------------------------------------------- + ! INTERF-TODO: NEED ALLOWANCES FOR REAL AND CHARACTER ARGS.. + ! Certain model control parameters and dimensions used by FATES are dictated by + ! the the driver or the host mode. To see which parameters should be filled here + ! please also look at the ctrl_parms_type in FATESTYpeMod, in the section listing + ! components dictated by the host model. + ! + ! Some important points: + ! 1. Calls to this function are likely from the clm_fates module in the HLM. + ! 2. The calls should be preceeded by a flush function. + ! 3. All values in ctrl_parm (FATESTypesMod.F90) that are classified as + ! 'dictated by the HLM' must be listed in this subroutine + ! 4. Should look like this: + ! + ! call set_fates_ctrlparms('flush_to_unset') + ! call set_fates_ctrlparms('num_sw_bbands',numrad) ! or other variable + ! ... + ! call set_fates_ctrlparms('num_lev_ground',nlevgrnd) ! or other variable + ! call set_fates_ctrlparms('check_allset') + ! + ! RGK-2016 + ! --------------------------------------------------------------------------------- + + ! Arguments + integer, optional, intent(in) :: dimval + character(len=*),intent(in) :: tag + + ! local variables + logical :: all_set + integer, parameter :: unset_int = -999 + real(r8), parameter :: unset_double = -999.9 + + select case (trim(tag)) + case('flush_to_unset') + + write(*,*) 'Flushing FATES control parameters prior to transfer from host' + ctrl_parms%numSwBands = unset_int + ctrl_parms%numlevgrnd = unset_int + + case('check_allset') + + if(ctrl_parms%numSWBands .eq. unset_int) then + write(*,*) 'FATES dimension/parameter unset: num_sw_rad_bbands' + ! INTERF-TODO: FATES NEEDS INTERNAL end_run + ! end_run('MESSAGE') + end if + + if(ctrl_parms%numlevgrnd .eq. unset_int) then + write(*,*) 'FATES dimension/parameter unset: numlevground' + ! INTERF-TODO: FATES NEEDS INTERNAL end_run + ! end_run('MESSAGE') + end if + + write(*,*) 'Checked. All control parameters sent to FATES.' + + case default + + if(present(dimval))then + select case (trim(tag)) + + case('num_sw_bbands') + + ctrl_parms%numSwBands = dimval + write(*,*) 'Transfering num_sw_bbands = ',dimval,' to FATES' + + case('num_lev_ground') + + ctrl_parms%numlevgrnd = dimval + write(*,*) 'Transfering num_lev_ground = ',dimval,' to FATES' + + case default + write(*,*) 'tag not recognized:',trim(tag) + ! end_run + end select + else + write(*,*) 'no value was provided for the tag' + end if + + end select + + + return + end subroutine set_fates_ctrlparms + end module FatesInterfaceMod From 3ee5771a3225b49250689ebfe5d9a1f90242c2a8 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 1 Jul 2016 09:38:47 -0700 Subject: [PATCH 121/437] 1) Changed naming convention of some boundary condition variables per suggestion by D Lawrence. 2) moved a logical step related to btran to be inside the fates btran calculation, to do this I moved the soil volume and temperature variables to boundary conditions and removed the active flag logical --- biogeophys/EDBtranMod.F90 | 29 ++++++------- biogeophys/EDSurfaceAlbedoMod.F90 | 12 +++--- main/FatesInterfaceMod.F90 | 70 ++++++++++++++++--------------- 3 files changed, 57 insertions(+), 54 deletions(-) diff --git a/biogeophys/EDBtranMod.F90 b/biogeophys/EDBtranMod.F90 index d9f5b464..c0fc9179 100644 --- a/biogeophys/EDBtranMod.F90 +++ b/biogeophys/EDBtranMod.F90 @@ -6,6 +6,7 @@ module EDBtranMod ! ------------------------------------------------------------------------------------ use pftconMod , only : pftcon + use clm_varcon , only : tfrz use EDTypesMod , only : ed_site_type, & ed_patch_type, & ed_cohort_type, & @@ -34,11 +35,11 @@ subroutine btran_ed( sites, nsites, bc_in, bc_out) ! --------------------------------------------------------------------------------- ! Calculate the transpiration wetness function (BTRAN) and the root uptake ! distribution (ROOTR). - ! Boundary conditions in: bc_in(s)%eff_porosity_sl(j) unfrozen porosity - ! bc_in(s)%watsat_sl(j) porosity - ! bc_in(s)%active_uptake_sl(j) frozen/not frozen - ! bc_in(s)%smp_sl(j) suction - ! Boundary conditions out: bc_out(s)%rootr_pa root uptake distribution + ! Boundary conditions in: bc_in(s)%eff_porosity_gl(j) unfrozen porosity + ! bc_in(s)%watsat_gl(j) porosity + ! bc_in(s)%active_uptake_gl(j) frozen/not frozen + ! bc_in(s)%smp_gl(j) suction + ! Boundary conditions out: bc_out(s)%rootr_pagl root uptake distribution ! bc_out(s)%btran_pa wetness factor ! --------------------------------------------------------------------------------- @@ -86,12 +87,12 @@ subroutine btran_ed( sites, nsites, bc_in, bc_out) ! Calculations are only relevant where liquid water exists ! see clm_fates%wrap_btran for calculation with CLM/ALM - - if( bc_in(s)%active_uptake_sl(j) ) then + + if ( bc_in(s)%h2o_liqvol_gl(j) .gt. 0._r8 .and. bc_in(s)%tempk_gl(j) .gt. tfrz-2._r8) then - smp_node = max(smpsc(ft), bc_in(s)%smp_sl(j)) + smp_node = max(smpsc(ft), bc_in(s)%smp_gl(j)) - rresis = min( (bc_in(s)%eff_porosity_sl(j)/bc_in(s)%watsat_sl(j))* & + rresis = min( (bc_in(s)%eff_porosity_gl(j)/bc_in(s)%watsat_gl(j))* & (smp_node - smpsc(ft)) / (smpso(ft) - smpsc(ft)), 1._r8) cpatch%rootr_ft(ft,j) = cpatch%rootfr_ft(ft,j)*rresis @@ -134,14 +135,14 @@ subroutine btran_ed( sites, nsites, bc_in, bc_out) ! distributed over the soil layers. do j = 1,numlevgrnd - bc_out(s)%rootr_pa(ifp,j) = 0._r8 + bc_out(s)%rootr_pagl(ifp,j) = 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) - bc_out(s)%rootr_pa(ifp,j) = bc_out(s)%rootr_pa(ifp,j) + & + bc_out(s)%rootr_pagl(ifp,j) = bc_out(s)%rootr_pagl(ifp,j) + & cpatch%rootr_ft(ft,j) * pftgs(ft)/sum(pftgs) else - bc_out(s)%rootr_pa(ifp,j) = bc_out(s)%rootr_pa(ifp,j) + & + bc_out(s)%rootr_pagl(ifp,j) = bc_out(s)%rootr_pagl(ifp,j) + & cpatch%rootr_ft(ft,j) * 1./numpft_ed end if enddo @@ -160,12 +161,12 @@ subroutine btran_ed( sites, nsites, bc_in, bc_out) - temprootr = sum(bc_out(s)%rootr_pa(ifp,:)) + temprootr = sum(bc_out(s)%rootr_pagl(ifp,:)) if(temprootr /= 1.0_r8)then write(iulog,*) 'error with rootr in canopy fluxes',temprootr if(temprootr > 0._r8)then do j = 1,numlevgrnd - bc_out(s)%rootr_pa(ifp,j) = bc_out(s)%rootr_pa(ifp,j)/temprootr + bc_out(s)%rootr_pagl(ifp,j) = bc_out(s)%rootr_pagl(ifp,j)/temprootr enddo end if end if diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index a8df5e60..7aedb32e 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -1065,21 +1065,21 @@ subroutine ED_SunShadeFracs(sites,nsites,bc_in,bc_out) if ( DEBUG ) then write(iulog,*) 'edsurfRad 653 ', cpatch%ed_parsun_z(CL,ft,iv) - write(iulog,*) 'edsurfRad 654 ', bc_in(s)%solad_pa(ifp,ipar) - write(iulog,*) 'edsurfRad 655 ', bc_in(s)%solai_pa(ifp,ipar) + write(iulog,*) 'edsurfRad 654 ', bc_in(s)%solad_parb(ifp,ipar) + write(iulog,*) 'edsurfRad 655 ', bc_in(s)%solai_parb(ifp,ipar) write(iulog,*) 'edsurfRad 656 ', cpatch%fabd_sun_z(CL,ft,iv) write(iulog,*) 'edsurfRad 657 ', cpatch%fabi_sun_z(CL,ft,iv) endif cpatch%ed_parsun_z(CL,ft,iv) = & - bc_in(s)%solad_pa(ifp,ipar)*cpatch%fabd_sun_z(CL,ft,iv) + & - bc_in(s)%solai_pa(ifp,ipar)*cpatch%fabi_sun_z(CL,ft,iv) + bc_in(s)%solad_parb(ifp,ipar)*cpatch%fabd_sun_z(CL,ft,iv) + & + bc_in(s)%solai_parb(ifp,ipar)*cpatch%fabi_sun_z(CL,ft,iv) if ( DEBUG )write(iulog,*) 'edsurfRad 663 ', cpatch%ed_parsun_z(CL,ft,iv) cpatch%ed_parsha_z(CL,ft,iv) = & - bc_in(s)%solad_pa(ifp,ipar)*cpatch%fabd_sha_z(CL,ft,iv) + & - bc_in(s)%solai_pa(ifp,ipar)*cpatch%fabi_sha_z(CL,ft,iv) + bc_in(s)%solad_parb(ifp,ipar)*cpatch%fabd_sha_z(CL,ft,iv) + & + bc_in(s)%solai_parb(ifp,ipar)*cpatch%fabi_sha_z(CL,ft,iv) if ( DEBUG ) write(iulog,*) 'edsurfRad 669 ', cpatch%ed_parsha_z(CL,ft,iv) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index ef10b388..1394145a 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -31,6 +31,9 @@ module FatesInterfaceMod ! or alias other variables, ALLOCATABLES cannnot. According to S. Lionel ! (Intel-Forum Post), ALLOCATABLES are better perfomance wise as long as they point ! to contiguous memory spaces and do not alias other variables, the case here. + ! Naming conventions: _gl means ground layer dimensions + ! _pa means patch dimensions + ! _rb means radiation band ! ------------------------------------------------------------------------------------ type, public :: bc_in_type @@ -38,25 +41,27 @@ module FatesInterfaceMod ! The actual number of FATES' ED patches integer :: npatches - ! Downwelling direct beam radiation (patch,broad-band) [W/m2] - real(r8), allocatable :: solad_pa(:,:) + ! Downwelling direct beam radiation (patch,radiation-band) [W/m2] + real(r8), allocatable :: solad_parb(:,:) - ! Downwelling diffuse (I-ndirect) radiation (patch,broad-band) [W/m2] - real(r8), allocatable :: solai_pa(:,:) + ! Downwelling diffuse (I-ndirect) radiation (patch,radiation-band) [W/m2] + real(r8), allocatable :: solai_parb(:,:) ! Soil suction potential of layers in each site, negative, [mm] - real(r8), allocatable :: smp_sl(:) + real(r8), allocatable :: smp_gl(:) ! Effective porosity = porosity - vol_ic, of layers in each site [-] - real(r8), allocatable :: eff_porosity_sl(:) + real(r8), allocatable :: eff_porosity_gl(:) ! volumetric soil water at saturation (porosity) - real(r8), allocatable :: watsat_sl(:) + real(r8), allocatable :: watsat_gl(:) + + ! Temperature of ground layers [K] + real(r8), allocatable :: tempk_gl(:) + + ! Liquid volume in ground layer + real(r8), allocatable :: h2o_liqvol_gl(:) - ! If there is no liquid volume of water in a soil layer, or - ! if the layer is 2 degrees below freezing, the layer will not - ! be deemed active for water uptake via transpiration and photosynthesis - logical, allocatable :: active_uptake_sl(:) end type bc_in_type @@ -66,14 +71,8 @@ module FatesInterfaceMod ! Sunlit fraction of the canopy for this patch [0-1] real(r8),allocatable :: fsun_pa(:) - ! Root soil water stress (resistance) by layer - ! (diagnostic, should not be used by HLM) -! real(r8),allocatable :: rresis_pa(:,:) ! not used by host, not calculated - ! yet by FATES - ! Effective fraction of roots in each soil layer - ! (diagnostic, should not be used by HLM) - real(r8), allocatable :: rootr_pa(:,:) + real(r8), allocatable :: rootr_pagl(:,:) ! Integrated (vertically) transpiration wetness factor (0 to 1) ! (diagnostic, should not be used by HLM) @@ -155,14 +154,15 @@ subroutine allocate_bcin(bc_in) ! Allocate input boundaries ! Radiation - allocate(bc_in%solad_pa(numPatchesPerCol,ctrl_parms%numSWBands)) - allocate(bc_in%solai_pa(numPatchesPerCol,ctrl_parms%numSWBands)) + allocate(bc_in%solad_parb(numPatchesPerCol,ctrl_parms%numSWBands)) + allocate(bc_in%solai_parb(numPatchesPerCol,ctrl_parms%numSWBands)) ! Hydrology - allocate(bc_in%smp_sl(ctrl_parms%numlevgrnd)) - allocate(bc_in%eff_porosity_sl(ctrl_parms%numlevgrnd)) - allocate(bc_in%watsat_sl(ctrl_parms%numlevgrnd)) - allocate(bc_in%active_uptake_sl(ctrl_parms%numlevgrnd)) + allocate(bc_in%smp_gl(ctrl_parms%numlevgrnd)) + allocate(bc_in%eff_porosity_gl(ctrl_parms%numlevgrnd)) + allocate(bc_in%watsat_gl(ctrl_parms%numlevgrnd)) + allocate(bc_in%tempk_gl(ctrl_parms%numlevgrnd)) + allocate(bc_in%h2o_liqvol_gl(ctrl_parms%numlevgrnd)) return end subroutine allocate_bcin @@ -181,9 +181,10 @@ subroutine allocate_bcout(bc_out) allocate(bc_out%fsun_pa(numPatchesPerCol)) ! Hydrology - allocate(bc_out%rootr_pa(numPatchesPerCol,ctrl_parms%numlevgrnd)) + allocate(bc_out%rootr_pagl(numPatchesPerCol,ctrl_parms%numlevgrnd)) allocate(bc_out%btran_pa(numPatchesPerCol)) + return end subroutine allocate_bcout @@ -197,18 +198,19 @@ subroutine zero_bcs(this,s) ! Input boundaries - this%bc_in(s)%solad_pa(:,:) = 0.0_r8 - this%bc_in(s)%solai_pa(:,:) = 0.0_r8 - this%bc_in(s)%smp_sl(:) = 0.0_r8 - this%bc_in(s)%eff_porosity_sl(:) = 0.0_r8 - this%bc_in(s)%watsat_sl(:) = 0.0_r8 - this%bc_in(s)%active_uptake_sl(:) = .false. + this%bc_in(s)%solad_parb(:,:) = 0.0_r8 + this%bc_in(s)%solai_parb(:,:) = 0.0_r8 + this%bc_in(s)%smp_gl(:) = 0.0_r8 + this%bc_in(s)%eff_porosity_gl(:) = 0.0_r8 + this%bc_in(s)%watsat_gl(:) = 0.0_r8 + this%bc_in(s)%tempk_gl(:) = 0.0_r8 + this%bc_in(s)%h2o_liqvol_gl(:) = 0.0_r8 ! Output boundaries - this%bc_out(s)%fsun_pa(:) = 0.0_r8 - this%bc_out(s)%rootr_pa(:,:) = 0.0_r8 - this%bc_out(s)%btran_pa(:) = 0.0_r8 + this%bc_out(s)%fsun_pa(:) = 0.0_r8 + this%bc_out(s)%rootr_pagl(:,:) = 0.0_r8 + this%bc_out(s)%btran_pa(:) = 0.0_r8 return end subroutine zero_bcs From 34822f97fdef3d29438348bded03a748a904b2bb Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Sun, 3 Jul 2016 18:10:03 -0400 Subject: [PATCH 122/437] Added a call to determine active layers with plant water uptake. Could not embed this logic inside the btran because the active layer filters are also needed for determining which layers suction can be calculated for, but this is outside of FATES perview, so a call before btran was made. --- biogeophys/EDBtranMod.F90 | 66 +++++++++++++++++++++++++++++++------- main/FatesInterfaceMod.F90 | 8 ++++- 2 files changed, 61 insertions(+), 13 deletions(-) diff --git a/biogeophys/EDBtranMod.F90 b/biogeophys/EDBtranMod.F90 index c0fc9179..b2270559 100644 --- a/biogeophys/EDBtranMod.F90 +++ b/biogeophys/EDBtranMod.F90 @@ -22,15 +22,58 @@ module EDBtranMod private public :: btran_ed - ! - type(ed_cohort_type), pointer :: currentCohort ! current cohort - type(ed_patch_type) , pointer :: currentPatch ! current patch + public :: get_active_suction_layers contains - ! ==================================================================================== + ! ==================================================================================== + + logical function check_layer_water(h2o_liq_vol, tempk) + + implicit none + ! Arguments + real(r8) :: h2o_liq_vol + real(r8) :: tempk + + if ( h2o_liq_vol .gt. 0._r8 .and. tempk .gt. tfrz-2._r8) then + check_layer_water = .true. + else + check_layer_water = .false. + end if + return + end function check_layer_water + + ! ===================================================================================== + + subroutine get_active_suction_layers(sites,nsites,bc_in,bc_out) + + ! Arguments + + type(ed_site_type),intent(inout),target :: sites(nsites) + integer,intent(in) :: nsites + type(bc_in_type),intent(in) :: bc_in(nsites) + type(bc_out_type),intent(inout) :: bc_out(nsites) + + ! !LOCAL VARIABLES: + integer :: s ! site + integer :: j ! soil layer + !------------------------------------------------------------------------------ + + associate( & + numlevgrnd => ctrl_parms%numlevgrnd ) + + do s = 1,nsites + do j = 1,numlevgrnd + bc_out(s)%active_suction_gl(j) = check_layer_water(bc_in(s)%h2o_liqvol_gl(j),bc_in(s)%tempk_gl(j) ) + end do + end do + + end associate + end subroutine get_active_suction_layers + + ! ===================================================================================== - subroutine btran_ed( sites, nsites, bc_in, bc_out) + subroutine btran_ed( sites, nsites, bc_in, bc_out) ! --------------------------------------------------------------------------------- ! Calculate the transpiration wetness function (BTRAN) and the root uptake @@ -42,8 +85,6 @@ subroutine btran_ed( sites, nsites, bc_in, bc_out) ! Boundary conditions out: bc_out(s)%rootr_pagl root uptake distribution ! bc_out(s)%btran_pa wetness factor ! --------------------------------------------------------------------------------- - - ! Arguments @@ -55,6 +96,7 @@ subroutine btran_ed( sites, nsites, bc_in, bc_out) ! ! !LOCAL VARIABLES: type(ed_patch_type),pointer :: cpatch ! Current Patch Pointer + type(ed_cohort_type),pointer :: ccohort ! Current cohort pointer integer :: s ! site integer :: j ! soil layer integer :: ifp ! patch vector index for the site @@ -88,7 +130,7 @@ subroutine btran_ed( sites, nsites, bc_in, bc_out) ! Calculations are only relevant where liquid water exists ! see clm_fates%wrap_btran for calculation with CLM/ALM - if ( bc_in(s)%h2o_liqvol_gl(j) .gt. 0._r8 .and. bc_in(s)%tempk_gl(j) .gt. tfrz-2._r8) then + if ( check_layer_water(bc_in(s)%h2o_liqvol_gl(j),bc_in(s)%tempk_gl(j)) ) then smp_node = max(smpsc(ft), bc_in(s)%smp_gl(j)) @@ -123,10 +165,10 @@ subroutine btran_ed( sites, nsites, bc_in, bc_out) ! 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 => cpatch%tallest - do while(associated(currentCohort)) - pftgs(currentCohort%pft) = pftgs(currentCohort%pft) + currentCohort%gscan * currentCohort%n - currentCohort => currentCohort%shorter + ccohort => cpatch%tallest + do while(associated(ccohort)) + pftgs(ccohort%pft) = pftgs(ccohort%pft) + ccohort%gscan * ccohort%n + ccohort => ccohort%shorter enddo ! Process the boundary output, this is necessary for calculating the soil-moisture diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 1394145a..7266f1d8 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -71,6 +71,11 @@ module FatesInterfaceMod ! Sunlit fraction of the canopy for this patch [0-1] real(r8),allocatable :: fsun_pa(:) + ! Logical stating whether a ground layer can have water uptake by plants + ! The only condition right now is that liquid water exists + ! The name (suction) is used to indicate that soil suction should be calculated + logical, allocatable :: active_suction_gl(:) + ! Effective fraction of roots in each soil layer real(r8), allocatable :: rootr_pagl(:,:) @@ -181,6 +186,7 @@ subroutine allocate_bcout(bc_out) allocate(bc_out%fsun_pa(numPatchesPerCol)) ! Hydrology + allocate(bc_out%active_suction_gl(ctrl_parms%numlevgrnd)) allocate(bc_out%rootr_pagl(numPatchesPerCol,ctrl_parms%numlevgrnd)) allocate(bc_out%btran_pa(numPatchesPerCol)) @@ -207,7 +213,7 @@ subroutine zero_bcs(this,s) this%bc_in(s)%h2o_liqvol_gl(:) = 0.0_r8 ! Output boundaries - + this%bc_out(s)%active_suction_gl(:) = .false. this%bc_out(s)%fsun_pa(:) = 0.0_r8 this%bc_out(s)%rootr_pagl(:,:) = 0.0_r8 this%bc_out(s)%btran_pa(:) = 0.0_r8 From 36fbb223e01d1967355b097f04d4d404e3c2f660 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Sun, 3 Jul 2016 20:12:05 -0400 Subject: [PATCH 123/437] optimized the logical function that tests if liquid soil water is present for uptake. --- biogeophys/EDBtranMod.F90 | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/biogeophys/EDBtranMod.F90 b/biogeophys/EDBtranMod.F90 index b2270559..a3537449 100644 --- a/biogeophys/EDBtranMod.F90 +++ b/biogeophys/EDBtranMod.F90 @@ -32,13 +32,14 @@ logical function check_layer_water(h2o_liq_vol, tempk) implicit none ! Arguments - real(r8) :: h2o_liq_vol - real(r8) :: tempk - - if ( h2o_liq_vol .gt. 0._r8 .and. tempk .gt. tfrz-2._r8) then - check_layer_water = .true. - else - check_layer_water = .false. + real(r8),intent(in) :: h2o_liq_vol + real(r8),intent(in) :: tempk + + check_layer_water = .false. + if ( h2o_liq_vol .gt. 0._r8 ) then + if ( tempk .gt. tfrz-2._r8) then + check_layer_water = .true. + end if end if return end function check_layer_water @@ -64,7 +65,7 @@ subroutine get_active_suction_layers(sites,nsites,bc_in,bc_out) do s = 1,nsites do j = 1,numlevgrnd - bc_out(s)%active_suction_gl(j) = check_layer_water(bc_in(s)%h2o_liqvol_gl(j),bc_in(s)%tempk_gl(j) ) + bc_out(s)%active_suction_gl(j) = check_layer_water( bc_in(s)%h2o_liqvol_gl(j),bc_in(s)%tempk_gl(j) ) end do end do From f42826d77b31978a1362ab454f4aab3bdf357984 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 13 Jul 2016 16:39:29 -0400 Subject: [PATCH 124/437] migrated to a restart IO allocation scheme where cohorts are only allocated on naturally vegetated columns. this should reduce the memory footprint of restart files considerably, and also works with the layout of the subroutines in the host model more cleanly. --- main/EDRestVectorMod.F90 | 245 ++++++++++++++++++++++----------------- 1 file changed, 140 insertions(+), 105 deletions(-) diff --git a/main/EDRestVectorMod.F90 b/main/EDRestVectorMod.F90 index e4704819..a58fb338 100755 --- a/main/EDRestVectorMod.F90 +++ b/main/EDRestVectorMod.F90 @@ -627,7 +627,10 @@ subroutine setVectors( this, bounds, sites, nsites, fcolumn ) if (this%DEBUG) then call this%printIoInfoLL ( bounds, sites, nsites, fcolumn ) call this%printDataInfoLL ( bounds, sites, nsites ) - call this%printDataInfoVector ( ) + + ! RGK: Commenting this out because it is calling several + ! variables over the wrong indices +! call this%printDataInfoVector ( ) end if end subroutine setVectors @@ -649,8 +652,6 @@ subroutine getVectors( this, bounds, sites, nsites, fcolumn) type(ed_site_type) , intent(inout), target :: sites(nsites) integer , intent(in) :: nsites integer , intent(in) :: fcolumn(nsites) - - ! ! !LOCAL VARIABLES: integer :: s @@ -695,281 +696,296 @@ subroutine doVectorIO( this, ncid, flag ) ! ! !LOCAL VARIABLES: logical :: readvar - character(len=16) :: dimName = trim(nameCohort) + character(len=16) :: coh_dimName = trim(nameCohort) + character(len=16) :: col_dimName = trim(namec) !----------------------------------------------------------------------- + + if(this%DEBUG) then + write(iulog,*) 'flag:',flag + write(iulog,*) 'dimname:',col_dimName + write(iulog,*) 'readvar:',readvar + write(iulog,*) 'associated?',associated(this%numPatchesPerCol) + write(iulog,*) '' + write(iulog,*) 'col size:',size(this%numPatchesPerCol) + write(iulog,*) 'col lbound:',lbound(this%numPatchesPerCol) + write(iulog,*) 'col ubound:',ubound(this%numPatchesPerCol) + + write(iulog,*) 'coh size:',size(this%cohortsPerPatch) + write(iulog,*) 'coh lbound:',lbound(this%cohortsPerPatch) + write(iulog,*) 'coh ubound:',ubound(this%cohortsPerPatch) + write(iulog,*) '' + end if + call restartvar(ncid=ncid, flag=flag, varname='ed_io_numPatchesPerCol', xtype=ncd_int, & - dim1name=namec, & + dim1name=col_dimName, & long_name='Num patches per column', units='unitless', & interpinic_flag='interp', data=this%numPatchesPerCol, & readvar=readvar) - + call restartvar(ncid=ncid, flag=flag, varname='ed_old_stock', xtype=ncd_double, & - dim1name=namec, & + dim1name=col_dimName, & long_name='ed cohort - old_stock', units='unitless', & interpinic_flag='interp', data=this%old_stock, & readvar=readvar) call restartvar(ncid=ncid, flag=flag, varname='ed_cd_status', xtype=ncd_double, & - dim1name=namec, & + dim1name=col_dimName, & long_name='ed cold dec status', units='unitless', & interpinic_flag='interp', data=this%cd_status, & readvar=readvar) - call restartvar(ncid=ncid, flag=flag, varname='ed_dd_status', xtype=ncd_double, & - dim1name=namec, & + dim1name=col_dimName, & long_name='ed drought dec status', units='unitless', & interpinic_flag='interp', data=this%dd_status, & readvar=readvar) - - + call restartvar(ncid=ncid, flag=flag, varname='ed_chilling_days', xtype=ncd_double, & - dim1name=namec, & + dim1name=col_dimName, & long_name='ed chilling day counter', units='unitless', & interpinic_flag='interp', data=this%ncd, & readvar=readvar) - call restartvar(ncid=ncid, flag=flag, varname='ed_leafondate', xtype=ncd_double, & - dim1name=namec, & + dim1name=col_dimName, & long_name='ed leafondate', units='unitless', & interpinic_flag='interp', data=this%leafondate, & readvar=readvar) - + call restartvar(ncid=ncid, flag=flag, varname='ed_leafoffdate', xtype=ncd_double, & - dim1name=namec, & + dim1name=col_dimName, & long_name='ed leafoffdate', units='unitless', & interpinic_flag='interp', data=this%leafoffdate, & readvar=readvar) call restartvar(ncid=ncid, flag=flag, varname='ed_dleafondate', xtype=ncd_double, & - dim1name=namec, & + dim1name=col_dimName, & long_name='ed dleafondate', units='unitless', & interpinic_flag='interp', data=this%dleafondate, & readvar=readvar) call restartvar(ncid=ncid, flag=flag, varname='ed_dleafoffdate', xtype=ncd_double, & - dim1name=namec, & + dim1name=col_dimName, & long_name='ed dleafoffdate', units='unitless', & interpinic_flag='interp', data=this%dleafoffdate, & readvar=readvar) - + call restartvar(ncid=ncid, flag=flag, varname='ed_acc_NI', xtype=ncd_double, & - dim1name=namec, & + dim1name=col_dimName, & long_name='ed nesterov index', units='unitless', & interpinic_flag='interp', data=this%acc_NI, & readvar=readvar) + call restartvar(ncid=ncid, flag=flag, varname='ed_gdd_site', xtype=ncd_double, & + dim1name=col_dimName, & + long_name='ed GDD site', units='unitless', & + interpinic_flag='interp', data=this%ED_GDD_site, & + readvar=readvar) + call restartvar(ncid=ncid, flag=flag, varname='ed_balive', xtype=ncd_double, & + dim1name=coh_dimName, & + long_name='ed cohort ed_balive', units='unitless', & + interpinic_flag='interp', data=this%balive, & + readvar=readvar) ! ! cohort level vars ! - - - - call restartvar(ncid=ncid, flag=flag, varname='ed_io_cohortsPerPatch', xtype=ncd_int, & - dim1name=dimName, & - long_name='list of cohorts per patch. indexed by numPatchesPerCol', units='unitless', & + dim1name=coh_dimName, & + long_name='cohorts per patch, indexed by numPatchesPerCol', 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, & + dim1name=coh_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, & + dim1name=coh_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, & + dim1name=coh_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, & + dim1name=coh_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, & + dim1name=coh_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, & + dim1name=coh_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, & + dim1name=coh_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, & + dim1name=coh_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, & + dim1name=coh_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, & + dim1name=coh_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, & + dim1name=coh_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, & + dim1name=coh_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, & + dim1name=coh_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, & + dim1name=coh_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_gpp', xtype=ncd_double, & - dim1name=dimName, & + dim1name=coh_dimName, & long_name='ed cohort - gpp', units='unitless', & interpinic_flag='interp', data=this%gpp, & readvar=readvar) call restartvar(ncid=ncid, flag=flag, varname='ed_npp', xtype=ncd_double, & - dim1name=dimName, & + dim1name=coh_dimName, & long_name='ed cohort - npp', units='unitless', & interpinic_flag='interp', data=this%npp, & readvar=readvar) call restartvar(ncid=ncid, flag=flag, varname='ed_npp_leaf', xtype=ncd_double, & - dim1name=dimName, & + dim1name=coh_dimName, & long_name='ed cohort - npp_leaf', units='unitless', & interpinic_flag='interp', data=this%npp_leaf, & readvar=readvar) call restartvar(ncid=ncid, flag=flag, varname='ed_npp_froot', xtype=ncd_double, & - dim1name=dimName, & + dim1name=coh_dimName, & long_name='ed cohort - npp_froot', units='unitless', & interpinic_flag='interp', data=this%npp_froot, & readvar=readvar) call restartvar(ncid=ncid, flag=flag, varname='ed_npp_bsw', xtype=ncd_double, & - dim1name=dimName, & + dim1name=coh_dimName, & long_name='ed cohort - npp_bsw', units='unitless', & interpinic_flag='interp', data=this%npp_bsw, & readvar=readvar) call restartvar(ncid=ncid, flag=flag, varname='ed_npp_bdead', xtype=ncd_double, & - dim1name=dimName, & + dim1name=coh_dimName, & long_name='ed cohort - npp_bdead', units='unitless', & interpinic_flag='interp', data=this%npp_bdead, & readvar=readvar) call restartvar(ncid=ncid, flag=flag, varname='ed_npp_bseed', xtype=ncd_double, & - dim1name=dimName, & + dim1name=coh_dimName, & long_name='ed cohort - npp_bseed', units='unitless', & interpinic_flag='interp', data=this%npp_bseed, & readvar=readvar) call restartvar(ncid=ncid, flag=flag, varname='ed_npp_store', xtype=ncd_double, & - dim1name=dimName, & + dim1name=coh_dimName, & long_name='ed cohort - npp_store', units='unitless', & interpinic_flag='interp', data=this%npp_store, & readvar=readvar) call restartvar(ncid=ncid, flag=flag, varname='ed_bmort', xtype=ncd_double, & - dim1name=dimName, & + dim1name=coh_dimName, & long_name='ed cohort - bmort', units='unitless', & interpinic_flag='interp', data=this%bmort, & readvar=readvar) call restartvar(ncid=ncid, flag=flag, varname='ed_hmort', xtype=ncd_double, & - dim1name=dimName, & + dim1name=coh_dimName, & long_name='ed cohort - hmort', units='unitless', & interpinic_flag='interp', data=this%hmort, & readvar=readvar) call restartvar(ncid=ncid, flag=flag, varname='ed_cmort', xtype=ncd_double, & - dim1name=dimName, & + dim1name=coh_dimName, & long_name='ed cohort - cmort', units='unitless', & interpinic_flag='interp', data=this%cmort, & readvar=readvar) call restartvar(ncid=ncid, flag=flag, varname='ed_imort', xtype=ncd_double, & - dim1name=dimName, & + dim1name=coh_dimName, & long_name='ed cohort - imort', units='unitless', & interpinic_flag='interp', data=this%imort, & readvar=readvar) call restartvar(ncid=ncid, flag=flag, varname='ed_fmort', xtype=ncd_double, & - dim1name=dimName, & + dim1name=coh_dimName, & long_name='ed cohort - fmort', units='unitless', & interpinic_flag='interp', data=this%fmort, & readvar=readvar) call restartvar(ncid=ncid, flag=flag, varname='ed_ddbhdt', xtype=ncd_double, & - dim1name=dimName, & + dim1name=coh_dimName, & long_name='ed cohort - ddbhdt', units='unitless', & interpinic_flag='interp', data=this%ddbhdt, & readvar=readvar) call restartvar(ncid=ncid, flag=flag, varname='ed_resp_clm', xtype=ncd_double, & - dim1name=dimName, & + dim1name=coh_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, & + dim1name=coh_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, & + dim1name=coh_dimName, & long_name='ed cohort - status_coh', units='unitless', & interpinic_flag='interp', data=this%status_coh, & readvar=readvar) - + call restartvar(ncid=ncid, flag=flag, varname='ed_isnew', xtype=ncd_int, & - dim1name=dimName, & + dim1name=coh_dimName, & long_name='ed cohort - isnew', units='unitless', & interpinic_flag='interp', data=this%isnew, & readvar=readvar) @@ -979,97 +995,97 @@ subroutine doVectorIO( this, ncid, flag ) ! call restartvar(ncid=ncid, flag=flag, varname='ed_cwd_ag', xtype=ncd_double, & - dim1name=dimName, & + dim1name=coh_dimName, & long_name='ed patch - 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, & + dim1name=coh_dimName, & long_name='ed patch - 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, & + dim1name=coh_dimName, & long_name='ed patch - 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, & + dim1name=coh_dimName, & long_name='ed patch - 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, & + dim1name=coh_dimName, & long_name='ed patch - 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, & + dim1name=coh_dimName, & long_name='ed patch - 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, & + dim1name=coh_dimName, & long_name='ed patch - 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, & + dim1name=coh_dimName, & long_name='ed patch - 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, & + dim1name=coh_dimName, & long_name='ed patch - 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, & + dim1name=coh_dimName, & long_name='ed patch - 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, & + dim1name=coh_dimName, & long_name='ed patch - area', units='unitless', & interpinic_flag='interp', data=this%areaRestart, & readvar=readvar) call restartvar(ncid=ncid, flag=flag, varname='ed_f_sun', xtype=ncd_double, & - dim1name=dimName, & + dim1name=coh_dimName, & long_name='ed patch - f_sun', units='unitless', & interpinic_flag='interp', data=this%f_sun, & readvar=readvar) call restartvar(ncid=ncid, flag=flag, varname='ed_fabd_sun_z', xtype=ncd_double, & - dim1name=dimName, & + dim1name=coh_dimName, & long_name='ed patch - fabd_sun_z', units='unitless', & interpinic_flag='interp', data=this%fabd_sun_z, & readvar=readvar) call restartvar(ncid=ncid, flag=flag, varname='ed_fabi_sun_z', xtype=ncd_double, & - dim1name=dimName, & + dim1name=coh_dimName, & long_name='ed patch - fabi_sun_z', units='unitless', & interpinic_flag='interp', data=this%fabi_sun_z, & readvar=readvar) call restartvar(ncid=ncid, flag=flag, varname='ed_fabd_sha_z', xtype=ncd_double, & - dim1name=dimName, & + dim1name=coh_dimName, & long_name='ed patch - fabd_sha_z', units='unitless', & interpinic_flag='interp', data=this%fabd_sha_z, & readvar=readvar) call restartvar(ncid=ncid, flag=flag, varname='ed_fabi_sha_z', xtype=ncd_double, & - dim1name=dimName, & + dim1name=coh_dimName, & long_name='ed patch - fabi_sha_z', units='unitless', & interpinic_flag='interp', data=this%fabi_sha_z, & readvar=readvar) @@ -1078,7 +1094,7 @@ subroutine doVectorIO( this, ncid, flag ) ! call restartvar(ncid=ncid, flag=flag, varname='ed_water_memory', xtype=ncd_double, & - dim1name=dimName, & + dim1name=coh_dimName, & long_name='ed cohort - water_memory', units='unitless', & interpinic_flag='interp', data=this%water_memory, & readvar=readvar) @@ -1509,12 +1525,12 @@ subroutine convertCohortListToVector( this, bounds, sites, nsites, fcolumn ) totalCohorts = 0 - if(fcolumn(1).eq.bounds%begc .and. & - (fcolumn(1)-1)*cohorts_per_col+1.ne.bounds%begCohort) then - write(iulog,*) 'fcolumn(1) in this clump, points to the first column of the clump' - write(iulog,*) 'but the assumption on first cohort index does not jive' - call endrun(msg=errMsg(__FILE__, __LINE__)) - end if +! if(fcolumn(1).eq.bounds%begc .and. & +! (fcolumn(1)-1)*cohorts_per_col+1.ne.bounds%begCohort) then +! write(iulog,*) 'fcolumn(1) in this clump, points to the first column of the clump' +! write(iulog,*) 'but the assumption on first cohort index does not jive' +! call endrun(msg=errMsg(__FILE__, __LINE__)) +! end if do s = 1,nsites @@ -1526,13 +1542,21 @@ subroutine convertCohortListToVector( this, bounds, sites, nsites, fcolumn ) c = fcolumn(s) - incrementOffset = (c-1)*cohorts_per_col + 1 - countCohort = (c-1)*cohorts_per_col + 1 - countPft = (c-1)*cohorts_per_col + 1 - countNcwd = (c-1)*cohorts_per_col + 1 - countNclmax = (c-1)*cohorts_per_col + 1 - countWaterMem = (c-1)*cohorts_per_col + 1 - countSunZ = (c-1)*cohorts_per_col + 1 +! incrementOffset = (c-1)*cohorts_per_col + 1 +! countCohort = (c-1)*cohorts_per_col + 1 +! countPft = (c-1)*cohorts_per_col + 1 +! countNcwd = (c-1)*cohorts_per_col + 1 +! countNclmax = (c-1)*cohorts_per_col + 1 +! countWaterMem = (c-1)*cohorts_per_col + 1 +! countSunZ = (c-1)*cohorts_per_col + 1 + + incrementOffset = bounds%begCohort+(s-1)*cohorts_per_col + 1 + countCohort = bounds%begCohort+(s-1)*cohorts_per_col + 1 + countPft = bounds%begCohort+(s-1)*cohorts_per_col + 1 + countNcwd = bounds%begCohort+(s-1)*cohorts_per_col + 1 + countNclmax = bounds%begCohort+(s-1)*cohorts_per_col + 1 + countWaterMem = bounds%begCohort+(s-1)*cohorts_per_col + 1 + countSunZ = bounds%begCohort+(s-1)*cohorts_per_col + 1 currentPatch => sites(s)%oldest_patch @@ -1773,8 +1797,9 @@ subroutine createPatchCohortStructure( this, bounds, sites, nsites, fcolumn ) c = fcolumn(s) g = col%gridcell(c) - - currIdx = (c-1)*cohorts_per_col + 1 ! global cohort index at the head of the column + + currIdx = bounds%begCohort + (s-1)*cohorts_per_col + 1 +! currIdx = (c-1)*cohorts_per_col + 1 ! global cohort index at the head of the column call zero_site( sites(s) ) ! @@ -1943,13 +1968,21 @@ subroutine convertCohortVectorToList( this, bounds, sites, nsites, fcolumn ) c = fcolumn(s) - incrementOffset = (c-1)*cohorts_per_col + 1 - countCohort = (c-1)*cohorts_per_col + 1 - countPft = (c-1)*cohorts_per_col + 1 - countNcwd = (c-1)*cohorts_per_col + 1 - countNclmax = (c-1)*cohorts_per_col + 1 - countWaterMem = (c-1)*cohorts_per_col + 1 - countSunZ = (c-1)*cohorts_per_col + 1 +! incrementOffset = (c-1)*cohorts_per_col + 1 +! countCohort = (c-1)*cohorts_per_col + 1 +! countPft = (c-1)*cohorts_per_col + 1 +! countNcwd = (c-1)*cohorts_per_col + 1 +! countNclmax = (c-1)*cohorts_per_col + 1 +! countWaterMem = (c-1)*cohorts_per_col + 1 +! countSunZ = (c-1)*cohorts_per_col + 1 + + incrementOffset = bounds%begCohort+(s-1)*cohorts_per_col + 1 + countCohort = bounds%begCohort+(s-1)*cohorts_per_col + 1 + countPft = bounds%begCohort+(s-1)*cohorts_per_col + 1 + countNcwd = bounds%begCohort+(s-1)*cohorts_per_col + 1 + countNclmax = bounds%begCohort+(s-1)*cohorts_per_col + 1 + countWaterMem = bounds%begCohort+(s-1)*cohorts_per_col + 1 + countSunZ = bounds%begCohort+(s-1)*cohorts_per_col + 1 currentPatch => sites(s)%oldest_patch @@ -2157,10 +2190,12 @@ subroutine EDRest ( bounds, sites, nsites, fcolumn, ncid, flag ) ! ! !LOCAL VARIABLES: type(EDRestartVectorClass) :: ervc + !----------------------------------------------------------------------- ! ! Note: ed_allsites_inst already exists and is allocated in clm_instInit ! + ervc = newEDRestartVectorClass( bounds ) if (ervc%DEBUG) then From 678e3df4834f81eb2d5f1836fda21ea10d6cf83f Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 18 Jul 2016 14:56:27 -0400 Subject: [PATCH 125/437] Added an input filter to the wrap_btran that operates on the exposed veg filter. --- biogeophys/EDBtranMod.F90 | 33 ++++++++++++++++++++------------- main/FatesInterfaceMod.F90 | 3 +++ 2 files changed, 23 insertions(+), 13 deletions(-) diff --git a/biogeophys/EDBtranMod.F90 b/biogeophys/EDBtranMod.F90 index a3537449..ebb41293 100644 --- a/biogeophys/EDBtranMod.F90 +++ b/biogeophys/EDBtranMod.F90 @@ -36,6 +36,7 @@ logical function check_layer_water(h2o_liq_vol, tempk) real(r8),intent(in) :: tempk check_layer_water = .false. + if ( h2o_liq_vol .gt. 0._r8 ) then if ( tempk .gt. tfrz-2._r8) then check_layer_water = .true. @@ -64,9 +65,13 @@ subroutine get_active_suction_layers(sites,nsites,bc_in,bc_out) numlevgrnd => ctrl_parms%numlevgrnd ) do s = 1,nsites - do j = 1,numlevgrnd - bc_out(s)%active_suction_gl(j) = check_layer_water( bc_in(s)%h2o_liqvol_gl(j),bc_in(s)%tempk_gl(j) ) - end do + if (bc_in(s)%filter_btran) then + do j = 1,numlevgrnd + bc_out(s)%active_suction_gl(j) = check_layer_water( bc_in(s)%h2o_liqvol_gl(j),bc_in(s)%tempk_gl(j) ) + end do + else + bc_out(s)%active_suction_gl(:) = .false. + end if end do end associate @@ -116,7 +121,9 @@ subroutine btran_ed( sites, nsites, bc_in, bc_out) ) do s = 1,nsites - + + bc_out(s)%rootr_pagl(:,:) = 0._r8 + ifp = 0 cpatch => sites(s)%oldest_patch do while (associated(cpatch)) @@ -130,13 +137,13 @@ subroutine btran_ed( sites, nsites, bc_in, bc_out) ! Calculations are only relevant where liquid water exists ! see clm_fates%wrap_btran for calculation with CLM/ALM - + if ( check_layer_water(bc_in(s)%h2o_liqvol_gl(j),bc_in(s)%tempk_gl(j)) ) then smp_node = max(smpsc(ft), bc_in(s)%smp_gl(j)) rresis = min( (bc_in(s)%eff_porosity_gl(j)/bc_in(s)%watsat_gl(j))* & - (smp_node - smpsc(ft)) / (smpso(ft) - smpsc(ft)), 1._r8) + (smp_node - smpsc(ft)) / (smpso(ft) - smpsc(ft)), 1._r8) cpatch%rootr_ft(ft,j) = cpatch%rootfr_ft(ft,j)*rresis @@ -183,10 +190,10 @@ subroutine btran_ed( sites, nsites, bc_in, bc_out) if(sum(pftgs) > 0._r8)then !prevent problem with the first timestep - might fail !bit-retart test as a result? FIX(RF,032414) bc_out(s)%rootr_pagl(ifp,j) = bc_out(s)%rootr_pagl(ifp,j) + & - cpatch%rootr_ft(ft,j) * pftgs(ft)/sum(pftgs) + cpatch%rootr_ft(ft,j) * pftgs(ft)/sum(pftgs) else bc_out(s)%rootr_pagl(ifp,j) = bc_out(s)%rootr_pagl(ifp,j) + & - cpatch%rootr_ft(ft,j) * 1./numpft_ed + cpatch%rootr_ft(ft,j) * 1./numpft_ed end if enddo enddo @@ -202,11 +209,9 @@ subroutine btran_ed( sites, nsites, bc_in, bc_out) end if enddo - - temprootr = sum(bc_out(s)%rootr_pagl(ifp,:)) - if(temprootr /= 1.0_r8)then - write(iulog,*) 'error with rootr in canopy fluxes',temprootr + if(abs(1.0_r8-temprootr) > 1.0e-9_r8)then + write(iulog,*) 'error with rootr in canopy fluxes',temprootr,sum(pftgs),sum(cpatch%rootr_ft(1:2,:),dim=2) if(temprootr > 0._r8)then do j = 1,numlevgrnd bc_out(s)%rootr_pagl(ifp,j) = bc_out(s)%rootr_pagl(ifp,j)/temprootr @@ -216,11 +221,13 @@ subroutine btran_ed( sites, nsites, bc_in, bc_out) cpatch => cpatch%younger end do + + end do end associate - end subroutine btran_ed + end subroutine btran_ed ! ========================================================================================= diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 7266f1d8..79ae9d60 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -62,6 +62,9 @@ module FatesInterfaceMod ! Liquid volume in ground layer real(r8), allocatable :: h2o_liqvol_gl(:) + ! Site level filter for uptake response functions + logical :: filter_btran + end type bc_in_type From 0e6f6ee0a45fdac7226a2f7185572d16d2ac5162 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 20 Jul 2016 02:39:33 -0700 Subject: [PATCH 126/437] modified some print statements --- biogeophys/EDBtranMod.F90 | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/biogeophys/EDBtranMod.F90 b/biogeophys/EDBtranMod.F90 index ebb41293..69662574 100644 --- a/biogeophys/EDBtranMod.F90 +++ b/biogeophys/EDBtranMod.F90 @@ -210,13 +210,11 @@ subroutine btran_ed( sites, nsites, bc_in, bc_out) enddo temprootr = sum(bc_out(s)%rootr_pagl(ifp,:)) - if(abs(1.0_r8-temprootr) > 1.0e-9_r8)then + if(abs(1.0_r8-temprootr) > 1.0e-10_r8 .and. temprootr > 1.0e-10_r8)then write(iulog,*) 'error with rootr in canopy fluxes',temprootr,sum(pftgs),sum(cpatch%rootr_ft(1:2,:),dim=2) - if(temprootr > 0._r8)then - do j = 1,numlevgrnd - bc_out(s)%rootr_pagl(ifp,j) = bc_out(s)%rootr_pagl(ifp,j)/temprootr - enddo - end if + do j = 1,numlevgrnd + bc_out(s)%rootr_pagl(ifp,j) = bc_out(s)%rootr_pagl(ifp,j)/temprootr + enddo end if cpatch => cpatch%younger From 780d5d1e8edb5be5a20c781d372ee8d35193be67 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 20 Jul 2016 21:18:04 -0700 Subject: [PATCH 127/437] multithreading potential fixes. --- main/EDRestVectorMod.F90 | 48 +++++++++++++++++++++------------------- 1 file changed, 25 insertions(+), 23 deletions(-) diff --git a/main/EDRestVectorMod.F90 b/main/EDRestVectorMod.F90 index a58fb338..1ae393cc 100755 --- a/main/EDRestVectorMod.F90 +++ b/main/EDRestVectorMod.F90 @@ -1532,6 +1532,9 @@ subroutine convertCohortListToVector( this, bounds, sites, nsites, fcolumn ) ! call endrun(msg=errMsg(__FILE__, __LINE__)) ! end if + if(nsites>0)then + + do s = 1,nsites @@ -1550,13 +1553,13 @@ subroutine convertCohortListToVector( this, bounds, sites, nsites, fcolumn ) ! countWaterMem = (c-1)*cohorts_per_col + 1 ! countSunZ = (c-1)*cohorts_per_col + 1 - incrementOffset = bounds%begCohort+(s-1)*cohorts_per_col + 1 - countCohort = bounds%begCohort+(s-1)*cohorts_per_col + 1 - countPft = bounds%begCohort+(s-1)*cohorts_per_col + 1 - countNcwd = bounds%begCohort+(s-1)*cohorts_per_col + 1 - countNclmax = bounds%begCohort+(s-1)*cohorts_per_col + 1 - countWaterMem = bounds%begCohort+(s-1)*cohorts_per_col + 1 - countSunZ = bounds%begCohort+(s-1)*cohorts_per_col + 1 + incrementOffset = bounds%begCohort+(c-bounds%begc)*cohorts_per_col + 1 + countCohort = bounds%begCohort+(c-bounds%begc)*cohorts_per_col + 1 + countPft = bounds%begCohort+(c-bounds%begc)*cohorts_per_col + 1 + countNcwd = bounds%begCohort+(c-bounds%begc)*cohorts_per_col + 1 + countNclmax = bounds%begCohort+(c-bounds%begc)*cohorts_per_col + 1 + countWaterMem = bounds%begCohort+(c-bounds%begc)*cohorts_per_col + 1 + countSunZ = bounds%begCohort+(c-bounds%begc)*cohorts_per_col + 1 currentPatch => sites(s)%oldest_patch @@ -1795,14 +1798,20 @@ subroutine createPatchCohortStructure( this, bounds, sites, nsites, fcolumn ) ! do s = 1,nsites + + if( (s-1) .ne. (c-bounds%begc) ) then + write(iulog,*) 'NAT COLUMNS REALLY ARENT MONOTONICALLY INCREASING' + write(iulog,*) s,c,bounds%begc,s-1,c-bounds%begc + end if + c = fcolumn(s) g = col%gridcell(c) - currIdx = bounds%begCohort + (s-1)*cohorts_per_col + 1 + currIdx = bounds%begCohort + (c-bounds%begc)*cohorts_per_col + 1 ! currIdx = (c-1)*cohorts_per_col + 1 ! global cohort index at the head of the column call zero_site( sites(s) ) - ! + ! ! set a few items that are necessary on restart for ED but not on the ! restart file ! @@ -1968,21 +1977,14 @@ subroutine convertCohortVectorToList( this, bounds, sites, nsites, fcolumn ) c = fcolumn(s) -! incrementOffset = (c-1)*cohorts_per_col + 1 -! countCohort = (c-1)*cohorts_per_col + 1 -! countPft = (c-1)*cohorts_per_col + 1 -! countNcwd = (c-1)*cohorts_per_col + 1 -! countNclmax = (c-1)*cohorts_per_col + 1 -! countWaterMem = (c-1)*cohorts_per_col + 1 -! countSunZ = (c-1)*cohorts_per_col + 1 + incrementOffset = bounds%begCohort+(c-bounds%begc)*cohorts_per_col + 1 - incrementOffset = bounds%begCohort+(s-1)*cohorts_per_col + 1 - countCohort = bounds%begCohort+(s-1)*cohorts_per_col + 1 - countPft = bounds%begCohort+(s-1)*cohorts_per_col + 1 - countNcwd = bounds%begCohort+(s-1)*cohorts_per_col + 1 - countNclmax = bounds%begCohort+(s-1)*cohorts_per_col + 1 - countWaterMem = bounds%begCohort+(s-1)*cohorts_per_col + 1 - countSunZ = bounds%begCohort+(s-1)*cohorts_per_col + 1 + countCohort = bounds%begCohort+(c-bounds%begc)*cohorts_per_col + 1 + countPft = bounds%begCohort+(c-bounds%begc)*cohorts_per_col + 1 + countNcwd = bounds%begCohort+(c-bounds%begc)*cohorts_per_col + 1 + countNclmax = bounds%begCohort+(c-bounds%begc)*cohorts_per_col + 1 + countWaterMem = bounds%begCohort+(c-bounds%begc)*cohorts_per_col + 1 + countSunZ = bounds%begCohort+(c-bounds%begc)*cohorts_per_col + 1 currentPatch => sites(s)%oldest_patch From e39b097c5c1667cb4d692f3fa46373a01b8a7c0e Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 20 Jul 2016 21:44:16 -0700 Subject: [PATCH 128/437] bug fix, removed rogue if statement --- main/EDRestVectorMod.F90 | 3 --- 1 file changed, 3 deletions(-) diff --git a/main/EDRestVectorMod.F90 b/main/EDRestVectorMod.F90 index 1ae393cc..fa3112ff 100755 --- a/main/EDRestVectorMod.F90 +++ b/main/EDRestVectorMod.F90 @@ -1532,9 +1532,6 @@ subroutine convertCohortListToVector( this, bounds, sites, nsites, fcolumn ) ! call endrun(msg=errMsg(__FILE__, __LINE__)) ! end if - if(nsites>0)then - - do s = 1,nsites From d4ee17a9b3cc416273774239e766fdd249a47748 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 22 Jul 2016 00:21:14 -0700 Subject: [PATCH 129/437] a calculation of the column index was moved to be prior to its use (thats a good thing), and the f2hmap_type might need to be public (pgi compiler error). --- main/EDRestVectorMod.F90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/main/EDRestVectorMod.F90 b/main/EDRestVectorMod.F90 index fa3112ff..725b3bc0 100755 --- a/main/EDRestVectorMod.F90 +++ b/main/EDRestVectorMod.F90 @@ -1795,13 +1795,12 @@ subroutine createPatchCohortStructure( this, bounds, sites, nsites, fcolumn ) ! do s = 1,nsites - + c = fcolumn(s) if( (s-1) .ne. (c-bounds%begc) ) then write(iulog,*) 'NAT COLUMNS REALLY ARENT MONOTONICALLY INCREASING' write(iulog,*) s,c,bounds%begc,s-1,c-bounds%begc end if - c = fcolumn(s) g = col%gridcell(c) currIdx = bounds%begCohort + (c-bounds%begc)*cohorts_per_col + 1 From eb19fdebb0225efdfc45aa81d2f8331bd354fd3f Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 4 Aug 2016 16:15:49 -0700 Subject: [PATCH 130/437] incremental change 1 for photosynthesis interface, 1x1br passes science regression test on transpiration, npp and biomass --- biogeophys/EDPhotosynthesisMod.F90 | 559 +++++++++++++++-------------- main/FatesInterfaceMod.F90 | 61 +++- 2 files changed, 342 insertions(+), 278 deletions(-) diff --git a/biogeophys/EDPhotosynthesisMod.F90 b/biogeophys/EDPhotosynthesisMod.F90 index 7aeef5eb..eb45c40f 100644 --- a/biogeophys/EDPhotosynthesisMod.F90 +++ b/biogeophys/EDPhotosynthesisMod.F90 @@ -9,9 +9,16 @@ module EDPhotosynthesisMod ! ! !USES: ! + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_log_mod , only : errMsg => shr_log_errMsg + use abortutils , only : endrun + use clm_varctl , only : iulog implicit none private ! + + + ! PUBLIC MEMBER FUNCTIONS: public :: Photosynthesis_ED !ED specific photosynthesis routine !------------------------------------------------------------------------------ @@ -19,9 +26,9 @@ module EDPhotosynthesisMod contains !--------------------------------------------------------- - subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & - rb, dayl_factor, sites, nsites, hsites, & - atm2lnd_inst, temperature_inst, canopystate_inst, photosyns_inst) + subroutine Photosynthesis_ED (sites,nsites,fcolumn,bc_in,bc_out, & + canopystate_inst, photosyns_inst) + ! ! !DESCRIPTION: ! Leaf photosynthesis and stomatal conductance calculation as described by @@ -47,25 +54,19 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & 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 EDTypesMod , only : numpft_ed, dinc_ed + use EDtypesMod , only : numPatchesPerCol + use EDtypesMod , only : ed_patch_type, ed_cohort_type, ed_site_type, numpft_ed use EDEcophysContype , only : EDecophyscon + use FatesInterfaceMod , only : bc_in_type,bc_out_type + use ColumnType , only : col ! ! !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(in) :: 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 :: sites(nsites) - integer , intent(in) :: nsites - integer , intent(in) :: hsites(bounds%begc:bounds%endc) - type(atm2lnd_type) , intent(in) :: atm2lnd_inst - type(temperature_type) , intent(in) :: temperature_inst + type(ed_site_type),intent(inout),target :: sites(nsites) + integer,intent(in) :: nsites + type(bc_in_type),intent(in) :: bc_in(nsites) + type(bc_out_type),intent(inout) :: bc_out(nsites) + integer,intent(in) :: fcolumn(nsites) type(canopystate_type) , intent(inout) :: canopystate_inst type(photosyns_type) , intent(inout) :: photosyns_inst ! @@ -92,9 +93,10 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & 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) :: kc( numpatchespercol ) ! Michaelis-Menten constant for CO2 (Pa) + real(r8) :: ko( numpatchespercol ) ! Michaelis-Menten constant for O2 (Pa) + real(r8) :: co2_cp( numpatchespercol ) ! CO2 compensation point (Pa) ! --------------------------------------------------------------- ! TO-DO: bbbopt is slated to be transferred to the parameter file @@ -149,7 +151,7 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & real(r8) :: theta_ip ! empirical curvature parameter for ap photosynthesis co-limitation ! Other - integer :: c,CL,f,s,iv,j,p,ps,ft ! indices + integer :: c,CL,f,s,iv,j,clmp,ps,ft,ifp ! 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] @@ -228,17 +230,12 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & 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 ) @@ -313,231 +310,236 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & theta_cj(2) = 0.80_r8 bbbopt(2) = 40000._r8 + do s = 1,nsites + + c = fcolumn(s) + ifp = 0 + currentpatch => sites(s)%oldest_patch + do while (associated(currentpatch)) + ifp = ifp+1 + + clmp = col%patchi(c)+ifp + + psncanopy(clmp) = 0._r8 + lmrcanopy(clmp) = 0._r8 + rscanopy(clmp) = 0._r8 + gccanopy(clmp) = 0._r8 + + + ! Patch level filter flag for photosynthesis calculations + ! has a short memory, flags: + ! 1 = patch has not been called + ! 2 = patch is currently marked for photosynthesis + ! 3 = patch has been called for photosynthesis at least once + if(bc_in(s)%filter_photo_pa(ifp)==2)then + + 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 + - 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 - - c = patch%column(p) - s = hsites(c) - - currentPatch => map_clmpatch_to_edpatch(sites(s), 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 - - - ! 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) - s = hsites(c) - - if (patch%is_veg(p)) then - - currentPatch => map_clmpatch_to_edpatch(sites(s), p) - - NCL_p = currentPatch%NCL_p - - do FT = 1,numpft_ed !calculate patch and pft specific propserties at canopy top. - - if (nint(c3psn(FT)) == 1)then - ps = 1 - else - ps = 2 - end if - bbb(FT) = max (bbbopt(ps)*currentPatch%btran_ft(FT), 1._r8) - - ! THIS CALL APPEARS TO BE REDUNDANT WITH LINE 650 (RGK) - if (nint(c3psn(FT)) == 1)then - ci(:,FT,:) = 0.7_r8 * cair(p) - else - ci(:,FT,:) = 0.4_r8 * cair(p) - end if - - - ! 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) = 1.67_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. + ! kc, ko, currentPatch, from: Bernacchi et al (2001) Plant, Cell and Environment 24:253-259 ! - ! 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) + ! kc25 = 404.9 umol/mol + ! ko25 = 278.4 mmol/mol + ! cp25 = 42.75 umol/mol ! - ! Base rate is at 20C. Adjust to 25C using the CN Q10 = 1.5 + ! 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 ! - ! 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 + kc25 = (404.9_r8 / 1.e06_r8) * bc_in(s)%forc_pbot + ko25 = (278.4_r8 / 1.e03_r8) * bc_in(s)%forc_pbot + sco = 0.5_r8 * 0.209_r8 / (42.75_r8 / 1.e06_r8) + cp25 = 0.5_r8 * bc_in(s)%oair_pa(ifp) / sco + + if(bc_in(s)%t_veg_pa(ifp).gt.150_r8.and.bc_in(s)%t_veg_pa(ifp).lt.350_r8)then + kc(ifp) = kc25 * ft1(bc_in(s)%t_veg_pa(ifp), kcha) + ko(ifp) = ko25 * ft1(bc_in(s)%t_veg_pa(ifp), koha) + co2_cp(ifp) = cp25 * ft1(bc_in(s)%t_veg_pa(ifp), cpha) + else + kc(ifp) = 1 + ko(ifp) = 1 + co2_cp(ifp) = 1 + end if - !==============================================================================! - ! Calculate Nitrogen scaling factors and photosynthetic parameters. - !==============================================================================! - do CL = 1, NCL_p - do FT = 1,numpft_ed + end if + + currentpatch => currentpatch%younger + 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 + + ifp = 0 + c = fcolumn(s) + currentpatch => sites(s)%oldest_patch + do while (associated(currentpatch)) + ifp = ifp+1 + clmp = col%patchi(c)+ifp + + if(bc_in(s)%filter_photo_pa(ifp)==2)then + + call t_startf('edfluxes') + + NCL_p = currentPatch%NCL_p + + do FT = 1,numpft_ed !calculate patch and pft specific propserties at canopy top. + + if (nint(c3psn(FT)) == 1)then + ps = 1 + else + ps = 2 + end if + bbb(FT) = max (bbbopt(ps)*currentPatch%btran_ft(FT), 1._r8) - 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 + ! THIS CALL APPEARS TO BE REDUNDANT WITH LINE 650 (RGK) + if (nint(c3psn(FT)) == 1)then + ci(:,FT,:) = 0.7_r8 * bc_in(s)%cair_pa(ifp) + else + ci(:,FT,:) = 0.4_r8 * bc_in(s)%cair_pa(ifp) + end if - 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 + ! 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) = 1.67_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 (bc_in(s)%dayl_factor_pa(ifp) == 0._r8) then + kn(FT) = 0._r8 + else + kn(FT) = exp(0.00963_r8 * vcmax25top(FT) - 2.43_r8) + end if - ! Loop through canopy layers (above snow). Respiration needs to be - ! calculated every timestep. Others are calculated only if daytime + ! 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) - 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 + 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 - ! Scale for leaf nitrogen profile - nscaler = exp(-kn(FT) * laican) - - - ! Maintenance respiration: umol CO2 / m**2 [leaf] / s - lmr25 = lmr25top(FT) * nscaler + if(currentPatch%present(CL,FT) == 1)then ! are there any leaves of this pft in this layer? - if (nint(c3psn(FT)) == 1)then - lmr_z(CL,FT,iv) = lmr25 * ft1(t_veg(p), lmrha) * fth(t_veg(p), lmrhd, lmrse, lmrc) + if(CL==NCL_p)then !are we in the top canopy layer or a shaded layer? + laican = 0._r8 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)) )) + 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) + - 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)) )) + ! 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(bc_in(s)%t_veg_pa(ifp), lmrha) * fth(bc_in(s)%t_veg_pa(ifp), lmrhd, lmrse, lmrc) + else + lmr_z(CL,FT,iv) = lmr25 * 2._r8**((bc_in(s)%t_veg_pa(ifp)-(tfrz+25._r8))/10._r8) + lmr_z(CL,FT,iv) = lmr_z(CL,FT,iv) / (1._r8 + exp( 1.3_r8*(bc_in(s)%t_veg_pa(ifp)-(tfrz+55._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. + + 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(bc_in(s)%t_veg_pa(ifp), vcmaxha) * fth(bc_in(s)%t_veg_pa(ifp), vcmaxhd, vcmaxse, vcmaxc) + jmax_z(CL,FT,iv) = jmax25 * ft1(bc_in(s)%t_veg_pa(ifp), jmaxha) * fth(bc_in(s)%t_veg_pa(ifp), jmaxhd, jmaxse, jmaxc) + tpu_z(CL,FT,iv) = tpu25 * ft1(bc_in(s)%t_veg_pa(ifp), tpuha) * fth(bc_in(s)%t_veg_pa(ifp), tpuhd, tpuse, tpuc) + + if (nint(c3psn(FT)) /= 1) then + vcmax_z(CL,FT,iv) = vcmax25 * 2._r8**((bc_in(s)%t_veg_pa(ifp)-(tfrz+25._r8))/10._r8) + vcmax_z(CL,FT,iv) = vcmax_z(CL,FT,iv) / (1._r8 + exp( 0.2_r8*((tfrz+15._r8)-bc_in(s)%t_veg_pa(ifp)) )) + vcmax_z(CL,FT,iv) = vcmax_z(CL,FT,iv) / (1._r8 + exp( 0.3_r8*(bc_in(s)%t_veg_pa(ifp)-(tfrz+40._r8)) )) + end if + kp_z(CL,FT,iv) = kp25 * 2._r8**((bc_in(s)%t_veg_pa(ifp)-(tfrz+25._r8))/10._r8) !q10 response of product limited psn. end if ! Adjust for soil water:(umol co2/m**2/s) @@ -559,13 +561,14 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & ! 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) + cf = bc_in(s)%forc_pbot/(rgas*1.e-3_r8*bc_in(s)%tgcm_pa(ifp))*1.e06_r8 + gb = 1._r8/bc_in(s)%rb_pa(ifp) 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(bc_in(s)%eair_pa(ifp), 0.05_r8*bc_in(s)%esat_tv_pa(ifp)), bc_in(s)%esat_tv_pa(ifp) ) - 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 @@ -639,9 +642,9 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & ! THIS CALL APPEARS TO BE REDUNDANT WITH LINE 423 (RGK) if (nint(c3psn(FT)) == 1)then - ci(cl,ft,iv) = 0.7_r8 * cair(p) + ci(cl,ft,iv) = 0.7_r8 * bc_in(s)%cair_pa(ifp) else - ci(cl,ft,iv) = 0.4_r8 * cair(p) + ci(cl,ft,iv) = 0.4_r8 * bc_in(s)%cair_pa(ifp) end if niter = 0 @@ -656,10 +659,10 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & ! 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))) + ac = vcmax_z(cl,ft,iv) * max(ci(cl,ft,iv)-co2_cp(ifp), 0._r8) / (ci(cl,ft,iv)+kc(ifp)* & + (1._r8+bc_in(s)%oair_pa(ifp)/ko(ifp))) ! 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)) + aj = je * max(ci(cl,ft,iv)-co2_cp(ifp), 0._r8) / (4._r8*ci(cl,ft,iv)+8._r8*co2_cp(ifp)) ! C3: Product-limited photosynthesis ap = 3._r8 * tpu_z(cl,ft,iv) else @@ -683,7 +686,7 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & end if ! C4: PEP carboxylase-limited (CO2-limited) - ap = kp_z(cl,ft,iv) * max(ci(cl,ft,iv), 0._r8) / forc_pbot(c) + ap = kp_z(cl,ft,iv) * max(ci(cl,ft,iv), 0._r8) / bc_in(s)%forc_pbot end if ! Gross photosynthesis smoothing calculations. First co-limit ac and aj. Then co-limit ap aquad = theta_cj(ps) @@ -707,23 +710,23 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & ! 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 = bc_in(s)%cair_pa(ifp) - 1.4_r8/gb_mol * an(cl,ft,iv) * bc_in(s)%forc_pbot cs = max(cs,1.e-06_r8) aquad = cs - bquad = cs*(gb_mol - bbb(FT)) - bb_slope(ft)*an(cl,ft,iv)*forc_pbot(c) - cquad = -gb_mol*(cs*bbb(FT) + bb_slope(ft)*an(cl,ft,iv)*forc_pbot(c)*ceair/esat_tv(p)) + bquad = cs*(gb_mol - bbb(FT)) - bb_slope(ft)*an(cl,ft,iv)*bc_in(s)%forc_pbot + cquad = -gb_mol*(cs*bbb(FT) + bb_slope(ft)*an(cl,ft,iv)*bc_in(s)%forc_pbot*ceair/bc_in(s)%esat_tv_pa(ifp)) 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) * & + ci(cl,ft,iv) = bc_in(s)%cair_pa(ifp) - an(cl,ft,iv) * bc_in(s)%forc_pbot * & (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 + if ((abs(ci(cl,ft,iv)-ciold)/bc_in(s)%forc_pbot*1.e06_r8 <= 2.e-06_r8) .or. niter == 5) then exitloop = 1 end if end do !iteration loop @@ -734,9 +737,9 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & 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 = bc_in(s)%cair_pa(ifp) - 1.4_r8/gb_mol * an(cl,ft,iv) * bc_in(s)%forc_pbot 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) / & + ci(cl,ft,iv) = bc_in(s)%cair_pa(ifp) - an(cl,ft,iv) * bc_in(s)%forc_pbot * (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 @@ -773,13 +776,13 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & ! 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__)) + write (iulog,*)'clmp,iv,gs_mol= ',clmp,iv,gs_mol + call endrun(decomp_index=clmp, 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 = bb_slope(ft)*max(an(cl,ft,iv), 0._r8)*hs/cs*forc_pbot(c) + bbb(FT) + hs = (gb_mol*ceair + gs_mol*bc_in(s)%esat_tv_pa(ifp)) / ((gb_mol+gs_mol)*bc_in(s)%esat_tv_pa(ifp)) + gs_mol_err = bb_slope(ft)*max(an(cl,ft,iv), 0._r8)*hs/cs*bc_in(s)%forc_pbot + bbb(FT) if (abs(gs_mol-gs_mol_err) > 1.e-01_r8) then write (iulog,*) 'CF: Ball-Berry error check - stomatal conductance error:' @@ -850,7 +853,7 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & 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%gscan = sum((1.0_r8/(rs_z(cl,ft,1:currentCohort%nv-1)+bc_in(s)%rb_pa(ifp)))) * tree_area currentCohort%ts_net_uptake(1:currentCohort%nv) = an_av(cl,ft,1:currentCohort%nv) * 12E-9 * dtime else @@ -866,7 +869,7 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & 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 + gs_cohort = 1.0_r8/(rs_z(cl,ft,currentCohort%nv)+bc_in(s)%rb_pa(ifp))*laifrac*tree_area currentCohort%gscan = currentCohort%gscan+gs_cohort if ( DEBUG ) then @@ -915,11 +918,12 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & if ( DEBUG ) write(iulog,*) 'EDPhoto 875 ', currentCohort%livecrootn if (woody(FT) == 1) then - tc = q10**((t_veg(p)-tfrz - 20.0_r8)/10.0_r8) + tc = q10**((bc_in(s)%t_veg_pa(ifp)-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 + ! TODO: CHANGE THAT 1000 to 1000.0_r8 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! currentCohort%livestem_mr = currentCohort%livestem_mr /1000 currentCohort%livecroot_mr = currentCohort%livecroot_mr /1000 else @@ -938,7 +942,7 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & currentCohort%froot_mr = 0._r8 do j = 1,nlevsoi - tcsoi = q10**((t_soisno(c,j)-tfrz - 20.0_r8)/10.0_r8) + tcsoi = q10**((bc_in(s)%t_soisno_gl(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) @@ -997,38 +1001,39 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & 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 + psncanopy(clmp) = psncanopy(clmp) + currentCohort%gpp_clm + lmrcanopy(clmp) = lmrcanopy(clmp) + 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 + gccanopy(clmp) = gccanopy(clmp) + 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. + psncanopy(clmp) = psncanopy(clmp) / currentPatch%area + lmrcanopy(clmp) = lmrcanopy(clmp) / currentPatch%area + if(gccanopy(clmp) > 1._r8/rsmax0.and.elai(clmp) > 0.0_r8)then + rscanopy(clmp) = (1.0_r8/gccanopy(clmp))-bc_in(s)%rb_pa(ifp)/elai(clmp) ! this needs to be resistance per unit leaf area. else - rscanopy(p) = rsmax0 + rscanopy(clmp) = rsmax0 end if - gccanopy(p) = 1.0_r8/rscanopy(p) *cf /1000 !convert into umol m02 s-1 then mmol m-2 s-1. + gccanopy(clmp) = 1.0_r8/rscanopy(clmp) *cf /1000 !convert into umol m02 s-1 then mmol m-2 s-1. - else !EDpatch - - rscanopy(p) = rsmax0 + else + rscanopy(clmp) = rsmax0 + end if - end if !edpatch + currentPatch => currentPatch%younger call t_stopf('edfluxunpack3') call t_stopf('edunpack') + end do + + end do !site loop + + end associate - end do !patch loop - - end associate - - end subroutine Photosynthesis_ED +end subroutine Photosynthesis_ED end module EDPhotosynthesisMod diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 79ae9d60..e0810794 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -41,12 +41,18 @@ module FatesInterfaceMod ! The actual number of FATES' ED patches integer :: npatches + ! Radiation variables for calculating sun/shade fractions + ! --------------------------------------------------------------------------------- + ! Downwelling direct beam radiation (patch,radiation-band) [W/m2] real(r8), allocatable :: solad_parb(:,:) ! Downwelling diffuse (I-ndirect) radiation (patch,radiation-band) [W/m2] real(r8), allocatable :: solai_parb(:,:) + ! Hydrology variables for BTRAN + ! --------------------------------------------------------------------------------- + ! Soil suction potential of layers in each site, negative, [mm] real(r8), allocatable :: smp_gl(:) @@ -65,6 +71,47 @@ module FatesInterfaceMod ! Site level filter for uptake response functions logical :: filter_btran + ! Photosynthesis variables + ! --------------------------------------------------------------------------------- + + ! Patch level filter flag for photosynthesis calculations + ! has a short memory, flags: + ! 1 = patch has not been called + ! 2 = patch is currently marked for photosynthesis + ! 3 = patch has been called for photosynthesis at least once + integer, allocatable :: filter_photo_pa(:) + + ! atmospheric pressure (Pa) + real(r8) :: forc_pbot + + ! daylength scaling factor (0-1) + real(r8), allocatable :: dayl_factor_pa(:) + + ! saturation vapor pressure at t_veg (Pa) + real(r8), allocatable :: esat_tv_pa(:) + + ! vapor pressure of canopy air (Pa) + real(r8), allocatable :: eair_pa(:) + + ! Atmospheric O2 partial pressure (Pa) + real(r8), allocatable :: oair_pa(:) + + ! Atmospheric CO2 partial pressure (Pa) + real(r8), allocatable :: cair_pa(:) + + ! boundary layer resistance (s/m) + real(r8), allocatable :: rb_pa(:) + + ! vegetation temperature (Kelvin) + real(r8), allocatable :: t_veg_pa(:) + + ! air temperature at agcm reference height (kelvin) + real(r8), allocatable :: tgcm_pa(:) + + ! soil temperature (Kelvin) + real(r8), allocatable :: t_soisno_gl(:) + + end type bc_in_type @@ -171,7 +218,19 @@ subroutine allocate_bcin(bc_in) allocate(bc_in%watsat_gl(ctrl_parms%numlevgrnd)) allocate(bc_in%tempk_gl(ctrl_parms%numlevgrnd)) allocate(bc_in%h2o_liqvol_gl(ctrl_parms%numlevgrnd)) - + + ! Photosynthesis + allocate(bc_in%filter_photo_pa(numPatchesPerCol)) + allocate(bc_in%dayl_factor_pa(numPatchesPerCol)) + allocate(bc_in%esat_tv_pa(numPatchesPerCol)) + allocate(bc_in%eair_pa(numPatchesPerCol)) + allocate(bc_in%oair_pa(numPatchesPerCol)) + allocate(bc_in%cair_pa(numPatchesPerCol)) + allocate(bc_in%rb_pa(numPatchesPerCol)) + allocate(bc_in%t_veg_pa(numPatchesPerCol)) + allocate(bc_in%tgcm_pa(numPatchesPerCol)) + allocate(bc_in%t_soisno_gl(ctrl_parms%numlevgrnd)) + return end subroutine allocate_bcin From b94041c83bd238767d1dd8cce30664dd24995996 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 4 Aug 2016 17:10:32 -0700 Subject: [PATCH 131/437] incremental change 2 for photosynthesis interface, 1x1br passes science regression, these changes added the output boundary conditions (although temporary) --- biogeophys/EDPhotosynthesisMod.F90 | 59 ++++++++++++++---------------- main/FatesInterfaceMod.F90 | 18 ++++++++- 2 files changed, 44 insertions(+), 33 deletions(-) diff --git a/biogeophys/EDPhotosynthesisMod.F90 b/biogeophys/EDPhotosynthesisMod.F90 index eb45c40f..16673377 100644 --- a/biogeophys/EDPhotosynthesisMod.F90 +++ b/biogeophys/EDPhotosynthesisMod.F90 @@ -26,8 +26,8 @@ module EDPhotosynthesisMod contains !--------------------------------------------------------- - subroutine Photosynthesis_ED (sites,nsites,fcolumn,bc_in,bc_out, & - canopystate_inst, photosyns_inst) + subroutine Photosynthesis_ED (sites,nsites,fcolumn,bc_in,bc_out,canopystate_inst) + ! ! !DESCRIPTION: @@ -46,10 +46,6 @@ subroutine Photosynthesis_ED (sites,nsites,fcolumn,bc_in,bc_out, & 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 @@ -60,6 +56,9 @@ subroutine Photosynthesis_ED (sites,nsites,fcolumn,bc_in,bc_out, & use EDEcophysContype , only : EDecophyscon use FatesInterfaceMod , only : bc_in_type,bc_out_type use ColumnType , only : col + use CanopyStateType , only : canopystate_type + + ! ! !ARGUMENTS: type(ed_site_type),intent(inout),target :: sites(nsites) @@ -67,8 +66,9 @@ subroutine Photosynthesis_ED (sites,nsites,fcolumn,bc_in,bc_out, & type(bc_in_type),intent(in) :: bc_in(nsites) type(bc_out_type),intent(inout) :: bc_out(nsites) integer,intent(in) :: fcolumn(nsites) - type(canopystate_type) , intent(inout) :: canopystate_inst - type(photosyns_type) , intent(inout) :: photosyns_inst + + type(canopystate_type) , intent(in) :: canopystate_inst !LAI + ! ! !CALLED FROM: ! subroutine CanopyFluxes @@ -227,18 +227,13 @@ subroutine Photosynthesis_ED (sites,nsites,fcolumn,bc_in,bc_out, & 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 + 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 - 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 - ) +! 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() @@ -320,10 +315,10 @@ subroutine Photosynthesis_ED (sites,nsites,fcolumn,bc_in,bc_out, & clmp = col%patchi(c)+ifp - psncanopy(clmp) = 0._r8 - lmrcanopy(clmp) = 0._r8 - rscanopy(clmp) = 0._r8 - gccanopy(clmp) = 0._r8 + bc_out(s)%psncanopy_pa(ifp) = 0._r8 + bc_out(s)%lmrcanopy_pa(ifp) = 0._r8 + bc_out(s)%rscanopy_pa(ifp) = 0._r8 + bc_out(s)%gccanopy_pa(ifp) = 0._r8 ! Patch level filter flag for photosynthesis calculations @@ -1001,27 +996,27 @@ subroutine Photosynthesis_ED (sites,nsites,fcolumn,bc_in,bc_out, & currentCohort%ts_net_uptake(1:currentCohort%nv) = 0._r8 end if !pft<0 n<0 - psncanopy(clmp) = psncanopy(clmp) + currentCohort%gpp_clm - lmrcanopy(clmp) = lmrcanopy(clmp) + currentCohort%resp_m + bc_out(s)%psncanopy_pa(ifp) = bc_out(s)%psncanopy_pa(ifp) + currentCohort%gpp_clm + bc_out(s)%lmrcanopy_pa(ifp) = bc_out(s)%lmrcanopy_pa(ifp) + currentCohort%resp_m ! accumulate cohort level canopy conductances over whole area before dividing by total area. - gccanopy(clmp) = gccanopy(clmp) + currentCohort%gscan * currentCohort%n /currentPatch%total_canopy_area + bc_out(s)%gccanopy_pa(ifp) = bc_out(s)%gccanopy_pa(ifp) + currentCohort%gscan * currentCohort%n /currentPatch%total_canopy_area currentCohort => currentCohort%shorter enddo ! end cohort loop. end if !count_cohorts is more than zero. - psncanopy(clmp) = psncanopy(clmp) / currentPatch%area - lmrcanopy(clmp) = lmrcanopy(clmp) / currentPatch%area - if(gccanopy(clmp) > 1._r8/rsmax0.and.elai(clmp) > 0.0_r8)then - rscanopy(clmp) = (1.0_r8/gccanopy(clmp))-bc_in(s)%rb_pa(ifp)/elai(clmp) ! this needs to be resistance per unit leaf area. + bc_out(s)%psncanopy_pa(ifp) = bc_out(s)%psncanopy_pa(ifp) / currentPatch%area + bc_out(s)%lmrcanopy_pa(ifp) = bc_out(s)%lmrcanopy_pa(ifp) / currentPatch%area + if(bc_out(s)%gccanopy_pa(ifp) > 1._r8/rsmax0.and.elai(clmp) > 0.0_r8)then + bc_out(s)%rscanopy_pa(ifp) = (1.0_r8/bc_out(s)%gccanopy_pa(ifp))-bc_in(s)%rb_pa(ifp)/elai(clmp) ! this needs to be resistance per unit leaf area. else - rscanopy(clmp) = rsmax0 + bc_out(s)%rscanopy_pa(ifp) = rsmax0 end if - gccanopy(clmp) = 1.0_r8/rscanopy(clmp) *cf /1000 !convert into umol m02 s-1 then mmol m-2 s-1. + bc_out(s)%gccanopy_pa(ifp) = 1.0_r8/bc_out(s)%rscanopy_pa(ifp) *cf /1000 !convert into umol m02 s-1 then mmol m-2 s-1. else - rscanopy(clmp) = rsmax0 + bc_out(s)%rscanopy_pa(ifp) = rsmax0 end if currentPatch => currentPatch%younger diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index e0810794..2abd4940 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -133,6 +133,12 @@ module FatesInterfaceMod ! (diagnostic, should not be used by HLM) real(r8), allocatable :: btran_pa(:) + real(r8), allocatable :: rscanopy_pa(:) + real(r8), allocatable :: gccanopy_pa(:) + real(r8), allocatable :: psncanopy_pa(:) + real(r8), allocatable :: lmrcanopy_pa(:) + + end type bc_out_type @@ -252,7 +258,12 @@ subroutine allocate_bcout(bc_out) allocate(bc_out%rootr_pagl(numPatchesPerCol,ctrl_parms%numlevgrnd)) allocate(bc_out%btran_pa(numPatchesPerCol)) - + ! Photosynthesis + allocate(bc_out%rscanopy_pa(numPatchesPerCol)) + allocate(bc_out%gccanopy_pa(numPatchesPerCol)) + allocate(bc_out%lmrcanopy_pa(numPatchesPerCol)) + allocate(bc_out%psncanopy_pa(numPatchesPerCol)) + return end subroutine allocate_bcout @@ -280,6 +291,11 @@ subroutine zero_bcs(this,s) this%bc_out(s)%rootr_pagl(:,:) = 0.0_r8 this%bc_out(s)%btran_pa(:) = 0.0_r8 + this%bc_out(s)%rscanopy_pa(:) = 0.0_r8 + this%bc_out(s)%gccanopy_pa(:) = 0.0_r8 + this%bc_out(s)%psncanopy_pa(:) = 0.0_r8 + this%bc_out(s)%lmrcanopy_pa(:) = 0.0_r8 + return end subroutine zero_bcs From b6561108e8b6154b84368939e03c98ec5cef9200 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 4 Aug 2016 17:29:08 -0700 Subject: [PATCH 132/437] incremental photosyns interface 3: removed lmrcanopy,psncanopy and gccanopy from _inst structures and maintained in FATES. --- biogeophys/EDAccumulateFluxesMod.F90 | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/biogeophys/EDAccumulateFluxesMod.F90 b/biogeophys/EDAccumulateFluxesMod.F90 index 006a0353..b9d32588 100644 --- a/biogeophys/EDAccumulateFluxesMod.F90 +++ b/biogeophys/EDAccumulateFluxesMod.F90 @@ -50,17 +50,17 @@ subroutine AccumulateFluxes_ED(bounds, p, sites, nsites, hsites , photosyns_inst integer :: s ! ed site !---------------------------------------------------------------------- - 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 - ) +! 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 +! ) ! INTERF-TODO: WHY IS THIS BEING UPDATED? ! IT IS JUST GOING TO BE ZEROED A THE END OF THE FUNCTION ! THAT CALLS THIS SUBROUTINE (CANOPYFLUXES), AND IT WON'T ! BE USED BETWEEN NOW AND THEN - fpsn(p) = psncanopy(p) + ! fpsn(p) = psncanopy(p) if (patch%is_veg(p)) then @@ -98,7 +98,7 @@ subroutine AccumulateFluxes_ED(bounds, p, sites, nsites, hsites , photosyns_inst end if !is_veg - end associate +! end associate end subroutine AccumulateFluxes_ED From 381edc39bd799da072470385fc70f9000fd2c490 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 4 Aug 2016 22:44:17 -0700 Subject: [PATCH 133/437] photo interface part 4: added rssun and rssha as output boundaries so we conform with the CLM method of calculating transpiration flux in CanopyFluxes --- biogeophys/EDPhotosynthesisMod.F90 | 20 +++++++++--------- biogeophys/EDSurfaceAlbedoMod.F90 | 3 +++ main/FatesInterfaceMod.F90 | 34 ++++++++++++++++++++++++------ 3 files changed, 41 insertions(+), 16 deletions(-) diff --git a/biogeophys/EDPhotosynthesisMod.F90 b/biogeophys/EDPhotosynthesisMod.F90 index 16673377..57f2d3c0 100644 --- a/biogeophys/EDPhotosynthesisMod.F90 +++ b/biogeophys/EDPhotosynthesisMod.F90 @@ -201,6 +201,7 @@ subroutine Photosynthesis_ED (sites,nsites,fcolumn,bc_in,bc_out,canopystate_inst real(r8) :: coarse_wood_frac ! amount of woody biomass that is coarse... real(r8) :: tree_area real(r8) :: gs_cohort + real(r8) :: rscanopy ! FIX(SPM, 040714) [I]- these should be proper functions... real(r8) :: ft1 ! photosynthesis temperature response (statement function) @@ -231,9 +232,6 @@ subroutine Photosynthesis_ED (sites,nsites,fcolumn,bc_in,bc_out,canopystate_inst 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() @@ -317,9 +315,9 @@ subroutine Photosynthesis_ED (sites,nsites,fcolumn,bc_in,bc_out,canopystate_inst bc_out(s)%psncanopy_pa(ifp) = 0._r8 bc_out(s)%lmrcanopy_pa(ifp) = 0._r8 - bc_out(s)%rscanopy_pa(ifp) = 0._r8 + bc_out(s)%rssun_pa(ifp) = 0._r8 + bc_out(s)%rssha_pa(ifp) = 0._r8 bc_out(s)%gccanopy_pa(ifp) = 0._r8 - ! Patch level filter flag for photosynthesis calculations ! has a short memory, flags: @@ -1009,16 +1007,18 @@ subroutine Photosynthesis_ED (sites,nsites,fcolumn,bc_in,bc_out,canopystate_inst bc_out(s)%psncanopy_pa(ifp) = bc_out(s)%psncanopy_pa(ifp) / currentPatch%area bc_out(s)%lmrcanopy_pa(ifp) = bc_out(s)%lmrcanopy_pa(ifp) / currentPatch%area if(bc_out(s)%gccanopy_pa(ifp) > 1._r8/rsmax0.and.elai(clmp) > 0.0_r8)then - bc_out(s)%rscanopy_pa(ifp) = (1.0_r8/bc_out(s)%gccanopy_pa(ifp))-bc_in(s)%rb_pa(ifp)/elai(clmp) ! this needs to be resistance per unit leaf area. + rscanopy = (1.0_r8/bc_out(s)%gccanopy_pa(ifp))-bc_in(s)%rb_pa(ifp)/elai(clmp) ! this needs to be resistance per unit leaf area. else - bc_out(s)%rscanopy_pa(ifp) = rsmax0 + rscanopy = rsmax0 end if - bc_out(s)%gccanopy_pa(ifp) = 1.0_r8/bc_out(s)%rscanopy_pa(ifp) *cf /1000 !convert into umol m02 s-1 then mmol m-2 s-1. - + bc_out(s)%gccanopy_pa(ifp) = 1.0_r8/rscanopy*cf/1000 !convert into umol m02 s-1 then mmol m-2 s-1. else - bc_out(s)%rscanopy_pa(ifp) = rsmax0 + rscanopy = rsmax0 end if + bc_out(s)%rssun_pa(ifp) = (bc_out(s)%laisun_pa(ifp)+bc_out(s)%laisha_pa(ifp))*(bc_in(s)%rb_pa(ifp)+rscanopy)/elai(clmp) - bc_in(s)%rb_pa(ifp) + bc_out(s)%rssha_pa(ifp) = bc_out(s)%rssun_pa(ifp) + currentPatch => currentPatch%younger call t_stopf('edfluxunpack3') diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index 7aedb32e..be49b03e 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -1038,6 +1038,9 @@ subroutine ED_SunShadeFracs(sites,nsites,bc_in,bc_out) end do end do + + bc_out(s)%laisun_pa(ifp) = sunlai + bc_out(s)%laisha_pa(ifp) = shalai if(sunlai+shalai > 0._r8)then bc_out(s)%fsun_pa(ifp) = sunlai / (sunlai+shalai) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 2abd4940..cdc8af92 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -121,6 +121,12 @@ module FatesInterfaceMod ! Sunlit fraction of the canopy for this patch [0-1] real(r8),allocatable :: fsun_pa(:) + ! Sunlit canopy LAI + real(r8),allocatable :: laisun_pa(:) + + ! Shaded canopy LAI + real(r8),allocatable :: laisha_pa(:) + ! Logical stating whether a ground layer can have water uptake by plants ! The only condition right now is that liquid water exists ! The name (suction) is used to indicate that soil suction should be calculated @@ -133,9 +139,19 @@ module FatesInterfaceMod ! (diagnostic, should not be used by HLM) real(r8), allocatable :: btran_pa(:) - real(r8), allocatable :: rscanopy_pa(:) + ! Sunlit canopy resistance [s/m] + real(r8), allocatable :: rssun_pa(:) + + ! Shaded canopy resistance [s/m] + real(r8), allocatable :: rssha_pa(:) + + ! Canopy conductance [mmol m-2 s-1] real(r8), allocatable :: gccanopy_pa(:) + + ! patch sunlit leaf photosynthesis (umol CO2 /m**2/ s) real(r8), allocatable :: psncanopy_pa(:) + + ! patch sunlit leaf maintenance respiration rate (umol CO2/m**2/s) real(r8), allocatable :: lmrcanopy_pa(:) @@ -252,6 +268,8 @@ subroutine allocate_bcout(bc_out) ! Radiation allocate(bc_out%fsun_pa(numPatchesPerCol)) + allocate(bc_out%laisun_pa(numPatchesPerCol)) + allocate(bc_out%laisha_pa(numPatchesPerCol)) ! Hydrology allocate(bc_out%active_suction_gl(ctrl_parms%numlevgrnd)) @@ -259,7 +277,8 @@ subroutine allocate_bcout(bc_out) allocate(bc_out%btran_pa(numPatchesPerCol)) ! Photosynthesis - allocate(bc_out%rscanopy_pa(numPatchesPerCol)) + allocate(bc_out%rssun_pa(numPatchesPerCol)) + allocate(bc_out%rssha_pa(numPatchesPerCol)) allocate(bc_out%gccanopy_pa(numPatchesPerCol)) allocate(bc_out%lmrcanopy_pa(numPatchesPerCol)) allocate(bc_out%psncanopy_pa(numPatchesPerCol)) @@ -288,13 +307,16 @@ subroutine zero_bcs(this,s) ! Output boundaries this%bc_out(s)%active_suction_gl(:) = .false. this%bc_out(s)%fsun_pa(:) = 0.0_r8 + this%bc_out(s)%laisun_pa(:) = 0.0_r8 + this%bc_out(s)%laisha_pa(:) = 0.0_r8 this%bc_out(s)%rootr_pagl(:,:) = 0.0_r8 this%bc_out(s)%btran_pa(:) = 0.0_r8 - this%bc_out(s)%rscanopy_pa(:) = 0.0_r8 - this%bc_out(s)%gccanopy_pa(:) = 0.0_r8 - this%bc_out(s)%psncanopy_pa(:) = 0.0_r8 - this%bc_out(s)%lmrcanopy_pa(:) = 0.0_r8 + this%bc_out(s)%rssun_pa(:) = 0.0_r8 + this%bc_out(s)%rssha_pa(:) = 0.0_r8 + this%bc_out(s)%gccanopy_pa(:) = 0.0_r8 + this%bc_out(s)%psncanopy_pa(:) = 0.0_r8 + this%bc_out(s)%lmrcanopy_pa(:) = 0.0_r8 return end subroutine zero_bcs From 3e538535ae8b20daeccab322ecdc8bee57164a23 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 5 Aug 2016 10:46:45 -0700 Subject: [PATCH 134/437] testing introduction of interally calculated LAI to photosynthesis --- biogeophys/EDPhotosynthesisMod.F90 | 62 +++++++++++++++--------------- 1 file changed, 32 insertions(+), 30 deletions(-) diff --git a/biogeophys/EDPhotosynthesisMod.F90 b/biogeophys/EDPhotosynthesisMod.F90 index 57f2d3c0..3113ce64 100644 --- a/biogeophys/EDPhotosynthesisMod.F90 +++ b/biogeophys/EDPhotosynthesisMod.F90 @@ -26,7 +26,7 @@ module EDPhotosynthesisMod contains !--------------------------------------------------------- - subroutine Photosynthesis_ED (sites,nsites,fcolumn,bc_in,bc_out,canopystate_inst) + subroutine Photosynthesis_ED (sites,nsites,fcolumn,bc_in,bc_out,dtime,canopystate_inst) ! @@ -39,8 +39,6 @@ subroutine Photosynthesis_ED (sites,nsites,fcolumn,bc_in,bc_out,canopystate_inst 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 @@ -51,13 +49,15 @@ subroutine Photosynthesis_ED (sites,nsites,fcolumn,bc_in,bc_out,canopystate_inst use EDParamsMod , only : ED_val_grperc use EDSharedParamsMod , only : EDParamsShareInst use EDTypesMod , only : numpft_ed, dinc_ed - use EDtypesMod , only : numPatchesPerCol + use EDtypesMod , only : numPatchesPerCol use EDtypesMod , only : ed_patch_type, ed_cohort_type, ed_site_type, numpft_ed use EDEcophysContype , only : EDecophyscon use FatesInterfaceMod , only : bc_in_type,bc_out_type use ColumnType , only : col +! use clm_time_manager , only : get_step_size use CanopyStateType , only : canopystate_type - + + ! ! !ARGUMENTS: @@ -66,8 +66,8 @@ subroutine Photosynthesis_ED (sites,nsites,fcolumn,bc_in,bc_out,canopystate_inst type(bc_in_type),intent(in) :: bc_in(nsites) type(bc_out_type),intent(inout) :: bc_out(nsites) integer,intent(in) :: fcolumn(nsites) - - type(canopystate_type) , intent(in) :: canopystate_inst !LAI + real(r8),intent(in) :: dtime + type(canopystate_type) , intent(inout) :: canopystate_inst ! ! !CALLED FROM: @@ -151,7 +151,7 @@ subroutine Photosynthesis_ED (sites,nsites,fcolumn,bc_in,bc_out,canopystate_inst real(r8) :: theta_ip ! empirical curvature parameter for ap photosynthesis co-limitation ! Other - integer :: c,CL,f,s,iv,j,clmp,ps,ft,ifp ! indices + integer :: c,CL,f,s,iv,j,ps,ft,ifp ! 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] @@ -202,14 +202,13 @@ subroutine Photosynthesis_ED (sites,nsites,fcolumn,bc_in,bc_out,canopystate_inst real(r8) :: tree_area real(r8) :: gs_cohort real(r8) :: rscanopy + real(r8) :: elai ! 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 !------------------------------------------------------------------------------ ! @@ -228,13 +227,8 @@ subroutine Photosynthesis_ED (sites,nsites,fcolumn,bc_in,bc_out,canopystate_inst 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 - 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 - - - !set timestep - dtime = get_step_size() + elai_clm => canopystate_inst%elai_patch , & + bb_slope => EDecophyscon%BB_slope ) ! slope of BB relationship ! Assign local pointers to derived type members (gridcell-level) dr(1) = 0.025_r8; dr(2) = 0.015_r8 @@ -311,8 +305,6 @@ subroutine Photosynthesis_ED (sites,nsites,fcolumn,bc_in,bc_out,canopystate_inst do while (associated(currentpatch)) ifp = ifp+1 - clmp = col%patchi(c)+ifp - bc_out(s)%psncanopy_pa(ifp) = 0._r8 bc_out(s)%lmrcanopy_pa(ifp) = 0._r8 bc_out(s)%rssun_pa(ifp) = 0._r8 @@ -390,8 +382,7 @@ subroutine Photosynthesis_ED (sites,nsites,fcolumn,bc_in,bc_out,canopystate_inst currentpatch => sites(s)%oldest_patch do while (associated(currentpatch)) ifp = ifp+1 - clmp = col%patchi(c)+ifp - + if(bc_in(s)%filter_photo_pa(ifp)==2)then call t_startf('edfluxes') @@ -769,8 +760,8 @@ subroutine Photosynthesis_ED (sites,nsites,fcolumn,bc_in,bc_out,canopystate_inst ! Make sure iterative solution is correct if (gs_mol < 0._r8) then write (iulog,*)'Negative stomatal conductance:' - write (iulog,*)'clmp,iv,gs_mol= ',clmp,iv,gs_mol - call endrun(decomp_index=clmp, clmlevel=namep, msg=errmsg(__FILE__, __LINE__)) + write (iulog,*)'ifp,iv,gs_mol= ',ifp,iv,gs_mol + call endrun(msg=errmsg(__FILE__, __LINE__)) end if ! Compare with Ball-Berry model: gs_mol = m * an * hs/cs p + b @@ -1003,22 +994,33 @@ subroutine Photosynthesis_ED (sites,nsites,fcolumn,bc_in,bc_out,canopystate_inst enddo ! end cohort loop. end if !count_cohorts is more than zero. + + elai = 0._r8 + do CL = 1,currentPatch%NCL_p + do ft = 1,numpft_ed + elai = elai + sum(currentPatch%canopy_area_profile(CL,ft,1:currentPatch%nrad(CL,ft)) * & + currentPatch%elai_profile(CL,ft,1:currentPatch%nrad(CL,ft))) + enddo + enddo + elai = max(0.1_r8,elai) + + if( abs(elai-elai_clm(ifp+col%patchi(c)))>0.001_r8 )then + print*,ifp,elai,elai_clm(ifp+col%patchi(c)) + stop + end if bc_out(s)%psncanopy_pa(ifp) = bc_out(s)%psncanopy_pa(ifp) / currentPatch%area bc_out(s)%lmrcanopy_pa(ifp) = bc_out(s)%lmrcanopy_pa(ifp) / currentPatch%area - if(bc_out(s)%gccanopy_pa(ifp) > 1._r8/rsmax0.and.elai(clmp) > 0.0_r8)then - rscanopy = (1.0_r8/bc_out(s)%gccanopy_pa(ifp))-bc_in(s)%rb_pa(ifp)/elai(clmp) ! this needs to be resistance per unit leaf area. + if(bc_out(s)%gccanopy_pa(ifp) > 1._r8/rsmax0.and.elai_clm(ifp+col%patchi(c)) > 0.0_r8)then + rscanopy = (1.0_r8/bc_out(s)%gccanopy_pa(ifp))-bc_in(s)%rb_pa(ifp) ! this needs to be resistance per unit leaf area. else rscanopy = rsmax0 end if + bc_out(s)%rssun_pa(ifp) = (bc_out(s)%laisun_pa(ifp)+bc_out(s)%laisha_pa(ifp))*(bc_in(s)%rb_pa(ifp)+rscanopy)/elai_clm(ifp+col%patchi(c)) - bc_in(s)%rb_pa(ifp) + bc_out(s)%rssha_pa(ifp) = bc_out(s)%rssun_pa(ifp) bc_out(s)%gccanopy_pa(ifp) = 1.0_r8/rscanopy*cf/1000 !convert into umol m02 s-1 then mmol m-2 s-1. - else - rscanopy = rsmax0 end if - bc_out(s)%rssun_pa(ifp) = (bc_out(s)%laisun_pa(ifp)+bc_out(s)%laisha_pa(ifp))*(bc_in(s)%rb_pa(ifp)+rscanopy)/elai(clmp) - bc_in(s)%rb_pa(ifp) - bc_out(s)%rssha_pa(ifp) = bc_out(s)%rssun_pa(ifp) - currentPatch => currentPatch%younger call t_stopf('edfluxunpack3') From 0dc0614092505f04c01c001d4cb36739c74559c6 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 5 Aug 2016 12:29:05 -0700 Subject: [PATCH 135/437] photo interface 5: migrated internal lai calculation to photosynthesis and timestep as argument, 1x1br regressions pass --- biogeophys/EDPhotosynthesisMod.F90 | 18 ++++-------------- 1 file changed, 4 insertions(+), 14 deletions(-) diff --git a/biogeophys/EDPhotosynthesisMod.F90 b/biogeophys/EDPhotosynthesisMod.F90 index 3113ce64..11250167 100644 --- a/biogeophys/EDPhotosynthesisMod.F90 +++ b/biogeophys/EDPhotosynthesisMod.F90 @@ -26,7 +26,7 @@ module EDPhotosynthesisMod contains !--------------------------------------------------------- - subroutine Photosynthesis_ED (sites,nsites,fcolumn,bc_in,bc_out,dtime,canopystate_inst) + subroutine Photosynthesis_ED (sites,nsites,bc_in,bc_out,dtime) ! @@ -65,9 +65,7 @@ subroutine Photosynthesis_ED (sites,nsites,fcolumn,bc_in,bc_out,dtime,canopystat integer,intent(in) :: nsites type(bc_in_type),intent(in) :: bc_in(nsites) type(bc_out_type),intent(inout) :: bc_out(nsites) - integer,intent(in) :: fcolumn(nsites) real(r8),intent(in) :: dtime - type(canopystate_type) , intent(inout) :: canopystate_inst ! ! !CALLED FROM: @@ -227,7 +225,6 @@ subroutine Photosynthesis_ED (sites,nsites,fcolumn,bc_in,bc_out,dtime,canopystat woody => pftcon%woody , & ! Is vegetation woody or not? fnitr => pftcon%fnitr , & ! foliage nitrogen limitation factor (-) leafcn => pftcon%leafcn , & ! leaf C:N (gC/gN) - elai_clm => canopystate_inst%elai_patch , & bb_slope => EDecophyscon%BB_slope ) ! slope of BB relationship ! Assign local pointers to derived type members (gridcell-level) @@ -299,7 +296,6 @@ subroutine Photosynthesis_ED (sites,nsites,fcolumn,bc_in,bc_out,dtime,canopystat do s = 1,nsites - c = fcolumn(s) ifp = 0 currentpatch => sites(s)%oldest_patch do while (associated(currentpatch)) @@ -378,7 +374,6 @@ subroutine Photosynthesis_ED (sites,nsites,fcolumn,bc_in,bc_out,dtime,canopystat ! cumulative lai at the midpoint of the layer ifp = 0 - c = fcolumn(s) currentpatch => sites(s)%oldest_patch do while (associated(currentpatch)) ifp = ifp+1 @@ -1004,19 +999,14 @@ subroutine Photosynthesis_ED (sites,nsites,fcolumn,bc_in,bc_out,dtime,canopystat enddo elai = max(0.1_r8,elai) - if( abs(elai-elai_clm(ifp+col%patchi(c)))>0.001_r8 )then - print*,ifp,elai,elai_clm(ifp+col%patchi(c)) - stop - end if - bc_out(s)%psncanopy_pa(ifp) = bc_out(s)%psncanopy_pa(ifp) / currentPatch%area bc_out(s)%lmrcanopy_pa(ifp) = bc_out(s)%lmrcanopy_pa(ifp) / currentPatch%area - if(bc_out(s)%gccanopy_pa(ifp) > 1._r8/rsmax0.and.elai_clm(ifp+col%patchi(c)) > 0.0_r8)then - rscanopy = (1.0_r8/bc_out(s)%gccanopy_pa(ifp))-bc_in(s)%rb_pa(ifp) ! this needs to be resistance per unit leaf area. + if(bc_out(s)%gccanopy_pa(ifp) > 1._r8/rsmax0 .and. elai > 0.0_r8)then + rscanopy = (1.0_r8/bc_out(s)%gccanopy_pa(ifp))-bc_in(s)%rb_pa(ifp)/elai ! this needs to be resistance per unit leaf area. else rscanopy = rsmax0 end if - bc_out(s)%rssun_pa(ifp) = (bc_out(s)%laisun_pa(ifp)+bc_out(s)%laisha_pa(ifp))*(bc_in(s)%rb_pa(ifp)+rscanopy)/elai_clm(ifp+col%patchi(c)) - bc_in(s)%rb_pa(ifp) + bc_out(s)%rssun_pa(ifp) = (bc_out(s)%laisun_pa(ifp)+bc_out(s)%laisha_pa(ifp))*(bc_in(s)%rb_pa(ifp)+rscanopy)/elai - bc_in(s)%rb_pa(ifp) bc_out(s)%rssha_pa(ifp) = bc_out(s)%rssun_pa(ifp) bc_out(s)%gccanopy_pa(ifp) = 1.0_r8/rscanopy*cf/1000 !convert into umol m02 s-1 then mmol m-2 s-1. end if From 44b0fba20c06273e52f142f5176bbb298dc47772 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 5 Aug 2016 12:49:46 -0700 Subject: [PATCH 136/437] photo interface 6: made local copies of photosynthesis response and inhibition functions (Jinyun's)' --- biogeophys/EDPhotosynthesisMod.F90 | 188 +++++++++++++++++++++-------- 1 file changed, 140 insertions(+), 48 deletions(-) diff --git a/biogeophys/EDPhotosynthesisMod.F90 b/biogeophys/EDPhotosynthesisMod.F90 index 11250167..00813cee 100644 --- a/biogeophys/EDPhotosynthesisMod.F90 +++ b/biogeophys/EDPhotosynthesisMod.F90 @@ -43,9 +43,6 @@ subroutine Photosynthesis_ED (sites,nsites,bc_in,bc_out,dtime) 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 PatchType , only : patch - use quadraticMod , only : quadratic use EDParamsMod , only : ED_val_grperc use EDSharedParamsMod , only : EDParamsShareInst use EDTypesMod , only : numpft_ed, dinc_ed @@ -53,10 +50,6 @@ subroutine Photosynthesis_ED (sites,nsites,bc_in,bc_out,dtime) use EDtypesMod , only : ed_patch_type, ed_cohort_type, ed_site_type, numpft_ed use EDEcophysContype , only : EDecophyscon use FatesInterfaceMod , only : bc_in_type,bc_out_type - use ColumnType , only : col -! use clm_time_manager , only : get_step_size - use CanopyStateType , only : canopystate_type - ! @@ -202,22 +195,6 @@ subroutine Photosynthesis_ED (sites,nsites,bc_in,bc_out,dtime) real(r8) :: rscanopy real(r8) :: elai - ! 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] - !------------------------------------------------------------------------------ - - ! - ! 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] @@ -275,10 +252,10 @@ subroutine Photosynthesis_ED (sites,nsites,bc_in,bc_out,dtime) tpuse = 490._r8 lmrse = 490._r8 - vcmaxc = fth25(vcmaxhd, vcmaxse) - jmaxc = fth25(jmaxhd, jmaxse) - tpuc = fth25(tpuhd, tpuse) - lmrc = fth25(lmrhd, lmrse) + vcmaxc = fth25_f(vcmaxhd, vcmaxse) + jmaxc = fth25_f(jmaxhd, jmaxse) + tpuc = fth25_f(tpuhd, tpuse) + lmrc = fth25_f(lmrhd, lmrse) ! Miscellaneous parameters, from Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 @@ -355,9 +332,9 @@ subroutine Photosynthesis_ED (sites,nsites,bc_in,bc_out,dtime) cp25 = 0.5_r8 * bc_in(s)%oair_pa(ifp) / sco if(bc_in(s)%t_veg_pa(ifp).gt.150_r8.and.bc_in(s)%t_veg_pa(ifp).lt.350_r8)then - kc(ifp) = kc25 * ft1(bc_in(s)%t_veg_pa(ifp), kcha) - ko(ifp) = ko25 * ft1(bc_in(s)%t_veg_pa(ifp), koha) - co2_cp(ifp) = cp25 * ft1(bc_in(s)%t_veg_pa(ifp), cpha) + kc(ifp) = kc25 * ft1_f(bc_in(s)%t_veg_pa(ifp), kcha) + ko(ifp) = ko25 * ft1_f(bc_in(s)%t_veg_pa(ifp), koha) + co2_cp(ifp) = cp25 * ft1_f(bc_in(s)%t_veg_pa(ifp), cpha) else kc(ifp) = 1 ko(ifp) = 1 @@ -380,8 +357,6 @@ subroutine Photosynthesis_ED (sites,nsites,bc_in,bc_out,dtime) if(bc_in(s)%filter_photo_pa(ifp)==2)then - call t_startf('edfluxes') - NCL_p = currentPatch%NCL_p do FT = 1,numpft_ed !calculate patch and pft specific propserties at canopy top. @@ -491,7 +466,7 @@ subroutine Photosynthesis_ED (sites,nsites,bc_in,bc_out,dtime) lmr25 = lmr25top(FT) * nscaler if (nint(c3psn(FT)) == 1)then - lmr_z(CL,FT,iv) = lmr25 * ft1(bc_in(s)%t_veg_pa(ifp), lmrha) * fth(bc_in(s)%t_veg_pa(ifp), lmrhd, lmrse, lmrc) + lmr_z(CL,FT,iv) = lmr25 * ft1_f(bc_in(s)%t_veg_pa(ifp), lmrha) * fth_f(bc_in(s)%t_veg_pa(ifp), lmrhd, lmrse, lmrc) else lmr_z(CL,FT,iv) = lmr25 * 2._r8**((bc_in(s)%t_veg_pa(ifp)-(tfrz+25._r8))/10._r8) lmr_z(CL,FT,iv) = lmr_z(CL,FT,iv) / (1._r8 + exp( 1.3_r8*(bc_in(s)%t_veg_pa(ifp)-(tfrz+55._r8)) )) @@ -509,9 +484,9 @@ subroutine Photosynthesis_ED (sites,nsites,bc_in,bc_out,dtime) kp25 = kp25top(FT) * nscaler ! Adjust for temperature - vcmax_z(CL,FT,iv) = vcmax25 * ft1(bc_in(s)%t_veg_pa(ifp), vcmaxha) * fth(bc_in(s)%t_veg_pa(ifp), vcmaxhd, vcmaxse, vcmaxc) - jmax_z(CL,FT,iv) = jmax25 * ft1(bc_in(s)%t_veg_pa(ifp), jmaxha) * fth(bc_in(s)%t_veg_pa(ifp), jmaxhd, jmaxse, jmaxc) - tpu_z(CL,FT,iv) = tpu25 * ft1(bc_in(s)%t_veg_pa(ifp), tpuha) * fth(bc_in(s)%t_veg_pa(ifp), tpuhd, tpuse, tpuc) + vcmax_z(CL,FT,iv) = vcmax25 * ft1_f(bc_in(s)%t_veg_pa(ifp), vcmaxha) * fth_f(bc_in(s)%t_veg_pa(ifp), vcmaxhd, vcmaxse, vcmaxc) + jmax_z(CL,FT,iv) = jmax25 * ft1_f(bc_in(s)%t_veg_pa(ifp), jmaxha) * fth_f(bc_in(s)%t_veg_pa(ifp), jmaxhd, jmaxse, jmaxc) + tpu_z(CL,FT,iv) = tpu25 * ft1_f(bc_in(s)%t_veg_pa(ifp), tpuha) * fth_f(bc_in(s)%t_veg_pa(ifp), tpuhd, tpuse, tpuc) if (nint(c3psn(FT)) /= 1) then vcmax_z(CL,FT,iv) = vcmax25 * 2._r8**((bc_in(s)%t_veg_pa(ifp)-(tfrz+25._r8))/10._r8) @@ -784,9 +759,6 @@ subroutine Photosynthesis_ED (sites,nsites,bc_in,bc_out,dtime) end do ! PFT loop end do !canopy layer - call t_stopf('edfluxes') - call t_startf('edunpack') - !==============================================================================! ! Unpack fluxes from arrays into cohorts !==============================================================================! @@ -798,7 +770,6 @@ subroutine Photosynthesis_ED (sites,nsites,bc_in,bc_out,dtime) currentCohort => currentPatch%tallest ! Cohort loop do while (associated(currentCohort)) ! Cohort loop - call t_startf('edfluxunpack1') if(currentCohort%n > 0._r8)then @@ -868,9 +839,6 @@ subroutine Photosynthesis_ED (sites,nsites,bc_in,bc_out,dtime) 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. @@ -929,8 +897,6 @@ subroutine Photosynthesis_ED (sites,nsites,bc_in,bc_out,dtime) 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 @@ -1013,14 +979,140 @@ subroutine Photosynthesis_ED (sites,nsites,bc_in,bc_out,dtime) currentPatch => currentPatch%younger - call t_stopf('edfluxunpack3') - call t_stopf('edunpack') end do end do !site loop end associate - + end subroutine Photosynthesis_ED +! ======================================================================================= + +function ft1_f(tl, ha) result(ans) + ! + !!DESCRIPTION: + ! photosynthesis temperature response + ! + ! !REVISION HISTORY + ! Jinyun Tang separated it out from Photosynthesis, Feb. 07/2013 + ! 7/23/16: Copied over from CLM by Ryan Knox + ! + !!USES + use clm_varcon , only : rgas, tfrz + ! + ! !ARGUMENTS: + real(r8), intent(in) :: tl ! leaf temperature in photosynthesis temperature function (K) + real(r8), intent(in) :: ha ! activation energy in photosynthesis temperature function (J/mol) + ! + ! !LOCAL VARIABLES: + real(r8) :: ans + !------------------------------------------------------------------------------- + + ans = exp( ha / (rgas*1.e-3_r8*(tfrz+25._r8)) * (1._r8 - (tfrz+25._r8)/tl) ) + + return + end function ft1_f + + ! ===================================================================================== + + function fth_f(tl,hd,se,scaleFactor) result(ans) + ! + !!DESCRIPTION: + !photosynthesis temperature inhibition + ! + ! !REVISION HISTORY + ! Jinyun Tang separated it out from Photosynthesis, Feb. 07/2013 + ! 7/23/16: Copied over from CLM by Ryan Knox + ! + use clm_varcon , only : rgas, tfrz + ! + ! !ARGUMENTS: + real(r8), intent(in) :: tl ! leaf temperature in photosynthesis temperature function (K) + real(r8), intent(in) :: hd ! deactivation energy in photosynthesis temperature function (J/mol) + real(r8), intent(in) :: se ! entropy term in photosynthesis temperature function (J/mol/K) + real(r8), intent(in) :: scaleFactor ! scaling factor for high temperature inhibition (25 C = 1.0) + ! + ! !LOCAL VARIABLES: + real(r8) :: ans + !------------------------------------------------------------------------------- + + ans = scaleFactor / ( 1._r8 + exp( (-hd+se*tl) / (rgas*1.e-3_r8*tl) ) ) + + return + end function fth_f + + ! ===================================================================================== + + function fth25_f(hd,se)result(ans) + ! + !!DESCRIPTION: + ! scaling factor for photosynthesis temperature inhibition + ! + ! !REVISION HISTORY: + ! Jinyun Tang separated it out from Photosynthesis, Feb. 07/2013 + ! 7/23/16: Copied over from CLM by Ryan Knox + ! + !!USES + use clm_varcon , only : rgas, tfrz + ! + ! !ARGUMENTS: + real(r8), intent(in) :: hd ! deactivation energy in photosynthesis temperature function (J/mol) + real(r8), intent(in) :: se ! entropy term in photosynthesis temperature function (J/mol/K) + ! + ! !LOCAL VARIABLES: + real(r8) :: ans + !------------------------------------------------------------------------------- + + ans = 1._r8 + exp( (-hd+se*(tfrz+25._r8)) / (rgas*1.e-3_r8*(tfrz+25._r8)) ) + + return + end function fth25_f + + ! ===================================================================================== + + subroutine quadratic_f (a, b, c, r1, r2) + ! + ! !DESCRIPTION: + !==============================================================================! + !----------------- Solve quadratic equation for its two roots -----------------! + !==============================================================================! + ! Solution from Press et al (1986) Numerical Recipes: The Art of Scientific + ! Computing (Cambridge University Press, Cambridge), pp. 145. + ! + ! !REVISION HISTORY: + ! 4/5/10: Adapted from /home/bonan/ecm/psn/An_gs_iterative.f90 by Keith Oleson + ! 7/23/16: Copied over from CLM by Ryan Knox + ! + ! !USES: + implicit none + ! + ! !ARGUMENTS: + real(r8), intent(in) :: a,b,c ! Terms for quadratic equation + real(r8), intent(out) :: r1,r2 ! Roots of quadratic equation + ! + ! !LOCAL VARIABLES: + real(r8) :: q ! Temporary term for quadratic solution + !------------------------------------------------------------------------------ + + if (a == 0._r8) then + write (iulog,*) 'Quadratic solution error: a = ',a + call endrun(msg=errmsg(__FILE__, __LINE__)) + end if + + if (b >= 0._r8) then + q = -0.5_r8 * (b + sqrt(b*b - 4._r8*a*c)) + else + q = -0.5_r8 * (b - sqrt(b*b - 4._r8*a*c)) + end if + + r1 = q / a + if (q /= 0._r8) then + r2 = c / q + else + r2 = 1.e36_r8 + end if + + end subroutine quadratic_f + end module EDPhotosynthesisMod From a4ec8c95ca35fa41538bfb89030fdef202d7591a Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Fri, 5 Aug 2016 13:54:00 -0700 Subject: [PATCH 137/437] start of some changes to pull flux_into_litter_pools out of EDCLMLinkMod and into EDPhysiologyMod --- biogeochem/EDPhysiologyMod.F90 | 353 ++++++++++++++++++++++++++++++++ main/EDCLMLinkMod.F90 | 364 --------------------------------- main/EDTypesMod.F90 | 2 + main/FatesInterfaceMod.F90 | 32 ++- 4 files changed, 386 insertions(+), 365 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 4f00de3b..49d7ee30 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1269,4 +1269,357 @@ end subroutine cwd_out + subroutine flux_into_litter_pools(bounds, sites, nsites, fcolumn, canopystate_inst) + ! Created by Charlie Koven and Rosie Fisher, 2014-2015 + ! take the flux out of the fragmenting litter pools and port into the decomposing litter pools. + ! in this implementation, decomposing pools are assumed to be humus and non-flammable, whereas fragmenting pools + ! are assumed to be physically fragmenting but not respiring. This is a simplification, but allows us to + ! a) reconcile the need to track both chemical fractions (lignin, cellulose, labile) and size fractions (trunk, branch, etc.) + ! b) to impose a realistic delay on the surge of nutrients into the litter pools when large CWD is added to the system via mortality + + ! because of the different subgrid structure, this subroutine includes the functionality that in the big-leaf BGC model, is calculated in SoilBiogeochemVerticalProfileMod + + ! The ED code is resolved at a daily timestep, but all of the CN-BGC fluxes are passed in as derivatives per second, + ! and then accumulated in the CNStateUpdate routines. One way of doing this is to pass back the CN fluxes per second, + ! and keep them constant for the whole day (making sure they are not overwritten. + ! This means that the carbon gets passed back and forth between the photosynthesis code (fast timestepping) to the ED code (slow timestepping), back to the BGC code (fast timestepping). + ! This means that the state update for the litter pools and for the CWD pools occurs at different timescales. + + use SFParamsMod, only: SF_val_max_decomp + use clm_varpar, only : mxpft,nlevdecomp, nlevdecomp_full + use EDTypesMod, only : AREA, numpft_ed + use SoilBiogeochemVerticalProfileMod, only: exponential_rooting_profile, pftspecific_rootingprofile, rootprof_exp, surfprof_exp + use pftconMod, only : pftcon + + use clm_varcon, only : zisoi, dzsoi_decomp, zsoi + use EDParamsMod, only : ED_val_ag_biomass + ! + implicit none + ! + ! !ARGUMENTS + type(bounds_type) , intent(in) :: bounds + type(ed_site_type) , intent(inout), target :: sites(nsites) + integer , intent(in) :: nsites + integer , intent(in) :: fcolumn(nsites) + type(canopystate_type) , intent(inout) :: canopystate_inst + ! + ! !LOCAL VARIABLES: + type (ed_patch_type) , pointer :: currentPatch + type (ed_cohort_type) , pointer :: currentCohort + type(ed_site_type), pointer :: cs + integer c,p,ci,j,s + real(r8) time_convert ! from year to seconds + real(r8) mass_convert ! ED uses kg, CLM uses g + integer :: begp,endp + integer :: begc,endc !bounds + !------------------------------------------------------------------------ + real(r8) :: cinput_rootfr(bounds%begc:bounds%endc, 1:numpft_ed, 1:nlevdecomp_full) ! column by pft root fraction used for calculating inputs + real(r8) :: croot_prof_perpatch(1:nlevdecomp_full) + real(r8) :: surface_prof(1:nlevdecomp_full) + integer :: ft, lev + real(r8) :: rootfr_tot(1:numpft_ed), biomass_bg_ft(1:numpft_ed) + real(r8) :: surface_prof_tot, leaf_prof_sum, stem_prof_sum, froot_prof_sum, biomass_bg_tot + real(r8) :: delta + + begp = bounds%begp; endp = bounds%endp + begc = bounds%begc; endc = bounds%endc + delta = 0.001_r8 + !no of seconds in a year. + time_convert = 365.0_r8*SHR_CONST_CDAY + + ! number of grams in a kilogram + mass_convert = 1000._r8 + + associate( & + ED_c_to_litr_lab_c => this%ED_c_to_litr_lab_c_col , & ! Output: total labile litter coming from ED. gC/m3/s + ED_c_to_litr_cel_c => this%ED_c_to_litr_cel_c_col , & ! Output: total cellulose litter coming from ED. gC/m3/s + ED_c_to_litr_lig_c => this%ED_c_to_litr_lig_c_col , & ! Output: total lignin litter coming from ED. gC/m3/s + leaf_prof => this%leaf_prof_col , & ! Output: (1/m) profile of leaves + froot_prof => this%froot_prof_col , & ! Output: (1/m) profile of fine roots + croot_prof => this%croot_prof_col , & ! Output: (1/m) profile of coarse roots + stem_prof => this%stem_prof_col , & ! Output: (1/m) profile of leaves + max_rooting_depth_index => bc_in%max_rooting_depth_index_col & ! Input: index of lowest soil level where roots may be, due to permafrost or bedrock constraints + ) + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! first calculate vertical profiles + ! define two types of profiles: + ! (1) a surface profile, for leaves and stem inputs, which is the same for each pft but differs from one column to the next to avoid inputting any C into permafrost + ! (2) a fine root profile, which is indexed by both column and pft, differs for each pft and also from one column to the next to avoid inputting any C into permafrost + ! (3) a coarse root profile, which is the root-biomass=weighted average of the fine root profiles + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + if (use_vertsoilc) then + + ! define a single shallow surface profile for surface additions (leaves, stems, and N deposition) + surface_prof(:) = 0._r8 + do j = 1, nlevdecomp + surface_prof(j) = exp(-surfprof_exp * zsoi(j)) / dzsoi_decomp(j) + end do + + ! initialize profiles to zero + leaf_prof(begc:endc, :) = 0._r8 + froot_prof(begc:endc, 1:numpft_ed, :) = 0._r8 + croot_prof(begc:endc, :) = 0._r8 + stem_prof(begc:endc, :) = 0._r8 + + cinput_rootfr(begc:endc, 1:numpft_ed, :) = 0._r8 + + do c = bounds%begc,bounds%endc + + ! calculate pft-specific rooting profiles in the absence of permafrost limitations + if ( exponential_rooting_profile ) then + if ( .not. pftspecific_rootingprofile ) then + ! define rooting profile from exponential parameters + do ft = 1, numpft_ed + do j = 1, nlevdecomp + cinput_rootfr(c,ft,j) = exp(-rootprof_exp * zsoi(j)) / dzsoi_decomp(j) + end do + end do + else + ! use beta distribution parameter from Jackson et al., 1996 + do ft = 1, numpft_ed + do j = 1, nlevdecomp + cinput_rootfr(c,ft,j) = ( pftcon%rootprof_beta(ft) ** (zisoi(j-1)*100._r8) - & + pftcon%rootprof_beta(ft) ** (zisoi(j)*100._r8) ) & + / dzsoi_decomp(j) + end do + end do + endif + else + do ft = 1,numpft_ed + do j = 1, nlevdecomp + ! use standard CLM root fraction profiles; + cinput_rootfr(c,ft,j) = ( .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)))) / dzsoi_decomp(j) + end do + end do + endif + ! + ! + ! now add permafrost constraint: integrate rootfr over active layer of soil column, + ! truncate below permafrost table where present, and rescale so that integral = 1 + do ft = 1,numpft_ed + rootfr_tot(ft) = 0._r8 + end do + surface_prof_tot = 0._r8 + ! + do j = 1, min(max(max_rooting_depth_index(c), 1), nlevdecomp) + surface_prof_tot = surface_prof_tot + surface_prof(j) * dzsoi_decomp(j) + end do + do ft = 1,numpft_ed + do j = 1, min(max(max_rooting_depth_index(c), 1), nlevdecomp) + rootfr_tot(ft) = rootfr_tot(ft) + cinput_rootfr(c,ft,j) * dzsoi_decomp(j) + end do + end do + ! + ! rescale the fine root profile + do ft = 1,numpft_ed + if ( (max_rooting_depth_index(c) > 0) .and. (rootfr_tot(ft) > 0._r8) ) then + ! where there is not permafrost extending to the surface, integrate the profiles over the active layer + ! this is equivalent to integrating over all soil layers outside of permafrost regions + do j = 1, min(max(max_rooting_depth_index(c), 1), nlevdecomp) + froot_prof(c,ft,j) = cinput_rootfr(c,ft,j) / rootfr_tot(ft) + end do + else + ! if fully frozen, or no roots, put everything in the top layer + froot_prof(c,ft,1) = 1._r8/dzsoi_decomp(1) + endif + end do + ! + ! rescale the shallow profiles + if ( (max_rooting_depth_index(c) > 0) .and. (surface_prof_tot > 0._r8) ) then + ! where there is not permafrost extending to the surface, integrate the profiles over the active layer + ! this is equivalent to integrating over all soil layers outside of permafrost regions + do j = 1, min(max(max_rooting_depth_index(c), 1), nlevdecomp) + ! set all surface processes to shallower profile + leaf_prof(c,j) = surface_prof(j)/ surface_prof_tot + stem_prof(c,j) = surface_prof(j)/ surface_prof_tot + end do + else + ! if fully frozen, or no roots, put everything in the top layer + leaf_prof(c,1) = 1._r8/dzsoi_decomp(1) + stem_prof(c,1) = 1._r8/dzsoi_decomp(1) + do j = 2, nlevdecomp + leaf_prof(c,j) = 0._r8 + stem_prof(c,j) = 0._r8 + end do + endif + end do + + else + + ! for one layer decomposition model, set profiles to unity + leaf_prof(bounds%begc:bounds%endc, :) = 1._r8 + froot_prof(bounds%begc:bounds%endc, 1:numpft_ed, :) = 1._r8 + stem_prof(bounds%begc:bounds%endc, :) = 1._r8 + + end if + + ! sanity check to ensure they integrate to 1 + do c = bounds%begc,bounds%endc + ! check the leaf and stem profiles + leaf_prof_sum = 0._r8 + stem_prof_sum = 0._r8 + do j = 1, nlevdecomp + leaf_prof_sum = leaf_prof_sum + leaf_prof(c,j) * dzsoi_decomp(j) + stem_prof_sum = stem_prof_sum + stem_prof(c,j) * dzsoi_decomp(j) + end do + if ( ( abs(stem_prof_sum - 1._r8) > delta ) .or. ( abs(leaf_prof_sum - 1._r8) > delta ) ) then + write(iulog, *) 'profile sums: ', leaf_prof_sum, stem_prof_sum + write(iulog, *) 'surface_prof: ', surface_prof + write(iulog, *) 'surface_prof_tot: ', surface_prof_tot + write(iulog, *) 'leaf_prof: ', leaf_prof(c,:) + write(iulog, *) 'stem_prof: ', stem_prof(c,:) + write(iulog, *) 'max_rooting_depth_index: ', max_rooting_depth_index(c) + write(iulog, *) 'dzsoi_decomp: ', dzsoi_decomp + call endrun(msg=' ERROR: sum-1 > delta'//errMsg(__FILE__, __LINE__)) + endif + ! now check each fine root profile + do ft = 1,numpft_ed + froot_prof_sum = 0._r8 + do j = 1, nlevdecomp + froot_prof_sum = froot_prof_sum + froot_prof(c,ft,j) * dzsoi_decomp(j) + end do + if ( ( abs(froot_prof_sum - 1._r8) > delta ) ) then + write(iulog, *) 'profile sums: ', froot_prof_sum + call endrun(msg=' ERROR: sum-1 > delta'//errMsg(__FILE__, __LINE__)) + endif + end do + end do + + ! zero the column-level C input variables + do c = bounds%begc,bounds%endc + do j = 1, nlevdecomp + ED_c_to_litr_lab_c(c,j) = 0._r8 + ED_c_to_litr_cel_c(c,j) = 0._r8 + ED_c_to_litr_lig_c(c,j) = 0._r8 + croot_prof(c,j) = 0._r8 + end do + end do + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! now disaggregate the inputs vertically, using the vertical profiles + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + do s = 1,nsites + + ! do g = bounds%begg,bounds%endg + ! if (firstsoilpatch(g) >= 0 .and. ed_allsites_inst(g)%istheresoil) then + c = fcolumn(s) + currentPatch => sites(s)%oldest_patch + + do while(associated(currentPatch)) + + ! cs => currentpatch%siteptr + ! cc = cs%clmcolumn + + ! the CWD pools lose information about which PFT they came from; for the stems this doesn't matter as they all have the same profile, + ! however for the coarse roots they may have different profiles. to approximately recover this information, loop over all cohorts in patch + ! to calculate the total root biomass in that patch of each pft, and then rescale the croot_prof as the weighted average of the froot_prof + biomass_bg_ft(1:numpft_ed) = 0._r8 + currentCohort => currentPatch%tallest + do while(associated(currentCohort)) + biomass_bg_ft(currentCohort%pft) = biomass_bg_ft(currentCohort%pft) + currentCohort%b * (currentCohort%n / currentPatch%area) * (1.0_r8-ED_val_ag_biomass) + currentCohort => currentCohort%shorter + enddo !currentCohort + ! + biomass_bg_tot = 0._r8 + do ft = 1,numpft_ed + biomass_bg_tot = biomass_bg_tot + biomass_bg_ft(ft) + end do + ! + do j = 1, nlevdecomp + ! zero this for each patch + croot_prof_perpatch(j) = 0._r8 + end do + ! + if ( biomass_bg_tot .gt. 0._r8) then + do ft = 1,numpft_ed + do j = 1, nlevdecomp + croot_prof_perpatch(j) = croot_prof_perpatch(j) + froot_prof(c,ft,j) * biomass_bg_ft(ft) / biomass_bg_tot + end do + end do + else ! no biomass + croot_prof_perpatch(1) = 1./dzsoi_decomp(1) + end if + + ! + ! add croot_prof as weighted average (weighted by patch area) of croot_prof_perpatch + do j = 1, nlevdecomp + croot_prof(c, j) = croot_prof(c, j) + croot_prof_perpatch(j) * currentPatch%area / AREA + end do + ! + ! now disaggregate, vertically and by decomposition substrate type, the actual fluxes from CWD and litter pools + ! + ! do c = 1, ncwd + ! write(iulog,*)'cdk CWD_AG_out', c, currentpatch%CWD_AG_out(c), cwd_fcel_ed, currentpatch%area/AREA + ! write(iulog,*)'cdk CWD_BG_out', c, currentpatch%CWD_BG_out(c), cwd_fcel_ed, currentpatch%area/AREA + ! end do + ! do ft = 1,numpft_ed + ! write(iulog,*)'cdk leaf_litter_out', ft, currentpatch%leaf_litter_out(ft), cwd_fcel_ed, currentpatch%area/AREA + ! write(iulog,*)'cdk root_litter_out', ft, currentpatch%root_litter_out(ft), cwd_fcel_ed, currentpatch%area/AREA + ! end do + ! ! + ! CWD pools fragmenting into decomposing litter pools. + do ci = 1, ncwd + do j = 1, nlevdecomp + ED_c_to_litr_cel_c(c,j) = ED_c_to_litr_cel_c(c,j) + currentpatch%CWD_AG_out(ci) * cwd_fcel_ed * currentpatch%area/AREA * stem_prof(c,j) + ED_c_to_litr_lig_c(c,j) = ED_c_to_litr_lig_c(c,j) + currentpatch%CWD_AG_out(ci) * cwd_flig_ed * currentpatch%area/AREA * stem_prof(c,j) + ! + ED_c_to_litr_cel_c(c,j) = ED_c_to_litr_cel_c(c,j) + currentpatch%CWD_BG_out(ci) * cwd_fcel_ed * currentpatch%area/AREA * croot_prof_perpatch(j) + ED_c_to_litr_lig_c(c,j) = ED_c_to_litr_lig_c(c,j) + currentpatch%CWD_BG_out(ci) * cwd_flig_ed * currentpatch%area/AREA * croot_prof_perpatch(j) + end do + end do + + ! leaf and fine root pools. + do ft = 1,numpft_ed + do j = 1, nlevdecomp + ED_c_to_litr_lab_c(c,j) = ED_c_to_litr_lab_c(c,j) + currentpatch%leaf_litter_out(ft) * pftcon%lf_flab(ft) * currentpatch%area/AREA * leaf_prof(c,j) + ED_c_to_litr_cel_c(c,j) = ED_c_to_litr_cel_c(c,j) + currentpatch%leaf_litter_out(ft) * pftcon%lf_fcel(ft) * currentpatch%area/AREA * leaf_prof(c,j) + ED_c_to_litr_lig_c(c,j) = ED_c_to_litr_lig_c(c,j) + currentpatch%leaf_litter_out(ft) * pftcon%lf_flig(ft) * currentpatch%area/AREA * leaf_prof(c,j) + ! + ED_c_to_litr_lab_c(c,j) = ED_c_to_litr_lab_c(c,j) + currentpatch%root_litter_out(ft) * pftcon%fr_flab(ft) * currentpatch%area/AREA * froot_prof(c,ft,j) + ED_c_to_litr_cel_c(c,j) = ED_c_to_litr_cel_c(c,j) + currentpatch%root_litter_out(ft) * pftcon%fr_fcel(ft) * currentpatch%area/AREA * froot_prof(c,ft,j) + ED_c_to_litr_lig_c(c,j) = ED_c_to_litr_lig_c(c,j) + currentpatch%root_litter_out(ft) * pftcon%fr_flig(ft) * currentpatch%area/AREA * froot_prof(c,ft,j) + ! + !! and seed_decay too. for now, use the same lability fractions as for leaf litter + ED_c_to_litr_lab_c(c,j) = ED_c_to_litr_lab_c(c,j) + currentpatch%seed_decay(ft) * pftcon%lf_flab(ft) * currentpatch%area/AREA * leaf_prof(c,j) + ED_c_to_litr_cel_c(c,j) = ED_c_to_litr_cel_c(c,j) + currentpatch%seed_decay(ft) * pftcon%lf_fcel(ft) * currentpatch%area/AREA * leaf_prof(c,j) + ED_c_to_litr_lig_c(c,j) = ED_c_to_litr_lig_c(c,j) + currentpatch%seed_decay(ft) * pftcon%lf_flig(ft) * currentpatch%area/AREA * leaf_prof(c,j) + ! + enddo + end do + + currentPatch => currentPatch%younger + end do !currentPatch + + end do ! do sites(s) + + do c = bounds%begc,bounds%endc + do j = 1, nlevdecomp + ! time unit conversion + ED_c_to_litr_lab_c(c,j)=ED_c_to_litr_lab_c(c,j) * mass_convert / time_convert + ED_c_to_litr_cel_c(c,j)=ED_c_to_litr_cel_c(c,j) * mass_convert / time_convert + ED_c_to_litr_lig_c(c,j)=ED_c_to_litr_lig_c(c,j) * mass_convert / time_convert + + end do + end do + + ! write(iulog,*)'cdk ED_c_to_litr_lab_c: ', ED_c_to_litr_lab_c + ! write(iulog,*)'cdk ED_c_to_litr_cel_c: ', ED_c_to_litr_cel_c + ! write(iulog,*)'cdk ED_c_to_litr_lig_c: ', ED_c_to_litr_lig_c + ! write(iulog,*)'cdk nlevdecomp_full, bounds%begc, bounds%endc: ', nlevdecomp_full, bounds%begc, bounds%endc + ! write(iulog,*)'cdk leaf_prof: ', leaf_prof + ! write(iulog,*)'cdk stem_prof: ', stem_prof + ! write(iulog,*)'cdk froot_prof: ', froot_prof + ! write(iulog,*)'cdk croot_prof_perpatch: ', croot_prof_perpatch + ! write(iulog,*)'cdk croot_prof: ', croot_prof + + end associate + end subroutine flux_into_litter_pools + end module EDPhysiologyMod diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 67ccb500..be1c3a3b 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -123,11 +123,6 @@ module EDCLMLinkMod real(r8), pointer :: ed_m4_col_scpf (:,:) ! [Stems/ha/yr] Mean Impact Mortality real(r8), pointer :: ed_m5_col_scpf (:,:) ! [Stems/ha/yr] Mean Fire Mortality - ! litterfall fluxes of C from ED patches to BGC columns - real(r8), pointer, public :: ED_c_to_litr_lab_c_col(:,:) !total labile litter coming from ED. gC/m3/s - real(r8), pointer, public :: ED_c_to_litr_cel_c_col(:,:) !total cellulose litter coming from ED. gC/m3/s - real(r8), pointer, public :: ED_c_to_litr_lig_c_col(:,:) !total lignin litter coming from ED. gC/m3/s - ! profiles for vertically disaggregating litterfall fluxes real(r8), pointer, private :: leaf_prof_col(:,:) !(1/m) profile of leaves real(r8), pointer, private :: froot_prof_col(:,:,:) !(1/m) profile of fine roots @@ -184,7 +179,6 @@ module EDCLMLinkMod procedure , private :: InitAllocate procedure , private :: InitHistory ! procedure , private :: InitCold - procedure , private :: flux_into_litter_pools end type ed_clm_type @@ -279,10 +273,6 @@ subroutine InitAllocate(this, bounds) allocate(this%maint_resp_patch (begp:endp)) ; this%maint_resp_patch (:) = nan allocate(this%growth_resp_patch (begp:endp)) ; this%growth_resp_patch (:) = nan - allocate(this%ED_c_to_litr_lab_c_col (begc:endc,1:nlevdecomp_full)) ; this%ED_c_to_litr_lab_c_col (:,:) = nan - allocate(this%ED_c_to_litr_cel_c_col (begc:endc,1:nlevdecomp_full)) ; this%ED_c_to_litr_cel_c_col (:,:) = nan - allocate(this%ED_c_to_litr_lig_c_col (begc:endc,1:nlevdecomp_full)) ; this%ED_c_to_litr_lig_c_col (:,:) = nan - allocate(this%leaf_prof_col (begc:endc,1:nlevdecomp_full)) ; this%leaf_prof_col (:,:) = nan allocate(this%froot_prof_col (begc:endc,1:numpft_ed,1:nlevdecomp_full)); this%froot_prof_col (:,:,:) = nan allocate(this%croot_prof_col (begc:endc,1:nlevdecomp_full)) ; this%croot_prof_col (:,:) = nan @@ -2082,360 +2072,6 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, colindex, waterstate_ins end subroutine ed_clm_leaf_area_profile - subroutine flux_into_litter_pools(this, bounds, sites, nsites, fcolumn, canopystate_inst) - ! Created by Charlie Koven and Rosie Fisher, 2014-2015 - ! take the flux out of the fragmenting litter pools and port into the decomposing litter pools. - ! in this implementation, decomposing pools are assumed to be humus and non-flammable, whereas fragmenting pools - ! are assumed to be physically fragmenting but not respiring. This is a simplification, but allows us to - ! a) reconcile the need to track both chemical fractions (lignin, cellulose, labile) and size fractions (trunk, branch, etc.) - ! b) to impose a realistic delay on the surge of nutrients into the litter pools when large CWD is added to the system via mortality - - ! because of the different subgrid structure, this subroutine includes the functionality that in the big-leaf BGC model, is calculated in SoilBiogeochemVerticalProfileMod - - ! The ED code is resolved at a daily timestep, but all of the CN-BGC fluxes are passed in as derivatives per second, - ! and then accumulated in the CNStateUpdate routines. One way of doing this is to pass back the CN fluxes per second, - ! and keep them constant for the whole day (making sure they are not overwritten. - ! This means that the carbon gets passed back and forth between the photosynthesis code (fast timestepping) to the ED code (slow timestepping), back to the BGC code (fast timestepping). - ! This means that the state update for the litter pools and for the CWD pools occurs at different timescales. - - use SFParamsMod, only: SF_val_max_decomp - use clm_varpar, only : mxpft,nlevdecomp, nlevdecomp_full - use EDTypesMod, only : AREA, numpft_ed - use SoilBiogeochemVerticalProfileMod, only: exponential_rooting_profile, pftspecific_rootingprofile, rootprof_exp, surfprof_exp - use pftconMod, only : pftcon - - use clm_varcon, only : zisoi, dzsoi_decomp, zsoi - use EDParamsMod, only : ED_val_ag_biomass - ! - implicit none - ! - ! !ARGUMENTS - class(ed_clm_type) :: this - type(bounds_type) , intent(in) :: bounds - type(ed_site_type) , intent(inout), target :: sites(nsites) - integer , intent(in) :: nsites - integer , intent(in) :: fcolumn(nsites) - type(canopystate_type) , intent(inout) :: canopystate_inst - ! - ! !LOCAL VARIABLES: - type (ed_patch_type) , pointer :: currentPatch - type (ed_cohort_type) , pointer :: currentCohort - type(ed_site_type), pointer :: cs - integer c,p,ci,j,s - real(r8) time_convert ! from year to seconds - real(r8) mass_convert ! ED uses kg, CLM uses g - integer :: begp,endp - integer :: begc,endc !bounds - !------------------------------------------------------------------------ - real(r8) :: cinput_rootfr(bounds%begc:bounds%endc, 1:numpft_ed, 1:nlevdecomp_full) ! column by pft root fraction used for calculating inputs - real(r8) :: croot_prof_perpatch(1:nlevdecomp_full) - real(r8) :: surface_prof(1:nlevdecomp_full) - integer :: ft, lev - real(r8) :: rootfr_tot(1:numpft_ed), biomass_bg_ft(1:numpft_ed) - real(r8) :: surface_prof_tot, leaf_prof_sum, stem_prof_sum, froot_prof_sum, biomass_bg_tot - real(r8) :: delta - - begp = bounds%begp; endp = bounds%endp - begc = bounds%begc; endc = bounds%endc - delta = 0.001_r8 - !no of seconds in a year. - time_convert = 365.0_r8*SHR_CONST_CDAY - - ! number of grams in a kilogram - mass_convert = 1000._r8 - - associate( & - ED_c_to_litr_lab_c => this%ED_c_to_litr_lab_c_col , & ! Output: total labile litter coming from ED. gC/m3/s - ED_c_to_litr_cel_c => this%ED_c_to_litr_cel_c_col , & ! Output: total cellulose litter coming from ED. gC/m3/s - ED_c_to_litr_lig_c => this%ED_c_to_litr_lig_c_col , & ! Output: total lignin litter coming from ED. gC/m3/s - leaf_prof => this%leaf_prof_col , & ! Output: (1/m) profile of leaves - froot_prof => this%froot_prof_col , & ! Output: (1/m) profile of fine roots - croot_prof => this%croot_prof_col , & ! Output: (1/m) profile of coarse roots - stem_prof => this%stem_prof_col , & ! Output: (1/m) profile of leaves - altmax_lastyear_indx => canopystate_inst%altmax_lastyear_indx_col & ! Input: [integer (:) ]frost table depth (m) - ) - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! first calculate vertical profiles - ! define two types of profiles: - ! (1) a surface profile, for leaves and stem inputs, which is the same for each pft but differs from one column to the next to avoid inputting any C into permafrost - ! (2) a fine root profile, which is indexed by both column and pft, differs for each pft and also from one column to the next to avoid inputting any C into permafrost - ! (3) a coarse root profile, which is the root-biomass=weighted average of the fine root profiles - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - if (use_vertsoilc) then - - ! define a single shallow surface profile for surface additions (leaves, stems, and N deposition) - surface_prof(:) = 0._r8 - do j = 1, nlevdecomp - surface_prof(j) = exp(-surfprof_exp * zsoi(j)) / dzsoi_decomp(j) - end do - - ! initialize profiles to zero - leaf_prof(begc:endc, :) = 0._r8 - froot_prof(begc:endc, 1:numpft_ed, :) = 0._r8 - croot_prof(begc:endc, :) = 0._r8 - stem_prof(begc:endc, :) = 0._r8 - - cinput_rootfr(begc:endc, 1:numpft_ed, :) = 0._r8 - - do c = bounds%begc,bounds%endc - - ! calculate pft-specific rooting profiles in the absence of permafrost limitations - if ( exponential_rooting_profile ) then - if ( .not. pftspecific_rootingprofile ) then - ! define rooting profile from exponential parameters - do ft = 1, numpft_ed - do j = 1, nlevdecomp - cinput_rootfr(c,ft,j) = exp(-rootprof_exp * zsoi(j)) / dzsoi_decomp(j) - end do - end do - else - ! use beta distribution parameter from Jackson et al., 1996 - do ft = 1, numpft_ed - do j = 1, nlevdecomp - cinput_rootfr(c,ft,j) = ( pftcon%rootprof_beta(ft) ** (zisoi(j-1)*100._r8) - & - pftcon%rootprof_beta(ft) ** (zisoi(j)*100._r8) ) & - / dzsoi_decomp(j) - end do - end do - endif - else - do ft = 1,numpft_ed - do j = 1, nlevdecomp - ! use standard CLM root fraction profiles; - cinput_rootfr(c,ft,j) = ( .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)))) / dzsoi_decomp(j) - end do - end do - endif - ! - ! - ! now add permafrost constraint: integrate rootfr over active layer of soil column, - ! truncate below permafrost table where present, and rescale so that integral = 1 - do ft = 1,numpft_ed - rootfr_tot(ft) = 0._r8 - end do - surface_prof_tot = 0._r8 - ! - do j = 1, min(max(altmax_lastyear_indx(c), 1), nlevdecomp) - surface_prof_tot = surface_prof_tot + surface_prof(j) * dzsoi_decomp(j) - end do - do ft = 1,numpft_ed - do j = 1, min(max(altmax_lastyear_indx(c), 1), nlevdecomp) - rootfr_tot(ft) = rootfr_tot(ft) + cinput_rootfr(c,ft,j) * dzsoi_decomp(j) - end do - end do - ! - ! rescale the fine root profile - do ft = 1,numpft_ed - if ( (altmax_lastyear_indx(c) > 0) .and. (rootfr_tot(ft) > 0._r8) ) then - ! where there is not permafrost extending to the surface, integrate the profiles over the active layer - ! this is equivalent to integrating over all soil layers outside of permafrost regions - do j = 1, min(max(altmax_lastyear_indx(c), 1), nlevdecomp) - froot_prof(c,ft,j) = cinput_rootfr(c,ft,j) / rootfr_tot(ft) - end do - else - ! if fully frozen, or no roots, put everything in the top layer - froot_prof(c,ft,1) = 1._r8/dzsoi_decomp(1) - endif - end do - ! - ! rescale the shallow profiles - if ( (altmax_lastyear_indx(c) > 0) .and. (surface_prof_tot > 0._r8) ) then - ! where there is not permafrost extending to the surface, integrate the profiles over the active layer - ! this is equivalent to integrating over all soil layers outside of permafrost regions - do j = 1, min(max(altmax_lastyear_indx(c), 1), nlevdecomp) - ! set all surface processes to shallower profile - leaf_prof(c,j) = surface_prof(j)/ surface_prof_tot - stem_prof(c,j) = surface_prof(j)/ surface_prof_tot - end do - else - ! if fully frozen, or no roots, put everything in the top layer - leaf_prof(c,1) = 1._r8/dzsoi_decomp(1) - stem_prof(c,1) = 1._r8/dzsoi_decomp(1) - do j = 2, nlevdecomp - leaf_prof(c,j) = 0._r8 - stem_prof(c,j) = 0._r8 - end do - endif - end do - - else - - ! for one layer decomposition model, set profiles to unity - leaf_prof(bounds%begc:bounds%endc, :) = 1._r8 - froot_prof(bounds%begc:bounds%endc, 1:numpft_ed, :) = 1._r8 - stem_prof(bounds%begc:bounds%endc, :) = 1._r8 - - end if - - ! sanity check to ensure they integrate to 1 - do c = bounds%begc,bounds%endc - ! check the leaf and stem profiles - leaf_prof_sum = 0._r8 - stem_prof_sum = 0._r8 - do j = 1, nlevdecomp - leaf_prof_sum = leaf_prof_sum + leaf_prof(c,j) * dzsoi_decomp(j) - stem_prof_sum = stem_prof_sum + stem_prof(c,j) * dzsoi_decomp(j) - end do - if ( ( abs(stem_prof_sum - 1._r8) > delta ) .or. ( abs(leaf_prof_sum - 1._r8) > delta ) ) then - write(iulog, *) 'profile sums: ', leaf_prof_sum, stem_prof_sum - write(iulog, *) 'surface_prof: ', surface_prof - write(iulog, *) 'surface_prof_tot: ', surface_prof_tot - write(iulog, *) 'leaf_prof: ', leaf_prof(c,:) - write(iulog, *) 'stem_prof: ', stem_prof(c,:) - write(iulog, *) 'altmax_lastyear_indx: ', altmax_lastyear_indx(c) - write(iulog, *) 'dzsoi_decomp: ', dzsoi_decomp - call endrun(msg=' ERROR: sum-1 > delta'//errMsg(__FILE__, __LINE__)) - endif - ! now check each fine root profile - do ft = 1,numpft_ed - froot_prof_sum = 0._r8 - do j = 1, nlevdecomp - froot_prof_sum = froot_prof_sum + froot_prof(c,ft,j) * dzsoi_decomp(j) - end do - if ( ( abs(froot_prof_sum - 1._r8) > delta ) ) then - write(iulog, *) 'profile sums: ', froot_prof_sum - call endrun(msg=' ERROR: sum-1 > delta'//errMsg(__FILE__, __LINE__)) - endif - end do - end do - - ! zero the column-level C input variables - do c = bounds%begc,bounds%endc - do j = 1, nlevdecomp - ED_c_to_litr_lab_c(c,j) = 0._r8 - ED_c_to_litr_cel_c(c,j) = 0._r8 - ED_c_to_litr_lig_c(c,j) = 0._r8 - croot_prof(c,j) = 0._r8 - end do - end do - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! now disaggregate the inputs vertically, using the vertical profiles - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - do s = 1,nsites - - ! do g = bounds%begg,bounds%endg - ! if (firstsoilpatch(g) >= 0 .and. ed_allsites_inst(g)%istheresoil) then - c = fcolumn(s) - currentPatch => sites(s)%oldest_patch - - do while(associated(currentPatch)) - - ! cs => currentpatch%siteptr - ! cc = cs%clmcolumn - - ! the CWD pools lose information about which PFT they came from; for the stems this doesn't matter as they all have the same profile, - ! however for the coarse roots they may have different profiles. to approximately recover this information, loop over all cohorts in patch - ! to calculate the total root biomass in that patch of each pft, and then rescale the croot_prof as the weighted average of the froot_prof - biomass_bg_ft(1:numpft_ed) = 0._r8 - currentCohort => currentPatch%tallest - do while(associated(currentCohort)) - biomass_bg_ft(currentCohort%pft) = biomass_bg_ft(currentCohort%pft) + currentCohort%b * (currentCohort%n / currentPatch%area) * (1.0_r8-ED_val_ag_biomass) - currentCohort => currentCohort%shorter - enddo !currentCohort - ! - biomass_bg_tot = 0._r8 - do ft = 1,numpft_ed - biomass_bg_tot = biomass_bg_tot + biomass_bg_ft(ft) - end do - ! - do j = 1, nlevdecomp - ! zero this for each patch - croot_prof_perpatch(j) = 0._r8 - end do - ! - if ( biomass_bg_tot .gt. 0._r8) then - do ft = 1,numpft_ed - do j = 1, nlevdecomp - croot_prof_perpatch(j) = croot_prof_perpatch(j) + froot_prof(c,ft,j) * biomass_bg_ft(ft) / biomass_bg_tot - end do - end do - else ! no biomass - croot_prof_perpatch(1) = 1./dzsoi_decomp(1) - end if - - ! - ! add croot_prof as weighted average (weighted by patch area) of croot_prof_perpatch - do j = 1, nlevdecomp - croot_prof(c, j) = croot_prof(c, j) + croot_prof_perpatch(j) * currentPatch%area / AREA - end do - ! - ! now disaggregate, vertically and by decomposition substrate type, the actual fluxes from CWD and litter pools - ! - ! do c = 1, ncwd - ! write(iulog,*)'cdk CWD_AG_out', c, currentpatch%CWD_AG_out(c), cwd_fcel_ed, currentpatch%area/AREA - ! write(iulog,*)'cdk CWD_BG_out', c, currentpatch%CWD_BG_out(c), cwd_fcel_ed, currentpatch%area/AREA - ! end do - ! do ft = 1,numpft_ed - ! write(iulog,*)'cdk leaf_litter_out', ft, currentpatch%leaf_litter_out(ft), cwd_fcel_ed, currentpatch%area/AREA - ! write(iulog,*)'cdk root_litter_out', ft, currentpatch%root_litter_out(ft), cwd_fcel_ed, currentpatch%area/AREA - ! end do - ! ! - ! CWD pools fragmenting into decomposing litter pools. - do ci = 1, ncwd - do j = 1, nlevdecomp - ED_c_to_litr_cel_c(c,j) = ED_c_to_litr_cel_c(c,j) + currentpatch%CWD_AG_out(ci) * cwd_fcel_ed * currentpatch%area/AREA * stem_prof(c,j) - ED_c_to_litr_lig_c(c,j) = ED_c_to_litr_lig_c(c,j) + currentpatch%CWD_AG_out(ci) * cwd_flig_ed * currentpatch%area/AREA * stem_prof(c,j) - ! - ED_c_to_litr_cel_c(c,j) = ED_c_to_litr_cel_c(c,j) + currentpatch%CWD_BG_out(ci) * cwd_fcel_ed * currentpatch%area/AREA * croot_prof_perpatch(j) - ED_c_to_litr_lig_c(c,j) = ED_c_to_litr_lig_c(c,j) + currentpatch%CWD_BG_out(ci) * cwd_flig_ed * currentpatch%area/AREA * croot_prof_perpatch(j) - end do - end do - - ! leaf and fine root pools. - do ft = 1,numpft_ed - do j = 1, nlevdecomp - ED_c_to_litr_lab_c(c,j) = ED_c_to_litr_lab_c(c,j) + currentpatch%leaf_litter_out(ft) * pftcon%lf_flab(ft) * currentpatch%area/AREA * leaf_prof(c,j) - ED_c_to_litr_cel_c(c,j) = ED_c_to_litr_cel_c(c,j) + currentpatch%leaf_litter_out(ft) * pftcon%lf_fcel(ft) * currentpatch%area/AREA * leaf_prof(c,j) - ED_c_to_litr_lig_c(c,j) = ED_c_to_litr_lig_c(c,j) + currentpatch%leaf_litter_out(ft) * pftcon%lf_flig(ft) * currentpatch%area/AREA * leaf_prof(c,j) - ! - ED_c_to_litr_lab_c(c,j) = ED_c_to_litr_lab_c(c,j) + currentpatch%root_litter_out(ft) * pftcon%fr_flab(ft) * currentpatch%area/AREA * froot_prof(c,ft,j) - ED_c_to_litr_cel_c(c,j) = ED_c_to_litr_cel_c(c,j) + currentpatch%root_litter_out(ft) * pftcon%fr_fcel(ft) * currentpatch%area/AREA * froot_prof(c,ft,j) - ED_c_to_litr_lig_c(c,j) = ED_c_to_litr_lig_c(c,j) + currentpatch%root_litter_out(ft) * pftcon%fr_flig(ft) * currentpatch%area/AREA * froot_prof(c,ft,j) - ! - !! and seed_decay too. for now, use the same lability fractions as for leaf litter - ED_c_to_litr_lab_c(c,j) = ED_c_to_litr_lab_c(c,j) + currentpatch%seed_decay(ft) * pftcon%lf_flab(ft) * currentpatch%area/AREA * leaf_prof(c,j) - ED_c_to_litr_cel_c(c,j) = ED_c_to_litr_cel_c(c,j) + currentpatch%seed_decay(ft) * pftcon%lf_fcel(ft) * currentpatch%area/AREA * leaf_prof(c,j) - ED_c_to_litr_lig_c(c,j) = ED_c_to_litr_lig_c(c,j) + currentpatch%seed_decay(ft) * pftcon%lf_flig(ft) * currentpatch%area/AREA * leaf_prof(c,j) - ! - enddo - end do - - currentPatch => currentPatch%younger - end do !currentPatch - - end do ! do sites(s) - - do c = bounds%begc,bounds%endc - do j = 1, nlevdecomp - ! time unit conversion - ED_c_to_litr_lab_c(c,j)=ED_c_to_litr_lab_c(c,j) * mass_convert / time_convert - ED_c_to_litr_cel_c(c,j)=ED_c_to_litr_cel_c(c,j) * mass_convert / time_convert - ED_c_to_litr_lig_c(c,j)=ED_c_to_litr_lig_c(c,j) * mass_convert / time_convert - - end do - end do - - ! write(iulog,*)'cdk ED_c_to_litr_lab_c: ', ED_c_to_litr_lab_c - ! write(iulog,*)'cdk ED_c_to_litr_cel_c: ', ED_c_to_litr_cel_c - ! write(iulog,*)'cdk ED_c_to_litr_lig_c: ', ED_c_to_litr_lig_c - ! write(iulog,*)'cdk nlevdecomp_full, bounds%begc, bounds%endc: ', nlevdecomp_full, bounds%begc, bounds%endc - ! write(iulog,*)'cdk leaf_prof: ', leaf_prof - ! write(iulog,*)'cdk stem_prof: ', stem_prof - ! write(iulog,*)'cdk froot_prof: ', froot_prof - ! write(iulog,*)'cdk croot_prof_perpatch: ', croot_prof_perpatch - ! write(iulog,*)'cdk croot_prof: ', croot_prof - - end associate - end subroutine flux_into_litter_pools - !------------------------------------------------------------------------ subroutine SummarizeProductivityFluxes(this, bounds, sites, nsites, fcolumn) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index d69ebf6d..122c730c 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -124,6 +124,8 @@ module EDTypesMod integer :: numlevgrnd ! Number of soil layers + integer :: numlevdecomp_full ! Number of soil layers for the purposes of biogeochemistry; can be either 1 or the total number of soil layers + end type ctrl_parms_type type(ctrl_parms_type), public :: ctrl_parms diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 79ae9d60..2883aa3c 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -65,6 +65,9 @@ module FatesInterfaceMod ! Site level filter for uptake response functions logical :: filter_btran + ! the index of the deepest model soil level where roots may be, due to permafrost or bedrock constraints + integer :: max_rooting_depth_index_col + end type bc_in_type @@ -86,6 +89,12 @@ module FatesInterfaceMod ! (diagnostic, should not be used by HLM) real(r8), allocatable :: btran_pa(:) + ! litterfall fluxes of C from ED patches to BGC columns + real(r8), allocatable :: ED_c_to_litr_lab_c_col(:) !total labile litter coming from ED. gC/m3/s + real(r8), allocatable :: ED_c_to_litr_cel_c_col(:) !total cellulose litter coming from ED. gC/m3/s + real(r8), allocatable :: ED_c_to_litr_lig_c_col(:) !total lignin litter coming from ED. gC/m3/s + + end type bc_out_type @@ -192,7 +201,12 @@ subroutine allocate_bcout(bc_out) allocate(bc_out%active_suction_gl(ctrl_parms%numlevgrnd)) allocate(bc_out%rootr_pagl(numPatchesPerCol,ctrl_parms%numlevgrnd)) allocate(bc_out%btran_pa(numPatchesPerCol)) - + + allocate(bc_out%ED_c_to_litr_lab_c_col(ctrl_parms%numlevdecomp_full)) + allocate(bc_out%ED_c_to_litr_cel_c_col(ctrl_parms%numlevdecomp_full)) + allocate(bc_out%ED_c_to_litr_lig_c_col(ctrl_parms%numlevdecomp_full)) + + return end subroutine allocate_bcout @@ -214,12 +228,16 @@ subroutine zero_bcs(this,s) this%bc_in(s)%watsat_gl(:) = 0.0_r8 this%bc_in(s)%tempk_gl(:) = 0.0_r8 this%bc_in(s)%h2o_liqvol_gl(:) = 0.0_r8 + this%bc_in(s)%max_rooting_depth_index_col = 0 ! Output boundaries this%bc_out(s)%active_suction_gl(:) = .false. this%bc_out(s)%fsun_pa(:) = 0.0_r8 this%bc_out(s)%rootr_pagl(:,:) = 0.0_r8 this%bc_out(s)%btran_pa(:) = 0.0_r8 + this%bc_out(s)%ED_c_to_litr_lab_c_col(:) = 0.0_r8 + this%bc_out(s)%ED_c_to_litr_cel_c_col(:, = 0.0_r8 + this%bc_out(s)%ED_c_to_litr_lig_c_col(:) = 0.0_r8 return end subroutine zero_bcs @@ -266,6 +284,7 @@ subroutine set_fates_ctrlparms(tag,dimval) write(*,*) 'Flushing FATES control parameters prior to transfer from host' ctrl_parms%numSwBands = unset_int ctrl_parms%numlevgrnd = unset_int + ctrl_parms%numlevdecomp_full = unset_int case('check_allset') @@ -281,6 +300,12 @@ subroutine set_fates_ctrlparms(tag,dimval) ! end_run('MESSAGE') end if + if(ctrl_parms%numlevdecomp_full .eq. unset_int) then + write(*,*) 'FATES dimension/parameter unset: numlevdecomp_full' + ! INTERF-TODO: FATES NEEDS INTERNAL end_run + ! end_run('MESSAGE') + end if + write(*,*) 'Checked. All control parameters sent to FATES.' case default @@ -298,6 +323,11 @@ subroutine set_fates_ctrlparms(tag,dimval) ctrl_parms%numlevgrnd = dimval write(*,*) 'Transfering num_lev_ground = ',dimval,' to FATES' + case('num_levdecomp_full') + + ctrl_parms%numlevdecomp_full = dimval + write(*,*) 'Transfering num_levdecomp_full = ',dimval,' to FATES' + case default write(*,*) 'tag not recognized:',trim(tag) ! end_run From 6bae5bb8c2b8e6906f5105336b83d2bd3c56eb4d Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 5 Aug 2016 16:29:36 -0700 Subject: [PATCH 138/437] cleaned up how we zeroed and set non-values in unused photosynthesis arrays in FATES, and implemented a wrapper around EDAccumulate (as well as changed the variable names of the time-step accumulators --- biogeochem/EDCohortDynamicsMod.F90 | 18 ++-- biogeophys/EDAccumulateFluxesMod.F90 | 121 ++++++++++++--------------- biogeophys/EDPhotosynthesisMod.F90 | 49 ++++++----- main/EDCLMLinkMod.F90 | 8 +- main/EDRestVectorMod.F90 | 26 +++--- main/EDTypesMod.F90 | 6 +- 6 files changed, 107 insertions(+), 121 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index beb2d106..a063592a 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -340,15 +340,15 @@ subroutine nan_cohort(cc_p) ! CARBON FLUXES currentCohort%gpp = nan ! GPP: kgC/indiv/year - currentCohort%gpp_clm = nan ! GPP: kgC/indiv/timestep + currentCohort%gpp_tstep = 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_tstep = 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_tstep = nan ! RESP: kgC/indiv/timestep currentCohort%resp_acc = nan ! RESP: kGC/cohort/day currentCohort%npp_leaf = nan @@ -432,9 +432,9 @@ subroutine zero_cohort(cc_p) 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%npp_tstep = 0._r8 + currentcohort%gpp_tstep = 0._r8 + currentcohort%resp_tstep = 0._r8 currentcohort%resp = 0._r8 currentcohort%carbon_balance = 0._r8 currentcohort%leaf_litter = 0._r8 @@ -1017,15 +1017,15 @@ subroutine copy_cohort( currentCohort,copyc ) ! CARBON FLUXES n%gpp = o%gpp n%gpp_acc = o%gpp_acc - n%gpp_clm = o%gpp_clm + n%gpp_tstep = o%gpp_tstep n%npp = o%npp - n%npp_clm = o%npp_clm + n%npp_tstep = o%npp_tstep if ( DEBUG ) write(iulog,*) 'EDcohortDyn Ia ',o%npp_acc if ( DEBUG ) write(iulog,*) 'EDcohortDyn Ib ',o%resp_acc n%npp_acc = o%npp_acc - n%resp_clm = o%resp_clm + n%resp_tstep = o%resp_tstep n%resp_acc = o%resp_acc n%resp = o%resp n%year_net_uptake = o%year_net_uptake diff --git a/biogeophys/EDAccumulateFluxesMod.F90 b/biogeophys/EDAccumulateFluxesMod.F90 index b9d32588..807b614f 100644 --- a/biogeophys/EDAccumulateFluxesMod.F90 +++ b/biogeophys/EDAccumulateFluxesMod.F90 @@ -3,7 +3,7 @@ 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 + ! The fluxes are stored per cohort, and the npp_tstep (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. @@ -20,86 +20,73 @@ module EDAccumulateFluxesMod contains !------------------------------------------------------------------------------ - subroutine AccumulateFluxes_ED(bounds, p, sites, nsites, hsites , photosyns_inst) + subroutine AccumulateFluxes_ED(sites, nsites, bc_in, bc_out) ! ! !DESCRIPTION: ! see above ! ! !USES: use shr_kind_mod , only : r8 => shr_kind_r8 - use decompMod , only : bounds_type use clm_varctl , only : iulog - 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 + use EDTypesMod , only : ed_patch_type, ed_cohort_type, ed_site_type + use FatesInterfaceMod , only : bc_in_type,bc_out_type ! ! !ARGUMENTS - type(bounds_type) , intent(in) :: bounds - integer , intent(in) :: p !patch/'p' - type(ed_site_type) , intent(inout), target :: sites(nsites) - integer , intent(in) :: nsites - integer , intent(in) :: hsites(bounds%begc:bounds%endc) - - type(photosyns_type) , intent(inout) :: photosyns_inst + type(ed_site_type), intent(inout), target :: sites(nsites) + integer, intent(in) :: nsites + type(bc_in_type), intent(in) :: bc_in(nsites) + type(bc_out_type), intent(inout) :: bc_out(nsites) ! ! !LOCAL VARIABLES: - type(ed_cohort_type), pointer :: currentCohort ! current cohort - type(ed_patch_type) , pointer :: currentPatch ! current patch + type(ed_cohort_type), pointer :: ccohort ! current cohort + type(ed_patch_type) , pointer :: cpatch ! current patch integer :: iv !leaf layer integer :: c ! clm/alm column integer :: s ! ed site + integer :: ifp ! index fates patch !---------------------------------------------------------------------- - -! 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 -! ) - - - ! INTERF-TODO: WHY IS THIS BEING UPDATED? - ! IT IS JUST GOING TO BE ZEROED A THE END OF THE FUNCTION - ! THAT CALLS THIS SUBROUTINE (CANOPYFLUXES), AND IT WON'T - ! BE USED BETWEEN NOW AND THEN - ! fpsn(p) = psncanopy(p) - - if (patch%is_veg(p)) then - - c = patch%column(p) - s = hsites(c) - - currentPatch => map_clmpatch_to_edpatch(sites(s), 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 - - if ( DEBUG ) then - write(iulog,*) 'EDAccumFlux 64 ',currentCohort%npp_acc, & - currentCohort%npp_clm - write(iulog,*) 'EDAccumFlux 66 ',currentCohort%gpp_clm - write(iulog,*) 'EDAccumFlux 67 ',currentCohort%resp_clm - endif - - 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 + + do s = 1, nsites + + ifp = 0 + cpatch => sites(s)%oldest_patch + do while (associated(cpatch)) + ifp = ifp+1 + + if( bc_in(s)%filter_photo_pa(ifp) == 3 ) then + ccohort => cpatch%shortest + do while(associated(ccohort)) + + ! Accumulate fluxes from hourly to daily values. + ! _tstep fluxes are KgC/indiv/timestep _acc are KgC/indiv/day + + if ( DEBUG ) then + write(iulog,*) 'EDAccumFlux 64 ',ccohort%npp_acc, & + ccohort%npp_tstep + write(iulog,*) 'EDAccumFlux 66 ',ccohort%gpp_tstep + write(iulog,*) 'EDAccumFlux 67 ',ccohort%resp_tstep + endif + + ccohort%npp_acc = ccohort%npp_acc + ccohort%npp_tstep + ccohort%gpp_acc = ccohort%gpp_acc + ccohort%gpp_tstep + ccohort%resp_acc = ccohort%resp_acc + ccohort%resp_tstep + + do iv=1,ccohort%nv + if(ccohort%year_net_uptake(iv) == 999._r8)then ! note that there were leaves in this layer this year. + ccohort%year_net_uptake(iv) = 0._r8 + end if + ccohort%year_net_uptake(iv) = ccohort%year_net_uptake(iv) + ccohort%ts_net_uptake(iv) + enddo + + ccohort => ccohort%taller + enddo ! while(associated(ccohort)) + end if + cpatch => cpatch%younger + end do ! while(associated(cpatch)) + end do + return + + end subroutine AccumulateFluxes_ED end module EDAccumulateFluxesMod + diff --git a/biogeophys/EDPhotosynthesisMod.F90 b/biogeophys/EDPhotosynthesisMod.F90 index 00813cee..80371ab5 100644 --- a/biogeophys/EDPhotosynthesisMod.F90 +++ b/biogeophys/EDPhotosynthesisMod.F90 @@ -46,11 +46,10 @@ subroutine Photosynthesis_ED (sites,nsites,bc_in,bc_out,dtime) use EDParamsMod , only : ED_val_grperc use EDSharedParamsMod , only : EDParamsShareInst use EDTypesMod , only : numpft_ed, dinc_ed - use EDtypesMod , only : numPatchesPerCol use EDtypesMod , only : ed_patch_type, ed_cohort_type, ed_site_type, numpft_ed use EDEcophysContype , only : EDecophyscon use FatesInterfaceMod , only : bc_in_type,bc_out_type - + use EDtypesMod , only : numpatchespercol ! ! !ARGUMENTS: @@ -589,7 +588,7 @@ subroutine Photosynthesis_ED (sites,nsites,bc_in,bc_out,dtime) aquad = theta_psii bquad = -(qabs + jmax_z(cl,ft,iv)) cquad = qabs * jmax_z(cl,ft,iv) - call quadratic (aquad, bquad, cquad, r1, r2) + call quadratic_f (aquad, bquad, cquad, r1, r2) je = min(r1,r2) ! Iterative loop for ci beginning with initial guess @@ -646,13 +645,13 @@ subroutine Photosynthesis_ED (sites,nsites,bc_in,bc_out,dtime) aquad = theta_cj(ps) bquad = -(ac + aj) cquad = ac * aj - call quadratic (aquad, bquad, cquad, r1, r2) + call quadratic_f (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) + call quadratic_f (aquad, bquad, cquad, r1, r2) ag(cl,ft,iv) = min(r1,r2) ! Net carbon assimilation. Exit iteration if an < 0 @@ -669,7 +668,7 @@ subroutine Photosynthesis_ED (sites,nsites,bc_in,bc_out,dtime) aquad = cs bquad = cs*(gb_mol - bbb(FT)) - bb_slope(ft)*an(cl,ft,iv)*bc_in(s)%forc_pbot cquad = -gb_mol*(cs*bbb(FT) + bb_slope(ft)*an(cl,ft,iv)*bc_in(s)%forc_pbot*ceair/bc_in(s)%esat_tv_pa(ifp)) - call quadratic (aquad, bquad, cquad, r1, r2) + call quadratic_f (aquad, bquad, cquad, r1, r2) gs_mol = max(r1,r2) ! Derive new estimate for ci @@ -774,9 +773,9 @@ subroutine Photosynthesis_ED (sites,nsites,bc_in,bc_out,dtime) if(currentCohort%n > 0._r8)then ! Zero cohort flux accumulators. - currentCohort%npp_clm = 0.0_r8 - currentCohort%resp_clm = 0.0_r8 - currentCohort%gpp_clm = 0.0_r8 + currentCohort%npp_tstep = 0.0_r8 + currentCohort%resp_tstep = 0.0_r8 + currentCohort%gpp_tstep = 0.0_r8 currentCohort%rd = 0.0_r8 currentCohort%resp_m = 0.0_r8 @@ -788,7 +787,7 @@ subroutine Photosynthesis_ED (sites,nsites,bc_in,bc_out,dtime) !------------------------------------------------------------------------------ ! Convert from umolC/m2leaf/s to umolC/indiv/s ( x canopy area x 1m2 leaf area). tree_area = currentCohort%c_area/currentCohort%n - if ( DEBUG ) write(iulog,*) 'EDPhoto 816 ', currentCohort%gpp_clm + if ( DEBUG ) write(iulog,*) 'EDPhoto 816 ', currentCohort%gpp_tstep if ( DEBUG ) write(iulog,*) 'EDPhoto 817 ', currentPatch%psn_z(cl,ft,1:currentCohort%nv-1) if ( DEBUG ) write(iulog,*) 'EDPhoto 818 ', cl if ( DEBUG ) write(iulog,*) 'EDPhoto 819 ', ft @@ -797,7 +796,7 @@ subroutine Photosynthesis_ED (sites,nsites,bc_in,bc_out,dtime) if (currentCohort%nv > 1) then !is there canopy, and are the leaves on? - currentCohort%gpp_clm = sum(currentPatch%psn_z(cl,ft,1:currentCohort%nv-1) * & + currentCohort%gpp_tstep = 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) * & @@ -808,14 +807,14 @@ subroutine Photosynthesis_ED (sites,nsites,bc_in,bc_out,dtime) else - currentCohort%gpp_clm = 0.0_r8 + currentCohort%gpp_tstep = 0.0_r8 currentCohort%rd = 0.0_r8 currentCohort%gscan = 0.0_r8 currentCohort%ts_net_uptake(:) = 0.0_r8 end if - if ( DEBUG ) write(iulog,*) 'EDPhoto 832 ', currentCohort%gpp_clm + if ( DEBUG ) write(iulog,*) 'EDPhoto 832 ', currentCohort%gpp_tstep laifrac = (currentCohort%treelai+currentCohort%treesai)-(currentCohort%nv-1)*dinc_ed @@ -823,7 +822,7 @@ subroutine Photosynthesis_ED (sites,nsites,bc_in,bc_out,dtime) currentCohort%gscan = currentCohort%gscan+gs_cohort if ( DEBUG ) then - write(iulog,*) 'EDPhoto 868 ', currentCohort%gpp_clm + write(iulog,*) 'EDPhoto 868 ', currentCohort%gpp_tstep write(iulog,*) 'EDPhoto 869 ', currentPatch%psn_z(cl,ft,currentCohort%nv) write(iulog,*) 'EDPhoto 870 ', currentPatch%elai_profile(cl,ft,currentCohort%nv) write(iulog,*) 'EDPhoto 871 ', laifrac @@ -831,7 +830,7 @@ subroutine Photosynthesis_ED (sites,nsites,bc_in,bc_out,dtime) write(iulog,*) 'EDPhoto 873 ', currentCohort%nv, cl, ft endif - currentCohort%gpp_clm = currentCohort%gpp_clm + currentPatch%psn_z(cl,ft,currentCohort%nv) * & + currentCohort%gpp_tstep = currentCohort%gpp_tstep + currentPatch%psn_z(cl,ft,currentCohort%nv) * & currentPatch%elai_profile(cl,ft,currentCohort%nv) * laifrac * tree_area if ( DEBUG ) write(iulog,*) 'EDPhoto 843 ', currentCohort%rd @@ -906,7 +905,7 @@ subroutine Photosynthesis_ED (sites,nsites,bc_in,bc_out,dtime) if ( DEBUG ) write(iulog,*) 'EDPhoto 907 ', currentCohort%livecroot_mr if ( DEBUG ) write(iulog,*) 'EDPhoto 908 ', currentCohort%froot_mr - currentCohort%gpp_clm = currentCohort%gpp_clm * 12.0E-9 + currentCohort%gpp_tstep = currentCohort%gpp_tstep * 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)) @@ -914,15 +913,15 @@ subroutine Photosynthesis_ED (sites,nsites,bc_in,bc_out,dtime) ! convert from kgC/indiv/s to kgC/indiv/timestep currentCohort%resp_m = currentCohort%resp_m * dtime - currentCohort%gpp_clm = currentCohort%gpp_clm * dtime + currentCohort%gpp_tstep = currentCohort%gpp_tstep * dtime - if ( DEBUG ) write(iulog,*) 'EDPhoto 911 ', currentCohort%gpp_clm - if ( DEBUG ) write(iulog,*) 'EDPhoto 912 ', currentCohort%resp_clm + if ( DEBUG ) write(iulog,*) 'EDPhoto 911 ', currentCohort%gpp_tstep + if ( DEBUG ) write(iulog,*) 'EDPhoto 912 ', currentCohort%resp_tstep if ( DEBUG ) write(iulog,*) 'EDPhoto 913 ', currentCohort%resp_m - currentCohort%resp_g = ED_val_grperc(1) * (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 + currentCohort%resp_g = ED_val_grperc(1) * (max(0._r8,currentCohort%gpp_tstep - currentCohort%resp_m)) + currentCohort%resp_tstep = currentCohort%resp_m + currentCohort%resp_g ! kgC/indiv/ts + currentCohort%npp_tstep = currentCohort%gpp_tstep - currentCohort%resp_tstep ! kgC/indiv/ts !------------------------------------------------------------------------------ ! Remove whole plant respiration from net uptake. (kgC/indiv/ts) @@ -934,19 +933,19 @@ subroutine Photosynthesis_ED (sites,nsites,bc_in,bc_out,dtime) ! + currentCohort%froot_mr))/(currentCohort%treelai*currentCohort%c_area/currentCohort%n) ! enddo else !lai<0 - currentCohort%gpp_clm = 0._r8 + currentCohort%gpp_tstep = 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%gpp_tstep = 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 - bc_out(s)%psncanopy_pa(ifp) = bc_out(s)%psncanopy_pa(ifp) + currentCohort%gpp_clm + bc_out(s)%psncanopy_pa(ifp) = bc_out(s)%psncanopy_pa(ifp) + currentCohort%gpp_tstep bc_out(s)%lmrcanopy_pa(ifp) = bc_out(s)%lmrcanopy_pa(ifp) + currentCohort%resp_m ! accumulate cohort level canopy conductances over whole area before dividing by total area. bc_out(s)%gccanopy_pa(ifp) = bc_out(s)%gccanopy_pa(ifp) + currentCohort%gscan * currentCohort%n /currentPatch%total_canopy_area diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 67ccb500..007a57de 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -2529,14 +2529,14 @@ subroutine SummarizeProductivityFluxes(this, bounds, sites, nsites, fcolumn) if ( .not. currentCohort%isnew ) then ! map ed cohort-level fluxes to clm patch fluxes - npp(p) = npp(p) + currentCohort%npp_clm * 1.e3_r8 * n_density / dt - gpp(p) = gpp(p) + currentCohort%gpp_clm * 1.e3_r8 * n_density / dt - ar(p) = ar(p) + currentCohort%resp_clm * 1.e3_r8 * n_density / dt + npp(p) = npp(p) + currentCohort%npp_tstep * 1.e3_r8 * n_density / dt + gpp(p) = gpp(p) + currentCohort%gpp_tstep * 1.e3_r8 * n_density / dt + ar(p) = ar(p) + currentCohort%resp_tstep * 1.e3_r8 * n_density / dt growth_resp(p) = growth_resp(p) + currentCohort%resp_g * 1.e3_r8 * n_density / dt maint_resp(p) = maint_resp(p) + currentCohort%resp_m * 1.e3_r8 * n_density / dt ! map ed cohort-level npp fluxes to clm column fluxes - npp_col(c) = npp_col(c) + currentCohort%npp_clm * n_perm2 * 1.e3_r8 /dt + npp_col(c) = npp_col(c) + currentCohort%npp_tstep * n_perm2 * 1.e3_r8 /dt endif diff --git a/main/EDRestVectorMod.F90 b/main/EDRestVectorMod.F90 index 725b3bc0..99230b47 100755 --- a/main/EDRestVectorMod.F90 +++ b/main/EDRestVectorMod.F90 @@ -72,7 +72,7 @@ module EDRestVectorMod real(r8), pointer :: imort(:) real(r8), pointer :: fmort(:) real(r8), pointer :: ddbhdt(:) - real(r8), pointer :: resp_clm(:) + real(r8), pointer :: resp_tstep(:) integer, pointer :: pft(:) integer, pointer :: status_coh(:) integer, pointer :: isnew(:) @@ -207,7 +207,7 @@ subroutine deleteEDRestartVectorClass( this ) deallocate(this%imort ) deallocate(this%fmort ) deallocate(this%ddbhdt ) - deallocate(this%resp_clm ) + deallocate(this%resp_tstep ) deallocate(this%pft ) deallocate(this%status_coh ) deallocate(this%isnew ) @@ -478,10 +478,10 @@ function newEDRestartVectorClass( bounds ) SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) new%ddbhdt(:) = 0.0_r8 - allocate(new%resp_clm & + allocate(new%resp_tstep & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) - new%resp_clm(:) = 0.0_r8 + new%resp_tstep(:) = 0.0_r8 allocate(new%pft & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) @@ -966,10 +966,10 @@ subroutine doVectorIO( this, ncid, flag ) interpinic_flag='interp', data=this%ddbhdt, & readvar=readvar) - call restartvar(ncid=ncid, flag=flag, varname='ed_resp_clm', xtype=ncd_double, & + call restartvar(ncid=ncid, flag=flag, varname='ed_resp_tstep', xtype=ncd_double, & dim1name=coh_dimName, & - long_name='ed cohort - resp_clm', units='unitless', & - interpinic_flag='interp', data=this%resp_clm, & + long_name='ed cohort - resp_tstep', units='unitless', & + interpinic_flag='interp', data=this%resp_tstep, & readvar=readvar) call restartvar(ncid=ncid, flag=flag, varname='ed_pft', xtype=ncd_int, & @@ -1188,8 +1188,8 @@ subroutine printDataInfoVector( this ) this%fmort(iSta:iSto) write(iulog,*) trim(methodName)//' :: ddbhdt ', & this%ddbhdt(iSta:iSto) - write(iulog,*) trim(methodName)//' :: resp_clm ', & - this%resp_clm(iSta:iSto) + write(iulog,*) trim(methodName)//' :: resp_tstep ', & + this%resp_tstep(iSta:iSto) write(iulog,*) trim(methodName)//' :: pft ', & this%pft(iSta:iSto) @@ -1330,7 +1330,7 @@ subroutine printDataInfoLL( this, bounds, sites, nsites ) write(iulog,*) trim(methodName)//' imort ' ,totalCohorts,currentCohort%imort write(iulog,*) trim(methodName)//' fmort ' ,totalCohorts,currentCohort%fmort write(iulog,*) trim(methodName)//' ddbhdt ' ,totalCohorts,currentCohort%ddbhdt - write(iulog,*) trim(methodName)//' resp_clm ' ,totalCohorts,currentCohort%resp_clm + write(iulog,*) trim(methodName)//' resp_tstep ' ,totalCohorts,currentCohort%resp_tstep write(iulog,*) trim(methodName)//' pft ' ,totalCohorts,currentCohort%pft write(iulog,*) trim(methodName)//' status_coh ' ,totalCohorts,currentCohort%status_coh write(iulog,*) trim(methodName)//' isnew ' ,totalCohorts,currentCohort%isnew @@ -1466,7 +1466,7 @@ subroutine printIoInfoLL( this, bounds, sites, nsites, fcolumn ) write(iulog,*) trim(methodName)//' imort ',currentCohort%imort write(iulog,*) trim(methodName)//' fmort ',currentCohort%fmort write(iulog,*) trim(methodName)//' ddbhdt ',currentCohort%ddbhdt - write(iulog,*) trim(methodName)//' resp_clm ',currentCohort%resp_clm + write(iulog,*) trim(methodName)//' resp_tstep ',currentCohort%resp_tstep write(iulog,*) trim(methodName)//' pft ',currentCohort%pft write(iulog,*) trim(methodName)//' status_coh ',currentCohort%status_coh write(iulog,*) trim(methodName)//' isnew ',currentCohort%isnew @@ -1614,7 +1614,7 @@ subroutine convertCohortListToVector( this, bounds, sites, nsites, fcolumn ) this%imort(countCohort) = currentCohort%imort this%fmort(countCohort) = currentCohort%fmort this%ddbhdt(countCohort) = currentCohort%ddbhdt - this%resp_clm(countCohort) = currentCohort%resp_clm + this%resp_tstep(countCohort) = currentCohort%resp_tstep this%pft(countCohort) = currentCohort%pft this%status_coh(countCohort) = currentCohort%status_coh if ( currentCohort%isnew ) then @@ -2036,7 +2036,7 @@ subroutine convertCohortVectorToList( this, bounds, sites, nsites, fcolumn ) currentCohort%imort = this%imort(countCohort) currentCohort%fmort = this%fmort(countCohort) currentCohort%ddbhdt = this%ddbhdt(countCohort) - currentCohort%resp_clm = this%resp_clm(countCohort) + currentCohort%resp_tstep = this%resp_tstep(countCohort) currentCohort%pft = this%pft(countCohort) currentCohort%status_coh = this%status_coh(countCohort) currentCohort%isnew = ( this%isnew(countCohort) .eq. new_cohort ) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index d69ebf6d..5676185a 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -173,13 +173,13 @@ module EDTypesMod ! 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) :: gpp_tstep ! 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) :: npp_tstep ! 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) :: resp_tstep ! Resp: kgC/indiv/timestep real(r8) :: npp_leaf ! NPP into leaves (includes replacement of turnover): KgC/indiv/day real(r8) :: npp_froot ! NPP into fine roots (includes replacement of turnover): KgC/indiv/day From 771e145e4068ef5bad5c53174fb5993679758afd Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 5 Aug 2016 18:12:11 -0700 Subject: [PATCH 139/437] incremental change towards interfaceing canopy radiation --- biogeophys/EDSurfaceAlbedoMod.F90 | 119 +++++++++++++++--------------- 1 file changed, 58 insertions(+), 61 deletions(-) diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index be49b03e..45f038cb 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -89,8 +89,8 @@ subroutine ED_Norman_Radiation (bounds, & 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) :: forc_dir(numPatchesPerCol,numrad) + real(r8) :: forc_dif(numPatchesPerCol,numrad) real(r8) :: weighted_dir_tr(nclmax) real(r8) :: weighted_fsun(nclmax) real(r8) :: weighted_dif_ratio(nclmax,numrad) @@ -102,33 +102,30 @@ subroutine ED_Norman_Radiation (bounds, & 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) :: phi1b(numPatchesPerCol,numpft_ed) ! Radiation transmitted to the soil surface. + real(r8) :: phi2b(numPatchesPerCol,numpft_ed) real(r8) :: laisum ! cumulative lai+sai for canopy layer (at middle of layer) - real(r8) :: angle + + real(r8),parameter :: tolerance = 0.000000001_r8 real(r8), parameter :: pi = 3.141592654 ! PI + real(r8) :: denom real(r8) :: lai_reduction(2) integer :: fp,p,c,iv,s ! 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) - !----------------------------------------------------------------------- + real(r8) :: chil(numPatchesPerCol) ! -0.4 <= xl <= 0.6 + real(r8) :: gdir(numPatchesPerCol) ! 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 @@ -139,6 +136,7 @@ subroutine ED_Norman_Radiation (bounds, & 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 @@ -158,56 +156,55 @@ subroutine ED_Norman_Radiation (bounds, & 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 - c = patch%column(p) - s = hsites(c) - currentPatch => map_clmpatch_to_edpatch(sites(s), 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) - - 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 - + ! RGK,2016-08-06: FATES is still incompatible with VOC emission module + ! ------------------------------------------------------------------------------- + + + do s = 1, this%fates(nc)%nsites + + ifp = 0 + currentpatch => sites(s)%oldest_patch + do while (associated(currentpatch)) + ifp = ifp+1 + + currentPatch%f_sun (:,:,:) = 0._r8 + currentPatch%fabd_sun_z (:,:,:) = 0._r8 + currentPatch%fabd_sha_z (:,:,:) = 0._r8 + currentPatch%fabi_sun_z (:,:,:) = 0._r8 + currentPatch%fabi_sha_z (:,:,:) = 0._r8 + currentPatch%fabd (:) = 0._r8 + currentPatch%fabi (:) = 0._r8 + + if(bc_in(s)%filter_vegzen_pa(ifp))then + + ! PREVIOUSLY FILTERING ON veg_sol + ! do fp = 1,num_vegsol + ! p = filter_vegsol(fp) + + 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... @@ -286,7 +283,7 @@ subroutine ED_Norman_Radiation (bounds, & !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! ! Direct beam extinction coefficient, k_dir. PFT specific. !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - cosz = max(0.001_r8, coszen(p)) !copied from previous radiation code... + cosz = max(0.001_r8, bc_in(s)%coszen_pa(ifp)) !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 ) From 1db3cc3c1cf4e1610284f1aee85a5e4aadfe58e8 Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Fri, 5 Aug 2016 19:29:15 -0700 Subject: [PATCH 140/437] more litter refactorization --- biogeochem/EDPhysiologyMod.F90 | 165 +++++++++++++++++---------------- main/FatesInterfaceMod.F90 | 20 ++-- 2 files changed, 94 insertions(+), 91 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 49d7ee30..a05d956e 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1269,7 +1269,7 @@ end subroutine cwd_out - subroutine flux_into_litter_pools(bounds, sites, nsites, fcolumn, canopystate_inst) + subroutine flux_into_litter_pools(sites, nsites, bc_in, bc_out) ! Created by Charlie Koven and Rosie Fisher, 2014-2015 ! take the flux out of the fragmenting litter pools and port into the decomposing litter pools. ! in this implementation, decomposing pools are assumed to be humus and non-flammable, whereas fragmenting pools @@ -1285,7 +1285,6 @@ subroutine flux_into_litter_pools(bounds, sites, nsites, fcolumn, canopystate_in ! This means that the carbon gets passed back and forth between the photosynthesis code (fast timestepping) to the ED code (slow timestepping), back to the BGC code (fast timestepping). ! This means that the state update for the litter pools and for the CWD pools occurs at different timescales. - use SFParamsMod, only: SF_val_max_decomp use clm_varpar, only : mxpft,nlevdecomp, nlevdecomp_full use EDTypesMod, only : AREA, numpft_ed use SoilBiogeochemVerticalProfileMod, only: exponential_rooting_profile, pftspecific_rootingprofile, rootprof_exp, surfprof_exp @@ -1293,15 +1292,17 @@ subroutine flux_into_litter_pools(bounds, sites, nsites, fcolumn, canopystate_in use clm_varcon, only : zisoi, dzsoi_decomp, zsoi use EDParamsMod, only : ED_val_ag_biomass + use FatesInterfaceMod, only : bc_in_type, bc_out_type + + ! INTERF-TODO: remove the control parameters: exponential_rooting_profile, pftspecific_rootingprofile, rootprof_exp, surfprof_exp, zisoi, dzsoi_decomp, zsoi ! implicit none ! ! !ARGUMENTS - type(bounds_type) , intent(in) :: bounds type(ed_site_type) , intent(inout), target :: sites(nsites) integer , intent(in) :: nsites - integer , intent(in) :: fcolumn(nsites) - type(canopystate_type) , intent(inout) :: canopystate_inst + type(bc_in_type) , intent(in) :: bc_in + type(bc_out_type) , intent(out) :: bc_out ! ! !LOCAL VARIABLES: type (ed_patch_type) , pointer :: currentPatch @@ -1313,16 +1314,19 @@ subroutine flux_into_litter_pools(bounds, sites, nsites, fcolumn, canopystate_in integer :: begp,endp integer :: begc,endc !bounds !------------------------------------------------------------------------ - real(r8) :: cinput_rootfr(bounds%begc:bounds%endc, 1:numpft_ed, 1:nlevdecomp_full) ! column by pft root fraction used for calculating inputs + real(r8) :: cinput_rootfr(1:nsites, 1:numpft_ed, 1:nlevdecomp_full) ! column by pft root fraction used for calculating inputs real(r8) :: croot_prof_perpatch(1:nlevdecomp_full) real(r8) :: surface_prof(1:nlevdecomp_full) integer :: ft, lev real(r8) :: rootfr_tot(1:numpft_ed), biomass_bg_ft(1:numpft_ed) real(r8) :: surface_prof_tot, leaf_prof_sum, stem_prof_sum, froot_prof_sum, biomass_bg_tot real(r8) :: delta + real(r8) :: leaf_prof(1:nsites, 1:nlevdecomp) + real(r8) :: froot_prof(1:nsites, 1:numpft_ed, 1:nlevdecomp) + real(r8) :: croot_prof(1:nsites, 1:nlevdecomp) + real(r8) :: stem_prof(1:nsites, 1:nlevdecomp) + - begp = bounds%begp; endp = bounds%endp - begc = bounds%begc; endc = bounds%endc delta = 0.001_r8 !no of seconds in a year. time_convert = 365.0_r8*SHR_CONST_CDAY @@ -1331,13 +1335,13 @@ subroutine flux_into_litter_pools(bounds, sites, nsites, fcolumn, canopystate_in mass_convert = 1000._r8 associate( & - ED_c_to_litr_lab_c => this%ED_c_to_litr_lab_c_col , & ! Output: total labile litter coming from ED. gC/m3/s - ED_c_to_litr_cel_c => this%ED_c_to_litr_cel_c_col , & ! Output: total cellulose litter coming from ED. gC/m3/s - ED_c_to_litr_lig_c => this%ED_c_to_litr_lig_c_col , & ! Output: total lignin litter coming from ED. gC/m3/s - leaf_prof => this%leaf_prof_col , & ! Output: (1/m) profile of leaves - froot_prof => this%froot_prof_col , & ! Output: (1/m) profile of fine roots - croot_prof => this%croot_prof_col , & ! Output: (1/m) profile of coarse roots - stem_prof => this%stem_prof_col , & ! Output: (1/m) profile of leaves + FATES_c_to_litr_lab_c => bc_out%FATES_c_to_litr_lab_c_col , & ! Output: total labile litter coming from ED. gC/m3/s + FATES_c_to_litr_cel_c => bc_out%FATES_c_to_litr_cel_c_col , & ! Output: total cellulose litter coming from ED. gC/m3/s + FATES_c_to_litr_lig_c => bc_out%FATES_c_to_litr_lig_c_col , & ! Output: total lignin litter coming from ED. gC/m3/s + ! leaf_prof => this%leaf_prof_col , & ! Output: (1/m) profile of leaves + ! froot_prof => this%froot_prof_col , & ! Output: (1/m) profile of fine roots + ! croot_prof => this%croot_prof_col , & ! Output: (1/m) profile of coarse roots + ! stem_prof => this%stem_prof_col , & ! Output: (1/m) profile of leaves max_rooting_depth_index => bc_in%max_rooting_depth_index_col & ! Input: index of lowest soil level where roots may be, due to permafrost or bedrock constraints ) @@ -1358,14 +1362,14 @@ subroutine flux_into_litter_pools(bounds, sites, nsites, fcolumn, canopystate_in end do ! initialize profiles to zero - leaf_prof(begc:endc, :) = 0._r8 - froot_prof(begc:endc, 1:numpft_ed, :) = 0._r8 - croot_prof(begc:endc, :) = 0._r8 - stem_prof(begc:endc, :) = 0._r8 + leaf_prof(1:nsites, :) = 0._r8 + froot_prof(1:nsites, 1:numpft_ed, :) = 0._r8 + croot_prof(1:nsites, :) = 0._r8 + stem_prof(1:nsites, :) = 0._r8 - cinput_rootfr(begc:endc, 1:numpft_ed, :) = 0._r8 + cinput_rootfr(1:nsites, 1:numpft_ed, :) = 0._r8 - do c = bounds%begc,bounds%endc + do s = 1,nsites ! calculate pft-specific rooting profiles in the absence of permafrost limitations if ( exponential_rooting_profile ) then @@ -1373,14 +1377,14 @@ subroutine flux_into_litter_pools(bounds, sites, nsites, fcolumn, canopystate_in ! define rooting profile from exponential parameters do ft = 1, numpft_ed do j = 1, nlevdecomp - cinput_rootfr(c,ft,j) = exp(-rootprof_exp * zsoi(j)) / dzsoi_decomp(j) + cinput_rootfr(s,ft,j) = exp(-rootprof_exp * zsoi(j)) / dzsoi_decomp(j) end do end do else ! use beta distribution parameter from Jackson et al., 1996 do ft = 1, numpft_ed do j = 1, nlevdecomp - cinput_rootfr(c,ft,j) = ( pftcon%rootprof_beta(ft) ** (zisoi(j-1)*100._r8) - & + cinput_rootfr(s,ft,j) = ( pftcon%rootprof_beta(ft) ** (zisoi(j-1)*100._r8) - & pftcon%rootprof_beta(ft) ** (zisoi(j)*100._r8) ) & / dzsoi_decomp(j) end do @@ -1390,11 +1394,11 @@ subroutine flux_into_litter_pools(bounds, sites, nsites, fcolumn, canopystate_in do ft = 1,numpft_ed do j = 1, nlevdecomp ! use standard CLM root fraction profiles; - cinput_rootfr(c,ft,j) = ( .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)))) / dzsoi_decomp(j) + cinput_rootfr(s,ft,j) = ( .5_r8*( & + exp(-pftcon%roota_par(ft) * col%zi(s,lev-1)) & + + exp(-pftcon%rootb_par(ft) * col%zi(s,lev-1)) & + - exp(-pftcon%roota_par(ft) * col%zi(s,lev)) & + - exp(-pftcon%rootb_par(ft) * col%zi(s,lev)))) / dzsoi_decomp(j) end do end do endif @@ -1407,45 +1411,45 @@ subroutine flux_into_litter_pools(bounds, sites, nsites, fcolumn, canopystate_in end do surface_prof_tot = 0._r8 ! - do j = 1, min(max(max_rooting_depth_index(c), 1), nlevdecomp) + do j = 1, min(max(max_rooting_depth_index(s), 1), nlevdecomp) surface_prof_tot = surface_prof_tot + surface_prof(j) * dzsoi_decomp(j) end do do ft = 1,numpft_ed - do j = 1, min(max(max_rooting_depth_index(c), 1), nlevdecomp) - rootfr_tot(ft) = rootfr_tot(ft) + cinput_rootfr(c,ft,j) * dzsoi_decomp(j) + do j = 1, min(max(max_rooting_depth_index(s), 1), nlevdecomp) + rootfr_tot(ft) = rootfr_tot(ft) + cinput_rootfr(s,ft,j) * dzsoi_decomp(j) end do end do ! ! rescale the fine root profile do ft = 1,numpft_ed - if ( (max_rooting_depth_index(c) > 0) .and. (rootfr_tot(ft) > 0._r8) ) then + if ( (max_rooting_depth_index(s) > 0) .and. (rootfr_tot(ft) > 0._r8) ) then ! where there is not permafrost extending to the surface, integrate the profiles over the active layer ! this is equivalent to integrating over all soil layers outside of permafrost regions - do j = 1, min(max(max_rooting_depth_index(c), 1), nlevdecomp) - froot_prof(c,ft,j) = cinput_rootfr(c,ft,j) / rootfr_tot(ft) + do j = 1, min(max(max_rooting_depth_index(s), 1), nlevdecomp) + froot_prof(s,ft,j) = cinput_rootfr(s,ft,j) / rootfr_tot(ft) end do else ! if fully frozen, or no roots, put everything in the top layer - froot_prof(c,ft,1) = 1._r8/dzsoi_decomp(1) + froot_prof(s,ft,1) = 1._r8/dzsoi_decomp(1) endif end do ! ! rescale the shallow profiles - if ( (max_rooting_depth_index(c) > 0) .and. (surface_prof_tot > 0._r8) ) then + if ( (max_rooting_depth_index(s) > 0) .and. (surface_prof_tot > 0._r8) ) then ! where there is not permafrost extending to the surface, integrate the profiles over the active layer ! this is equivalent to integrating over all soil layers outside of permafrost regions - do j = 1, min(max(max_rooting_depth_index(c), 1), nlevdecomp) + do j = 1, min(max(max_rooting_depth_index(s), 1), nlevdecomp) ! set all surface processes to shallower profile - leaf_prof(c,j) = surface_prof(j)/ surface_prof_tot - stem_prof(c,j) = surface_prof(j)/ surface_prof_tot + leaf_prof(s,j) = surface_prof(j)/ surface_prof_tot + stem_prof(s,j) = surface_prof(j)/ surface_prof_tot end do else ! if fully frozen, or no roots, put everything in the top layer - leaf_prof(c,1) = 1._r8/dzsoi_decomp(1) - stem_prof(c,1) = 1._r8/dzsoi_decomp(1) + leaf_prof(s,1) = 1._r8/dzsoi_decomp(1) + stem_prof(s,1) = 1._r8/dzsoi_decomp(1) do j = 2, nlevdecomp - leaf_prof(c,j) = 0._r8 - stem_prof(c,j) = 0._r8 + leaf_prof(s,j) = 0._r8 + stem_prof(s,j) = 0._r8 end do endif end do @@ -1453,28 +1457,28 @@ subroutine flux_into_litter_pools(bounds, sites, nsites, fcolumn, canopystate_in else ! for one layer decomposition model, set profiles to unity - leaf_prof(bounds%begc:bounds%endc, :) = 1._r8 - froot_prof(bounds%begc:bounds%endc, 1:numpft_ed, :) = 1._r8 - stem_prof(bounds%begc:bounds%endc, :) = 1._r8 + leaf_prof(1:nsites, :) = 1._r8 + froot_prof(1:nsites, 1:numpft_ed, :) = 1._r8 + stem_prof(1:nsites, :) = 1._r8 end if ! sanity check to ensure they integrate to 1 - do c = bounds%begc,bounds%endc + do s = 1, nsites ! check the leaf and stem profiles leaf_prof_sum = 0._r8 stem_prof_sum = 0._r8 do j = 1, nlevdecomp - leaf_prof_sum = leaf_prof_sum + leaf_prof(c,j) * dzsoi_decomp(j) - stem_prof_sum = stem_prof_sum + stem_prof(c,j) * dzsoi_decomp(j) + leaf_prof_sum = leaf_prof_sum + leaf_prof(s,j) * dzsoi_decomp(j) + stem_prof_sum = stem_prof_sum + stem_prof(s,j) * dzsoi_decomp(j) end do if ( ( abs(stem_prof_sum - 1._r8) > delta ) .or. ( abs(leaf_prof_sum - 1._r8) > delta ) ) then write(iulog, *) 'profile sums: ', leaf_prof_sum, stem_prof_sum write(iulog, *) 'surface_prof: ', surface_prof write(iulog, *) 'surface_prof_tot: ', surface_prof_tot - write(iulog, *) 'leaf_prof: ', leaf_prof(c,:) - write(iulog, *) 'stem_prof: ', stem_prof(c,:) - write(iulog, *) 'max_rooting_depth_index: ', max_rooting_depth_index(c) + write(iulog, *) 'leaf_prof: ', leaf_prof(s,:) + write(iulog, *) 'stem_prof: ', stem_prof(s,:) + write(iulog, *) 'max_rooting_depth_index: ', max_rooting_depth_index(s) write(iulog, *) 'dzsoi_decomp: ', dzsoi_decomp call endrun(msg=' ERROR: sum-1 > delta'//errMsg(__FILE__, __LINE__)) endif @@ -1482,7 +1486,7 @@ subroutine flux_into_litter_pools(bounds, sites, nsites, fcolumn, canopystate_in do ft = 1,numpft_ed froot_prof_sum = 0._r8 do j = 1, nlevdecomp - froot_prof_sum = froot_prof_sum + froot_prof(c,ft,j) * dzsoi_decomp(j) + froot_prof_sum = froot_prof_sum + froot_prof(s,ft,j) * dzsoi_decomp(j) end do if ( ( abs(froot_prof_sum - 1._r8) > delta ) ) then write(iulog, *) 'profile sums: ', froot_prof_sum @@ -1492,12 +1496,12 @@ subroutine flux_into_litter_pools(bounds, sites, nsites, fcolumn, canopystate_in end do ! zero the column-level C input variables - do c = bounds%begc,bounds%endc + do s = 1, nsites do j = 1, nlevdecomp - ED_c_to_litr_lab_c(c,j) = 0._r8 - ED_c_to_litr_cel_c(c,j) = 0._r8 - ED_c_to_litr_lig_c(c,j) = 0._r8 - croot_prof(c,j) = 0._r8 + FATES_c_to_litr_lab_c(s,j) = 0._r8 + FATES_c_to_litr_cel_c(s,j) = 0._r8 + FATES_c_to_litr_lig_c(s,j) = 0._r8 + croot_prof(s,j) = 0._r8 end do end do @@ -1509,7 +1513,6 @@ subroutine flux_into_litter_pools(bounds, sites, nsites, fcolumn, canopystate_in ! do g = bounds%begg,bounds%endg ! if (firstsoilpatch(g) >= 0 .and. ed_allsites_inst(g)%istheresoil) then - c = fcolumn(s) currentPatch => sites(s)%oldest_patch do while(associated(currentPatch)) @@ -1540,7 +1543,7 @@ subroutine flux_into_litter_pools(bounds, sites, nsites, fcolumn, canopystate_in if ( biomass_bg_tot .gt. 0._r8) then do ft = 1,numpft_ed do j = 1, nlevdecomp - croot_prof_perpatch(j) = croot_prof_perpatch(j) + froot_prof(c,ft,j) * biomass_bg_ft(ft) / biomass_bg_tot + croot_prof_perpatch(j) = croot_prof_perpatch(j) + froot_prof(s,ft,j) * biomass_bg_ft(ft) / biomass_bg_tot end do end do else ! no biomass @@ -1550,7 +1553,7 @@ subroutine flux_into_litter_pools(bounds, sites, nsites, fcolumn, canopystate_in ! ! add croot_prof as weighted average (weighted by patch area) of croot_prof_perpatch do j = 1, nlevdecomp - croot_prof(c, j) = croot_prof(c, j) + croot_prof_perpatch(j) * currentPatch%area / AREA + croot_prof(s, j) = croot_prof(s, j) + croot_prof_perpatch(j) * currentPatch%area / AREA end do ! ! now disaggregate, vertically and by decomposition substrate type, the actual fluxes from CWD and litter pools @@ -1567,29 +1570,29 @@ subroutine flux_into_litter_pools(bounds, sites, nsites, fcolumn, canopystate_in ! CWD pools fragmenting into decomposing litter pools. do ci = 1, ncwd do j = 1, nlevdecomp - ED_c_to_litr_cel_c(c,j) = ED_c_to_litr_cel_c(c,j) + currentpatch%CWD_AG_out(ci) * cwd_fcel_ed * currentpatch%area/AREA * stem_prof(c,j) - ED_c_to_litr_lig_c(c,j) = ED_c_to_litr_lig_c(c,j) + currentpatch%CWD_AG_out(ci) * cwd_flig_ed * currentpatch%area/AREA * stem_prof(c,j) + FATES_c_to_litr_cel_c(s,j) = FATES_c_to_litr_cel_c(s,j) + currentpatch%CWD_AG_out(ci) * cwd_fcel_ed * currentpatch%area/AREA * stem_prof(s,j) + FATES_c_to_litr_lig_c(s,j) = FATES_c_to_litr_lig_c(s,j) + currentpatch%CWD_AG_out(ci) * cwd_flig_ed * currentpatch%area/AREA * stem_prof(s,j) ! - ED_c_to_litr_cel_c(c,j) = ED_c_to_litr_cel_c(c,j) + currentpatch%CWD_BG_out(ci) * cwd_fcel_ed * currentpatch%area/AREA * croot_prof_perpatch(j) - ED_c_to_litr_lig_c(c,j) = ED_c_to_litr_lig_c(c,j) + currentpatch%CWD_BG_out(ci) * cwd_flig_ed * currentpatch%area/AREA * croot_prof_perpatch(j) + FATES_c_to_litr_cel_c(s,j) = FATES_c_to_litr_cel_c(s,j) + currentpatch%CWD_BG_out(ci) * cwd_fcel_ed * currentpatch%area/AREA * croot_prof_perpatch(j) + FATES_c_to_litr_lig_c(s,j) = FATES_c_to_litr_lig_c(s,j) + currentpatch%CWD_BG_out(ci) * cwd_flig_ed * currentpatch%area/AREA * croot_prof_perpatch(j) end do end do ! leaf and fine root pools. do ft = 1,numpft_ed do j = 1, nlevdecomp - ED_c_to_litr_lab_c(c,j) = ED_c_to_litr_lab_c(c,j) + currentpatch%leaf_litter_out(ft) * pftcon%lf_flab(ft) * currentpatch%area/AREA * leaf_prof(c,j) - ED_c_to_litr_cel_c(c,j) = ED_c_to_litr_cel_c(c,j) + currentpatch%leaf_litter_out(ft) * pftcon%lf_fcel(ft) * currentpatch%area/AREA * leaf_prof(c,j) - ED_c_to_litr_lig_c(c,j) = ED_c_to_litr_lig_c(c,j) + currentpatch%leaf_litter_out(ft) * pftcon%lf_flig(ft) * currentpatch%area/AREA * leaf_prof(c,j) + FATES_c_to_litr_lab_c(s,j) = FATES_c_to_litr_lab_c(s,j) + currentpatch%leaf_litter_out(ft) * pftcon%lf_flab(ft) * currentpatch%area/AREA * leaf_prof(s,j) + FATES_c_to_litr_cel_c(s,j) = FATES_c_to_litr_cel_c(s,j) + currentpatch%leaf_litter_out(ft) * pftcon%lf_fcel(ft) * currentpatch%area/AREA * leaf_prof(s,j) + FATES_c_to_litr_lig_c(s,j) = FATES_c_to_litr_lig_c(s,j) + currentpatch%leaf_litter_out(ft) * pftcon%lf_flig(ft) * currentpatch%area/AREA * leaf_prof(s,j) ! - ED_c_to_litr_lab_c(c,j) = ED_c_to_litr_lab_c(c,j) + currentpatch%root_litter_out(ft) * pftcon%fr_flab(ft) * currentpatch%area/AREA * froot_prof(c,ft,j) - ED_c_to_litr_cel_c(c,j) = ED_c_to_litr_cel_c(c,j) + currentpatch%root_litter_out(ft) * pftcon%fr_fcel(ft) * currentpatch%area/AREA * froot_prof(c,ft,j) - ED_c_to_litr_lig_c(c,j) = ED_c_to_litr_lig_c(c,j) + currentpatch%root_litter_out(ft) * pftcon%fr_flig(ft) * currentpatch%area/AREA * froot_prof(c,ft,j) + FATES_c_to_litr_lab_c(s,j) = FATES_c_to_litr_lab_c(s,j) + currentpatch%root_litter_out(ft) * pftcon%fr_flab(ft) * currentpatch%area/AREA * froot_prof(s,ft,j) + FATES_c_to_litr_cel_c(s,j) = FATES_c_to_litr_cel_c(s,j) + currentpatch%root_litter_out(ft) * pftcon%fr_fcel(ft) * currentpatch%area/AREA * froot_prof(s,ft,j) + FATES_c_to_litr_lig_c(s,j) = FATES_c_to_litr_lig_c(s,j) + currentpatch%root_litter_out(ft) * pftcon%fr_flig(ft) * currentpatch%area/AREA * froot_prof(s,ft,j) ! !! and seed_decay too. for now, use the same lability fractions as for leaf litter - ED_c_to_litr_lab_c(c,j) = ED_c_to_litr_lab_c(c,j) + currentpatch%seed_decay(ft) * pftcon%lf_flab(ft) * currentpatch%area/AREA * leaf_prof(c,j) - ED_c_to_litr_cel_c(c,j) = ED_c_to_litr_cel_c(c,j) + currentpatch%seed_decay(ft) * pftcon%lf_fcel(ft) * currentpatch%area/AREA * leaf_prof(c,j) - ED_c_to_litr_lig_c(c,j) = ED_c_to_litr_lig_c(c,j) + currentpatch%seed_decay(ft) * pftcon%lf_flig(ft) * currentpatch%area/AREA * leaf_prof(c,j) + FATES_c_to_litr_lab_c(s,j) = FATES_c_to_litr_lab_c(s,j) + currentpatch%seed_decay(ft) * pftcon%lf_flab(ft) * currentpatch%area/AREA * leaf_prof(s,j) + FATES_c_to_litr_cel_c(s,j) = FATES_c_to_litr_cel_c(s,j) + currentpatch%seed_decay(ft) * pftcon%lf_fcel(ft) * currentpatch%area/AREA * leaf_prof(s,j) + FATES_c_to_litr_lig_c(s,j) = FATES_c_to_litr_lig_c(s,j) + currentpatch%seed_decay(ft) * pftcon%lf_flig(ft) * currentpatch%area/AREA * leaf_prof(s,j) ! enddo end do @@ -1599,19 +1602,19 @@ subroutine flux_into_litter_pools(bounds, sites, nsites, fcolumn, canopystate_in end do ! do sites(s) - do c = bounds%begc,bounds%endc + do s = 1, nsites do j = 1, nlevdecomp ! time unit conversion - ED_c_to_litr_lab_c(c,j)=ED_c_to_litr_lab_c(c,j) * mass_convert / time_convert - ED_c_to_litr_cel_c(c,j)=ED_c_to_litr_cel_c(c,j) * mass_convert / time_convert - ED_c_to_litr_lig_c(c,j)=ED_c_to_litr_lig_c(c,j) * mass_convert / time_convert + FATES_c_to_litr_lab_c(s,j)=FATES_c_to_litr_lab_c(s,j) * mass_convert / time_convert + FATES_c_to_litr_cel_c(s,j)=FATES_c_to_litr_cel_c(s,j) * mass_convert / time_convert + FATES_c_to_litr_lig_c(s,j)=FATES_c_to_litr_lig_c(s,j) * mass_convert / time_convert end do end do - ! write(iulog,*)'cdk ED_c_to_litr_lab_c: ', ED_c_to_litr_lab_c - ! write(iulog,*)'cdk ED_c_to_litr_cel_c: ', ED_c_to_litr_cel_c - ! write(iulog,*)'cdk ED_c_to_litr_lig_c: ', ED_c_to_litr_lig_c + ! write(iulog,*)'cdk FATES_c_to_litr_lab_c: ', FATES_c_to_litr_lab_c + ! write(iulog,*)'cdk FATES_c_to_litr_cel_c: ', FATES_c_to_litr_cel_c + ! write(iulog,*)'cdk FATES_c_to_litr_lig_c: ', FATES_c_to_litr_lig_c ! write(iulog,*)'cdk nlevdecomp_full, bounds%begc, bounds%endc: ', nlevdecomp_full, bounds%begc, bounds%endc ! write(iulog,*)'cdk leaf_prof: ', leaf_prof ! write(iulog,*)'cdk stem_prof: ', stem_prof diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 2883aa3c..86f6f112 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -89,10 +89,10 @@ module FatesInterfaceMod ! (diagnostic, should not be used by HLM) real(r8), allocatable :: btran_pa(:) - ! litterfall fluxes of C from ED patches to BGC columns - real(r8), allocatable :: ED_c_to_litr_lab_c_col(:) !total labile litter coming from ED. gC/m3/s - real(r8), allocatable :: ED_c_to_litr_cel_c_col(:) !total cellulose litter coming from ED. gC/m3/s - real(r8), allocatable :: ED_c_to_litr_lig_c_col(:) !total lignin litter coming from ED. gC/m3/s + ! litterfall fluxes of C from FATES patches to BGC columns + real(r8), allocatable :: FATES_c_to_litr_lab_c_col(:) !total labile litter coming from ED. gC/m3/s + real(r8), allocatable :: FATES_c_to_litr_cel_c_col(:) !total cellulose litter coming from ED. gC/m3/s + real(r8), allocatable :: FATES_c_to_litr_lig_c_col(:) !total lignin litter coming from ED. gC/m3/s end type bc_out_type @@ -202,9 +202,9 @@ subroutine allocate_bcout(bc_out) allocate(bc_out%rootr_pagl(numPatchesPerCol,ctrl_parms%numlevgrnd)) allocate(bc_out%btran_pa(numPatchesPerCol)) - allocate(bc_out%ED_c_to_litr_lab_c_col(ctrl_parms%numlevdecomp_full)) - allocate(bc_out%ED_c_to_litr_cel_c_col(ctrl_parms%numlevdecomp_full)) - allocate(bc_out%ED_c_to_litr_lig_c_col(ctrl_parms%numlevdecomp_full)) + allocate(bc_out%FATES_c_to_litr_lab_c_col(ctrl_parms%numlevdecomp_full)) + allocate(bc_out%FATES_c_to_litr_cel_c_col(ctrl_parms%numlevdecomp_full)) + allocate(bc_out%FATES_c_to_litr_lig_c_col(ctrl_parms%numlevdecomp_full)) @@ -235,9 +235,9 @@ subroutine zero_bcs(this,s) this%bc_out(s)%fsun_pa(:) = 0.0_r8 this%bc_out(s)%rootr_pagl(:,:) = 0.0_r8 this%bc_out(s)%btran_pa(:) = 0.0_r8 - this%bc_out(s)%ED_c_to_litr_lab_c_col(:) = 0.0_r8 - this%bc_out(s)%ED_c_to_litr_cel_c_col(:, = 0.0_r8 - this%bc_out(s)%ED_c_to_litr_lig_c_col(:) = 0.0_r8 + this%bc_out(s)%FATES_c_to_litr_lab_c_col(:) = 0.0_r8 + this%bc_out(s)%FATES_c_to_litr_cel_c_col(:, = 0.0_r8 + this%bc_out(s)%FATES_c_to_litr_lig_c_col(:) = 0.0_r8 return end subroutine zero_bcs From 04294b2a1f92bfa5636010ca48ab141192cecb27 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Sat, 6 Aug 2016 13:32:07 -0700 Subject: [PATCH 141/437] partial commit towards first phase of radiation interface --- biogeophys/EDSurfaceAlbedoMod.F90 | 48 +++++++++---------------------- 1 file changed, 14 insertions(+), 34 deletions(-) diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index 45f038cb..44279f96 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -37,43 +37,24 @@ module EDSurfaceRadiationMod contains - subroutine ED_Norman_Radiation (bounds, & - filter_vegsol, num_vegsol, filter_nourbanp, num_nourbanp, & - coszen, sites, nsites, fcolumn, hsites, surfalb_inst) + subroutine ED_Norman_Radiation (sites, nsites, bc_in, bc_out) ! - ! !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 - ! in this routine in the future - 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 :: sites(nsites) ! FATES site vector - integer , intent(in) :: nsites - integer , intent(in) :: fcolumn(nsites) - integer , intent(in) :: hsites(bounds%begc:bounds%endc) - type(surfalb_type) , intent(inout) :: surfalb_inst - ! + + type(ed_site_type), intent(inout), target :: sites(nsites) ! FATES site vector + integer, intent(in) :: nsites + type(bc_in_type), intent(in) :: bc_in(nsites) + type(bc_out_type), intent(inout) :: bc_out(nsites) + ! !LOCAL VARIABLES: ! ============================================================================ ! ED/NORMAN RADIATION DECS @@ -134,8 +115,8 @@ subroutine ED_Norman_Radiation (bounds, & 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) +! 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) @@ -148,7 +129,6 @@ subroutine ED_Norman_Radiation (bounds, & 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 @@ -228,8 +208,8 @@ subroutine ED_Norman_Radiation (bounds, & 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) + albd(p,ib) = bc_in(s)%albgr_dir_rb(ib) !albgrd(c,ib) + albd(p,ib) = bc_in(s)%albgr_dif_rb(ib) !albgri(c,ib) ftdd(p,ib)= 1.0_r8 ftid(p,ib)= 1.0_r8 ftii(p,ib)= 1.0_r8 From 0e508cf4e014fda93483d7da6193495e10abd7a5 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Sun, 7 Aug 2016 12:51:06 -0700 Subject: [PATCH 142/437] photosynthesis interface 1: wrapper in place, bc_in in place, 1x1br tests running, results forthcoming --- biogeophys/EDSurfaceAlbedoMod.F90 | 1518 ++++++++++++++--------------- main/FatesInterfaceMod.F90 | 30 + 2 files changed, 781 insertions(+), 767 deletions(-) diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index 44279f96..71786c4b 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -12,11 +12,12 @@ module EDSurfaceRadiationMod use EDtypesMod , only : ed_patch_type, ed_site_type use EDtypesMod , only : numpft_ed - use EDTypesMod , only : map_clmpatch_to_edpatch + use EDtypesMod , only : numPatchesPerCol use shr_kind_mod , only : r8 => shr_kind_r8 use shr_log_mod , only : errMsg => shr_log_errMsg use decompMod , only : bounds_type use clm_varpar , only : numrad, nclmax + use ColumnType , only : col use FatesInterfaceMod , only : bc_in_type, & bc_out_type @@ -37,7 +38,7 @@ module EDSurfaceRadiationMod contains - subroutine ED_Norman_Radiation (sites, nsites, bc_in, bc_out) + subroutine ED_Norman_Radiation (sites, nsites, fcolumn, bc_in, bc_out, surfalb_inst) ! ! @@ -46,21 +47,23 @@ subroutine ED_Norman_Radiation (sites, nsites, bc_in, bc_out) use pftconMod , only : pftcon use EDtypesMod , only : ed_patch_type, numpft_ed, nlevcan_ed use EDTypesMod , only : ed_site_type - + use SurfaceAlbedoType , only : surfalb_type ! !ARGUMENTS: type(ed_site_type), intent(inout), target :: sites(nsites) ! FATES site vector integer, intent(in) :: nsites + integer, intent(in) :: fcolumn(nsites) type(bc_in_type), intent(in) :: bc_in(nsites) type(bc_out_type), intent(inout) :: bc_out(nsites) + type(surfalb_type), intent(inout) :: surfalb_inst ! !LOCAL VARIABLES: ! ============================================================================ ! ED/NORMAN RADIATION DECS ! ============================================================================ type (ed_patch_type) , pointer :: currentPatch - integer :: radtype, L, ft, j + integer :: radtype, L, ft, j, ifp integer :: iter ! Iteration index integer :: irep ! Flag to exit iteration loop real(r8) :: sb @@ -114,7 +117,6 @@ subroutine ED_Norman_Radiation (sites, nsites, bc_in, bc_out) 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) @@ -144,12 +146,14 @@ subroutine ED_Norman_Radiation (sites, nsites, bc_in, bc_out) ! ------------------------------------------------------------------------------- - do s = 1, this%fates(nc)%nsites + do s = 1, nsites + c = fcolumn(s) ifp = 0 currentpatch => sites(s)%oldest_patch do while (associated(currentpatch)) ifp = ifp+1 + p = col%patchi(c)+ifp ! Maintain the CLM patch index temporarily currentPatch%f_sun (:,:,:) = 0._r8 currentPatch%fabd_sun_z (:,:,:) = 0._r8 @@ -161,18 +165,14 @@ subroutine ED_Norman_Radiation (sites, nsites, bc_in, bc_out) if(bc_in(s)%filter_vegzen_pa(ifp))then - ! PREVIOUSLY FILTERING ON veg_sol - ! do fp = 1,num_vegsol - ! p = filter_vegsol(fp) - 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 + albd(p,:) = 0._r8 ! output HLM + albi(p,:) = 0._r8 ! output HLM + fabi(p,:) = 0._r8 ! output HLM + fabd(p,:) = 0._r8 ! output HLM + tr_dir_z(:,:,:) = 0._r8 tr_dif_z(:,:,:) = 0._r8 ftweight(:,:,:) = 0._r8 lai_change(:,:,:) = 0._r8 @@ -181,758 +181,742 @@ subroutine ED_Norman_Radiation (sites, nsites, bc_in, bc_out) 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... - - - ! INTERF-TODO: - s = hsites(c) - currentPatch => map_clmpatch_to_edpatch(sites(s), 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) = bc_in(s)%albgr_dir_rb(ib) !albgrd(c,ib) - albd(p,ib) = bc_in(s)%albgr_dif_rb(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, bc_in(s)%coszen_pa(ifp)) !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(p) = 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? - if (ib == 1) then ! only set the absorbed PAR for the visible light band. - do iv = 1, currentPatch%nrad(L,ft) - if (radtype==1) then - if ( DEBUG ) then - write(iulog,*) 'EDsurfAlb 730 ',Abs_dif_z(ft,iv),currentPatch%f_sun(L,ft,iv) - write(iulog,*) 'EDsurfAlb 731 ',currentPatch%fabd_sha_z(L,ft,iv),currentPatch%fabd_sun_z(L,ft,iv) - endif - currentPatch%fabd_sha_z(L,ft,iv) = Abs_dif_z(ft,iv) * & - (1._r8 - currentPatch%f_sun(L,ft,iv)) - currentPatch%fabd_sun_z(L,ft,iv) = Abs_dif_z(ft,iv) * & - currentPatch%f_sun(L,ft,iv) + & - Abs_dir_z(ft,iv) - else - currentPatch%fabi_sha_z(L,ft,iv) = Abs_dif_z(ft,iv) * & - (1._r8 - currentPatch%f_sun(L,ft,iv)) - currentPatch%fabi_sun_z(L,ft,iv) = Abs_dif_z(ft,iv) * & - currentPatch%f_sun(L,ft,iv) - endif - if ( DEBUG ) then - write(iulog,*) 'EDsurfAlb 740 ',currentPatch%fabd_sha_z(L,ft,iv),currentPatch%fabd_sun_z(L,ft,iv) - endif - end do - endif ! ib - - !==============================================================================! - ! Sum fluxes - !==============================================================================! - ! Solar radiation absorbed by ground - iv = currentPatch%nrad(L,ft) + 1 - if (L==currentPatch%NCL_p)then - abs_rad(ib) = abs_rad(ib) + (Abs_dir_z(ft,iv) + Abs_dif_z(ft,iv)) - end if - ! Solar radiation absorbed by vegetation and sunlit/shaded leaves - do iv = 1,currentPatch%nrad(L,ft) - if (radtype == 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,c,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,c,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 - ! NO-OP - ! 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 - ! NO-OP - ! 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 - ! NO-OP - ! 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 - 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 - 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 - + ftdd(p,:) = 1._r8 ! output HLM + ftid(p,:) = 1._r8 ! output HLM + ftii(p,:) = 1._r8 ! output HLM + + if (maxval(currentPatch%nrad(1,:))==0)then + !there are no leaf layers in this patch. it is effectively bare ground. + ! no radiation is absorbed + fabd(p,:) = 0.0_r8 + fabi(p,:) = 0.0_r8 + do ib = 1,numrad + albd(p,ib) = bc_in(s)%albgr_dir_rb(ib) !albgrd(c,ib) + albd(p,ib) = bc_in(s)%albgr_dif_rb(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 + + 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, bc_in(s)%coszen_pa(ifp)) !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(p) = 0.01_r8 + end if + phi1b(ifp,ft) = 0.5_r8 - 0.633_r8*chil(p) - 0.330_r8*chil(p)*chil(p) + phi2b(ifp,ft) = 0.877_r8 * (1._r8 - 2._r8*phi1b(ifp,ft)) !0 = horiz leaves, 1 - vert leaves. + gdir(p) = phi1b(ifp,ft) + phi2b(ifp,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(ifp,ft) + phi2b(ifp,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) = bc_in(s)%albgr_dif_rb(ib) + else + dif_ratio(L,ft,iv,ib) = weighted_dif_ratio(L+1,ib) + end if + ! Canopy layers, working upwardfrom soil with dif_ratio(iv+1) known + ! FIX(RF,032414) ray tracing eqution - need to find derivation of this... + ! for each unit going down, there are x units going up. + do iv = currentPatch%nrad(L,ft),1, -1 + dif_ratio(L,ft,iv,ib) = dif_ratio(L,ft,iv+1,ib) * tran_dif(L,ft,iv,ib)*tran_dif(L,ft,iv,ib) / & + (1._r8 - dif_ratio(L,ft,iv+1,ib) * refl_dif(L,ft,iv,ib)) + refl_dif(L,ft,iv,ib) + dif_ratio(L,ft,iv,ib) = dif_ratio(L,ft,iv,ib) * ftweight(L,ft,iv)/ftweight(L,ft,1) + dif_ratio(L,ft,iv,ib) = dif_ratio(L,ft,iv,ib) + dif_ratio(L,ft,iv+1,ib)* & + (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) + end do + weighted_dif_ratio(L,ib) = weighted_dif_ratio(L,ib) + dif_ratio(L,ft,1,ib) * ftweight(L,ft,1) + !instance where the first layer ftweight is used a proxy for the whole column. FTWA + end do!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) =bc_in(s)%albgr_dif_rb(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) * bc_in(s)%albgr_dif_rb(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)))*bc_in(s)%albgr_dir_rb(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) *bc_in(s)%albgr_dif_rb(ib) + & + forc_dir(p,ib) * tr_dir_z(L,ft,iv) *bc_in(s)%albgr_dir_rb(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) * bc_in(s)%albgr_dif_rb(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)))*bc_in(s)%albgr_dir_rb(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 -bc_in(s)%albgr_dif_rb(ib)) + Abs_dir_z(ft,iv) = ftweight(L,ft,1)*forc_dir(p,ib) * & + tr_dir_z(L,ft,iv) * (1.0_r8 -bc_in(s)%albgr_dir_rb(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? + if (ib == 1) then ! only set the absorbed PAR for the visible light band. + do iv = 1, currentPatch%nrad(L,ft) + if (radtype==1) then + if ( DEBUG ) then + write(iulog,*) 'EDsurfAlb 730 ',Abs_dif_z(ft,iv),currentPatch%f_sun(L,ft,iv) + write(iulog,*) 'EDsurfAlb 731 ',currentPatch%fabd_sha_z(L,ft,iv),currentPatch%fabd_sun_z(L,ft,iv) + endif + currentPatch%fabd_sha_z(L,ft,iv) = Abs_dif_z(ft,iv) * & + (1._r8 - currentPatch%f_sun(L,ft,iv)) + currentPatch%fabd_sun_z(L,ft,iv) = Abs_dif_z(ft,iv) * & + currentPatch%f_sun(L,ft,iv) + & + Abs_dir_z(ft,iv) + else + currentPatch%fabi_sha_z(L,ft,iv) = Abs_dif_z(ft,iv) * & + (1._r8 - currentPatch%f_sun(L,ft,iv)) + currentPatch%fabi_sun_z(L,ft,iv) = Abs_dif_z(ft,iv) * & + currentPatch%f_sun(L,ft,iv) + endif + if ( DEBUG ) then + write(iulog,*) 'EDsurfAlb 740 ',currentPatch%fabd_sha_z(L,ft,iv),currentPatch%fabd_sun_z(L,ft,iv) + endif + end do + endif ! ib + + !==============================================================================! + ! Sum fluxes + !==============================================================================! + ! Solar radiation absorbed by ground + iv = currentPatch%nrad(L,ft) + 1 + if (L==currentPatch%NCL_p)then + abs_rad(ib) = abs_rad(ib) + (Abs_dir_z(ft,iv) + Abs_dif_z(ft,iv)) + end if + ! Solar radiation absorbed by vegetation and sunlit/shaded leaves + do iv = 1,currentPatch%nrad(L,ft) + if (radtype == 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-bc_in(s)%albgr_dif_rb(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-bc_in(s)%albgr_dir_rb(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-bc_in(s)%albgr_dir_rb(ib))+ & + currentPatch%tr_soil_dir_dif(ib)*(1.0_r8-bc_in(s)%albgr_dif_rb(ib)))) + if ( abs(error) > 0.0001)then + write(iulog,*)'dir ground absorption error',p,c,error,currentPatch%sabs_dir(ib), & + currentPatch%tr_soil_dir(ib)* & + (1.0_r8-bc_in(s)%albgr_dir_rb(ib)),currentPatch%NCL_p,ib,sum(ftweight(1,:,1)) + write(iulog,*) 'albedos',currentPatch%sabs_dir(ib) ,currentPatch%tr_soil_dir(ib), & + (1.0_r8-bc_in(s)%albgr_dir_rb(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-bc_in(s)%albgr_dif_rb(ib)))) > 0.0001)then + write(iulog,*)'dif ground absorption error',p,c,currentPatch%sabs_dif(ib) , & + (currentPatch%tr_soil_dif(ib)* & + (1.0_r8-bc_in(s)%albgr_dif_rb(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 + ! NO-OP + ! 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 + ! NO-OP + ! 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 + ! NO-OP + ! 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 + 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,*) 'bc_in(s)%albgr_dir_rb(ib)',bc_in(s)%albgr_dir_rb(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 + 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,*) 'bc_in(s)%albgr_dif_rb(ib)',bc_in(s)%albgr_dif_rb(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? + + end if ! if the vegetation and zenith filter is active + currentPatch => currentPatch%younger + end do ! Loop linked-list patches + enddo ! Loop Sites + + end associate + return + end subroutine ED_Norman_Radiation + ! ====================================================================================== subroutine ED_SunShadeFracs(sites,nsites,bc_in,bc_out) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index cdc8af92..aba12931 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -111,6 +111,25 @@ module FatesInterfaceMod ! soil temperature (Kelvin) real(r8), allocatable :: t_soisno_gl(:) + ! Canopy Radiation Boundaries + ! --------------------------------------------------------------------------------- + + ! Filter for vegetation patches with a positive zenith angle (daylight) + logical, allocatable :: filter_vegzen_pa(:) + + ! Cosine of the zenith angle (0-1), by patch + ! Note RGK: It does not seem like the code would currently generate + ! different zenith angles for different patches (nor should it) + ! I am leaving it at this scale for simplicity. Patches should + ! have no spacially variable information + real(r8), allocatable :: coszen_pa(:) + + ! Abledo of the ground for direct radiation, by site broadband (0-1) + real(r8), allocatable :: albgr_dir_rb(:) + + ! Albedo of the ground for diffuse radiation, by site broadband (0-1) + real(r8), allocatable :: albgr_dif_rb(:) + end type bc_in_type @@ -253,6 +272,12 @@ subroutine allocate_bcin(bc_in) allocate(bc_in%tgcm_pa(numPatchesPerCol)) allocate(bc_in%t_soisno_gl(ctrl_parms%numlevgrnd)) + ! Canopy Radiation + allocate(bc_in%filter_vegzen_pa(numPatchesPerCol)) + allocate(bc_in%coszen_pa(numPatchesPerCol)) + allocate(bc_in%albgr_dir_rb(ctrl_parms%numSWBands)) + allocate(bc_in%albgr_dif_rb(ctrl_parms%numSWBands)) + return end subroutine allocate_bcin @@ -303,6 +328,11 @@ subroutine zero_bcs(this,s) this%bc_in(s)%watsat_gl(:) = 0.0_r8 this%bc_in(s)%tempk_gl(:) = 0.0_r8 this%bc_in(s)%h2o_liqvol_gl(:) = 0.0_r8 + + this%bc_in(s)%filter_vegzen_pa(:) = .false. + this%bc_in(s)%coszen_pa(:) = 0.0_r8 + this%bc_in(s)%albgr_dir_rb(:) = 0.0_r8 + this%bc_in(s)%albgr_dif_rb(:) = 0.0_r8 ! Output boundaries this%bc_out(s)%active_suction_gl(:) = .false. From 6fb0a067bd704152ae6e49efb137a6302764c151 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Sun, 7 Aug 2016 14:42:19 -0700 Subject: [PATCH 143/437] canopy radiation interface 2: bc_out structures implemented and tested --- biogeophys/EDSurfaceAlbedoMod.F90 | 165 ++++++++++++++---------------- main/FatesInterfaceMod.F90 | 42 +++++++- 2 files changed, 116 insertions(+), 91 deletions(-) diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index 71786c4b..f73ce576 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -38,7 +38,7 @@ module EDSurfaceRadiationMod contains - subroutine ED_Norman_Radiation (sites, nsites, fcolumn, bc_in, bc_out, surfalb_inst) + subroutine ED_Norman_Radiation (sites, nsites, bc_in, bc_out ) ! ! @@ -47,16 +47,15 @@ subroutine ED_Norman_Radiation (sites, nsites, fcolumn, bc_in, bc_out, surfalb_i use pftconMod , only : pftcon use EDtypesMod , only : ed_patch_type, numpft_ed, nlevcan_ed use EDTypesMod , only : ed_site_type - use SurfaceAlbedoType , only : surfalb_type + ! !ARGUMENTS: type(ed_site_type), intent(inout), target :: sites(nsites) ! FATES site vector integer, intent(in) :: nsites - integer, intent(in) :: fcolumn(nsites) type(bc_in_type), intent(in) :: bc_in(nsites) type(bc_out_type), intent(inout) :: bc_out(nsites) - type(surfalb_type), intent(inout) :: surfalb_inst + ! !LOCAL VARIABLES: ! ============================================================================ @@ -103,7 +102,7 @@ subroutine ED_Norman_Radiation (sites, nsites, fcolumn, bc_in, bc_out, surfalb_i real(r8) :: denom real(r8) :: lai_reduction(2) - integer :: fp,p,c,iv,s ! array indices + integer :: fp,iv,s ! array indices integer :: ib ! waveband number real(r8) :: cosz ! 0.001 <= coszen <= 1.000 real(r8) :: chil(numPatchesPerCol) ! -0.4 <= xl <= 0.6 @@ -116,27 +115,15 @@ subroutine ED_Norman_Radiation (sites, nsites, fcolumn, bc_in, bc_out, surfalb_i 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 - 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 - ) + xl => pftcon%xl) ! Input: [real(r8) (:) ] ecophys const - leaf/stem orientation index + +! albd => surfalb_inst%albd_patch , & ! Output: [real(r8) (:,:) ] surface albedo (direct) (USED IN LND2ATM,BALANCE_CHECK) +! albi => surfalb_inst%albi_patch , & ! Output: [real(r8) (:,:) ] surface albedo (diffuse) (LND2ATM,BALANCE_CHECK) +! fabd => surfalb_inst%fabd_patch , & ! Output: [real(r8) (:,:) ] flux absorbed by canopy per unit direct flux (BALANCE_CHECK) +! fabi => surfalb_inst%fabi_patch , & ! Output: [real(r8) (:,:) ] flux absorbed by canopy per unit diffuse flux (BALANCE_CHECK) +! ftdd => surfalb_inst%ftdd_patch , & ! Output: [real(r8) (:,:) ] down direct flux below canopy per unit direct flx (BALANCE_CHECK) +! ftid => surfalb_inst%ftid_patch , & ! Output: [real(r8) (:,:) ] down diffuse flux below canopy per unit direct flx (BALANCE_CHECK) +! ftii => surfalb_inst%ftii_patch , & ! Output: [real(r8) (:,:) ] down diffuse flux below canopy per unit diffuse flx (BALANCE_CHECK) ! ------------------------------------------------------------------------------- ! TODO (mv, 2014-10-29) the filter here is different than below @@ -148,12 +135,10 @@ subroutine ED_Norman_Radiation (sites, nsites, fcolumn, bc_in, bc_out, surfalb_i do s = 1, nsites - c = fcolumn(s) ifp = 0 currentpatch => sites(s)%oldest_patch do while (associated(currentpatch)) ifp = ifp+1 - p = col%patchi(c)+ifp ! Maintain the CLM patch index temporarily currentPatch%f_sun (:,:,:) = 0._r8 currentPatch%fabd_sun_z (:,:,:) = 0._r8 @@ -168,10 +153,10 @@ subroutine ED_Norman_Radiation (sites, nsites, fcolumn, bc_in, bc_out, surfalb_i weighted_dir_tr(:) = 0._r8 weighted_dif_down(:) = 0._r8 weighted_dif_up(:) = 0._r8 - albd(p,:) = 0._r8 ! output HLM - albi(p,:) = 0._r8 ! output HLM - fabi(p,:) = 0._r8 ! output HLM - fabd(p,:) = 0._r8 ! output HLM + bc_out(s)%albd_parb(ifp,:) = 0._r8 ! output HLM + bc_out(s)%albi_parb(ifp,:) = 0._r8 ! output HLM + bc_out(s)%fabi_parb(ifp,:) = 0._r8 ! output HLM + bc_out(s)%fabd_parb(ifp,:) = 0._r8 ! output HLM tr_dir_z(:,:,:) = 0._r8 tr_dif_z(:,:,:) = 0._r8 ftweight(:,:,:) = 0._r8 @@ -181,21 +166,21 @@ subroutine ED_Norman_Radiation (sites, nsites, fcolumn, bc_in, bc_out, surfalb_i refl_dif(:,:,:,:) = 0.0_r8 tran_dif(:,:,:,:) = 0.0_r8 dif_ratio(:,:,:,:) = 0.0_r8 - ftdd(p,:) = 1._r8 ! output HLM - ftid(p,:) = 1._r8 ! output HLM - ftii(p,:) = 1._r8 ! output HLM + bc_out(s)%ftdd_parb(ifp,:) = 1._r8 ! output HLM + bc_out(s)%ftid_parb(ifp,:) = 1._r8 ! output HLM + bc_out(s)%ftii_parb(ifp,:) = 1._r8 ! output HLM if (maxval(currentPatch%nrad(1,:))==0)then !there are no leaf layers in this patch. it is effectively bare ground. ! no radiation is absorbed - fabd(p,:) = 0.0_r8 - fabi(p,:) = 0.0_r8 + bc_out(s)%fabd_parb(ifp,:) = 0.0_r8 + bc_out(s)%fabi_parb(ifp,:) = 0.0_r8 do ib = 1,numrad - albd(p,ib) = bc_in(s)%albgr_dir_rb(ib) !albgrd(c,ib) - albd(p,ib) = bc_in(s)%albgr_dif_rb(ib) !albgri(c,ib) - ftdd(p,ib)= 1.0_r8 - ftid(p,ib)= 1.0_r8 - ftii(p,ib)= 1.0_r8 + bc_out(s)%albd_parb(ifp,ib) = bc_in(s)%albgr_dir_rb(ib) + bc_out(s)%albd_parb(ifp,ib) = bc_in(s)%albgr_dif_rb(ib) + bc_out(s)%ftdd_parb(ifp,ib)= 1.0_r8 + bc_out(s)%ftid_parb(ifp,ib)= 1.0_r8 + bc_out(s)%ftii_parb(ifp,ib)= 1.0_r8 enddo else @@ -217,11 +202,11 @@ subroutine ED_Norman_Radiation (sites, nsites, fcolumn, bc_in, bc_out, surfalb_i 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 + forc_dir(ifp,ib) = 1.00_r8 + forc_dif(ifp,ib) = 0.00_r8 else !dif - forc_dir(p,ib) = 0.00_r8 - forc_dif(p,ib) = 1.00_r8 + forc_dir(ifp,ib) = 0.00_r8 + forc_dif(ifp,ib) = 1.00_r8 end if end do !ib @@ -248,15 +233,15 @@ subroutine ED_Norman_Radiation (sites, nsites, fcolumn, bc_in, bc_out, surfalb_i cosz = max(0.001_r8, bc_in(s)%coszen_pa(ifp)) !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(p) = 0.01_r8 + chil(ifp) = xl(ft) !min(max(xl(ft), -0.4_r8), 0.6_r8 ) + if (abs(chil(ifp)) <= 0.01_r8) then + chil(ifp) = 0.01_r8 end if - phi1b(ifp,ft) = 0.5_r8 - 0.633_r8*chil(p) - 0.330_r8*chil(p)*chil(p) + phi1b(ifp,ft) = 0.5_r8 - 0.633_r8*chil(ifp) - 0.330_r8*chil(ifp)*chil(ifp) phi2b(ifp,ft) = 0.877_r8 * (1._r8 - 2._r8*phi1b(ifp,ft)) !0 = horiz leaves, 1 - vert leaves. - gdir(p) = phi1b(ifp,ft) + phi2b(ifp,ft) * sin(sb) + gdir(ifp) = phi1b(ifp,ft) + phi2b(ifp,ft) * sin(sb) !how much direct light penetrates a singleunit of lai? - k_dir(ft) = gdir(p) / sin(sb) + k_dir(ft) = gdir(ifp) / sin(sb) end do !FT do L = 1,currentPatch%NCL_p !start at the top canopy layer (1 is the top layer.) @@ -275,8 +260,8 @@ subroutine ED_Norman_Radiation (sites, nsites, fcolumn, bc_in, bc_out, surfalb_i 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(ifp,ft) + phi2b(ifp,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) * & + gdir(ifp) = phi1b(ifp,ft) + phi2b(ifp,ft) * sin(angle) !This line is redundant FIX(RF,032414). + tr_dif_z(L,ft,iv) = tr_dif_z(L,ft,iv) + exp(-gdir(ifp) / sin(angle) * & (currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv))) * & sin(angle)*cos(angle) end do @@ -462,7 +447,7 @@ subroutine ED_Norman_Radiation (sites, nsites, fcolumn, bc_in, bc_out, surfalb_i ! downward diffuse flux onto the top surface of the canopy if (L == 1)then - Dif_dn(L,ft,1) = forc_dif(p,ib) + Dif_dn(L,ft,1) = forc_dif(ifp,ib) else Dif_dn(L,ft,1) = weighted_dif_down(L-1) end if @@ -541,7 +526,7 @@ subroutine ED_Norman_Radiation (sites, nsites, fcolumn, bc_in, bc_out, surfalb_i weighted_dif_up(L) = weighted_dif_up(L) +(1.0-sum(ftweight(L,:,1))) * & weighted_dif_down(L-1) * bc_in(s)%albgr_dif_rb(ib) !direct to diffuse - weighted_dif_up(L) = weighted_dif_up(L) + forc_dir(p,ib) * & + weighted_dif_up(L) = weighted_dif_up(L) + forc_dir(ifp,ib) * & weighted_dir_tr(L-1) * (1.0-sum(ftweight(L,:,1)))*bc_in(s)%albgr_dir_rb(ib) endif end do !L @@ -566,7 +551,7 @@ subroutine ED_Norman_Radiation (sites, nsites, fcolumn, bc_in, bc_out, surfalb_i ! 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) + Dif_dn(L,ft,1) = forc_dif(ifp,ib) else Dif_dn(L,ft,1) = weighted_dif_down(L-1) end if @@ -576,7 +561,7 @@ subroutine ED_Norman_Radiation (sites, nsites, fcolumn, bc_in, bc_out, surfalb_i 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 - & + forc_dir(ifp,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)) @@ -621,7 +606,7 @@ subroutine ED_Norman_Radiation (sites, nsites, fcolumn, bc_in, bc_out, surfalb_i 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) *bc_in(s)%albgr_dif_rb(ib) + & - forc_dir(p,ib) * tr_dir_z(L,ft,iv) *bc_in(s)%albgr_dir_rb(ib) + forc_dir(ifp,ib) * tr_dir_z(L,ft,iv) *bc_in(s)%albgr_dir_rb(ib) else !In the other canopy layers, reflect off the underlying vegetation. Dif_up(L,ft,iv) = weighted_dif_up(L+1) end if @@ -633,7 +618,7 @@ subroutine ED_Norman_Radiation (sites, nsites, fcolumn, bc_in, bc_out, surfalb_i !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) * & + up_rad = up_rad + forc_dir(ifp,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) @@ -654,7 +639,7 @@ subroutine ED_Norman_Radiation (sites, nsites, fcolumn, bc_in, bc_out, surfalb_i !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) * bc_in(s)%albgr_dif_rb(ib) - weighted_dif_up(L) = weighted_dif_up(L) + forc_dir(p,ib) * & + weighted_dif_up(L) = weighted_dif_up(L) + forc_dir(ifp,ib) * & weighted_dir_tr(L-1) * (1.0_r8-sum(ftweight(L,:,1)))*bc_in(s)%albgr_dir_rb(ib) end if end do!L @@ -674,7 +659,7 @@ subroutine ED_Norman_Radiation (sites, nsites, fcolumn, bc_in, bc_out, surfalb_i ! 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) * & + Abs_dir_z(ft,iv) = ftweight(L,ft,iv)* forc_dir(ifp,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) + & @@ -686,9 +671,9 @@ subroutine ED_Norman_Radiation (sites, nsites, fcolumn, bc_in, bc_out, surfalb_i 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 -bc_in(s)%albgr_dif_rb(ib)) - Abs_dir_z(ft,iv) = ftweight(L,ft,1)*forc_dir(p,ib) * & + Abs_dir_z(ft,iv) = ftweight(L,ft,1)*forc_dir(ifp,ib) * & tr_dir_z(L,ft,iv) * (1.0_r8 -bc_in(s)%albgr_dir_rb(ib)) - tr_soild = tr_soild + ftweight(L,ft,1)*forc_dir(p,ib) * tr_dir_z(L,ft,iv) + tr_soild = tr_soild + ftweight(L,ft,1)*forc_dir(ifp,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 @@ -730,26 +715,26 @@ subroutine ED_Norman_Radiation (sites, nsites, fcolumn, bc_in, bc_out, surfalb_i 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) + ! bc_out(s)%fabd_parb(ifp,ib) = currentPatch%fabd(ib) else currentPatch%fabi(ib) = currentPatch%fabi(ib) + Abs_dif_z(ft,iv) - ! fabi(p,ib) = currentPatch%fabi(ib) + ! bc_out(s)%fabi_parb(ifp,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) + bc_out(s)%albd_parb(ifp,ib) = bc_out(s)%albd_parb(ifp,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) + bc_out(s)%albi_parb(ifp,ib) = bc_out(s)%albi_parb(ifp,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) + bc_out(s)%fabd_parb(ifp,ib) = currentPatch%fabd(ib) else - fabi(p,ib) = currentPatch%fabi(ib) + bc_out(s)%fabi_parb(ifp,ib) = currentPatch%fabi(ib) endif @@ -757,22 +742,22 @@ subroutine ED_Norman_Radiation (sites, nsites, fcolumn, bc_in, bc_out, surfalb_i 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-bc_in(s)%albgr_dif_rb(ib)) - abs_rad(ib) = abs_rad(ib) + forc_dir(p,ib) * weighted_dir_tr(L-1) * & + abs_rad(ib) = abs_rad(ib) + forc_dir(ifp,ib) * weighted_dir_tr(L-1) * & (1.0_r8-sum(ftweight(L,:,1)))*(1.0_r8-bc_in(s)%albgr_dir_rb(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))) + tr_soild = tr_soild + forc_dir(ifp,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 + bc_out(s)%ftdd_parb(ifp,ib) = tr_soild + bc_out(s)%ftid_parb(ifp,ib) = tr_soili else currentPatch%tr_soil_dif(ib) = tr_soili currentPatch%sabs_dif(ib) = abs_rad(ib) - ftii(p,ib) = tr_soili + bc_out(s)%ftii_parb(ifp,ib) = tr_soili end if end do!l @@ -787,7 +772,7 @@ subroutine ED_Norman_Radiation (sites, nsites, fcolumn, bc_in, bc_out, surfalb_i error = abs(currentPatch%sabs_dir(ib)-(currentPatch%tr_soil_dir(ib)*(1.0_r8-bc_in(s)%albgr_dir_rb(ib))+ & currentPatch%tr_soil_dir_dif(ib)*(1.0_r8-bc_in(s)%albgr_dif_rb(ib)))) if ( abs(error) > 0.0001)then - write(iulog,*)'dir ground absorption error',p,c,error,currentPatch%sabs_dir(ib), & + write(iulog,*)'dir ground absorption error',ifp,s,error,currentPatch%sabs_dir(ib), & currentPatch%tr_soil_dir(ib)* & (1.0_r8-bc_in(s)%albgr_dir_rb(ib)),currentPatch%NCL_p,ib,sum(ftweight(1,:,1)) write(iulog,*) 'albedos',currentPatch%sabs_dir(ib) ,currentPatch%tr_soil_dir(ib), & @@ -802,16 +787,16 @@ subroutine ED_Norman_Radiation (sites, nsites, fcolumn, bc_in, bc_out, surfalb_i else if ( abs(currentPatch%sabs_dif(ib)-(currentPatch%tr_soil_dif(ib) * & (1.0_r8-bc_in(s)%albgr_dif_rb(ib)))) > 0.0001)then - write(iulog,*)'dif ground absorption error',p,c,currentPatch%sabs_dif(ib) , & + write(iulog,*)'dif ground absorption error',ifp,s,currentPatch%sabs_dif(ib) , & (currentPatch%tr_soil_dif(ib)* & (1.0_r8-bc_in(s)%albgr_dif_rb(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)) + error = (forc_dir(ifp,ib) + forc_dif(ifp,ib)) - (bc_out(s)%fabd_parb(ifp,ib) + bc_out(s)%albd_parb(ifp,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)) + error = (forc_dir(ifp,ib) + forc_dif(ifp,ib)) - (bc_out(s)%fabi_parb(ifp,ib) + bc_out(s)%albi_parb(ifp,ib) + currentPatch%sabs_dif(ib)) endif lai_reduction(:) = 0.0_r8 do L = 1, currentPatch%NCL_p @@ -848,7 +833,7 @@ subroutine ED_Norman_Radiation (sites, nsites, fcolumn, bc_in, bc_out, surfalb_i !here we are adding a within-ED radiation scheme tolerance, and then adding the diffrence onto the albedo !it is important that the lower boundary for this is ~1000 times smaller than the tolerance in surface albedo. if (abs(error) > 1.e-9_r8 .and. abs(error) < 0.15_r8)then - albd(p,ib) = albd(p,ib) + error + bc_out(s)%albd_parb(ifp,ib) = bc_out(s)%albd_parb(ifp,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. @@ -857,8 +842,8 @@ subroutine ED_Norman_Radiation (sites, nsites, fcolumn, bc_in, bc_out, surfalb_i ! 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,*) 'Large Dir Radn consvn error',error ,ifp,ib + write(iulog,*) 'diags',bc_out(s)%albd_parb(ifp,ib),bc_out(s)%ftdd_parb(ifp,ib),bc_out(s)%ftid_parb(ifp,ib),bc_out(s)%fabd_parb(ifp,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) @@ -866,17 +851,17 @@ subroutine ED_Norman_Radiation (sites, nsites, fcolumn, bc_in, bc_out, surfalb_i write(iulog,*) 'cp',currentPatch%area, currentPatch%patchno write(iulog,*) 'bc_in(s)%albgr_dir_rb(ib)',bc_in(s)%albgr_dir_rb(ib) - albd(p,ib) = albd(p,ib) + error + bc_out(s)%albd_parb(ifp,ib) = bc_out(s)%albd_parb(ifp,ib) + error end if else if (abs(error) > 1.e-9_r8 .and. abs(error) < 0.15_r8)then - albi(p,ib) = albi(p,ib) + error + bc_out(s)%albi_parb(ifp,ib) = bc_out(s)%albi_parb(ifp,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,*) '>5% Dif Radn consvn error',error ,ifp,ib + write(iulog,*) 'diags',bc_out(s)%albi_parb(ifp,ib),bc_out(s)%ftii_parb(ifp,ib),bc_out(s)%fabi_parb(ifp,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) @@ -888,17 +873,17 @@ subroutine ED_Norman_Radiation (sites, nsites, fcolumn, bc_in, bc_out, surfalb_i 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 + bc_out(s)%albi_parb(ifp,ib) = bc_out(s)%albi_parb(ifp,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)) + error = (forc_dir(ifp,ib) + forc_dif(ifp,ib)) - (bc_out(s)%fabd_parb(ifp,ib) + bc_out(s)%albd_parb(ifp,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)) + error = (forc_dir(ifp,ib) + forc_dif(ifp,ib)) - (bc_out(s)%fabi_parb(ifp,ib) + bc_out(s)%albi_parb(ifp,ib) + currentPatch%sabs_dif(ib)) endif if (abs(error) > 0.00000001_r8)then - write(iulog,*) 'there is still error after correction',error ,p,ib + write(iulog,*) 'there is still error after correction',error ,ifp,ib end if end if diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index aba12931..f5142adb 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -173,7 +173,30 @@ module FatesInterfaceMod ! patch sunlit leaf maintenance respiration rate (umol CO2/m**2/s) real(r8), allocatable :: lmrcanopy_pa(:) + ! Canopy Radiation Boundaries + ! --------------------------------------------------------------------------------- + + ! Surface albedo (direct) (HLMs use this for atm coupling and balance checks) + real(r8), allocatable :: albd_parb(:,:) + + ! Surface albedo (diffuse) (HLMs use this for atm coupling and balance checks) + real(r8), allocatable :: albi_parb(:,:) + + ! Flux absorbed by canopy per unit direct flux (HLMs use this for balance checks) + real(r8), allocatable :: fabd_parb(:,:) + + ! Flux absorbed by canopy per unit diffuse flux (HLMs use this for balance checks) + real(r8), allocatable :: fabi_parb(:,:) + ! Down direct flux below canopy per unit direct flx (HLMs use this for balance checks) + real(r8), allocatable :: ftdd_parb(:,:) + + ! Down diffuse flux below canopy per unit direct flx (HLMs use this for balance checks) + real(r8), allocatable :: ftid_parb(:,:) + + ! Down diffuse flux below canopy per unit diffuse flx (HLMs use this for balance checks) + real(r8), allocatable :: ftii_parb(:,:) + end type bc_out_type @@ -307,6 +330,15 @@ subroutine allocate_bcout(bc_out) allocate(bc_out%gccanopy_pa(numPatchesPerCol)) allocate(bc_out%lmrcanopy_pa(numPatchesPerCol)) allocate(bc_out%psncanopy_pa(numPatchesPerCol)) + + ! Canopy Radiation + allocate(bc_out%albd_parb(numPatchesPerCol,ctrl_parms%numSWBands)) + allocate(bc_out%albi_parb(numPatchesPerCol,ctrl_parms%numSWBands)) + allocate(bc_out%fabd_parb(numPatchesPerCol,ctrl_parms%numSWBands)) + allocate(bc_out%fabi_parb(numPatchesPerCol,ctrl_parms%numSWBands)) + allocate(bc_out%ftdd_parb(numPatchesPerCol,ctrl_parms%numSWBands)) + allocate(bc_out%ftid_parb(numPatchesPerCol,ctrl_parms%numSWBands)) + allocate(bc_out%ftii_parb(numPatchesPerCol,ctrl_parms%numSWBands)) return end subroutine allocate_bcout @@ -348,8 +380,16 @@ subroutine zero_bcs(this,s) this%bc_out(s)%psncanopy_pa(:) = 0.0_r8 this%bc_out(s)%lmrcanopy_pa(:) = 0.0_r8 + this%bc_out(s)%albd_parb(:,:) = 0.0_r8 + this%bc_out(s)%albi_parb(:,:) = 0.0_r8 + this%bc_out(s)%fabd_parb(:,:) = 0.0_r8 + this%bc_out(s)%fabi_parb(:,:) = 0.0_r8 + this%bc_out(s)%ftdd_parb(:,:) = 0.0_r8 + this%bc_out(s)%ftid_parb(:,:) = 0.0_r8 + this%bc_out(s)%ftii_parb(:,:) = 0.0_r8 + return - end subroutine zero_bcs + end subroutine zero_bcs ! ==================================================================================== From dc7f21d2f8149b4a190ecc43de43738215e52d92 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Sun, 7 Aug 2016 17:40:59 -0700 Subject: [PATCH 144/437] radiation part 3: cleaned up several global variables and sent them from CLM to FATES. Also found that patches were not being deallocated properly when terminated, in that the allocated vector spaces and the cohorts were not being deallocated. This was found because I had to convert some vectors on patch pointers to dynamically allocated memory, during which I found that other dynamically allocated memory on patch pointers were never deallocated. --- biogeochem/EDCanopyStructureMod.F90 | 30 ++++----- biogeochem/EDCohortDynamicsMod.F90 | 8 +-- biogeochem/EDGrowthFunctionsMod.F90 | 14 ++--- biogeochem/EDPatchDynamicsMod.F90 | 71 ++++++++++++++++++--- biogeochem/EDPhysiologyMod.F90 | 8 +-- biogeophys/EDBtranMod.F90 | 19 +++--- biogeophys/EDPhotosynthesisMod.F90 | 32 +++++----- biogeophys/EDSurfaceAlbedoMod.F90 | 66 ++++++++++---------- main/EDCLMLinkMod.F90 | 14 ++--- main/EDInitMod.F90 | 4 +- main/EDRestVectorMod.F90 | 26 ++++---- main/EDTypesMod.F90 | 96 +++++++++++++++-------------- main/FatesInterfaceMod.F90 | 71 ++++++++++++--------- 13 files changed, 261 insertions(+), 198 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index e8ae4985..68f57e16 100755 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -6,12 +6,12 @@ module EDCanopyStructureMod ! ============================================================================ 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 + use EDtypesMod , only : cp_nclmax implicit none private @@ -64,10 +64,10 @@ subroutine canopy_structure( currentSite ) ! 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, min_patch_area + use EDtypesMod , only : ncwd, min_patch_area, cp_nlevcan ! ! !ARGUMENTS type(ed_site_type) , intent(inout), target :: currentSite @@ -81,10 +81,10 @@ subroutine canopy_structure( currentSite ) 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) :: arealayer(cp_nlevcan) ! Amount of plant area currently in each canopy layer + real(r8) :: sumdiff(cp_nlevcan) ! 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) :: sum_weights(cp_nlevcan) real(r8) :: new_total_area_check real(r8) :: missing_area, promarea,cc_gain,sumgain integer :: promswitch,lower_cohort_switch @@ -126,7 +126,7 @@ subroutine canopy_structure( currentSite ) z = z + 1 endif - currentPatch%NCL_p = min(nclmax,z) ! Set current canopy layer occupancy indicator. + currentPatch%NCL_p = min(cp_nclmax,z) ! Set current canopy layer occupancy indicator. do i = 1,z ! Loop around the currently occupied canopy layers. @@ -187,7 +187,7 @@ subroutine canopy_structure( currentSite ) 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 + if(i+1 > cp_nclmax)then !put the litter from the terminated cohorts into the fragmenting pools ! write(iulog,*) '3rd canopy layer' do c=1,ncwd @@ -232,8 +232,8 @@ subroutine canopy_structure( currentSite ) 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 + !kill the ones which go into canopy layers that are not allowed... (default cp_nclmax=2) + if(i+1 > cp_nclmax)then !put the litter from the terminated cohorts into the fragmenting pools do c=1,ncwd @@ -305,7 +305,7 @@ subroutine canopy_structure( currentSite ) excess_area = arealayer(j)-currentPatch%area endif enddo - currentPatch%ncl_p = min(z,nclmax) + currentPatch%ncl_p = min(z,cp_nclmax) enddo !is there still excess area in any layer? @@ -507,7 +507,7 @@ subroutine canopy_structure( currentSite ) endif endif enddo - currentPatch%ncl_p = min(z,nclmax) + currentPatch%ncl_p = min(z,cp_nclmax) if(promswitch == 1)then ! write(iulog,*) 'missingarea loop',arealayer(1:3),currentPatch%patchno,missing_area,z endif @@ -579,7 +579,7 @@ subroutine canopy_spread( currentSite ) ! Calculates the spatial spread of tree canopies based on canopy closure. ! ! !USES: - use clm_varpar , only : nlevcan_ed + use EDTypesMod , only : cp_nlevcan use EDParamsMod , only : ED_val_maxspread, ED_val_minspread ! ! !ARGUMENTS @@ -588,7 +588,7 @@ subroutine canopy_spread( 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) :: arealayer(cp_nlevcan) ! Amount of canopy in each layer. real(r8) :: inc ! Arbitrary daily incremental change in canopy area integer :: z !---------------------------------------------------------------------- @@ -611,7 +611,7 @@ subroutine canopy_spread( currentSite ) enddo !If the canopy area is approaching closure, squash the tree canopies and make them taller and thinner - do z = 1,nclmax + do z = 1,cp_nclmax if(arealayer(z)/currentPatch%area > 0.9_r8)then currentPatch%spread(z) = currentPatch%spread(z) - inc diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index a063592a..ba76735f 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -10,7 +10,7 @@ module EDCohortDynamicsMod 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 : fusetol, cp_nclmax use EDtypesMod , only : ncwd, numcohortsperpatch, udata use EDtypesMod , only : sclass_ed,nlevsclass_ed,AREA use EDtypesMod , only : min_npm2, min_nppatch, min_n_safemath @@ -512,7 +512,7 @@ subroutine terminate_cohorts( patchptr ) endif ! In the third canopy layer - if (currentCohort%canopy_layer > NCLMAX) then + if (currentCohort%canopy_layer > cp_nclmax ) then terminate = 1 if ( DEBUG ) then write(iulog,*) 'terminating cohorts 2', currentCohort%canopy_layer @@ -584,7 +584,7 @@ subroutine fuse_cohorts(patchptr) ! Join similar cohorts to reduce total number ! ! !USES: - use clm_varpar , only : nlevcan_ed + use EDTypesMod , only : cp_nlevcan ! ! !ARGUMENTS type (ed_patch_type), intent(inout), target :: patchptr @@ -729,7 +729,7 @@ subroutine fuse_cohorts(patchptr) currentCohort%npp_bseed = (currentCohort%n*currentCohort%npp_bseed + nextc%n*nextc%npp_bseed)/newn currentCohort%npp_store = (currentCohort%n*currentCohort%npp_store + nextc%n*nextc%npp_store)/newn - do i=1, nlevcan_ed + do i=1, cp_nlevcan 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 diff --git a/biogeochem/EDGrowthFunctionsMod.F90 b/biogeochem/EDGrowthFunctionsMod.F90 index ea3dc4c7..a4ccdb2d 100755 --- a/biogeochem/EDGrowthFunctionsMod.F90 +++ b/biogeochem/EDGrowthFunctionsMod.F90 @@ -10,7 +10,7 @@ module EDGrowthFunctionsMod use clm_varctl , only : iulog use pftconMod , only : pftcon use EDEcophysContype , only : EDecophyscon - use EDTypesMod , only : ed_cohort_type, nlevcan_ed, dinc_ed + use EDTypesMod , only : ed_cohort_type, cp_nlevcan, dinc_ed implicit none private @@ -159,10 +159,10 @@ real(r8) function tree_lai( cohort_in ) 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 + ! at the moments cp_nlevcan 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 + if(cohort_in%treelai > cp_nlevcan*dinc_ed)then + write(iulog,*) 'too much lai' , cohort_in%treelai , cohort_in%pft , cp_nlevcan * dinc_ed endif return @@ -196,10 +196,10 @@ real(r8) function tree_sai( cohort_in ) 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 + ! at the moments cp_nlevcan 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 + if(cohort_in%treesai > cp_nlevcan*dinc_ed)then + write(iulog,*) 'too much sai' , cohort_in%treesai , cohort_in%pft , cp_nlevcan * dinc_ed endif return diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index edea8544..d38e868d 100755 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -11,7 +11,7 @@ module EDPatchDynamicsMod use EDCohortDynamicsMod , only : fuse_cohorts, sort_cohorts, insert_cohort use EDtypesMod , only : ncwd, n_dbh_bins, ntol, numpft_ed, area, dbhmax, numPatchesPerCol use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type, udata - use EDTypesMod , only : min_patch_area + use EDTypesMod , only : min_patch_area, cp_numlevgrnd, cp_numSWb ! implicit none private @@ -168,7 +168,7 @@ subroutine spawn_patches( currentSite ) ! 10) Area checked, and patchno recalculated. ! ! !USES: - use clm_varpar , only : nclmax + use EDTypesMod , only : cp_nclmax use EDParamsMod , only : ED_val_maxspread, ED_val_understorey_death use EDCohortDynamicsMod , only : zero_cohort, copy_cohort, terminate_cohorts ! @@ -192,7 +192,7 @@ subroutine spawn_patches( currentSite ) 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 + real(r8) :: spread_local(cp_nclmax) ! initial value of canopy spread parameter.no units !--------------------------------------------------------------------- storesmallcohort => null() ! storage of the smallest cohort for insertion routine @@ -220,13 +220,16 @@ subroutine spawn_patches( currentSite ) 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 + spread_local(1:cp_nclmax) = ED_val_maxspread age = 0.0_r8 seed_bank_local = 0.0_r8 allocate(new_patch) - call zero_patch(new_patch) +! This is called inside "create_patch" +! create_patch must first allocate some vector spaces before +! zero'ing can occur (RGK) +! 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, & @@ -796,7 +799,6 @@ subroutine create_patch(currentSite, new_patch, age, areap, spread_local,cwd_ag_ ! Set default values for creating a new patch ! ! !USES: - use clm_varpar , only : nlevgrnd ! ! !ARGUMENTS: type(ed_site_type) , intent(inout), target :: currentSite @@ -812,6 +814,17 @@ subroutine create_patch(currentSite, new_patch, age, areap, spread_local,cwd_ag_ ! ! !LOCAL VARIABLES: !--------------------------------------------------------------------- + + allocate(new_patch%tr_soil_dir(cp_numSWb)) + allocate(new_patch%tr_soil_dif(cp_numSWb)) + allocate(new_patch%tr_soil_dir_dif(cp_numSWb)) + allocate(new_patch%fab(cp_numSWb)) + allocate(new_patch%fabd(cp_numSWb)) + allocate(new_patch%fabi(cp_numSWb)) + allocate(new_patch%sabs_dir(cp_numSWb)) + allocate(new_patch%sabs_dif(cp_numSWb)) + allocate(new_patch%rootfr_ft(numpft_ed,cp_numlevgrnd)) + allocate(new_patch%rootr_ft(numpft_ed,cp_numlevgrnd)) call zero_patch(new_patch) !The nan value in here is not working?? @@ -861,8 +874,7 @@ subroutine create_patch(currentSite, new_patch, age, areap, spread_local,cwd_ag_ new_patch%leaf_litter_in(:) = 0._r8 new_patch%leaf_litter_out(:) = 0._r8 - allocate(new_patch%rootfr_ft(numpft_ed,nlevgrnd)) - allocate(new_patch%rootr_ft(numpft_ed,nlevgrnd)) + end subroutine create_patch @@ -922,7 +934,6 @@ subroutine zero_patch(cp_p) 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 @@ -983,6 +994,7 @@ subroutine zero_patch(cp_p) 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 @@ -1272,6 +1284,7 @@ subroutine fuse_2_patches(dp, rp) end if ! We have no need for the dp pointer anymore, we have passed on it's legacy + call dealloc_patch(dp) deallocate(dp) @@ -1359,6 +1372,46 @@ subroutine terminate_patches(cs_pnt) end subroutine terminate_patches + ! ===================================================================================== + + subroutine dealloc_patch(cpatch) + + ! This Subroutine is intended to de-allocate the allocatable memory that is pointed + ! to via the patch structure. This subroutine DOES NOT deallocate the patch + ! structure itself. + + type(ed_patch_type), target :: cpatch + type(ed_cohort_type), pointer :: ccohort ! current + type(ed_cohort_type), pointer :: ncohort ! next + + ! First Deallocate the cohort space + ! ----------------------------------------------------------------------------------- + ccohort => cpatch%shortest + do while(associated(ccohort)) + + ncohort => ccohort%taller + deallocate(ccohort) + ccohort => ncohort + + end do + + ! Secondly, and lastly, deallocate the allocatable vector spaces in the patch + if(allocated(cpatch%tr_soil_dir))then + deallocate(cpatch%tr_soil_dir) + deallocate(cpatch%tr_soil_dif) + deallocate(cpatch%tr_soil_dir_dif) + deallocate(cpatch%fab) + deallocate(cpatch%fabd) + deallocate(cpatch%fabi) + deallocate(cpatch%sabs_dir) + deallocate(cpatch%sabs_dif) + deallocate(cpatch%rootfr_ft) + deallocate(cpatch%rootr_ft) + end if + + return + end subroutine dealloc_patch + ! ============================================================================ subroutine patch_pft_size_profile(cp_pnt) ! diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 4f00de3b..d92c18bf 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -17,7 +17,7 @@ module EDPhysiologyMod use EDCohortDynamicsMod , only : allocate_live_biomass, zero_cohort use EDCohortDynamicsMod , only : create_cohort, fuse_cohorts, sort_cohorts use EDTypesMod , only : dg_sf, dinc_ed, external_recruitment - use EDTypesMod , only : ncwd, nlevcan_ed, numpft_ed, senes + use EDTypesMod , only : ncwd, cp_nlevcan, numpft_ed, senes use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type implicit none @@ -170,13 +170,13 @@ subroutine trim_canopy( currentSite ) 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, & + if (currentCohort%nv > cp_nlevcan)then + write(iulog,*) 'nv > cp_nlevcan',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 + do z = 1,cp_nlevcan 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. diff --git a/biogeophys/EDBtranMod.F90 b/biogeophys/EDBtranMod.F90 index 69662574..53d2816e 100644 --- a/biogeophys/EDBtranMod.F90 +++ b/biogeophys/EDBtranMod.F90 @@ -11,7 +11,7 @@ module EDBtranMod ed_patch_type, & ed_cohort_type, & numpft_ed, & - ctrl_parms + cp_numlevgrnd use shr_kind_mod , only : r8 => shr_kind_r8 use FatesInterfaceMod , only : bc_in_type, & bc_out_type @@ -61,20 +61,16 @@ subroutine get_active_suction_layers(sites,nsites,bc_in,bc_out) integer :: j ! soil layer !------------------------------------------------------------------------------ - associate( & - numlevgrnd => ctrl_parms%numlevgrnd ) - do s = 1,nsites if (bc_in(s)%filter_btran) then - do j = 1,numlevgrnd + do j = 1,cp_numlevgrnd bc_out(s)%active_suction_gl(j) = check_layer_water( bc_in(s)%h2o_liqvol_gl(j),bc_in(s)%tempk_gl(j) ) end do else bc_out(s)%active_suction_gl(:) = .false. end if end do - - end associate + end subroutine get_active_suction_layers ! ===================================================================================== @@ -115,7 +111,6 @@ subroutine btran_ed( sites, nsites, bc_in, bc_out) !------------------------------------------------------------------------------ associate( & - numlevgrnd => ctrl_parms%numlevgrnd , & smpsc => pftcon%smpsc , & ! INTERF-TODO: THESE SHOULD BE FATES PARAMETERS smpso => pftcon%smpso & ! INTERF-TODO: THESE SHOULD BE FATES PARAMETERS ) @@ -133,7 +128,7 @@ subroutine btran_ed( sites, nsites, bc_in, bc_out) do ft = 1,numpft_ed cpatch%btran_ft(ft) = 0.0_r8 - do j = 1,numlevgrnd + do j = 1,cp_numlevgrnd ! Calculations are only relevant where liquid water exists ! see clm_fates%wrap_btran for calculation with CLM/ALM @@ -160,7 +155,7 @@ subroutine btran_ed( sites, nsites, bc_in, bc_out) end do !j ! Normalize root resistances to get layer contribution to ET - do j = 1,numlevgrnd + do j = 1,cp_numlevgrnd if (cpatch%btran_ft(ft) > 0.0_r8) then cpatch%rootr_ft(ft,j) = cpatch%rootr_ft(ft,j)/cpatch%btran_ft(ft) else @@ -184,7 +179,7 @@ subroutine btran_ed( sites, nsites, bc_in, bc_out) ! pass the host a total transpiration for the patch. This needs rootr to be ! distributed over the soil layers. - do j = 1,numlevgrnd + do j = 1,cp_numlevgrnd bc_out(s)%rootr_pagl(ifp,j) = 0._r8 do ft = 1,numpft_ed if(sum(pftgs) > 0._r8)then !prevent problem with the first timestep - might fail @@ -212,7 +207,7 @@ subroutine btran_ed( sites, nsites, bc_in, bc_out) temprootr = sum(bc_out(s)%rootr_pagl(ifp,:)) if(abs(1.0_r8-temprootr) > 1.0e-10_r8 .and. temprootr > 1.0e-10_r8)then write(iulog,*) 'error with rootr in canopy fluxes',temprootr,sum(pftgs),sum(cpatch%rootr_ft(1:2,:),dim=2) - do j = 1,numlevgrnd + do j = 1,cp_numlevgrnd bc_out(s)%rootr_pagl(ifp,j) = bc_out(s)%rootr_pagl(ifp,j)/temprootr enddo end if diff --git a/biogeophys/EDPhotosynthesisMod.F90 b/biogeophys/EDPhotosynthesisMod.F90 index 80371ab5..2e828c48 100644 --- a/biogeophys/EDPhotosynthesisMod.F90 +++ b/biogeophys/EDPhotosynthesisMod.F90 @@ -40,7 +40,7 @@ subroutine Photosynthesis_ED (sites,nsites,bc_in,bc_out,dtime) use shr_log_mod , only : errMsg => shr_log_errMsg use abortutils , only : endrun use clm_varcon , only : rgas, tfrz, namep - use clm_varpar , only : nlevcan_ed, nclmax, nlevsoi, mxpft + use clm_varpar , only : nlevsoi, mxpft use clm_varctl , only : iulog use pftconMod , only : pftcon use EDParamsMod , only : ED_val_grperc @@ -49,7 +49,7 @@ subroutine Photosynthesis_ED (sites,nsites,bc_in,bc_out,dtime) use EDtypesMod , only : ed_patch_type, ed_cohort_type, ed_site_type, numpft_ed use EDEcophysContype , only : EDecophyscon use FatesInterfaceMod , only : bc_in_type,bc_out_type - use EDtypesMod , only : numpatchespercol + use EDtypesMod , only : numpatchespercol, cp_nlevcan, cp_nclmax ! ! !ARGUMENTS: @@ -73,15 +73,15 @@ subroutine Photosynthesis_ED (sites,nsites,bc_in,bc_out,dtime) ! ! 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) :: vcmax_z(cp_nclmax,mxpft,cp_nlevcan) ! maximum rate of carboxylation (umol co2/m**2/s) + real(r8) :: jmax_z(cp_nclmax,mxpft,cp_nlevcan) ! maximum electron transport rate (umol electrons/m**2/s) + real(r8) :: tpu_z(cp_nclmax,mxpft,cp_nlevcan) ! triose phosphate utilization rate (umol CO2/m**2/s) + real(r8) :: kp_z(cp_nclmax,mxpft,cp_nlevcan) ! initial slope of CO2 response curve (C4 plants) + real(r8) :: lmr_z(cp_nclmax,mxpft,cp_nlevcan) ! initial slope of CO2 response curve (C4 plants) + real(r8) :: rs_z(cp_nclmax,mxpft,cp_nlevcan) ! stomatal resistance s/m + real(r8) :: gs_z(cp_nclmax,mxpft,cp_nlevcan) ! stomatal conductance m/s + + real(r8) :: ci(cp_nclmax,mxpft,cp_nlevcan) ! intracellular leaf CO2 (Pa) real(r8) :: lnc(mxpft) ! leaf N concentration (gN leaf/m^2) real(r8) :: kc( numpatchespercol ) ! Michaelis-Menten constant for CO2 (Pa) @@ -172,9 +172,9 @@ subroutine Photosynthesis_ED (sites,nsites,bc_in,bc_out,dtime) 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) :: ag(cp_nclmax,mxpft,cp_nlevcan) ! co-limited gross leaf photosynthesis (umol CO2/m**2/s) + real(r8) :: an(cp_nclmax,mxpft,cp_nlevcan) ! net leaf photosynthesis (umol CO2/m**2/s) + real(r8) :: an_av(cp_nclmax,mxpft,cp_nlevcan) ! 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 @@ -303,7 +303,7 @@ subroutine Photosynthesis_ED (sites,nsites,bc_in,bc_out,dtime) enddo !cohort currentPatch%nrad = currentPatch%ncan - do CL = 1,nclmax + do CL = 1,cp_nclmax do ft = 1,numpft_ed currentPatch%present(CL,ft) = 0 do iv = 1, currentPatch%nrad(CL,ft); @@ -433,7 +433,7 @@ subroutine Photosynthesis_ED (sites,nsites,bc_in,bc_out,dtime) 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%nrad(CL,FT),currentPatch%ncl_p,cp_nclmax currentPatch%present(CL,FT) = 1 end if enddo diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index f73ce576..41865ae8 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -15,11 +15,11 @@ module EDSurfaceRadiationMod use EDtypesMod , only : numPatchesPerCol use shr_kind_mod , only : r8 => shr_kind_r8 use shr_log_mod , only : errMsg => shr_log_errMsg - use decompMod , only : bounds_type - use clm_varpar , only : numrad, nclmax - use ColumnType , only : col use FatesInterfaceMod , only : bc_in_type, & bc_out_type + use EDTypesMod , only : cp_numSWb, & ! Actual number of SW radiation bands + cp_maxSWb, & ! maximum number of SW bands (for scratch) + cp_nclmax ! control parameter, number of SW bands implicit none @@ -29,7 +29,7 @@ module EDSurfaceRadiationMod logical :: DEBUG = .false. ! for debugging this module - real(r8), public :: albice(numrad) = & ! albedo land ice by waveband (1=vis, 2=nir) + real(r8), public :: albice(cp_maxSWb) = & ! albedo land ice by waveband (1=vis, 2=nir) (/ 0.80_r8, 0.55_r8 /) ! INTERF-TODO: THIS NEEDS SOME CONSISTENCY AND SHOULD BE SET IN THE INTERFACE @@ -45,7 +45,7 @@ subroutine ED_Norman_Radiation (sites, nsites, bc_in, bc_out ) ! !USES: use clm_varctl , only : iulog use pftconMod , only : pftcon - use EDtypesMod , only : ed_patch_type, numpft_ed, nlevcan_ed + use EDtypesMod , only : ed_patch_type, numpft_ed, cp_nlevcan use EDTypesMod , only : ed_site_type @@ -68,27 +68,27 @@ subroutine ED_Norman_Radiation (sites, nsites, bc_in, bc_out ) 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) :: ftweight(cp_nclmax,numpft_ed,cp_nlevcan) 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(numPatchesPerCol,numrad) - real(r8) :: forc_dif(numPatchesPerCol,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) :: 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_dir_z(cp_nclmax,numpft_ed,cp_nlevcan) ! Exponential transmittance of direct beam radiation through a single layer + real(r8) :: tr_dif_z(cp_nclmax,numpft_ed,cp_nlevcan) ! Exponential transmittance of diffuse radiation through a single layer + real(r8) :: forc_dir(numPatchesPerCol,cp_maxSWb) + real(r8) :: forc_dif(numPatchesPerCol,cp_maxSWb) + real(r8) :: weighted_dir_tr(cp_nclmax) + real(r8) :: weighted_fsun(cp_nclmax) + real(r8) :: weighted_dif_ratio(cp_nclmax,cp_maxSWb) + real(r8) :: weighted_dif_down(cp_nclmax) + real(r8) :: weighted_dif_up(cp_nclmax) + real(r8) :: refl_dif(cp_nclmax,numpft_ed,cp_nlevcan,cp_maxSWb) ! Term for diffuse radiation reflected by laye + real(r8) :: tran_dif(cp_nclmax,numpft_ed,cp_nlevcan,cp_maxSWb) ! Term for diffuse radiation transmitted by layer + real(r8) :: dif_ratio(cp_nclmax,numpft_ed,cp_nlevcan,cp_maxSWb) ! Ratio of upward to forward diffuse fluxes + real(r8) :: Dif_dn(cp_nclmax,numpft_ed,cp_nlevcan) ! Forward diffuse flux onto canopy layer J (W/m**2 ground area) + real(r8) :: Dif_up(cp_nclmax,numpft_ed,cp_nlevcan) ! Upward diffuse flux above canopy layer J (W/m**2 ground area) + real(r8) :: lai_change(cp_nclmax,numpft_ed,cp_nlevcan) ! Forward diffuse flux onto canopy layer J (W/m**2 ground area) + real(r8) :: f_not_abs(numpft_ed,cp_maxSWb) ! Fraction reflected + transmitted. 1-absorbtion. + real(r8) :: Abs_dir_z(numpft_ed,cp_nlevcan) + real(r8) :: Abs_dif_z(numpft_ed,cp_nlevcan) + real(r8) :: abs_rad(cp_maxSWb) !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(numPatchesPerCol,numpft_ed) ! Radiation transmitted to the soil surface. @@ -175,7 +175,7 @@ subroutine ED_Norman_Radiation (sites, nsites, bc_in, bc_out ) ! no radiation is absorbed bc_out(s)%fabd_parb(ifp,:) = 0.0_r8 bc_out(s)%fabi_parb(ifp,:) = 0.0_r8 - do ib = 1,numrad + do ib = 1,cp_numSWb bc_out(s)%albd_parb(ifp,ib) = bc_in(s)%albgr_dir_rb(ib) bc_out(s)%albd_parb(ifp,ib) = bc_in(s)%albgr_dif_rb(ib) bc_out(s)%ftdd_parb(ifp,ib)= 1.0_r8 @@ -185,7 +185,7 @@ subroutine ED_Norman_Radiation (sites, nsites, bc_in, bc_out ) else ! Is this pft/canopy layer combination present in this patch? - do L = 1,nclmax + do L = 1,cp_nclmax do ft = 1,numpft_ed currentPatch%present(L,ft) = 0 do iv = 1, currentPatch%nrad(L,ft) @@ -198,7 +198,7 @@ subroutine ED_Norman_Radiation (sites, nsites, bc_in, bc_out ) end do !L do radtype = 1,2 !do this once for one unit of diffuse, and once for one unit of direct radiation - do ib = 1,numrad + do ib = 1,cp_numSWb 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. @@ -247,7 +247,7 @@ subroutine ED_Norman_Radiation (sites, nsites, bc_in, bc_out ) 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 + weighted_dif_ratio(L,1:cp_numSWb) = 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. @@ -387,7 +387,7 @@ subroutine ED_Norman_Radiation (sites, nsites, bc_in, bc_out ) ! Iterative solution do scattering !==============================================================================! - do ib = 1,numrad !vis, nir + do ib = 1,cp_numSWb !vis, nir !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! ! Leaf scattering coefficient and terms do diffuse radiation reflected ! and transmitted by a layer @@ -424,12 +424,12 @@ subroutine ED_Norman_Radiation (sites, nsites, bc_in, bc_out ) 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 + end do!cp_numSWb endif ! currentPatch%present end do!ft end do!L - do ib = 1,numrad + do ib = 1,cp_numSWb Dif_dn(:,:,:) = 0.00_r8 Dif_up(:,:,:) = 0.00_r8 do L = 1, currentPatch%NCL_p !work down from the top of the canopy. @@ -888,7 +888,7 @@ subroutine ED_Norman_Radiation (sites, nsites, bc_in, bc_out ) end if - end do !numrad + end do !cp_numSWb enddo ! rad-type endif ! is there vegetation? diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 007a57de..dc561573 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -8,11 +8,11 @@ module EDCLMLinkMod use shr_kind_mod , only : r8 => shr_kind_r8 use shr_infnan_mod, only : isnan => shr_infnan_isnan use decompMod , only : bounds_type - use clm_varpar , only : nclmax, nlevcan_ed, numpft, numcft, mxpft + use clm_varpar , only : numpft, numcft, mxpft use clm_varctl , only : iulog use ColumnType , only : col use EDtypesMod , only : ed_site_type, ed_cohort_type, ed_patch_type, ncwd - use EDtypesMod , only : sclass_ed, nlevsclass_ed, AREA + use EDtypesMod , only : sclass_ed, nlevsclass_ed, AREA, cp_nclmax, cp_nlevcan use CanopyStateType , only : canopystate_type use clm_varctl , only : use_vertsoilc use EDParamsMod , only : ED_val_ag_biomass @@ -1681,7 +1681,7 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, colindex, waterstate_ins max(currentPatch%ncan(currentCohort%canopy_layer,currentCohort%pft),currentCohort%NV) currentPatch%lai = currentPatch%lai +currentCohort%lai - do L = 1,nclmax-1 + do L = 1,cp_nclmax-1 if(currentCohort%canopy_layer == L)then currentPatch%canopy_layer_lai(L) = currentPatch%canopy_layer_lai(L) + currentCohort%lai + & currentCohort%sai @@ -1958,10 +1958,10 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, colindex, waterstate_ins /currentPatch%tlai_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 + currentPatch%tlai_profile(L,ft,currentPatch%nrad(L,ft)+1: cp_nlevcan) = 0._r8 + currentPatch%tsai_profile(L,ft,currentPatch%nrad(L,ft)+1: cp_nlevcan) = 0._r8 + currentPatch%elai_profile(L,ft,currentPatch%nrad(L,ft)+1: cp_nlevcan) = 0._r8 + currentPatch%esai_profile(L,ft,currentPatch%nrad(L,ft)+1: cp_nlevcan) = 0._r8 enddo enddo diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 60fce0d3..29a370c0 100755 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -8,7 +8,7 @@ module EDInitMod use spmdMod , only : masterproc use decompMod , only : bounds_type use abortutils , only : endrun - use clm_varpar , only : nclmax + use EDTypesMod , only : cp_nclmax use clm_varctl , only : iulog, use_ed_spit_fire use clm_time_manager , only : is_restart use CanopyStateType , only : canopystate_type @@ -176,7 +176,7 @@ subroutine init_patches( sites, nsites) integer :: s real(r8) :: cwd_ag_local(ncwd) real(r8) :: cwd_bg_local(ncwd) - real(r8) :: spread_local(nclmax) + real(r8) :: spread_local(cp_nclmax) real(r8) :: leaf_litter_local(numpft_ed) real(r8) :: root_litter_local(numpft_ed) real(r8) :: seed_bank_local(numpft_ed) diff --git a/main/EDRestVectorMod.F90 b/main/EDRestVectorMod.F90 index 99230b47..3f37c521 100755 --- a/main/EDRestVectorMod.F90 +++ b/main/EDRestVectorMod.F90 @@ -9,8 +9,8 @@ module EDRestVectorMod use spmdMod , only : masterproc use decompMod , only : bounds_type use pftconMod , only : pftcon - use EDTypesMod , only : area, cohorts_per_col, numpft_ed, numWaterMem, nclmax, numCohortsPerPatch - use EDTypesMod , only : ncwd, invalidValue, nlevcan_ed + use EDTypesMod , only : area, cohorts_per_col, numpft_ed, numWaterMem, cp_nclmax, numCohortsPerPatch + use EDTypesMod , only : ncwd, invalidValue, cp_nlevcan use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type use abortutils , only : endrun @@ -1495,7 +1495,7 @@ subroutine convertCohortListToVector( this, bounds, sites, nsites, fcolumn ) ! can allocate vectors, copy from LL -> vector and read/write restarts. ! ! !USES: - use clm_varpar, only : nclmax + use EDTypesMod, only : cp_nclmax ! ! !ARGUMENTS: class(EDRestartVectorClass) , intent(inout) :: this @@ -1668,18 +1668,18 @@ subroutine convertCohortListToVector( this, bounds, sites, nsites, fcolumn ) countNcwd = countNcwd + 1 end do - do i = 1,nclmax ! nclmax currently 2 + do i = 1,cp_nclmax ! cp_nclmax currently 2 this%spread(countNclmax) = currentPatch%spread(i) countNclmax = countNclmax + 1 end do if (this%DEBUG) write(iulog,*) 'CLTV countSunZ 1 ',countSunZ - if (this%DEBUG) write(iulog,*) 'CLTV 1186 ',nlevcan_ed,numpft_ed,nclmax + if (this%DEBUG) write(iulog,*) 'CLTV 1186 ',cp_nlevcan,numpft_ed,cp_nclmax - do k = 1,nlevcan_ed ! nlevcan_ed currently 40 + do k = 1,cp_nlevcan ! cp_nlevcan currently 40 do j = 1,numpft_ed ! numpft_ed currently 2 - do i = 1,nclmax ! nclmax currently 2 + do i = 1,cp_nclmax ! cp_nclmax currently 2 this%f_sun(countSunZ) = currentPatch%f_sun(i,j,k) this%fabd_sun_z(countSunZ) = currentPatch%fabd_sun_z(i,j,k) this%fabi_sun_z(countSunZ) = currentPatch%fabi_sun_z(i,j,k) @@ -1695,7 +1695,7 @@ subroutine convertCohortListToVector( this, bounds, sites, nsites, fcolumn ) incrementOffset = incrementOffset + numCohortsPerPatch ! reset counters so that they are all advanced evenly. Currently - ! the offset is 10, the max of numpft_ed, ncwd, nclmax, + ! the offset is 10, the max of numpft_ed, ncwd, cp_nclmax, ! countWaterMem and the number of allowed cohorts per patch countPft = incrementOffset countNcwd = incrementOffset @@ -1769,7 +1769,7 @@ subroutine createPatchCohortStructure( this, bounds, sites, nsites, fcolumn ) ! !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) :: cwd_ag_local(ncwd),cwd_bg_local(ncwd),spread_local(cp_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 @@ -1835,7 +1835,6 @@ subroutine createPatchCohortStructure( this, bounds, sites, nsites, fcolumn ) ! create patch allocate(newp) - call zero_patch(newp) ! make new patch call create_patch(sites(s), newp, age, area, & @@ -1939,7 +1938,6 @@ subroutine convertCohortVectorToList( this, bounds, sites, nsites, fcolumn ) ! can allocate vectors, copy from LL -> vector and read/write restarts. ! ! !USES: - use clm_varpar, only : nclmax ! ! !ARGUMENTS: class(EDRestartVectorClass) , intent(inout) :: this @@ -2096,16 +2094,16 @@ subroutine convertCohortVectorToList( this, bounds, sites, nsites, fcolumn ) countNcwd = countNcwd + 1 end do - do i = 1,nclmax ! nclmax currently 2 + do i = 1,cp_nclmax ! cp_nclmax currently 2 currentPatch%spread(i) = this%spread(countNclmax) countNclmax = countNclmax + 1 end do if (this%DEBUG) write(iulog,*) 'CVTL countSunZ 1 ',countSunZ - do k = 1,nlevcan_ed ! nlevcan_ed currently 40 + do k = 1,cp_nlevcan ! cp_nlevcan currently 40 do j = 1,numpft_ed ! numpft_ed currently 2 - do i = 1,nclmax ! nclmax currently 2 + do i = 1,cp_nclmax ! cp_nclmax currently 2 currentPatch%f_sun(i,j,k) = this%f_sun(countSunZ) currentPatch%fabd_sun_z(i,j,k) = this%fabd_sun_z(countSunZ) currentPatch%fabi_sun_z(i,j,k) = this%fabi_sun_z(countSunZ) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 5676185a..0a7219a7 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -2,7 +2,7 @@ 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, mxpft + use clm_varpar , only : nlevgrnd, mxpft use domainMod , only : domain_type use shr_sys_mod , only : shr_sys_flush @@ -107,26 +107,29 @@ module EDTypesMod integer , allocatable :: scls_levscpf_ed(:) + ! Control Parameters (cp_) + ! ------------------------------------------------------------------------------------- - type, public :: ctrl_parms_type - - - ! These parameters are dictated by FATES internals - - - - - ! These parameters are dictated by the host model or driver + ! These parameters are dictated by FATES internals + + integer, parameter :: cp_nclmax = 2 ! Maximum number of canopy layers - integer :: numSWBands ! Maximum number of broad-bands in the short-wave radiation + integer, parameter :: cp_nlevcan = 40 ! number of leaf layers in canopy layer + + integer, parameter :: cp_maxSWb = 2 ! maximum number of broad-bands in the + ! shortwave spectrum cp_numSWb <= cp_maxSWb + ! this is just for scratch-array purposes + ! if cp_numSWb is larger than this value + ! simply bump this number up as needed + ! These parameters are dictated by the host model or driver + + integer :: cp_numSWb ! Number of broad-bands in the short-wave radiation ! specturm to track ! (typically 2 as a default, VIS/NIR, in ED variants <2016) - integer :: numlevgrnd ! Number of soil layers - - end type ctrl_parms_type + integer :: cp_numlevgrnd ! Number of soil layers + - type(ctrl_parms_type), public :: ctrl_parms !************************************ @@ -188,8 +191,8 @@ module EDTypesMod real(r8) :: npp_bseed ! NPP into seeds: KgC/indiv/day real(r8) :: npp_store ! NPP into storage: KgC/indiv/day - 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 + real(r8) :: ts_net_uptake(cp_nlevcan) ! Net uptake of leaf layers: kgC/m2/s + real(r8) :: year_net_uptake(cp_nlevcan) ! Net uptake of leaf layers: kgC/m2/year ! RESPIRATION COMPONENTS real(r8) :: rd ! Dark respiration: umol/indiv/s @@ -266,54 +269,55 @@ module EDTypesMod 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) :: spread(cp_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) :: canopy_layer_lai(cp_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) :: layer_height_profile(nclmax,numpft_ed,nlevcan_ed) - real(r8) :: canopy_area_profile(nclmax,numpft_ed,nlevcan_ed) ! fraction of canopy in each canopy + real(r8) :: tlai_profile(cp_nclmax,numpft_ed,cp_nlevcan) ! total leaf area in each canopy layer, pft, and leaf layer. m2/m2 + real(r8) :: elai_profile(cp_nclmax,numpft_ed,cp_nlevcan) ! exposed leaf area in each canopy layer, pft, and leaf layer. m2/m2 + real(r8) :: tsai_profile(cp_nclmax,numpft_ed,cp_nlevcan) ! total stem area in each canopy layer, pft, and leaf layer. m2/m2 + real(r8) :: esai_profile(cp_nclmax,numpft_ed,cp_nlevcan) ! exposed stem area in each canopy layer, pft, and leaf layer. m2/m2 + real(r8) :: layer_height_profile(cp_nclmax,numpft_ed,cp_nlevcan) + real(r8) :: canopy_area_profile(cp_nclmax,numpft_ed,cp_nlevcan) ! 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 + integer :: present(cp_nclmax,numpft_ed) ! is there any of this pft in this canopy layer? + integer :: nrad(cp_nclmax,numpft_ed) ! number of exposed leaf layers for each canopy layer and pft + integer :: ncan(cp_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 + real(r8) :: fabd_sun_z(cp_nclmax,numpft_ed,cp_nlevcan) ! 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 + real(r8) :: fabd_sha_z(cp_nclmax,numpft_ed,cp_nlevcan) ! 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 + real(r8) :: fabi_sun_z(cp_nclmax,numpft_ed,cp_nlevcan) ! 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 + real(r8) :: fabi_sha_z(cp_nclmax,numpft_ed,cp_nlevcan) ! 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, + real(r8) :: ed_laisun_z(cp_nclmax,numpft_ed,cp_nlevcan) ! 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, + real(r8) :: ed_laisha_z(cp_nclmax,numpft_ed,cp_nlevcan) ! amount of LAI in the shade in each canopy layer, + real(r8) :: ed_parsun_z(cp_nclmax,numpft_ed,cp_nlevcan) ! PAR absorbed in the sun in each canopy layer, + real(r8) :: ed_parsha_z(cp_nclmax,numpft_ed,cp_nlevcan) ! PAR absorbed in the shade in each canopy layer, + real(r8) :: f_sun(cp_nclmax,numpft_ed,cp_nlevcan) ! 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 + real(r8),allocatable :: tr_soil_dir(:) ! fraction of incoming direct radiation that (cm_numSWb) ! is transmitted to the soil as direct - real(r8) :: tr_soil_dif(numrad) ! fraction of incoming diffuse radiation that + real(r8),allocatable :: tr_soil_dif(:) ! 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 + real(r8),allocatable :: tr_soil_dir_dif(:) ! 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 + real(r8),allocatable :: fab(:) ! fraction of incoming total radiation that is absorbed by the canopy + real(r8),allocatable :: fabd(:) ! fraction of incoming direct radiation that is absorbed by the canopy + real(r8),allocatable :: fabi(:) ! fraction of incoming diffuse radiation that is absorbed by the canopy + real(r8),allocatable :: sabs_dir(:) ! fraction of incoming direct radiation that is absorbed by the canopy + real(r8),allocatable :: sabs_dif(:) ! fraction of incoming diffuse radiation that is absorbed by the canopy !SEED BANK @@ -325,7 +329,7 @@ module EDTypesMod real(r8) :: seed_rain_flux(numpft_ed) ! flux of seeds from exterior KgC/m2/year (needed for C balance purposes) ! 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) :: psn_z(cp_nclmax,numpft_ed,cp_nlevcan) ! 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 diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index f5142adb..1c6a4233 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -17,10 +17,13 @@ module FatesInterfaceMod use EDtypesMod , only : ed_site_type, & numPatchesPerCol, & - ctrl_parms + cp_nclmax, & + cp_numSWb, & + cp_numlevgrnd, & + cp_maxSWb use shr_kind_mod , only : r8 => shr_kind_r8 ! INTERF-TODO: REMOVE THIS - use clm_varpar , only : nlevgrnd + ! ------------------------------------------------------------------------------------ @@ -273,15 +276,15 @@ subroutine allocate_bcin(bc_in) ! Allocate input boundaries ! Radiation - allocate(bc_in%solad_parb(numPatchesPerCol,ctrl_parms%numSWBands)) - allocate(bc_in%solai_parb(numPatchesPerCol,ctrl_parms%numSWBands)) + allocate(bc_in%solad_parb(numPatchesPerCol,cp_numSWb)) + allocate(bc_in%solai_parb(numPatchesPerCol,cp_numSWb)) ! Hydrology - allocate(bc_in%smp_gl(ctrl_parms%numlevgrnd)) - allocate(bc_in%eff_porosity_gl(ctrl_parms%numlevgrnd)) - allocate(bc_in%watsat_gl(ctrl_parms%numlevgrnd)) - allocate(bc_in%tempk_gl(ctrl_parms%numlevgrnd)) - allocate(bc_in%h2o_liqvol_gl(ctrl_parms%numlevgrnd)) + allocate(bc_in%smp_gl(cp_numlevgrnd)) + allocate(bc_in%eff_porosity_gl(cp_numlevgrnd)) + allocate(bc_in%watsat_gl(cp_numlevgrnd)) + allocate(bc_in%tempk_gl(cp_numlevgrnd)) + allocate(bc_in%h2o_liqvol_gl(cp_numlevgrnd)) ! Photosynthesis allocate(bc_in%filter_photo_pa(numPatchesPerCol)) @@ -293,13 +296,13 @@ subroutine allocate_bcin(bc_in) allocate(bc_in%rb_pa(numPatchesPerCol)) allocate(bc_in%t_veg_pa(numPatchesPerCol)) allocate(bc_in%tgcm_pa(numPatchesPerCol)) - allocate(bc_in%t_soisno_gl(ctrl_parms%numlevgrnd)) + allocate(bc_in%t_soisno_gl(cp_numlevgrnd)) ! Canopy Radiation allocate(bc_in%filter_vegzen_pa(numPatchesPerCol)) allocate(bc_in%coszen_pa(numPatchesPerCol)) - allocate(bc_in%albgr_dir_rb(ctrl_parms%numSWBands)) - allocate(bc_in%albgr_dif_rb(ctrl_parms%numSWBands)) + allocate(bc_in%albgr_dir_rb(cp_numSWb)) + allocate(bc_in%albgr_dif_rb(cp_numSWb)) return end subroutine allocate_bcin @@ -320,8 +323,8 @@ subroutine allocate_bcout(bc_out) allocate(bc_out%laisha_pa(numPatchesPerCol)) ! Hydrology - allocate(bc_out%active_suction_gl(ctrl_parms%numlevgrnd)) - allocate(bc_out%rootr_pagl(numPatchesPerCol,ctrl_parms%numlevgrnd)) + allocate(bc_out%active_suction_gl(cp_numlevgrnd)) + allocate(bc_out%rootr_pagl(numPatchesPerCol,cp_numlevgrnd)) allocate(bc_out%btran_pa(numPatchesPerCol)) ! Photosynthesis @@ -332,13 +335,13 @@ subroutine allocate_bcout(bc_out) allocate(bc_out%psncanopy_pa(numPatchesPerCol)) ! Canopy Radiation - allocate(bc_out%albd_parb(numPatchesPerCol,ctrl_parms%numSWBands)) - allocate(bc_out%albi_parb(numPatchesPerCol,ctrl_parms%numSWBands)) - allocate(bc_out%fabd_parb(numPatchesPerCol,ctrl_parms%numSWBands)) - allocate(bc_out%fabi_parb(numPatchesPerCol,ctrl_parms%numSWBands)) - allocate(bc_out%ftdd_parb(numPatchesPerCol,ctrl_parms%numSWBands)) - allocate(bc_out%ftid_parb(numPatchesPerCol,ctrl_parms%numSWBands)) - allocate(bc_out%ftii_parb(numPatchesPerCol,ctrl_parms%numSWBands)) + allocate(bc_out%albd_parb(numPatchesPerCol,cp_numSWb)) + allocate(bc_out%albi_parb(numPatchesPerCol,cp_numSWb)) + allocate(bc_out%fabd_parb(numPatchesPerCol,cp_numSWb)) + allocate(bc_out%fabi_parb(numPatchesPerCol,cp_numSWb)) + allocate(bc_out%ftdd_parb(numPatchesPerCol,cp_numSWb)) + allocate(bc_out%ftid_parb(numPatchesPerCol,cp_numSWb)) + allocate(bc_out%ftii_parb(numPatchesPerCol,cp_numSWb)) return end subroutine allocate_bcout @@ -431,23 +434,33 @@ subroutine set_fates_ctrlparms(tag,dimval) case('flush_to_unset') write(*,*) 'Flushing FATES control parameters prior to transfer from host' - ctrl_parms%numSwBands = unset_int - ctrl_parms%numlevgrnd = unset_int + cp_numSwb = unset_int + cp_numlevgrnd = unset_int case('check_allset') - if(ctrl_parms%numSWBands .eq. unset_int) then + if(cp_numSWb .eq. unset_int) then write(*,*) 'FATES dimension/parameter unset: num_sw_rad_bbands' ! INTERF-TODO: FATES NEEDS INTERNAL end_run ! end_run('MESSAGE') end if - - if(ctrl_parms%numlevgrnd .eq. unset_int) then + + if(cp_numSWb > cp_maxSWb) then + write(*,*) 'FATES sets a maximum number of shortwave bands' + write(*,*) 'for some scratch-space, cp_maxSWb' + write(*,*) 'it defaults to 2, but can be increased as needed' + write(*,*) 'your driver or host model is intending to drive' + write(*,*) 'FATES with:',cp_numSWb,' bands.' + write(*,*) 'please increase cp_maxSWb in EDTypes to match' + write(*,*) 'or exceed this value' + ! end_run('MESSAGE') + end if + + if(cp_numlevgrnd .eq. unset_int) then write(*,*) 'FATES dimension/parameter unset: numlevground' ! INTERF-TODO: FATES NEEDS INTERNAL end_run ! end_run('MESSAGE') end if - write(*,*) 'Checked. All control parameters sent to FATES.' case default @@ -457,12 +470,12 @@ subroutine set_fates_ctrlparms(tag,dimval) case('num_sw_bbands') - ctrl_parms%numSwBands = dimval + cp_numSwb = dimval write(*,*) 'Transfering num_sw_bbands = ',dimval,' to FATES' case('num_lev_ground') - ctrl_parms%numlevgrnd = dimval + cp_numlevgrnd = dimval write(*,*) 'Transfering num_lev_ground = ',dimval,' to FATES' case default From 6142551deeaea836e323bdb6655ea9b9ff2b8ae8 Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Mon, 8 Aug 2016 09:49:34 -0700 Subject: [PATCH 145/437] moved host-side receivers of the litter fluxes onto the soilbiogeochem_carbonflux type from the ed_clm_link type --- biogeochem/EDPhysiologyMod.F90 | 2 +- main/EDCLMLinkMod.F90 | 130 ++++----------------------------- 2 files changed, 16 insertions(+), 116 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index a05d956e..2e1e7db3 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1308,7 +1308,7 @@ subroutine flux_into_litter_pools(sites, nsites, bc_in, bc_out) type (ed_patch_type) , pointer :: currentPatch type (ed_cohort_type) , pointer :: currentCohort type(ed_site_type), pointer :: cs - integer c,p,ci,j,s + integer p,ci,j,s real(r8) time_convert ! from year to seconds real(r8) mass_convert ! ED uses kg, CLM uses g integer :: begp,endp diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index be1c3a3b..e650d1e4 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -587,36 +587,21 @@ subroutine InitHistory(this, bounds) avgflag='A', long_name='total seed carbon at the column level', & ptr_col=this%seed_stock_col) - !!! carbon fluxes into soil grid (dimensioned depth x column) - this%ED_c_to_litr_lab_c_col(begc:endc,1:nlevdecomp_full) = spval - call hist_addfld_decomp (fname='ED_c_to_litr_lab_c', units='gC/m^2/s', type2d='levdcmp', & - avgflag='A', long_name='ED_c_to_litr_lab_c', & - ptr_col=this%ED_c_to_litr_lab_c_col) - - this%ED_c_to_litr_cel_c_col(begc:endc,1:nlevdecomp_full) = spval - call hist_addfld_decomp (fname='ED_c_to_litr_cel_c', units='gC/m^2/s', type2d='levdcmp', & - avgflag='A', long_name='ED_c_to_litr_cel_c', & - ptr_col=this%ED_c_to_litr_cel_c_col) - - this%ED_c_to_litr_lig_c_col(begc:endc,1:nlevdecomp_full) = spval - call hist_addfld_decomp (fname='ED_c_to_litr_lig_c', units='gC/m^2/s', type2d='levdcmp', & - avgflag='A', long_name='ED_c_to_litr_lig_c', & - ptr_col=this%ED_c_to_litr_lig_c_col) - - this%leaf_prof_col(begc:endc,1:nlevdecomp_full) = spval - call hist_addfld_decomp (fname='leaf_prof', units='1/m', type2d='levdcmp', & - avgflag='A', long_name='leaf_prof', & - ptr_col=this%leaf_prof_col,default='inactive') - - this%croot_prof_col(begc:endc,1:nlevdecomp_full) = spval - call hist_addfld_decomp (fname='croot_prof', units='1/m', type2d='levdcmp', & - avgflag='A', long_name='croot_prof', & - ptr_col=this%croot_prof_col,default='inactive') - - this%stem_prof_col(begc:endc,1:nlevdecomp_full) = spval - call hist_addfld_decomp (fname='stem_prof', units='1/m', type2d='levdcmp', & - avgflag='A', long_name='stem_prof', & - ptr_col=this%stem_prof_col,default='inactive') + + ! this%leaf_prof_col(begc:endc,1:nlevdecomp_full) = spval + ! call hist_addfld_decomp (fname='leaf_prof', units='1/m', type2d='levdcmp', & + ! avgflag='A', long_name='leaf_prof', & + ! ptr_col=this%leaf_prof_col,default='inactive') + + ! this%croot_prof_col(begc:endc,1:nlevdecomp_full) = spval + ! call hist_addfld_decomp (fname='croot_prof', units='1/m', type2d='levdcmp', & + ! avgflag='A', long_name='croot_prof', & + ! ptr_col=this%croot_prof_col,default='inactive') + + ! this%stem_prof_col(begc:endc,1:nlevdecomp_full) = spval + ! call hist_addfld_decomp (fname='stem_prof', units='1/m', type2d='levdcmp', & + ! avgflag='A', long_name='stem_prof', & + ! ptr_col=this%stem_prof_col,default='inactive') ! Carbon Flux (grid dimension x scpf) @@ -824,91 +809,6 @@ subroutine Restart ( this, bounds, ncid, flag ) dim1name='column', long_name='', units='', & interpinic_flag='interp', readvar=readvar, data=ptr1d) - if (use_vertsoilc) then - ptr2d => this%ED_c_to_litr_lab_c_col - call restartvar(ncid=ncid, flag=flag, varname='ED_c_to_litr_lab_c_col', xtype=ncd_double, & - dim1name='column', dim2name='levgrnd', switchdim=.true., & - long_name='', units='', & - interpinic_flag='interp', readvar=readvar, data=ptr2d) - - ptr2d => this%ED_c_to_litr_cel_c_col - call restartvar(ncid=ncid, flag=flag, varname='ED_c_to_litr_cel_c_col', xtype=ncd_double, & - dim1name='column', dim2name='levgrnd', switchdim=.true., & - long_name='', units='', & - interpinic_flag='interp', readvar=readvar, data=ptr2d) - - ptr2d => this%ED_c_to_litr_lig_c_col - call restartvar(ncid=ncid, flag=flag, varname='ED_c_to_litr_lig_c_col', xtype=ncd_double, & - dim1name='column', dim2name='levgrnd', switchdim=.true., & - long_name='', units='', & - interpinic_flag='interp', readvar=readvar, data=ptr2d) - - ! ptr2d => this%leaf_prof_col - ! call restartvar(ncid=ncid, flag=flag, varname='leaf_prof_col', xtype=ncd_double, & - ! dim1name='column', dim2name='levgrnd', switchdim=.true., & - ! long_name='', units='', & - ! interpinic_flag='interp', readvar=readvar, data=ptr2d) - - ! ptr2d => this%croot_prof_col - ! call restartvar(ncid=ncid, flag=flag, varname='croot_prof_col', xtype=ncd_double, & - ! dim1name='column', dim2name='levgrnd', switchdim=.true., & - ! long_name='', units='', & - ! interpinic_flag='interp', readvar=readvar, data=ptr2d) - - ! ptr2d => this%stem_prof_col - ! call restartvar(ncid=ncid, flag=flag, varname='stem_prof_col', xtype=ncd_double, & - ! dim1name='column', dim2name='levgrnd', switchdim=.true., & - ! long_name='', units='', & - ! interpinic_flag='interp', readvar=readvar, data=ptr2d) - - ! do k = 1, numpft_ed - ! write(istr1,"(I3.3)") k - ! ptr2d => this%froot_prof_col(:,k,:) - ! call restartvar(ncid=ncid, flag=flag, varname='froot_prof_col_PFT'//istr1, xtype=ncd_double, & - ! dim1name='column', dim2name='levgrnd', switchdim=.true., & - ! long_name='', units='', & - ! interpinic_flag='interp', readvar=readvar, data=ptr2d) - ! end do - else - ptr1d => this%ED_c_to_litr_lab_c_col(:,1) - call restartvar(ncid=ncid, flag=flag, varname='ED_c_to_litr_lab_c_col', xtype=ncd_double, & - dim1name='column', long_name='', units='', & - interpinic_flag='interp', readvar=readvar, data=ptr1d) - - ptr1d => this%ED_c_to_litr_cel_c_col(:,1) - call restartvar(ncid=ncid, flag=flag, varname='ED_c_to_litr_cel_c_col', xtype=ncd_double, & - dim1name='column', long_name='', units='', & - interpinic_flag='interp', readvar=readvar, data=ptr1d) - - ptr1d => this%ED_c_to_litr_lig_c_col(:,1) - call restartvar(ncid=ncid, flag=flag, varname='ED_c_to_litr_lig_c_col', xtype=ncd_double, & - dim1name='column', long_name='', units='', & - interpinic_flag='interp', readvar=readvar, data=ptr1d) - - ! ptr1d => this%leaf_prof_col(:,1) - ! call restartvar(ncid=ncid, flag=flag, varname='leaf_prof_col', xtype=ncd_double, & - ! dim1name='column', long_name='', units='', & - ! interpinic_flag='interp', readvar=readvar, data=ptr1d) - - ! ptr1d => this%croot_prof_col(:,1) - ! call restartvar(ncid=ncid, flag=flag, varname='croot_prof_col', xtype=ncd_double, & - ! dim1name='column', long_name='', units='', & - ! interpinic_flag='interp', readvar=readvar, data=ptr1d) - - ! ptr1d => this%stem_prof_col(:,1) - ! call restartvar(ncid=ncid, flag=flag, varname='stem_prof_col', xtype=ncd_double, & - ! dim1name='column', long_name='', units='', & - ! interpinic_flag='interp', readvar=readvar, data=ptr1d) - - ! do k = 1, numpft_ed - ! write(istr1,"(I3.3)") k - ! ptr1d => this%froot_prof_col(:,k,1) - ! call restartvar(ncid=ncid, flag=flag, varname='froot_prof_col_PFT'//istr1, xtype=ncd_double, & - ! dim1name='column', long_name='', units='', & - ! interpinic_flag='interp', readvar=readvar, data=ptr1d) - ! end do - end if - end subroutine Restart From e83bc9ad6b03960f8142e3daa205844e9f76f57e Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 8 Aug 2016 13:22:15 -0700 Subject: [PATCH 146/437] added explanation text of calculating rssun and rssha --- biogeophys/EDPhotosynthesisMod.F90 | 33 ++++++++++++++++++++++++++++++ 1 file changed, 33 insertions(+) diff --git a/biogeophys/EDPhotosynthesisMod.F90 b/biogeophys/EDPhotosynthesisMod.F90 index 80371ab5..5243ebf3 100644 --- a/biogeophys/EDPhotosynthesisMod.F90 +++ b/biogeophys/EDPhotosynthesisMod.F90 @@ -964,6 +964,39 @@ subroutine Photosynthesis_ED (sites,nsites,bc_in,bc_out,dtime) enddo elai = max(0.1_r8,elai) + !---------------------------------------------------------------------------- + ! modification to output boundary (RGK 8-6-2016) + ! The HLMs ALM/CLM use canopy resistance (rscanopy) to calculate + ! rppdry, an intermediary towards transpiration and latent heat flux. + ! CLM/ALM, when FATES is not turned on, expect a slightly different format to + ! rscanopy, which includes having sunlit and shaded components, and how it is + ! normalized by those leaf areas (variables: rssun, rssha). To simplify and + ! streamline the interface, and remove the necessity in CanopyFluxesMod to + ! process the resistance in in different ways for FATES and non-FATES, we can + ! simply convert to their format by passing rssun and rssha. + ! + ! The key is equate our two methods of solving for rppdry, and calculate rssun + ! and rssha in terms of rscanopy: + ! + ! FATES existing way: + ! + ! rppdry_old = fdry*rb/(rb+rscanopy) + ! + ! CLM/ALM way: + ! + ! rppdry_new = fdry * rb*(laisun/(rb+rssun) + laisha/(rb+rssha ))/elai + ! + ! By equating the two, and assuming that rssun = rssha, we can solve for rssun + ! and rssha in terms of rscanopy, so that we can use the CLM system and get + ! the same rppdry: + ! + ! rppdry_new = fdry * rb*( (laisun+laisha)/(rb+rssun) )/elai + ! + ! simple mathematical manipulations: + ! + ! rssun = rssha = (laisun+laisha)*(rb+rscanopy)/elai - rb + ! --------------------------------------------------------------------------- + bc_out(s)%psncanopy_pa(ifp) = bc_out(s)%psncanopy_pa(ifp) / currentPatch%area bc_out(s)%lmrcanopy_pa(ifp) = bc_out(s)%lmrcanopy_pa(ifp) / currentPatch%area if(bc_out(s)%gccanopy_pa(ifp) > 1._r8/rsmax0 .and. elai > 0.0_r8)then From c362cc7d5eefd9999d600d50330686c24ed47cd1 Mon Sep 17 00:00:00 2001 From: ckoven Date: Mon, 8 Aug 2016 14:35:40 -0700 Subject: [PATCH 147/437] compile-time and runtime bugfixes --- biogeochem/EDPhysiologyMod.F90 | 93 ++++++++++++++++------------------ main/EDCLMLinkMod.F90 | 1 - main/FatesInterfaceMod.F90 | 5 +- 3 files changed, 45 insertions(+), 54 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 2e1e7db3..04915acc 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -36,6 +36,7 @@ module EDPhysiologyMod public :: seeds_in public :: seed_decay public :: seed_germination + public :: flux_into_litter_pools logical, parameter :: DEBUG = .false. ! local debug flag @@ -1288,11 +1289,14 @@ subroutine flux_into_litter_pools(sites, nsites, bc_in, bc_out) use clm_varpar, only : mxpft,nlevdecomp, nlevdecomp_full use EDTypesMod, only : AREA, numpft_ed use SoilBiogeochemVerticalProfileMod, only: exponential_rooting_profile, pftspecific_rootingprofile, rootprof_exp, surfprof_exp + use EDCLMLinkMod, only: cwd_fcel_ed, cwd_flig_ed use pftconMod, only : pftcon - + use shr_const_mod, only: SHR_CONST_CDAY use clm_varcon, only : zisoi, dzsoi_decomp, zsoi use EDParamsMod, only : ED_val_ag_biomass use FatesInterfaceMod, only : bc_in_type, bc_out_type + use clm_varctl, only : use_vertsoilc + use abortutils , only : endrun ! INTERF-TODO: remove the control parameters: exponential_rooting_profile, pftspecific_rootingprofile, rootprof_exp, surfprof_exp, zisoi, dzsoi_decomp, zsoi ! @@ -1301,8 +1305,8 @@ subroutine flux_into_litter_pools(sites, nsites, bc_in, bc_out) ! !ARGUMENTS type(ed_site_type) , intent(inout), target :: sites(nsites) integer , intent(in) :: nsites - type(bc_in_type) , intent(in) :: bc_in - type(bc_out_type) , intent(out) :: bc_out + type(bc_in_type) , intent(in) :: bc_in(:) + type(bc_out_type) , intent(inout) :: bc_out(:) ! ! !LOCAL VARIABLES: type (ed_patch_type) , pointer :: currentPatch @@ -1334,16 +1338,6 @@ subroutine flux_into_litter_pools(sites, nsites, bc_in, bc_out) ! number of grams in a kilogram mass_convert = 1000._r8 - associate( & - FATES_c_to_litr_lab_c => bc_out%FATES_c_to_litr_lab_c_col , & ! Output: total labile litter coming from ED. gC/m3/s - FATES_c_to_litr_cel_c => bc_out%FATES_c_to_litr_cel_c_col , & ! Output: total cellulose litter coming from ED. gC/m3/s - FATES_c_to_litr_lig_c => bc_out%FATES_c_to_litr_lig_c_col , & ! Output: total lignin litter coming from ED. gC/m3/s - ! leaf_prof => this%leaf_prof_col , & ! Output: (1/m) profile of leaves - ! froot_prof => this%froot_prof_col , & ! Output: (1/m) profile of fine roots - ! croot_prof => this%croot_prof_col , & ! Output: (1/m) profile of coarse roots - ! stem_prof => this%stem_prof_col , & ! Output: (1/m) profile of leaves - max_rooting_depth_index => bc_in%max_rooting_depth_index_col & ! Input: index of lowest soil level where roots may be, due to permafrost or bedrock constraints - ) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! first calculate vertical profiles @@ -1395,10 +1389,10 @@ subroutine flux_into_litter_pools(sites, nsites, bc_in, bc_out) do j = 1, nlevdecomp ! use standard CLM root fraction profiles; cinput_rootfr(s,ft,j) = ( .5_r8*( & - exp(-pftcon%roota_par(ft) * col%zi(s,lev-1)) & - + exp(-pftcon%rootb_par(ft) * col%zi(s,lev-1)) & - - exp(-pftcon%roota_par(ft) * col%zi(s,lev)) & - - exp(-pftcon%rootb_par(ft) * col%zi(s,lev)))) / dzsoi_decomp(j) + exp(-pftcon%roota_par(ft) * zisoi(lev-1)) & + + exp(-pftcon%rootb_par(ft) * zisoi(lev-1)) & + - exp(-pftcon%roota_par(ft) * zisoi(lev)) & + - exp(-pftcon%rootb_par(ft) * zisoi(lev)))) / dzsoi_decomp(j) end do end do endif @@ -1411,21 +1405,21 @@ subroutine flux_into_litter_pools(sites, nsites, bc_in, bc_out) end do surface_prof_tot = 0._r8 ! - do j = 1, min(max(max_rooting_depth_index(s), 1), nlevdecomp) + do j = 1, min(max(bc_in(s)%max_rooting_depth_index_col, 1), nlevdecomp) surface_prof_tot = surface_prof_tot + surface_prof(j) * dzsoi_decomp(j) end do do ft = 1,numpft_ed - do j = 1, min(max(max_rooting_depth_index(s), 1), nlevdecomp) + do j = 1, min(max(bc_in(s)%max_rooting_depth_index_col, 1), nlevdecomp) rootfr_tot(ft) = rootfr_tot(ft) + cinput_rootfr(s,ft,j) * dzsoi_decomp(j) end do end do ! ! rescale the fine root profile do ft = 1,numpft_ed - if ( (max_rooting_depth_index(s) > 0) .and. (rootfr_tot(ft) > 0._r8) ) then + if ( (bc_in(s)%max_rooting_depth_index_col > 0) .and. (rootfr_tot(ft) > 0._r8) ) then ! where there is not permafrost extending to the surface, integrate the profiles over the active layer ! this is equivalent to integrating over all soil layers outside of permafrost regions - do j = 1, min(max(max_rooting_depth_index(s), 1), nlevdecomp) + do j = 1, min(max(bc_in(s)%max_rooting_depth_index_col, 1), nlevdecomp) froot_prof(s,ft,j) = cinput_rootfr(s,ft,j) / rootfr_tot(ft) end do else @@ -1435,10 +1429,10 @@ subroutine flux_into_litter_pools(sites, nsites, bc_in, bc_out) end do ! ! rescale the shallow profiles - if ( (max_rooting_depth_index(s) > 0) .and. (surface_prof_tot > 0._r8) ) then + if ( (bc_in(s)%max_rooting_depth_index_col > 0) .and. (surface_prof_tot > 0._r8) ) then ! where there is not permafrost extending to the surface, integrate the profiles over the active layer ! this is equivalent to integrating over all soil layers outside of permafrost regions - do j = 1, min(max(max_rooting_depth_index(s), 1), nlevdecomp) + do j = 1, min(max(bc_in(s)%max_rooting_depth_index_col, 1), nlevdecomp) ! set all surface processes to shallower profile leaf_prof(s,j) = surface_prof(j)/ surface_prof_tot stem_prof(s,j) = surface_prof(j)/ surface_prof_tot @@ -1478,9 +1472,9 @@ subroutine flux_into_litter_pools(sites, nsites, bc_in, bc_out) write(iulog, *) 'surface_prof_tot: ', surface_prof_tot write(iulog, *) 'leaf_prof: ', leaf_prof(s,:) write(iulog, *) 'stem_prof: ', stem_prof(s,:) - write(iulog, *) 'max_rooting_depth_index: ', max_rooting_depth_index(s) + write(iulog, *) 'max_rooting_depth_index_col: ', bc_in(s)%max_rooting_depth_index_col write(iulog, *) 'dzsoi_decomp: ', dzsoi_decomp - call endrun(msg=' ERROR: sum-1 > delta'//errMsg(__FILE__, __LINE__)) + call endrun() endif ! now check each fine root profile do ft = 1,numpft_ed @@ -1490,7 +1484,7 @@ subroutine flux_into_litter_pools(sites, nsites, bc_in, bc_out) end do if ( ( abs(froot_prof_sum - 1._r8) > delta ) ) then write(iulog, *) 'profile sums: ', froot_prof_sum - call endrun(msg=' ERROR: sum-1 > delta'//errMsg(__FILE__, __LINE__)) + call endrun() endif end do end do @@ -1498,10 +1492,10 @@ subroutine flux_into_litter_pools(sites, nsites, bc_in, bc_out) ! zero the column-level C input variables do s = 1, nsites do j = 1, nlevdecomp - FATES_c_to_litr_lab_c(s,j) = 0._r8 - FATES_c_to_litr_cel_c(s,j) = 0._r8 - FATES_c_to_litr_lig_c(s,j) = 0._r8 - croot_prof(s,j) = 0._r8 + bc_out(s)%FATES_c_to_litr_lab_c_col(j) = 0._r8 + bc_out(s)%FATES_c_to_litr_cel_c_col(j) = 0._r8 + bc_out(s)%FATES_c_to_litr_lig_c_col(j) = 0._r8 + !croot_prof(s,j) = 0._r8 end do end do @@ -1570,29 +1564,29 @@ subroutine flux_into_litter_pools(sites, nsites, bc_in, bc_out) ! CWD pools fragmenting into decomposing litter pools. do ci = 1, ncwd do j = 1, nlevdecomp - FATES_c_to_litr_cel_c(s,j) = FATES_c_to_litr_cel_c(s,j) + currentpatch%CWD_AG_out(ci) * cwd_fcel_ed * currentpatch%area/AREA * stem_prof(s,j) - FATES_c_to_litr_lig_c(s,j) = FATES_c_to_litr_lig_c(s,j) + currentpatch%CWD_AG_out(ci) * cwd_flig_ed * currentpatch%area/AREA * stem_prof(s,j) + bc_out(s)%FATES_c_to_litr_cel_c_col(j) = bc_out(s)%FATES_c_to_litr_cel_c_col(j) + currentpatch%CWD_AG_out(ci) * cwd_fcel_ed * currentpatch%area/AREA * stem_prof(s,j) + bc_out(s)%FATES_c_to_litr_lig_c_col(j) = bc_out(s)%FATES_c_to_litr_lig_c_col(j) + currentpatch%CWD_AG_out(ci) * cwd_flig_ed * currentpatch%area/AREA * stem_prof(s,j) ! - FATES_c_to_litr_cel_c(s,j) = FATES_c_to_litr_cel_c(s,j) + currentpatch%CWD_BG_out(ci) * cwd_fcel_ed * currentpatch%area/AREA * croot_prof_perpatch(j) - FATES_c_to_litr_lig_c(s,j) = FATES_c_to_litr_lig_c(s,j) + currentpatch%CWD_BG_out(ci) * cwd_flig_ed * currentpatch%area/AREA * croot_prof_perpatch(j) + bc_out(s)%FATES_c_to_litr_cel_c_col(j) = bc_out(s)%FATES_c_to_litr_cel_c_col(j) + currentpatch%CWD_BG_out(ci) * cwd_fcel_ed * currentpatch%area/AREA * croot_prof_perpatch(j) + bc_out(s)%FATES_c_to_litr_lig_c_col(j) = bc_out(s)%FATES_c_to_litr_lig_c_col(j) + currentpatch%CWD_BG_out(ci) * cwd_flig_ed * currentpatch%area/AREA * croot_prof_perpatch(j) end do end do ! leaf and fine root pools. do ft = 1,numpft_ed do j = 1, nlevdecomp - FATES_c_to_litr_lab_c(s,j) = FATES_c_to_litr_lab_c(s,j) + currentpatch%leaf_litter_out(ft) * pftcon%lf_flab(ft) * currentpatch%area/AREA * leaf_prof(s,j) - FATES_c_to_litr_cel_c(s,j) = FATES_c_to_litr_cel_c(s,j) + currentpatch%leaf_litter_out(ft) * pftcon%lf_fcel(ft) * currentpatch%area/AREA * leaf_prof(s,j) - FATES_c_to_litr_lig_c(s,j) = FATES_c_to_litr_lig_c(s,j) + currentpatch%leaf_litter_out(ft) * pftcon%lf_flig(ft) * currentpatch%area/AREA * leaf_prof(s,j) + bc_out(s)%FATES_c_to_litr_lab_c_col(j) = bc_out(s)%FATES_c_to_litr_lab_c_col(j) + currentpatch%leaf_litter_out(ft) * pftcon%lf_flab(ft) * currentpatch%area/AREA * leaf_prof(s,j) + bc_out(s)%FATES_c_to_litr_cel_c_col(j) = bc_out(s)%FATES_c_to_litr_cel_c_col(j) + currentpatch%leaf_litter_out(ft) * pftcon%lf_fcel(ft) * currentpatch%area/AREA * leaf_prof(s,j) + bc_out(s)%FATES_c_to_litr_lig_c_col(j) = bc_out(s)%FATES_c_to_litr_lig_c_col(j) + currentpatch%leaf_litter_out(ft) * pftcon%lf_flig(ft) * currentpatch%area/AREA * leaf_prof(s,j) ! - FATES_c_to_litr_lab_c(s,j) = FATES_c_to_litr_lab_c(s,j) + currentpatch%root_litter_out(ft) * pftcon%fr_flab(ft) * currentpatch%area/AREA * froot_prof(s,ft,j) - FATES_c_to_litr_cel_c(s,j) = FATES_c_to_litr_cel_c(s,j) + currentpatch%root_litter_out(ft) * pftcon%fr_fcel(ft) * currentpatch%area/AREA * froot_prof(s,ft,j) - FATES_c_to_litr_lig_c(s,j) = FATES_c_to_litr_lig_c(s,j) + currentpatch%root_litter_out(ft) * pftcon%fr_flig(ft) * currentpatch%area/AREA * froot_prof(s,ft,j) + bc_out(s)%FATES_c_to_litr_lab_c_col(j) = bc_out(s)%FATES_c_to_litr_lab_c_col(j) + currentpatch%root_litter_out(ft) * pftcon%fr_flab(ft) * currentpatch%area/AREA * froot_prof(s,ft,j) + bc_out(s)%FATES_c_to_litr_cel_c_col(j) = bc_out(s)%FATES_c_to_litr_cel_c_col(j) + currentpatch%root_litter_out(ft) * pftcon%fr_fcel(ft) * currentpatch%area/AREA * froot_prof(s,ft,j) + bc_out(s)%FATES_c_to_litr_lig_c_col(j) = bc_out(s)%FATES_c_to_litr_lig_c_col(j) + currentpatch%root_litter_out(ft) * pftcon%fr_flig(ft) * currentpatch%area/AREA * froot_prof(s,ft,j) ! !! and seed_decay too. for now, use the same lability fractions as for leaf litter - FATES_c_to_litr_lab_c(s,j) = FATES_c_to_litr_lab_c(s,j) + currentpatch%seed_decay(ft) * pftcon%lf_flab(ft) * currentpatch%area/AREA * leaf_prof(s,j) - FATES_c_to_litr_cel_c(s,j) = FATES_c_to_litr_cel_c(s,j) + currentpatch%seed_decay(ft) * pftcon%lf_fcel(ft) * currentpatch%area/AREA * leaf_prof(s,j) - FATES_c_to_litr_lig_c(s,j) = FATES_c_to_litr_lig_c(s,j) + currentpatch%seed_decay(ft) * pftcon%lf_flig(ft) * currentpatch%area/AREA * leaf_prof(s,j) + bc_out(s)%FATES_c_to_litr_lab_c_col(j) = bc_out(s)%FATES_c_to_litr_lab_c_col(j) + currentpatch%seed_decay(ft) * pftcon%lf_flab(ft) * currentpatch%area/AREA * leaf_prof(s,j) + bc_out(s)%FATES_c_to_litr_cel_c_col(j) = bc_out(s)%FATES_c_to_litr_cel_c_col(j) + currentpatch%seed_decay(ft) * pftcon%lf_fcel(ft) * currentpatch%area/AREA * leaf_prof(s,j) + bc_out(s)%FATES_c_to_litr_lig_c_col(j) = bc_out(s)%FATES_c_to_litr_lig_c_col(j) + currentpatch%seed_decay(ft) * pftcon%lf_flig(ft) * currentpatch%area/AREA * leaf_prof(s,j) ! enddo end do @@ -1605,24 +1599,23 @@ subroutine flux_into_litter_pools(sites, nsites, bc_in, bc_out) do s = 1, nsites do j = 1, nlevdecomp ! time unit conversion - FATES_c_to_litr_lab_c(s,j)=FATES_c_to_litr_lab_c(s,j) * mass_convert / time_convert - FATES_c_to_litr_cel_c(s,j)=FATES_c_to_litr_cel_c(s,j) * mass_convert / time_convert - FATES_c_to_litr_lig_c(s,j)=FATES_c_to_litr_lig_c(s,j) * mass_convert / time_convert + bc_out(s)%FATES_c_to_litr_lab_c_col(j)=bc_out(s)%FATES_c_to_litr_lab_c_col(j) * mass_convert / time_convert + bc_out(s)%FATES_c_to_litr_cel_c_col(j)=bc_out(s)%FATES_c_to_litr_cel_c_col(j) * mass_convert / time_convert + bc_out(s)%FATES_c_to_litr_lig_c_col(j)=bc_out(s)%FATES_c_to_litr_lig_c_col(j) * mass_convert / time_convert end do end do ! write(iulog,*)'cdk FATES_c_to_litr_lab_c: ', FATES_c_to_litr_lab_c - ! write(iulog,*)'cdk FATES_c_to_litr_cel_c: ', FATES_c_to_litr_cel_c - ! write(iulog,*)'cdk FATES_c_to_litr_lig_c: ', FATES_c_to_litr_lig_c - ! write(iulog,*)'cdk nlevdecomp_full, bounds%begc, bounds%endc: ', nlevdecomp_full, bounds%begc, bounds%endc + ! write_col(iulog,*)'cdk FATES_c_to_litr_cel_c: ', FATES_c_to_litr_cel_c + ! write_col(iulog,*)'cdk FATES_c_to_litr_lig_c: ', FATES_c_to_litr_lig_c + ! write_col(iulog,*)'cdk nlevdecomp_full, bounds%begc, bounds%endc: ', nlevdecomp_full, bounds%begc, bounds%endc ! write(iulog,*)'cdk leaf_prof: ', leaf_prof ! write(iulog,*)'cdk stem_prof: ', stem_prof ! write(iulog,*)'cdk froot_prof: ', froot_prof ! write(iulog,*)'cdk croot_prof_perpatch: ', croot_prof_perpatch ! write(iulog,*)'cdk croot_prof: ', croot_prof - end associate end subroutine flux_into_litter_pools end module EDPhysiologyMod diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index e650d1e4..0bc30589 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -1083,7 +1083,6 @@ subroutine ed_clm_link( this, bounds, sites, nsites, fcolumn, waterstate_inst, c end do ! column loop - call this%flux_into_litter_pools(bounds, sites(:), nsites, fcolumn(:), canopystate_inst) call this%ed_update_history_variables(bounds, sites(:), nsites, fcolumn(:), canopystate_inst) end associate diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 86f6f112..93d85cb2 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -202,12 +202,11 @@ subroutine allocate_bcout(bc_out) allocate(bc_out%rootr_pagl(numPatchesPerCol,ctrl_parms%numlevgrnd)) allocate(bc_out%btran_pa(numPatchesPerCol)) + ! biogeochemistry allocate(bc_out%FATES_c_to_litr_lab_c_col(ctrl_parms%numlevdecomp_full)) allocate(bc_out%FATES_c_to_litr_cel_c_col(ctrl_parms%numlevdecomp_full)) allocate(bc_out%FATES_c_to_litr_lig_c_col(ctrl_parms%numlevdecomp_full)) - - return end subroutine allocate_bcout @@ -236,7 +235,7 @@ subroutine zero_bcs(this,s) this%bc_out(s)%rootr_pagl(:,:) = 0.0_r8 this%bc_out(s)%btran_pa(:) = 0.0_r8 this%bc_out(s)%FATES_c_to_litr_lab_c_col(:) = 0.0_r8 - this%bc_out(s)%FATES_c_to_litr_cel_c_col(:, = 0.0_r8 + this%bc_out(s)%FATES_c_to_litr_cel_c_col(:) = 0.0_r8 this%bc_out(s)%FATES_c_to_litr_lig_c_col(:) = 0.0_r8 return From a0e17eca90e180577fa8770309c7ecb5b736754f Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 8 Aug 2016 16:46:36 -0700 Subject: [PATCH 148/437] uninitialized index for calculating rootfr in CLMLinkMod --- main/EDCLMLinkMod.F90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 67ccb500..26b4b4f6 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -2130,7 +2130,7 @@ subroutine flux_into_litter_pools(this, bounds, sites, nsites, fcolumn, canopyst real(r8) :: cinput_rootfr(bounds%begc:bounds%endc, 1:numpft_ed, 1:nlevdecomp_full) ! column by pft root fraction used for calculating inputs real(r8) :: croot_prof_perpatch(1:nlevdecomp_full) real(r8) :: surface_prof(1:nlevdecomp_full) - integer :: ft, lev + integer :: ft real(r8) :: rootfr_tot(1:numpft_ed), biomass_bg_ft(1:numpft_ed) real(r8) :: surface_prof_tot, leaf_prof_sum, stem_prof_sum, froot_prof_sum, biomass_bg_tot real(r8) :: delta @@ -2205,10 +2205,10 @@ subroutine flux_into_litter_pools(this, bounds, sites, nsites, fcolumn, canopyst do j = 1, nlevdecomp ! use standard CLM root fraction profiles; cinput_rootfr(c,ft,j) = ( .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)))) / dzsoi_decomp(j) + exp(-pftcon%roota_par(ft) * col%zi(c,j-1)) & + + exp(-pftcon%rootb_par(ft) * col%zi(c,j-1)) & + - exp(-pftcon%roota_par(ft) * col%zi(c,j)) & + - exp(-pftcon%rootb_par(ft) * col%zi(c,j)))) / dzsoi_decomp(j) end do end do endif From 2abacf944603e74fbdfd1b3fa4ba84dceded11e0 Mon Sep 17 00:00:00 2001 From: ckoven Date: Mon, 8 Aug 2016 16:53:58 -0700 Subject: [PATCH 149/437] fixed an uninitialized variable bug and also streamlined some code, both in flux_litter_out --- biogeochem/EDPhysiologyMod.F90 | 81 ++++++++++++++++------------------ 1 file changed, 39 insertions(+), 42 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 04915acc..2590192f 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1318,10 +1318,10 @@ subroutine flux_into_litter_pools(sites, nsites, bc_in, bc_out) integer :: begp,endp integer :: begc,endc !bounds !------------------------------------------------------------------------ - real(r8) :: cinput_rootfr(1:nsites, 1:numpft_ed, 1:nlevdecomp_full) ! column by pft root fraction used for calculating inputs + real(r8) :: cinput_rootfr(1:numpft_ed, 1:nlevdecomp_full) ! column by pft root fraction used for calculating inputs real(r8) :: croot_prof_perpatch(1:nlevdecomp_full) real(r8) :: surface_prof(1:nlevdecomp_full) - integer :: ft, lev + integer :: ft real(r8) :: rootfr_tot(1:numpft_ed), biomass_bg_ft(1:numpft_ed) real(r8) :: surface_prof_tot, leaf_prof_sum, stem_prof_sum, froot_prof_sum, biomass_bg_tot real(r8) :: delta @@ -1342,8 +1342,8 @@ subroutine flux_into_litter_pools(sites, nsites, bc_in, bc_out) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! first calculate vertical profiles ! define two types of profiles: - ! (1) a surface profile, for leaves and stem inputs, which is the same for each pft but differs from one column to the next to avoid inputting any C into permafrost - ! (2) a fine root profile, which is indexed by both column and pft, differs for each pft and also from one column to the next to avoid inputting any C into permafrost + ! (1) a surface profile, for leaves and stem inputs, which is the same for each pft but differs from one site to the next to avoid inputting any C into permafrost or bedrock + ! (2) a fine root profile, which is indexed by both site and pft, differs for each pft and also from one site to the next to avoid inputting any C into permafrost or bedrock ! (3) a coarse root profile, which is the root-biomass=weighted average of the fine root profiles !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -1361,45 +1361,45 @@ subroutine flux_into_litter_pools(sites, nsites, bc_in, bc_out) croot_prof(1:nsites, :) = 0._r8 stem_prof(1:nsites, :) = 0._r8 - cinput_rootfr(1:nsites, 1:numpft_ed, :) = 0._r8 - - do s = 1,nsites + cinput_rootfr(1:numpft_ed, :) = 0._r8 - ! calculate pft-specific rooting profiles in the absence of permafrost limitations - if ( exponential_rooting_profile ) then - if ( .not. pftspecific_rootingprofile ) then - ! define rooting profile from exponential parameters - do ft = 1, numpft_ed - do j = 1, nlevdecomp - cinput_rootfr(s,ft,j) = exp(-rootprof_exp * zsoi(j)) / dzsoi_decomp(j) - end do - end do - else - ! use beta distribution parameter from Jackson et al., 1996 - do ft = 1, numpft_ed - do j = 1, nlevdecomp - cinput_rootfr(s,ft,j) = ( pftcon%rootprof_beta(ft) ** (zisoi(j-1)*100._r8) - & - pftcon%rootprof_beta(ft) ** (zisoi(j)*100._r8) ) & - / dzsoi_decomp(j) - end do + ! calculate pft-specific rooting profiles in the absence of permafrost or bedrock limitations + if ( exponential_rooting_profile ) then + if ( .not. pftspecific_rootingprofile ) then + ! define rooting profile from exponential parameters + do ft = 1, numpft_ed + do j = 1, nlevdecomp + cinput_rootfr(ft,j) = exp(-rootprof_exp * zsoi(j)) / dzsoi_decomp(j) end do - endif + end do else - do ft = 1,numpft_ed + ! use beta distribution parameter from Jackson et al., 1996 + do ft = 1, numpft_ed do j = 1, nlevdecomp - ! use standard CLM root fraction profiles; - cinput_rootfr(s,ft,j) = ( .5_r8*( & - exp(-pftcon%roota_par(ft) * zisoi(lev-1)) & - + exp(-pftcon%rootb_par(ft) * zisoi(lev-1)) & - - exp(-pftcon%roota_par(ft) * zisoi(lev)) & - - exp(-pftcon%rootb_par(ft) * zisoi(lev)))) / dzsoi_decomp(j) + cinput_rootfr(ft,j) = ( pftcon%rootprof_beta(ft) ** (zisoi(j-1)*100._r8) - & + pftcon%rootprof_beta(ft) ** (zisoi(j)*100._r8) ) & + / dzsoi_decomp(j) end do end do endif + else + do ft = 1,numpft_ed + do j = 1, nlevdecomp + ! use standard CLM root fraction profiles; + cinput_rootfr(ft,j) = ( .5_r8*( & + exp(-pftcon%roota_par(ft) * zisoi(j-1)) & + + exp(-pftcon%rootb_par(ft) * zisoi(j-1)) & + - exp(-pftcon%roota_par(ft) * zisoi(j)) & + - exp(-pftcon%rootb_par(ft) * zisoi(j)))) / dzsoi_decomp(j) + end do + end do + endif + ! + + do s = 1,nsites ! - ! - ! now add permafrost constraint: integrate rootfr over active layer of soil column, - ! truncate below permafrost table where present, and rescale so that integral = 1 + ! now add permafrost constraint: integrate rootfr over active layer of soil site, + ! truncate below permafrost or bedrock table where present, and rescale so that integral = 1 do ft = 1,numpft_ed rootfr_tot(ft) = 0._r8 end do @@ -1410,7 +1410,7 @@ subroutine flux_into_litter_pools(sites, nsites, bc_in, bc_out) end do do ft = 1,numpft_ed do j = 1, min(max(bc_in(s)%max_rooting_depth_index_col, 1), nlevdecomp) - rootfr_tot(ft) = rootfr_tot(ft) + cinput_rootfr(s,ft,j) * dzsoi_decomp(j) + rootfr_tot(ft) = rootfr_tot(ft) + cinput_rootfr(ft,j) * dzsoi_decomp(j) end do end do ! @@ -1420,7 +1420,7 @@ subroutine flux_into_litter_pools(sites, nsites, bc_in, bc_out) ! where there is not permafrost extending to the surface, integrate the profiles over the active layer ! this is equivalent to integrating over all soil layers outside of permafrost regions do j = 1, min(max(bc_in(s)%max_rooting_depth_index_col, 1), nlevdecomp) - froot_prof(s,ft,j) = cinput_rootfr(s,ft,j) / rootfr_tot(ft) + froot_prof(s,ft,j) = cinput_rootfr(ft,j) / rootfr_tot(ft) end do else ! if fully frozen, or no roots, put everything in the top layer @@ -1489,13 +1489,13 @@ subroutine flux_into_litter_pools(sites, nsites, bc_in, bc_out) end do end do - ! zero the column-level C input variables + ! zero the site-level C input variables do s = 1, nsites do j = 1, nlevdecomp bc_out(s)%FATES_c_to_litr_lab_c_col(j) = 0._r8 bc_out(s)%FATES_c_to_litr_cel_c_col(j) = 0._r8 bc_out(s)%FATES_c_to_litr_lig_c_col(j) = 0._r8 - !croot_prof(s,j) = 0._r8 + croot_prof(s,j) = 0._r8 end do end do @@ -1511,9 +1511,6 @@ subroutine flux_into_litter_pools(sites, nsites, bc_in, bc_out) do while(associated(currentPatch)) - ! cs => currentpatch%siteptr - ! cc = cs%clmcolumn - ! the CWD pools lose information about which PFT they came from; for the stems this doesn't matter as they all have the same profile, ! however for the coarse roots they may have different profiles. to approximately recover this information, loop over all cohorts in patch ! to calculate the total root biomass in that patch of each pft, and then rescale the croot_prof as the weighted average of the froot_prof From b1ccb099ed9096b00b85d0a2a06fdb996bf762ad Mon Sep 17 00:00:00 2001 From: Ben Andre Date: Mon, 8 Aug 2016 17:45:58 -0600 Subject: [PATCH 150/437] Merge clm4_5_10_r187, commit '869ed5a', into andre-ed-clm-16x CLM has changed how the vertical rooting profile code is handled. EDLinkMod.F90 now relies on some parameters that were removed CLM. Test suite: ed - yellowstone gnu, intel, pgi baseline - 14d0e61 clm_short - yellowstone gnu, intel, pgi baseline - clm4_5_10_r187 Test status: clm_short all tests pass, bit for bit with baseline. All ED tests in ed test list pass, bit for bit with baseline. clm tests in ED test list fail bit for bit with baseline because clm changed answers between r186 and r187, not expected to pass. --- main/EDCLMLinkMod.F90 | 21 ++++++++++++++++++--- 1 file changed, 18 insertions(+), 3 deletions(-) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 67ccb500..fd9479fe 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -2101,7 +2101,7 @@ subroutine flux_into_litter_pools(this, bounds, sites, nsites, fcolumn, canopyst use SFParamsMod, only: SF_val_max_decomp use clm_varpar, only : mxpft,nlevdecomp, nlevdecomp_full use EDTypesMod, only : AREA, numpft_ed - use SoilBiogeochemVerticalProfileMod, only: exponential_rooting_profile, pftspecific_rootingprofile, rootprof_exp, surfprof_exp + use SoilBiogeochemVerticalProfileMod, only: surfprof_exp use pftconMod, only : pftcon use clm_varcon, only : zisoi, dzsoi_decomp, zsoi @@ -2134,6 +2134,21 @@ subroutine flux_into_litter_pools(this, bounds, sites, nsites, fcolumn, canopyst real(r8) :: rootfr_tot(1:numpft_ed), biomass_bg_ft(1:numpft_ed) real(r8) :: surface_prof_tot, leaf_prof_sum, stem_prof_sum, froot_prof_sum, biomass_bg_tot real(r8) :: delta + + ! NOTE(bja, 201608) these were removed from clm in clm4_5_10_r187 + logical, parameter :: exponential_rooting_profile = .true. + logical, parameter :: pftspecific_rootingprofile = .true. + + ! NOTE(bja, 201608) as of clm4_5_10_r187 rootprof_exp is now a + ! private function level parameter in RootBiophysMod.F90::exponential_rootfr() + real(r8), parameter :: rootprof_exp = 3. ! how steep profile is + ! for root C inputs (1/ e-folding depth) (1/m) + + ! NOTE(bja, 201608) as of clm4_5_10_r187 rootprof_beta is now a + ! two dimensional array with the second dimension being water,1, + ! or carbon,2,. + integer, parameter :: rooting_profile_varindex_water = 1 + begp = bounds%begp; endp = bounds%endp begc = bounds%begc; endc = bounds%endc @@ -2194,8 +2209,8 @@ subroutine flux_into_litter_pools(this, bounds, sites, nsites, fcolumn, canopyst ! use beta distribution parameter from Jackson et al., 1996 do ft = 1, numpft_ed do j = 1, nlevdecomp - cinput_rootfr(c,ft,j) = ( pftcon%rootprof_beta(ft) ** (zisoi(j-1)*100._r8) - & - pftcon%rootprof_beta(ft) ** (zisoi(j)*100._r8) ) & + cinput_rootfr(c,ft,j) = ( pftcon%rootprof_beta(ft, rooting_profile_varindex_water) ** (zisoi(j-1)*100._r8) - & + pftcon%rootprof_beta(ft, rooting_profile_varindex_water) ** (zisoi(j)*100._r8) ) & / dzsoi_decomp(j) end do end do From 9d2648e61cad0a4a3ff10cc0cd37c04d0d596364 Mon Sep 17 00:00:00 2001 From: Ben Andre Date: Mon, 8 Aug 2016 18:54:53 -0600 Subject: [PATCH 151/437] Merge clm4_5_11_r188, commit '5af45b2', into andre-clm-integration. Testing: ed - yellowstone gnu, intel, pgi baseline: none status: all tests pass clm_short - yellowstone gnu, intel, pgi baseline: clm4_5_11_r188 status: all tests pass clm - yellowstone gnu, intel, pgi baseline: clm4_5_11_r188 status: expect all tests pass except BFAIL ICLM45ED (not maintained in trunk) and SSP (known failure, see issue #81) --- main/EDCLMLinkMod.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index fd9479fe..bf07057d 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -2146,7 +2146,8 @@ subroutine flux_into_litter_pools(this, bounds, sites, nsites, fcolumn, canopyst ! NOTE(bja, 201608) as of clm4_5_10_r187 rootprof_beta is now a ! two dimensional array with the second dimension being water,1, - ! or carbon,2,. + ! or carbon,2,. These are currently hard coded, but may be + ! overwritten by the namelist. integer, parameter :: rooting_profile_varindex_water = 1 From e2d07e7e8a3022adac5c6e26a3e1c12682ed3bdb Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 9 Aug 2016 17:17:19 -0700 Subject: [PATCH 152/437] As per discussions with Rosie F, we realized that sunlai and shalai were not summing to elai. If we do ensure that these sum to elai, then the math that converts rscanopy into rssun and rssha becomes trivial, like not-there type trivial. I added a function for calculating area indices for consistency in different subroutines. --- biogeochem/EDCanopyStructureMod.F90 | 69 ++++++++++++++++++++++++++++- biogeophys/EDPhotosynthesisMod.F90 | 19 ++++---- biogeophys/EDSurfaceAlbedoMod.F90 | 30 +++++++------ main/EDCLMLinkMod.F90 | 30 +++++++------ 4 files changed, 109 insertions(+), 39 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index e8ae4985..66b740f3 100755 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -12,12 +12,16 @@ module EDCanopyStructureMod use EDGrowthFunctionsMod , only : c_area use EDCohortDynamicsMod , only : copy_cohort, terminate_cohorts, fuse_cohorts use EDtypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type, ncwd - + use EDtypesMod , only : numpft_ed + use shr_log_mod , only : errMsg => shr_log_errMsg + use abortutils , only : endrun + implicit none private public :: canopy_structure public :: canopy_spread + public :: calc_areaindex ! 10/30/09: Created by Rosie Fisher ! ============================================================================ @@ -635,4 +639,67 @@ subroutine canopy_spread( currentSite ) end subroutine canopy_spread + ! ===================================================================================== + + function calc_areaindex(cpatch,ai_type) result(ai) + + ! ---------------------------------------------------------------------------------- + ! This subroutine calculates the exposed leaf area index of a patch + ! this is the square meters of leaf per square meter of ground area + ! It does so by integrating over the depth and functional type profile of leaf area + ! which are per area of crown. This value has to be scaled by crown area to convert + ! to ground area. + ! ---------------------------------------------------------------------------------- + + ! Arguments + type(ed_patch_type),intent(in), target :: cpatch + character(len=*),intent(in) :: ai_type + + integer :: cl,ft + real(r8) :: ai + real(r8),parameter :: ai_min = 0.1_r8 + real(r8),pointer :: ai_profile + + ai = 0._r8 + if (trim(ai_type) == 'elai') then + do cl = 1,cpatch%NCL_p + do ft = 1,numpft_ed + ai = ai + sum(cpatch%canopy_area_profile(cl,ft,1:cpatch%nrad(cl,ft)) * & + cpatch%elai_profile(cl,ft,1:cpatch%nrad(cl,ft))) + enddo + enddo + elseif (trim(ai_type) == 'tlai') then + do cl = 1,cpatch%NCL_p + do ft = 1,numpft_ed + ai = ai + sum(cpatch%canopy_area_profile(cl,ft,1:cpatch%nrad(cl,ft)) * & + cpatch%tlai_profile(cl,ft,1:cpatch%nrad(cl,ft))) + enddo + enddo + elseif (trim(ai_type) == 'esai') then + do cl = 1,cpatch%NCL_p + do ft = 1,numpft_ed + ai = ai + sum(cpatch%canopy_area_profile(cl,ft,1:cpatch%nrad(cl,ft)) * & + cpatch%esai_profile(cl,ft,1:cpatch%nrad(cl,ft))) + enddo + enddo + elseif (trim(ai_type) == 'tsai') then + do cl = 1,cpatch%NCL_p + do ft = 1,numpft_ed + ai = ai + sum(cpatch%canopy_area_profile(cl,ft,1:cpatch%nrad(cl,ft)) * & + cpatch%tsai_profile(cl,ft,1:cpatch%nrad(cl,ft))) + enddo + enddo + else + write(iulog,*) 'Unsupported area index sent to calc_areaindex' + call endrun(msg=errMsg(__FILE__, __LINE__)) + end if + + ai = max(ai_min,ai) + + return + + end function calc_areaindex + + + end module EDCanopyStructureMod diff --git a/biogeophys/EDPhotosynthesisMod.F90 b/biogeophys/EDPhotosynthesisMod.F90 index 5243ebf3..71708e80 100644 --- a/biogeophys/EDPhotosynthesisMod.F90 +++ b/biogeophys/EDPhotosynthesisMod.F90 @@ -50,6 +50,7 @@ subroutine Photosynthesis_ED (sites,nsites,bc_in,bc_out,dtime) use EDEcophysContype , only : EDecophyscon use FatesInterfaceMod , only : bc_in_type,bc_out_type use EDtypesMod , only : numpatchespercol + use EDCanopyStructureMod,only: calc_areaindex ! ! !ARGUMENTS: @@ -948,21 +949,17 @@ subroutine Photosynthesis_ED (sites,nsites,bc_in,bc_out,dtime) bc_out(s)%psncanopy_pa(ifp) = bc_out(s)%psncanopy_pa(ifp) + currentCohort%gpp_tstep bc_out(s)%lmrcanopy_pa(ifp) = bc_out(s)%lmrcanopy_pa(ifp) + currentCohort%resp_m ! accumulate cohort level canopy conductances over whole area before dividing by total area. - bc_out(s)%gccanopy_pa(ifp) = bc_out(s)%gccanopy_pa(ifp) + currentCohort%gscan * currentCohort%n /currentPatch%total_canopy_area + bc_out(s)%gccanopy_pa(ifp) = bc_out(s)%gccanopy_pa(ifp) + currentCohort%gscan * & + currentCohort%n /currentPatch%total_canopy_area currentCohort => currentCohort%shorter enddo ! end cohort loop. end if !count_cohorts is more than zero. - elai = 0._r8 - do CL = 1,currentPatch%NCL_p - do ft = 1,numpft_ed - elai = elai + sum(currentPatch%canopy_area_profile(CL,ft,1:currentPatch%nrad(CL,ft)) * & - currentPatch%elai_profile(CL,ft,1:currentPatch%nrad(CL,ft))) - enddo - enddo - elai = max(0.1_r8,elai) + + elai = calc_areaindex(currentPatch,'elai') + !---------------------------------------------------------------------------- ! modification to output boundary (RGK 8-6-2016) @@ -1004,8 +1001,8 @@ subroutine Photosynthesis_ED (sites,nsites,bc_in,bc_out,dtime) else rscanopy = rsmax0 end if - bc_out(s)%rssun_pa(ifp) = (bc_out(s)%laisun_pa(ifp)+bc_out(s)%laisha_pa(ifp))*(bc_in(s)%rb_pa(ifp)+rscanopy)/elai - bc_in(s)%rb_pa(ifp) - bc_out(s)%rssha_pa(ifp) = bc_out(s)%rssun_pa(ifp) + bc_out(s)%rssun_pa(ifp) = rscanopy + bc_out(s)%rssha_pa(ifp) = rscanopy bc_out(s)%gccanopy_pa(ifp) = 1.0_r8/rscanopy*cf/1000 !convert into umol m02 s-1 then mmol m-2 s-1. end if diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index be49b03e..1b6aab2f 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -10,15 +10,16 @@ module EDSurfaceRadiationMod #include "shr_assert.h" - use EDtypesMod , only : ed_patch_type, ed_site_type - use EDtypesMod , only : numpft_ed - use EDTypesMod , only : map_clmpatch_to_edpatch - use shr_kind_mod , only : r8 => shr_kind_r8 - use shr_log_mod , only : errMsg => shr_log_errMsg - use decompMod , only : bounds_type - use clm_varpar , only : numrad, nclmax - use FatesInterfaceMod , only : bc_in_type, & - bc_out_type + use EDtypesMod , only : ed_patch_type, ed_site_type + use EDtypesMod , only : numpft_ed + use EDTypesMod , only : map_clmpatch_to_edpatch + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_log_mod , only : errMsg => shr_log_errMsg + use decompMod , only : bounds_type + use clm_varpar , only : numrad, nclmax + use EDCanopyStructureMod , only : calc_areaindex + use FatesInterfaceMod , only : bc_in_type, & + bc_out_type implicit none @@ -975,6 +976,7 @@ subroutine ED_SunShadeFracs(sites,nsites,bc_in,bc_out) type (ed_patch_type),pointer :: cpatch ! c"urrent" patch real(r8) :: sunlai real(r8) :: shalai + real(r8) :: elai integer :: CL integer :: FT integer :: iv @@ -1038,9 +1040,6 @@ subroutine ED_SunShadeFracs(sites,nsites,bc_in,bc_out) end do end do - - bc_out(s)%laisun_pa(ifp) = sunlai - bc_out(s)%laisha_pa(ifp) = shalai if(sunlai+shalai > 0._r8)then bc_out(s)%fsun_pa(ifp) = sunlai / (sunlai+shalai) @@ -1052,7 +1051,12 @@ subroutine ED_SunShadeFracs(sites,nsites,bc_in,bc_out) write(iulog,*) 'too much leaf area in profile', bc_out(s)%fsun_pa(ifp), & cpatch%lai,sunlai,shalai endif - + + elai = calc_areaindex(cpatch,'elai') + + bc_out(s)%laisun_pa(ifp) = elai*bc_out(s)%fsun_pa(ifp) + bc_out(s)%laisha_pa(ifp) = elai*(1.0_r8-bc_out(s)%fsun_pa(ifp)) + ! Absorbed PAR profile through canopy ! If sun/shade big leaf code, nrad=1 and fluxes from SurfaceAlbedo ! are canopy integrated so that layer values equal big leaf values. diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 8ba0d9a5..bd517754 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -22,6 +22,7 @@ module EDCLMLinkMod use shr_const_mod, only: SHR_CONST_CDAY use abortutils , only : endrun use shr_log_mod , only : errMsg => shr_log_errMsg + use EDCanopyStructureMod, only : calc_areaindex ! implicit none @@ -1968,22 +1969,24 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, colindex, waterstate_ins !what is the resultant leaf area? + + tlai_temp = 0._r8 - elai_temp = 0._r8 - tsai_temp = 0._r8 - esai_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))) + ! 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 @@ -2001,11 +2004,10 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, colindex, waterstate_ins 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) - + elai(p) = calc_areaindex(currentPatch,'elai') + tlai(p) = calc_areaindex(currentPatch,'tlai') + esai(p) = calc_areaindex(currentPatch,'esai') + tsai(p) = calc_areaindex(currentPatch,'tsai') ! Fraction of vegetation free of snow. What does this do? Is it right? if ((elai(p) + esai(p)) > 0._r8) then From d7b4893d36dd7acad85168e882c4a6a195d5fb63 Mon Sep 17 00:00:00 2001 From: ckoven Date: Wed, 10 Aug 2016 11:04:38 -0700 Subject: [PATCH 153/437] some further cleanup of EDCLMLinkMod --- main/EDCLMLinkMod.F90 | 57 ------------------------------------------- 1 file changed, 57 deletions(-) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 0bc30589..292d65aa 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -79,13 +79,6 @@ module EDCLMLinkMod 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 - ! vegetation carbon fluxes at the patch scale 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 @@ -123,12 +116,6 @@ module EDCLMLinkMod real(r8), pointer :: ed_m4_col_scpf (:,:) ! [Stems/ha/yr] Mean Impact Mortality real(r8), pointer :: ed_m5_col_scpf (:,:) ! [Stems/ha/yr] Mean Fire Mortality - ! profiles for vertically disaggregating litterfall fluxes - real(r8), pointer, private :: leaf_prof_col(:,:) !(1/m) profile of leaves - real(r8), pointer, private :: froot_prof_col(:,:,:) !(1/m) profile of fine roots - real(r8), pointer, private :: croot_prof_col(:,:) !(1/m) profile of coarse roots - real(r8), pointer, private :: stem_prof_col(:,:) !(1/m) profile of leaves - ! summary carbon fluxes at the column level real(r8), pointer, private :: nep_col(:) ! [gC/m2/s] Net ecosystem production, i.e. fast-timescale carbon balance that does not include disturbance real(r8), pointer, private :: nep_timeintegrated_col(:) ! [gC/m2/s] Net ecosystem production, i.e. fast-timescale carbon balance that does not include disturbance @@ -260,24 +247,12 @@ subroutine InitAllocate(this, bounds) 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 allocate(this%ar_patch (begp:endp)) ; this%ar_patch (:) = nan allocate(this%maint_resp_patch (begp:endp)) ; this%maint_resp_patch (:) = nan allocate(this%growth_resp_patch (begp:endp)) ; this%growth_resp_patch (:) = nan - allocate(this%leaf_prof_col (begc:endc,1:nlevdecomp_full)) ; this%leaf_prof_col (:,:) = nan - allocate(this%froot_prof_col (begc:endc,1:numpft_ed,1:nlevdecomp_full)); this%froot_prof_col (:,:,:) = nan - allocate(this%croot_prof_col (begc:endc,1:nlevdecomp_full)) ; this%croot_prof_col (:,:) = nan - allocate(this%stem_prof_col (begc:endc,1:nlevdecomp_full)) ; this%stem_prof_col (:,:) = nan - allocate(this%ed_to_bgc_this_edts_col (begc:endc)) ; this%ed_to_bgc_this_edts_col (:) = nan allocate(this%ed_to_bgc_last_edts_col (begc:endc)) ; this%ed_to_bgc_last_edts_col (:) = nan allocate(this%seed_rain_flux_col (begc:endc)) ; this%seed_rain_flux_col (:) = nan @@ -587,22 +562,6 @@ subroutine InitHistory(this, bounds) avgflag='A', long_name='total seed carbon at the column level', & ptr_col=this%seed_stock_col) - - ! this%leaf_prof_col(begc:endc,1:nlevdecomp_full) = spval - ! call hist_addfld_decomp (fname='leaf_prof', units='1/m', type2d='levdcmp', & - ! avgflag='A', long_name='leaf_prof', & - ! ptr_col=this%leaf_prof_col,default='inactive') - - ! this%croot_prof_col(begc:endc,1:nlevdecomp_full) = spval - ! call hist_addfld_decomp (fname='croot_prof', units='1/m', type2d='levdcmp', & - ! avgflag='A', long_name='croot_prof', & - ! ptr_col=this%croot_prof_col,default='inactive') - - ! this%stem_prof_col(begc:endc,1:nlevdecomp_full) = spval - ! call hist_addfld_decomp (fname='stem_prof', units='1/m', type2d='levdcmp', & - ! avgflag='A', long_name='stem_prof', & - ! ptr_col=this%stem_prof_col,default='inactive') - ! Carbon Flux (grid dimension x scpf) ! ============================================================== @@ -733,22 +692,6 @@ subroutine Restart ( this, bounds, ncid, flag ) ! integer :: k !------------------------------------------------------------------------ - ! 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) - ptr1d => this%nep_timeintegrated_col(:) call restartvar(ncid=ncid, flag=flag, varname='nep_timeintegrated_col', xtype=ncd_double, & dim1name='column', long_name='', units='', & From 942a1508e342078a9f8b0d8c37eed36aaf0024e2 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 10 Aug 2016 12:36:50 -0700 Subject: [PATCH 154/437] removed explanation of conversion of rscanopy to rssun that is no longer valid. --- biogeophys/EDPhotosynthesisMod.F90 | 34 ------------------------------ 1 file changed, 34 deletions(-) diff --git a/biogeophys/EDPhotosynthesisMod.F90 b/biogeophys/EDPhotosynthesisMod.F90 index 71708e80..0b01702e 100644 --- a/biogeophys/EDPhotosynthesisMod.F90 +++ b/biogeophys/EDPhotosynthesisMod.F90 @@ -960,40 +960,6 @@ subroutine Photosynthesis_ED (sites,nsites,bc_in,bc_out,dtime) elai = calc_areaindex(currentPatch,'elai') - - !---------------------------------------------------------------------------- - ! modification to output boundary (RGK 8-6-2016) - ! The HLMs ALM/CLM use canopy resistance (rscanopy) to calculate - ! rppdry, an intermediary towards transpiration and latent heat flux. - ! CLM/ALM, when FATES is not turned on, expect a slightly different format to - ! rscanopy, which includes having sunlit and shaded components, and how it is - ! normalized by those leaf areas (variables: rssun, rssha). To simplify and - ! streamline the interface, and remove the necessity in CanopyFluxesMod to - ! process the resistance in in different ways for FATES and non-FATES, we can - ! simply convert to their format by passing rssun and rssha. - ! - ! The key is equate our two methods of solving for rppdry, and calculate rssun - ! and rssha in terms of rscanopy: - ! - ! FATES existing way: - ! - ! rppdry_old = fdry*rb/(rb+rscanopy) - ! - ! CLM/ALM way: - ! - ! rppdry_new = fdry * rb*(laisun/(rb+rssun) + laisha/(rb+rssha ))/elai - ! - ! By equating the two, and assuming that rssun = rssha, we can solve for rssun - ! and rssha in terms of rscanopy, so that we can use the CLM system and get - ! the same rppdry: - ! - ! rppdry_new = fdry * rb*( (laisun+laisha)/(rb+rssun) )/elai - ! - ! simple mathematical manipulations: - ! - ! rssun = rssha = (laisun+laisha)*(rb+rscanopy)/elai - rb - ! --------------------------------------------------------------------------- - bc_out(s)%psncanopy_pa(ifp) = bc_out(s)%psncanopy_pa(ifp) / currentPatch%area bc_out(s)%lmrcanopy_pa(ifp) = bc_out(s)%lmrcanopy_pa(ifp) / currentPatch%area if(bc_out(s)%gccanopy_pa(ifp) > 1._r8/rsmax0 .and. elai > 0.0_r8)then From 2b8efbfffcd3c6107867fc25f77075611268b6c2 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 10 Aug 2016 12:42:08 -0700 Subject: [PATCH 155/437] reverting bug-fix on cinput_rootfr for testing purposes, Charlies bgc interface work has the same fix. --- main/EDCLMLinkMod.F90 | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 82bc2408..79d399de 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -2132,7 +2132,7 @@ subroutine flux_into_litter_pools(this, bounds, sites, nsites, fcolumn, canopyst real(r8) :: cinput_rootfr(bounds%begc:bounds%endc, 1:numpft_ed, 1:nlevdecomp_full) ! column by pft root fraction used for calculating inputs real(r8) :: croot_prof_perpatch(1:nlevdecomp_full) real(r8) :: surface_prof(1:nlevdecomp_full) - integer :: ft + integer :: ft, lev real(r8) :: rootfr_tot(1:numpft_ed), biomass_bg_ft(1:numpft_ed) real(r8) :: surface_prof_tot, leaf_prof_sum, stem_prof_sum, froot_prof_sum, biomass_bg_tot real(r8) :: delta @@ -2222,11 +2222,12 @@ subroutine flux_into_litter_pools(this, bounds, sites, nsites, fcolumn, canopyst do ft = 1,numpft_ed do j = 1, nlevdecomp ! use standard CLM root fraction profiles; + ! THESE LEV's SHOULD BE FIXED (RGK) cinput_rootfr(c,ft,j) = ( .5_r8*( & - exp(-pftcon%roota_par(ft) * col%zi(c,j-1)) & - + exp(-pftcon%rootb_par(ft) * col%zi(c,j-1)) & - - exp(-pftcon%roota_par(ft) * col%zi(c,j)) & - - exp(-pftcon%rootb_par(ft) * col%zi(c,j)))) / dzsoi_decomp(j) + 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)))) / dzsoi_decomp(j) end do end do endif From 48febca49b9ee868205afe435cf67bd7a5745a6b Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Sun, 14 Aug 2016 13:46:47 -0700 Subject: [PATCH 156/437] merge fixes: somehow the definition of calc_areaindex was dropped in surface albedo, I also mis-spelled the name of the cp_numlevdecomp_full in litterflux_out --- biogeochem/EDPhysiologyMod.F90 | 8 ++++---- biogeophys/EDSurfaceAlbedoMod.F90 | 2 ++ 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 6bfc49ff..624fa62b 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1287,7 +1287,7 @@ subroutine flux_into_litter_pools(sites, nsites, bc_in, bc_out) ! This means that the state update for the litter pools and for the CWD pools occurs at different timescales. use clm_varpar, only : mxpft,nlevdecomp - use EDTypesMod, only : AREA, numpft_ed, cp_nlevdecomp_full + use EDTypesMod, only : AREA, numpft_ed, cp_numlevdecomp_full use SoilBiogeochemVerticalProfileMod, only: surfprof_exp use EDCLMLinkMod, only: cwd_fcel_ed, cwd_flig_ed use pftconMod, only : pftcon @@ -1318,9 +1318,9 @@ subroutine flux_into_litter_pools(sites, nsites, bc_in, bc_out) integer :: begp,endp integer :: begc,endc !bounds !------------------------------------------------------------------------ - real(r8) :: cinput_rootfr(1:numpft_ed, 1:cp_nlevdecomp_full) ! column by pft root fraction used for calculating inputs - real(r8) :: croot_prof_perpatch(1:cp_nlevdecomp_full) - real(r8) :: surface_prof(1:cp_nlevdecomp_full) + real(r8) :: cinput_rootfr(1:numpft_ed, 1:cp_numlevdecomp_full) ! column by pft root fraction used for calculating inputs + real(r8) :: croot_prof_perpatch(1:cp_numlevdecomp_full) + real(r8) :: surface_prof(1:cp_numlevdecomp_full) integer :: ft real(r8) :: rootfr_tot(1:numpft_ed), biomass_bg_ft(1:numpft_ed) real(r8) :: surface_prof_tot, leaf_prof_sum, stem_prof_sum, froot_prof_sum, biomass_bg_tot diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index 7c6d72cc..005f7cec 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -20,6 +20,8 @@ module EDSurfaceRadiationMod use EDTypesMod , only : cp_numSWb, & ! Actual number of SW radiation bands cp_maxSWb, & ! maximum number of SW bands (for scratch) cp_nclmax ! control parameter, number of SW bands + use EDCanopyStructureMod, only: calc_areaindex + implicit none From 6984517999a41a63b2bf785f3952e5a16ada2eed Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 15 Aug 2016 16:09:11 -0700 Subject: [PATCH 157/437] added cp_numlevdecomp to control parameters and added it to the HLM passing function --- biogeochem/EDPhysiologyMod.F90 | 50 +++++++++++++++++----------------- main/EDTypesMod.F90 | 7 +++-- main/FatesInterfaceMod.F90 | 13 +++++++++ 3 files changed, 43 insertions(+), 27 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 624fa62b..1dff2f2e 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1286,8 +1286,8 @@ subroutine flux_into_litter_pools(sites, nsites, bc_in, bc_out) ! This means that the carbon gets passed back and forth between the photosynthesis code (fast timestepping) to the ED code (slow timestepping), back to the BGC code (fast timestepping). ! This means that the state update for the litter pools and for the CWD pools occurs at different timescales. - use clm_varpar, only : mxpft,nlevdecomp - use EDTypesMod, only : AREA, numpft_ed, cp_numlevdecomp_full + + use EDTypesMod, only : AREA, numpft_ed, cp_numlevdecomp_full, cp_numlevdecomp use SoilBiogeochemVerticalProfileMod, only: surfprof_exp use EDCLMLinkMod, only: cwd_fcel_ed, cwd_flig_ed use pftconMod, only : pftcon @@ -1344,10 +1344,10 @@ subroutine flux_into_litter_pools(sites, nsites, bc_in, bc_out) ! Doing so will be answer changing though so perhaps easiest to do this in steps. integer, parameter :: rooting_profile_varindex_water = 1 - real(r8) :: leaf_prof(1:nsites, 1:nlevdecomp) - real(r8) :: froot_prof(1:nsites, 1:numpft_ed, 1:nlevdecomp) - real(r8) :: croot_prof(1:nsites, 1:nlevdecomp) - real(r8) :: stem_prof(1:nsites, 1:nlevdecomp) + real(r8) :: leaf_prof(1:nsites, 1:cp_numlevdecomp) + real(r8) :: froot_prof(1:nsites, 1:numpft_ed, 1:cp_numlevdecomp) + real(r8) :: croot_prof(1:nsites, 1:cp_numlevdecomp) + real(r8) :: stem_prof(1:nsites, 1:cp_numlevdecomp) delta = 0.001_r8 @@ -1370,7 +1370,7 @@ subroutine flux_into_litter_pools(sites, nsites, bc_in, bc_out) ! define a single shallow surface profile for surface additions (leaves, stems, and N deposition) surface_prof(:) = 0._r8 - do j = 1, nlevdecomp + do j = 1, cp_numlevdecomp surface_prof(j) = exp(-surfprof_exp * zsoi(j)) / dzsoi_decomp(j) end do @@ -1387,14 +1387,14 @@ subroutine flux_into_litter_pools(sites, nsites, bc_in, bc_out) if ( .not. pftspecific_rootingprofile ) then ! define rooting profile from exponential parameters do ft = 1, numpft_ed - do j = 1, nlevdecomp + do j = 1, cp_numlevdecomp cinput_rootfr(ft,j) = exp(-rootprof_exp * zsoi(j)) / dzsoi_decomp(j) end do end do else ! use beta distribution parameter from Jackson et al., 1996 do ft = 1, numpft_ed - do j = 1, nlevdecomp + do j = 1, cp_numlevdecomp cinput_rootfr(ft,j) = ( pftcon%rootprof_beta(ft, rooting_profile_varindex_water) ** (zisoi(j-1)*100._r8) - & pftcon%rootprof_beta(ft, rooting_profile_varindex_water) ** (zisoi(j)*100._r8) ) & / dzsoi_decomp(j) @@ -1403,7 +1403,7 @@ subroutine flux_into_litter_pools(sites, nsites, bc_in, bc_out) endif else do ft = 1,numpft_ed - do j = 1, nlevdecomp + do j = 1, cp_numlevdecomp ! use standard CLM root fraction profiles; cinput_rootfr(ft,j) = ( .5_r8*( & exp(-pftcon%roota_par(ft) * zisoi(j-1)) & @@ -1424,11 +1424,11 @@ subroutine flux_into_litter_pools(sites, nsites, bc_in, bc_out) end do surface_prof_tot = 0._r8 ! - do j = 1, min(max(bc_in(s)%max_rooting_depth_index_col, 1), nlevdecomp) + do j = 1, min(max(bc_in(s)%max_rooting_depth_index_col, 1), cp_numlevdecomp) surface_prof_tot = surface_prof_tot + surface_prof(j) * dzsoi_decomp(j) end do do ft = 1,numpft_ed - do j = 1, min(max(bc_in(s)%max_rooting_depth_index_col, 1), nlevdecomp) + do j = 1, min(max(bc_in(s)%max_rooting_depth_index_col, 1), cp_numlevdecomp) rootfr_tot(ft) = rootfr_tot(ft) + cinput_rootfr(ft,j) * dzsoi_decomp(j) end do end do @@ -1438,7 +1438,7 @@ subroutine flux_into_litter_pools(sites, nsites, bc_in, bc_out) if ( (bc_in(s)%max_rooting_depth_index_col > 0) .and. (rootfr_tot(ft) > 0._r8) ) then ! where there is not permafrost extending to the surface, integrate the profiles over the active layer ! this is equivalent to integrating over all soil layers outside of permafrost regions - do j = 1, min(max(bc_in(s)%max_rooting_depth_index_col, 1), nlevdecomp) + do j = 1, min(max(bc_in(s)%max_rooting_depth_index_col, 1), cp_numlevdecomp) froot_prof(s,ft,j) = cinput_rootfr(ft,j) / rootfr_tot(ft) end do else @@ -1451,7 +1451,7 @@ subroutine flux_into_litter_pools(sites, nsites, bc_in, bc_out) if ( (bc_in(s)%max_rooting_depth_index_col > 0) .and. (surface_prof_tot > 0._r8) ) then ! where there is not permafrost extending to the surface, integrate the profiles over the active layer ! this is equivalent to integrating over all soil layers outside of permafrost regions - do j = 1, min(max(bc_in(s)%max_rooting_depth_index_col, 1), nlevdecomp) + do j = 1, min(max(bc_in(s)%max_rooting_depth_index_col, 1), cp_numlevdecomp) ! set all surface processes to shallower profile leaf_prof(s,j) = surface_prof(j)/ surface_prof_tot stem_prof(s,j) = surface_prof(j)/ surface_prof_tot @@ -1460,7 +1460,7 @@ subroutine flux_into_litter_pools(sites, nsites, bc_in, bc_out) ! if fully frozen, or no roots, put everything in the top layer leaf_prof(s,1) = 1._r8/dzsoi_decomp(1) stem_prof(s,1) = 1._r8/dzsoi_decomp(1) - do j = 2, nlevdecomp + do j = 2, cp_numlevdecomp leaf_prof(s,j) = 0._r8 stem_prof(s,j) = 0._r8 end do @@ -1481,7 +1481,7 @@ subroutine flux_into_litter_pools(sites, nsites, bc_in, bc_out) ! check the leaf and stem profiles leaf_prof_sum = 0._r8 stem_prof_sum = 0._r8 - do j = 1, nlevdecomp + do j = 1, cp_numlevdecomp leaf_prof_sum = leaf_prof_sum + leaf_prof(s,j) * dzsoi_decomp(j) stem_prof_sum = stem_prof_sum + stem_prof(s,j) * dzsoi_decomp(j) end do @@ -1498,7 +1498,7 @@ subroutine flux_into_litter_pools(sites, nsites, bc_in, bc_out) ! now check each fine root profile do ft = 1,numpft_ed froot_prof_sum = 0._r8 - do j = 1, nlevdecomp + do j = 1, cp_numlevdecomp froot_prof_sum = froot_prof_sum + froot_prof(s,ft,j) * dzsoi_decomp(j) end do if ( ( abs(froot_prof_sum - 1._r8) > delta ) ) then @@ -1510,7 +1510,7 @@ subroutine flux_into_litter_pools(sites, nsites, bc_in, bc_out) ! zero the site-level C input variables do s = 1, nsites - do j = 1, nlevdecomp + do j = 1, cp_numlevdecomp bc_out(s)%FATES_c_to_litr_lab_c_col(j) = 0._r8 bc_out(s)%FATES_c_to_litr_cel_c_col(j) = 0._r8 bc_out(s)%FATES_c_to_litr_lig_c_col(j) = 0._r8 @@ -1545,14 +1545,14 @@ subroutine flux_into_litter_pools(sites, nsites, bc_in, bc_out) biomass_bg_tot = biomass_bg_tot + biomass_bg_ft(ft) end do ! - do j = 1, nlevdecomp + do j = 1, cp_numlevdecomp ! zero this for each patch croot_prof_perpatch(j) = 0._r8 end do ! if ( biomass_bg_tot .gt. 0._r8) then do ft = 1,numpft_ed - do j = 1, nlevdecomp + do j = 1, cp_numlevdecomp croot_prof_perpatch(j) = croot_prof_perpatch(j) + froot_prof(s,ft,j) * biomass_bg_ft(ft) / biomass_bg_tot end do end do @@ -1562,7 +1562,7 @@ subroutine flux_into_litter_pools(sites, nsites, bc_in, bc_out) ! ! add croot_prof as weighted average (weighted by patch area) of croot_prof_perpatch - do j = 1, nlevdecomp + do j = 1, cp_numlevdecomp croot_prof(s, j) = croot_prof(s, j) + croot_prof_perpatch(j) * currentPatch%area / AREA end do ! @@ -1579,7 +1579,7 @@ subroutine flux_into_litter_pools(sites, nsites, bc_in, bc_out) ! ! ! CWD pools fragmenting into decomposing litter pools. do ci = 1, ncwd - do j = 1, nlevdecomp + do j = 1, cp_numlevdecomp bc_out(s)%FATES_c_to_litr_cel_c_col(j) = bc_out(s)%FATES_c_to_litr_cel_c_col(j) + currentpatch%CWD_AG_out(ci) * cwd_fcel_ed * currentpatch%area/AREA * stem_prof(s,j) bc_out(s)%FATES_c_to_litr_lig_c_col(j) = bc_out(s)%FATES_c_to_litr_lig_c_col(j) + currentpatch%CWD_AG_out(ci) * cwd_flig_ed * currentpatch%area/AREA * stem_prof(s,j) ! @@ -1590,7 +1590,7 @@ subroutine flux_into_litter_pools(sites, nsites, bc_in, bc_out) ! leaf and fine root pools. do ft = 1,numpft_ed - do j = 1, nlevdecomp + do j = 1, cp_numlevdecomp bc_out(s)%FATES_c_to_litr_lab_c_col(j) = bc_out(s)%FATES_c_to_litr_lab_c_col(j) + currentpatch%leaf_litter_out(ft) * pftcon%lf_flab(ft) * currentpatch%area/AREA * leaf_prof(s,j) bc_out(s)%FATES_c_to_litr_cel_c_col(j) = bc_out(s)%FATES_c_to_litr_cel_c_col(j) + currentpatch%leaf_litter_out(ft) * pftcon%lf_fcel(ft) * currentpatch%area/AREA * leaf_prof(s,j) bc_out(s)%FATES_c_to_litr_lig_c_col(j) = bc_out(s)%FATES_c_to_litr_lig_c_col(j) + currentpatch%leaf_litter_out(ft) * pftcon%lf_flig(ft) * currentpatch%area/AREA * leaf_prof(s,j) @@ -1613,7 +1613,7 @@ subroutine flux_into_litter_pools(sites, nsites, bc_in, bc_out) end do ! do sites(s) do s = 1, nsites - do j = 1, nlevdecomp + do j = 1, cp_numlevdecomp ! time unit conversion bc_out(s)%FATES_c_to_litr_lab_c_col(j)=bc_out(s)%FATES_c_to_litr_lab_c_col(j) * mass_convert / time_convert bc_out(s)%FATES_c_to_litr_cel_c_col(j)=bc_out(s)%FATES_c_to_litr_cel_c_col(j) * mass_convert / time_convert @@ -1625,7 +1625,7 @@ subroutine flux_into_litter_pools(sites, nsites, bc_in, bc_out) ! write(iulog,*)'cdk FATES_c_to_litr_lab_c: ', FATES_c_to_litr_lab_c ! write_col(iulog,*)'cdk FATES_c_to_litr_cel_c: ', FATES_c_to_litr_cel_c ! write_col(iulog,*)'cdk FATES_c_to_litr_lig_c: ', FATES_c_to_litr_lig_c - ! write_col(iulog,*)'cdk nlevdecomp_full, bounds%begc, bounds%endc: ', nlevdecomp_full, bounds%begc, bounds%endc + ! write_col(iulog,*)'cdk cp_numlevdecomp_full, bounds%begc, bounds%endc: ', cp_numlevdecomp_full, bounds%begc, bounds%endc ! write(iulog,*)'cdk leaf_prof: ', leaf_prof ! write(iulog,*)'cdk stem_prof: ', stem_prof ! write(iulog,*)'cdk froot_prof: ', froot_prof diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 9a50fc0a..ca11fa8a 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -130,10 +130,13 @@ module EDTypesMod integer :: cp_numlevgrnd ! Number of soil layers - ! Number of soil layers for the purposes of biogeochemistry; can be either 1 - ! or the total number of soil layers + ! Number of GROUND layers for the purposes of biogeochemistry; can be either 1 + ! or the total number of soil layers (includes bedrock) integer :: cp_numlevdecomp_full + ! Number of SOIL layers for the purposes of biogeochemistry; can be either 1 + ! or the total number of soil layers + integer :: cp_numlevdecomp !************************************ diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 6b39daa7..0d3a4336 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -21,6 +21,7 @@ module FatesInterfaceMod cp_numSWb, & cp_numlevgrnd, & cp_maxSWb, & + cp_numlevdecomp, & cp_numlevdecomp_full use shr_kind_mod , only : r8 => shr_kind_r8 ! INTERF-TODO: REMOVE THIS @@ -466,6 +467,7 @@ subroutine set_fates_ctrlparms(tag,dimval) cp_numSwb = unset_int cp_numlevgrnd = unset_int cp_numlevdecomp_full = unset_int + cp_numlevdecomp = unset_int case('check_allset') @@ -499,6 +501,12 @@ subroutine set_fates_ctrlparms(tag,dimval) ! end_run('MESSAGE') end if + if(cp_numlevdecomp .eq. unset_int) then + write(*,*) 'FATES dimension/parameter unset: numlevdecomp' + ! INTERF-TODO: FATES NEEDS INTERNAL end_run + ! end_run('MESSAGE') + end if + write(*,*) 'Checked. All control parameters sent to FATES.' case default @@ -520,7 +528,12 @@ subroutine set_fates_ctrlparms(tag,dimval) cp_numlevdecomp_full = dimval write(*,*) 'Transfering num_levdecomp_full = ',dimval,' to FATES' + + case('num_levdecomp') + cp_numlevdecomp = dimval + write(*,*) 'Transfering num_levdecomp = ',dimval,' to FATES' + case default write(*,*) 'tag not recognized:',trim(tag) ! end_run From 8856ba0827d0dc9fd84e5ce75ad3dc91f0f2221a Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 17 Aug 2016 23:31:29 -0700 Subject: [PATCH 158/437] First pass at interfacing the histor IO. Includes a vector of history output variable objects, and dimensional objects. --- main/EDTypesMod.F90 | 2 + main/FatesInterfaceMod.F90 | 51 ++-- main/FatesUtilsMod.F90 | 129 +++++++++ main/HistoryIOMod.F90 | 560 +++++++++++++++++++++++++++++++++++++ 4 files changed, 726 insertions(+), 16 deletions(-) create mode 100644 main/FatesUtilsMod.F90 create mode 100644 main/HistoryIOMod.F90 diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index ca11fa8a..3ac8080b 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -138,6 +138,8 @@ module EDTypesMod ! or the total number of soil layers integer :: cp_numlevdecomp + character(len=16) :: cp_hlm_name + !************************************ !** COHORT type structure ** diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 0d3a4336..017a15d5 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -22,7 +22,8 @@ module FatesInterfaceMod cp_numlevgrnd, & cp_maxSWb, & cp_numlevdecomp, & - cp_numlevdecomp_full + cp_numlevdecomp_full, & + cp_hlm_name use shr_kind_mod , only : r8 => shr_kind_r8 ! INTERF-TODO: REMOVE THIS @@ -425,7 +426,7 @@ end subroutine zero_bcs ! ==================================================================================== - subroutine set_fates_ctrlparms(tag,dimval) + subroutine set_fates_ctrlparms(tag,idimval,cdimval) ! --------------------------------------------------------------------------------- ! INTERF-TODO: NEED ALLOWANCES FOR REAL AND CHARACTER ARGS.. @@ -451,8 +452,9 @@ subroutine set_fates_ctrlparms(tag,dimval) ! --------------------------------------------------------------------------------- ! Arguments - integer, optional, intent(in) :: dimval - character(len=*),intent(in) :: tag + integer, optional, intent(in) :: idimval + character(len=*),optional, intent(in) :: cdimval + character(len=*),intent(in) :: tag ! local variables logical :: all_set @@ -468,7 +470,7 @@ subroutine set_fates_ctrlparms(tag,dimval) cp_numlevgrnd = unset_int cp_numlevdecomp_full = unset_int cp_numlevdecomp = unset_int - + cp_hlm_name = 'unset' case('check_allset') @@ -507,39 +509,56 @@ subroutine set_fates_ctrlparms(tag,dimval) ! end_run('MESSAGE') end if + if(trim(cp_hlm_name) .eq. 'unset') then + write(*,*) 'FATES dimension/parameter unset: hlm_name' + ! INTERF-TODO: FATES NEEDS INTERNAL end_run + ! end_run('MESSAGE') + end if + write(*,*) 'Checked. All control parameters sent to FATES.' case default - if(present(dimval))then + if(present(idimval))then select case (trim(tag)) case('num_sw_bbands') - cp_numSwb = dimval - write(*,*) 'Transfering num_sw_bbands = ',dimval,' to FATES' + cp_numSwb = idimval + write(*,*) 'Transfering num_sw_bbands = ',idimval,' to FATES' case('num_lev_ground') - cp_numlevgrnd = dimval - write(*,*) 'Transfering num_lev_ground = ',dimval,' to FATES' + cp_numlevgrnd = idimval + write(*,*) 'Transfering num_lev_ground = ',idimval,' to FATES' case('num_levdecomp_full') - cp_numlevdecomp_full = dimval - write(*,*) 'Transfering num_levdecomp_full = ',dimval,' to FATES' + cp_numlevdecomp_full = idimval + write(*,*) 'Transfering num_levdecomp_full = ',idimval,' to FATES' case('num_levdecomp') - cp_numlevdecomp = dimval - write(*,*) 'Transfering num_levdecomp = ',dimval,' to FATES' + cp_numlevdecomp = idimval + write(*,*) 'Transfering num_levdecomp = ',idimval,' to FATES' case default write(*,*) 'tag not recognized:',trim(tag) ! end_run end select - else - write(*,*) 'no value was provided for the tag' + end if + + if(present(cdimval))then + select case (trim(tag)) + + case('hlm_name') + cp_hlm_name = trim(cdimval) + write(*,*) 'Transfering the HLM name = ',trim(cdimval) + + case default + write(*,*) 'tag not recognized:',trim(tag) + ! end_run + end select end if end select diff --git a/main/FatesUtilsMod.F90 b/main/FatesUtilsMod.F90 new file mode 100644 index 00000000..20557310 --- /dev/null +++ b/main/FatesUtilsMod.F90 @@ -0,0 +1,129 @@ +module FatesUtilsMod + + ! This module contains helper functions and subroutines which are general in nature. + ! Think string parsing, timing, maybe numerics, etc. + +contains + + + function check_hlm_list(hlms,hlm_name) result(astatus) + + ! --------------------------------------------------------------------------------- + ! This simple function compares a string of HLM tags to see if any of the names + ! match the name of the currently active HLM. If any do, return true, if any + ! don't, if any don't its a big secret. + ! --------------------------------------------------------------------------------- + + character(len=*),intent(in) :: hlms + character(len=*),intent(in) :: hlm_name + + logical :: astatus + integer :: nargs,ih + character(len=16),dimension(10) :: args + + call parse(hlms,':', args, nargs) + astatus = .false. + do ih=1,nargs + if(trim(args(ih)).eq.trim(hlm_name))then + astatus = .true. + return + end if + end do + return + end function check_hlm_list + + + ! ==================================================================================== + + + subroutine parse(str,delims,args,nargs) + + ! ---------------------------------------------------------------------------------- + ! Original Code by: George Benthien + ! Stripped down for simplified use by RGK + ! Parses the string 'str' into arguments args(1), ..., args(nargs) based on + ! the delimiters contained in the string 'delims'. Preceding a delimiter in + ! 'str' by a backslash (\) makes this particular instance not a delimiter. + ! The integer output variable nargs contains the number of arguments found. + ! --------------------------------------------------------------------------------- + + character(len=*),intent(in) :: str + character(len=*),intent(in) :: delims + character(len=len_trim(str)) :: strsav + character(len=*),dimension(:) :: args + integer,intent(out) :: nargs + integer :: i,na,k,lenstr + + strsav=str + na=size(args) + do i=1,na + args(i)=' ' + end do + nargs=0 + lenstr=len_trim(strsav) + if(lenstr==0) return + k=0 + do + if(len_trim(strsav) == 0) exit + nargs=nargs+1 + call split(strsav,delims,args(nargs)) + end do + + end subroutine parse + + ! ==================================================================================== + + subroutine split(str,delims,before) + + ! ---------------------------------------------------------------------------------- + ! OriGeorge Benthen + ! Routine finds the first instance of a character from 'delims' in the + ! the string 'str'. The characters before the found delimiter are + ! output in 'before'. The characters after the found delimiter are + ! output in 'str'. The optional output character 'sep' contains the + ! found delimiter. + ! ---------------------------------------------------------------------------------- + + character(len=*) :: str,delims,before + character(len=64) :: strtemp + character :: ch, cha + integer :: lenstr,k,i,iposa,ipos + + lenstr=len_trim(str) + if(lenstr == 0) return ! string str is empty + k=0 + before=' ' + do i=1,lenstr + ch=str(i:i) + ipos=index(delims,ch) + if(ipos == 0) then ! character is not a delimiter + k=k+1 + before(k:k)=ch + cycle + end if + if(ch /= ' ') then ! character is a delimiter that is not a space + strtemp=str(i+1:) + str = strtemp + exit + end if + cha=str(i+1:i+1) ! character is a space delimiter + iposa=index(delims,cha) + if(iposa > 0) then ! next character is a delimiter + strtemp=str(i+2:) + str = strtemp + exit + else + strtemp=str(i+1:) + str = strtemp + exit + end if + end do + + if(i >= lenstr) str='' + str=adjustl(str) ! remove initial spaces + + return + + end subroutine split + +end module FatesUtilsMod diff --git a/main/HistoryIOMod.F90 b/main/HistoryIOMod.F90 new file mode 100644 index 00000000..8ade582d --- /dev/null +++ b/main/HistoryIOMod.F90 @@ -0,0 +1,560 @@ +Module HistoryIOMod + + + use shr_kind_mod , only : r8 => shr_kind_r8 + use clm_varctl , only : iulog + + implicit none + + + ! These variables hold the index of the history output structure so we don't + ! have to constantly do name lookup when we want to populate the dataset + ! These indices are set during "define_history_vars()" call to "set_history_var()" + ! during the initialize phase. + + integer, private :: ind_hio_trimming_pa + integer, private :: ind_hio_area_plant_pa + integer, private :: ind_hio_area_treespread_pa + + + + integer, parameter :: n_iovar_dk = 2 + + ! This structure is allocated by thread, and there are two instances: patch and site + type iovar_bounds_type + integer :: lb1 + integer :: ub1 + integer,allocatable :: clump_lb1(:) ! lower bound of thread's portion of HIO array + integer,allocatable :: clump_ub1(:) ! upper bound of thread's portion of HIO array + end type iovar_bounds_type + + + + ! This structure is allocated by thread, and must be calculated after the FATES + ! sites are allocated, and their mapping to the HLM is identified. This structure + ! is not combined with iovar_bounds, because that one is multi-instanced. This + ! structure is used more during the update phase, wherease _bounds is used + ! more for things like flushing + type iovar_map_type + integer, allocatable :: site_index(:) ! maps site indexes to the HIO site position + integer, allocatable :: patch1_index(:) ! maps site index to the HIO patch 1st position + end type iovar_map_type + + + + ! This structure is not multi-threaded + type iovar_dimkind_type + character(len=32) :: name ! String labelling this IO type + integer :: ndims ! number of dimensions in this IO type + integer, allocatable :: dimsize(:) ! The size of each dimension + logical :: active + type(iovar_bounds_type), pointer :: bounds_ptr + end type iovar_dimkind_type + + + + ! This type is instanteated in the HLM-FATES interface (clmfates_interfaceMod.F90) + type iovar_def_type + character(len=32) :: vname + character(len=24) :: units + character(len=128) :: long + character(len=16) :: vtype + character(len=1) :: avgflag + type(iovar_dimkind_type),pointer :: iovar_dk_ptr + ! Pointers (only one of these is allocated per variable) + real(r8), pointer :: r81d(:) + real(r8), pointer :: r82d(:,:) + real(r8), pointer :: r83d(:,:,:) + integer, pointer :: int1d(:) + integer, pointer :: int2d(:,:) + integer, pointer :: int3d(:,:,:) + end type iovar_def_type + + + type, public :: fates_hio_interface_type + + ! Instance of the list of history output varialbes + type(iovar_def_type), pointer :: hvars(:) + integer :: n_hvars + + ! Instanteat one registry of the different dimension/kinds (dk) + ! All output variables will have a pointer to one of these dk's + type(iovar_dimkind_type), pointer :: iovar_dk(:) + + ! This is a structure that explains where FATES patch boundaries + ! on each thread point to in the host IO array, this structure + ! is allocated by number of threads + type(iovar_bounds_type) :: iopa_bounds + + ! This is a structure that explains where FATES patch boundaries + ! on each thread point to in the host IO array, this structure + ! is allocated by number of threads + type(iovar_bounds_type) :: iosi_bounds + + type(iovar_map_type), pointer :: iovar_map(:) + + contains + + procedure, public :: update_history_variables + procedure, public :: define_history_vars + procedure, public :: set_history_var + procedure, public :: init_iovar_dk_maps + procedure, public :: iotype_index + procedure, public :: set_bounds_map_ptrs + + end type fates_hio_interface_type + + + +contains + + + ! ==================================================================================== + + subroutine update_history_variables(this,nc,sites,nsites,fcolumn) + + ! --------------------------------------------------------------------------------- + ! This is the main call to update the history IO arrays that are registerred with + ! the Host Model. + ! --------------------------------------------------------------------------------- + + use EDtypesMod , only : ed_site_type, & + ed_cohort_type, & + ed_patch_type + ! Arguments + class(fates_hio_interface_type) :: this + integer , intent(in) :: nc ! clump index + type(ed_site_type) , intent(inout), target :: sites(nsites) + integer , intent(in) :: nsites + integer , intent(in) :: fcolumn(nsites) + + ! Locals + integer :: s ! The local site index + integer :: io_s ! The site index of the IO array + integer :: ipa ! The local "I"ndex of "PA"tches + integer :: io_pa ! The patch index of the IO array + integer :: io_pa1 ! The first patch index in the IO array for each site + integer :: io_soipa + integer :: lb1,ub1 ! IO array bounds for the calling thread + integer :: ivar ! index of IO variable object vector + type(ed_patch_type),pointer :: cpatch + + ! --------------------------------------------------------------------------------- + ! Flush arrays to zero + ! INTERF-TODO: We need to define a flush type, some variables may not want to + ! average in zero's for patches that are + ! --------------------------------------------------------------------------------- + do ivar=1,ubound(this%hvars,1) + + lb1 = this%hvars(ivar)%iovar_dk_ptr%bounds_ptr%clump_lb1(nc) + ub1 = this%hvars(ivar)%iovar_dk_ptr%bounds_ptr%clump_ub1(nc) + + select case(trim(this%hvars(ivar)%iovar_dk_ptr%name)) + case('PA_R8') + this%hvars(ivar)%r81d(lb1:ub1) = 0.0_r8 + case('SI_R8') + this%hvars(ivar)%r81d(lb1:ub1) = 0.0_r8 + case default + write(iulog,*) 'iotyp undefined while flushing history variables' + stop + !end_run + end select + + end do + + ! Perform any special flushes + + lb1 = this%hvars(ind_hio_trimming_pa)%iovar_dk_ptr%bounds_ptr%clump_lb1(nc) + ub1 = this%hvars(ind_hio_trimming_pa)%iovar_dk_ptr%bounds_ptr%clump_ub1(nc) + this%hvars(ind_hio_trimming_pa)%r81d(lb1:ub1) = 1.0_r8 + + ! --------------------------------------------------------------------------------- + ! Loop through the FATES scale hierarchy and fill the history IO arrays + ! --------------------------------------------------------------------------------- + + + + do s = 1,nsites + + io_s = this%iovar_map(nc)%site_index(s) + io_pa1 = this%iovar_map(nc)%patch1_index(s) + io_soipa = io_pa1-1 + + ! TRIMMING2 (soil patch): ind_hio_trimming_pa + this%hvars(ind_hio_trimming_pa)%r81d(io_soipa) = 1.0_r8 + + ipa = 0 + cpatch => sites(s)%oldest_patch + do while(associated(cpatch)) + + io_pa = io_pa1 + ipa + + ! TRIMMING2: ind_hio_trimming_pa + if(associated(cpatch%tallest))then + this%hvars(ind_hio_trimming_pa)%r81d(io_pa) = cpatch%tallest%canopy_trim + else + this%hvars(ind_hio_trimming_pa)%r81d(io_pa) = 0.0_r8 + endif + + ! AREA_PLANT2: ind_hio_area_plant_pa + this%hvars(ind_hio_area_plant_pa)%r81d(io_pa) = 1._r8 + + ! AREA_TREES: ind_hio_area_treespread_pa + if (min(cpatch%total_canopy_area,cpatch%area)>0.0_r8) then + this%hvars(ind_hio_area_treespread_pa)%r81d(io_pa) = cpatch%total_tree_area & + / min(cpatch%total_canopy_area,cpatch%area) + else + this%hvars(ind_hio_area_treespread_pa)%r81d(io_pa) = 0.0_r8 + end if + + + ipa = ipa + 1 + cpatch => cpatch%younger + end do !patch loop + + enddo ! site loop + + return + end subroutine update_history_variables + + ! ==================================================================================== + + subroutine define_history_vars(this,callstep,nvar) + + ! --------------------------------------------------------------------------------- + ! This subroutine is called in two contexts, either in count mode or inialize mode + ! In count mode, we just walk through the list of registerred variables, compare + ! if the variable of interest list the current host model and add it to the count + ! if true. This count is used just to allocate the variable space. After this + ! has been done, we go through the list a second time populating a memory structure. + ! This phase is the "initialize" phase. These two phases are differntiated by the + ! string "callstep", which should be either "count" or "initialize". + ! --------------------------------------------------------------------------------- + class(fates_hio_interface_type) :: this + character(len=*),intent(in) :: callstep ! are we 'count'ing or 'initializ'ing? + integer,optional,intent(out) :: nvar + + integer :: ivar + + if(.not. (trim(callstep).eq.'count' .or. trim(callstep).eq.'initialize') ) then + write(iulog,*) 'defining history variables in FATES requires callstep count or initialize' + ! end_run('MESSAGE') + end if + + ivar=0 + call this%set_history_var(vname='TRIMMING2',units='none', & + long='Degree to which canopy expansion is limited by leaf economics', & + avgflag='A',vtype='PA_R8',hlms='CLM:ALM',ivar=ivar, & + callstep=callstep,index = ind_hio_trimming_pa) + + + call this%set_history_var(vname='AREA_PLANT2',units='m2', & + long='area occupied by all plants', & + avgflag='A',vtype='PA_R8',hlms='CLM:ALM',ivar=ivar, & + callstep=callstep,index = ind_hio_area_plant_pa) + + + call this%set_history_var(vname='AREA_TREES2',units='m2', & + long='area occupied by woody plants', & + avgflag='A',vtype='PA_R8',hlms='CLM:ALM',ivar=ivar, & + callstep=callstep,index = ind_hio_area_treespread_pa) + + + ! Must be last thing before return + if(present(nvar)) nvar = ivar + + return + + end subroutine define_history_vars + + ! ===================================================================================== + + subroutine set_history_var(this,vname,units,long,avgflag,vtype,hlms,ivar,callstep,index) + + + use FatesUtilsMod, only : check_hlm_list + use EDTypesMod, only : cp_hlm_name + + ! arguments + class(fates_hio_interface_type) :: this + character(len=*),intent(in) :: vname + character(len=*),intent(in) :: units + character(len=*),intent(in) :: long + character(len=*),intent(in) :: avgflag + character(len=*),intent(in) :: vtype + character(len=*),intent(in) :: hlms + character(len=*),intent(in) :: callstep + integer, intent(inout) :: ivar + integer, intent(inout) :: index ! This is the index for the variable of + ! interest that is associated with an + ! explict name (for fast reference during update) + ! A zero is passed back when the variable is + ! not used + + ! locals + type(iovar_def_type),pointer :: hvar + integer :: ub1,lb1,ub2,ub3 ! Bounds for allocating the var + integer :: ityp + + if( check_hlm_list(trim(hlms),trim(cp_hlm_name)) ) then + + ivar = ivar+1 + index = ivar + + if(trim(callstep).eq.'initialize')then + + hvar => this%hvars(ivar) + hvar%vname = vname + hvar%units = units + hvar%long = long + hvar%vtype = vtype + hvar%avgflag = avgflag + + ityp=this%iotype_index(trim(vtype)) + hvar%iovar_dk_ptr => this%iovar_dk(ityp) + this%iovar_dk(ityp)%active = .true. + + nullify(hvar%r81d) + nullify(hvar%r82d) + nullify(hvar%r83d) + nullify(hvar%int1d) + nullify(hvar%int2d) + nullify(hvar%int3d) + + lb1 = hvar%iovar_dk_ptr%bounds_ptr%lb1 + ub1 = hvar%iovar_dk_ptr%bounds_ptr%ub1 + + select case(trim(vtype)) + case('PA_R8') + allocate(hvar%r81d(lb1:ub1)) + case('SI_R8') + allocate(hvar%r81d(lb1:ub1)) + case default + write(iulog,*) 'Incompatible vtype passed to set_history_var' + write(iulog,*) 'vtype = ',trim(vtype),' ?' + stop + ! end_run + end select + + end if + else + + index = 0 + end if + + return + end subroutine set_history_var + + ! ==================================================================================== + + subroutine init_iovar_dk_maps(this,nclumps) + + ! ---------------------------------------------------------------------------------- + ! This subroutine simply initializes the structures that define the different + ! array and type formats for different IO variables + ! + ! PA_R8 : 1D patch scale 8-byte reals + ! SI_R8 : 1D site scale 8-byte reals + ! + ! The allocation on the structures is not dynamic and should only add up to the + ! number of entries listed here. + ! + ! note (RGK) %active is not used yet. Was intended as a check on the HLM->FATES + ! control parameter passing to ensure all active dimension types received all + ! dimensioning specifications from the host, but we currently arent using those + ! passing functions.. + ! ---------------------------------------------------------------------------------- + + ! Arguments + class(fates_hio_interface_type) :: this + integer,intent(in) :: nclumps + + ! Locals + integer :: ityp + integer, parameter :: unset_int = -999 + + allocate(this%iovar_dk(n_iovar_dk)) + print*,"1" + + ityp = 1 + this%iovar_dk(ityp)%name = 'PA_R8' + print*,"2" + this%iovar_dk(ityp)%ndims = 1 + print*,"3" + allocate(this%iovar_dk(ityp)%dimsize(this%iovar_dk(ityp)%ndims)) + print*,"4" + this%iovar_dk(ityp)%dimsize(:) = unset_int + print*,"5" + this%iovar_dk(ityp)%active = .false. + print*,"6" + nullify(this%iovar_dk(ityp)%bounds_ptr) + print*,"7" + + ityp = 2 + this%iovar_dk(ityp)%name = 'SI_R8' + this%iovar_dk(ityp)%ndims = 1 + allocate(this%iovar_dk(ityp)%dimsize(this%iovar_dk(ityp)%ndims)) + this%iovar_dk(ityp)%dimsize(:) = unset_int + this%iovar_dk(ityp)%active = .false. + nullify(this%iovar_dk(ityp)%bounds_ptr) + + ! Allocate bounds associated with patches + allocate(this%iopa_bounds%clump_lb1(nclumps)) + allocate(this%iopa_bounds%clump_ub1(nclumps)) + + ! Allocate bounds associated with sites + allocate(this%iosi_bounds%clump_lb1(nclumps)) + allocate(this%iosi_bounds%clump_ub1(nclumps)) + + ! Allocate the mapping between FATES indices and the IO indices + allocate(this%iovar_map(nclumps)) + + return + end subroutine init_iovar_dk_maps + + ! =================================================================================== + + subroutine set_bounds_map_ptrs(this,iovar_dk_name,map_ptr) + + ! arguments + class(fates_hio_interface_type) :: this + character(len=*),intent(in) :: iovar_dk_name + type(iovar_bounds_type),target :: map_ptr + + ! local + integer :: ityp + + ityp = this%iotype_index(trim(iovar_dk_name)) + + this%iovar_dk(ityp)%bounds_ptr => map_ptr + + ! With the map, we can set the first dimension size + this%iovar_dk(ityp)%dimsize(1) = this%iovar_dk(ityp)%bounds_ptr%ub1 - & + this%iovar_dk(ityp)%bounds_ptr%lb1 + 1 + + + return + end subroutine set_bounds_map_ptrs + + ! ==================================================================================== + + function iotype_index(this,iotype_name) result(ityp) + + ! argument + class(fates_hio_interface_type) :: this + character(len=*),intent(in) :: iotype_name + + ! local + integer :: ityp + + do ityp=1,n_iovar_dk + if(trim(iotype_name).eq.trim(this%iovar_dk(ityp)%name))then + return + end if + end do + write(iulog,*) 'An IOTYPE THAT DOESNT EXIST WAS SPECIFIED' + !end_run + + end function iotype_index + + + + + ! ==================================================================================== + ! DEPRECATED, TRANSITIONAL OR FUTURE CODE SECTION + ! ==================================================================================== + + !subroutine set_fates_hio_str(tag,iotype_name,iostr_val) + +! ! Arguments +! character(len=*),intent(in) :: tag +! character(len=*), optional,intent(in) :: iotype_name +! integer, optional, intent(in) :: iostr_val + +! ! local variables +! logical :: all_set +! integer, parameter :: unset_int = -999 +! real(r8), parameter :: unset_double = -999.9 +! integer :: ityp, idim + +! select case (trim(tag)) +! case('flush_to_unset') +! write(*,*) '' +! write(*,*) 'Flushing FATES IO types prior to transfer from host' +! do ityp=1,ubound(iovar_str,1) +! iovar_str(ityp)%dimsize = unset_int +! iovar_str(ityp)%active = .false. +! end do + +! case('check_allset') +! do ityp=1,ubound(iovar_str,1) +! write(*,*) 'Checking to see if ',iovar_str(ityp)%name,' IO communicators were sent to FATES' +! if(iovar_str(ityp)%active)then +! if(iovar_str(ityp)%offset .eq. unset_int) then +! write(*,*) 'FATES offset information of IO type:',iovar_str(ityp)%name +! write(*,*) 'was never set' +! ! end_run('MESSAGE') +! end if +! do idim=1,iovar_str(ityp)%ndims +! if(iovar_str(ityp)%dimsize(idim) .eq. unset_int) then +! write(*,*) 'FATES dimension information of IO type:',iovar_str(ityp)%name +! write(*,*) 'was never set' +! ! end_run('MESSAGE') +! end if +! end do +! end if +! end do +! write(*,*) 'Checked. All history IO specifications properly sent to FATES.' +! case default + +! ! Must have two arguments if this is not a check or flush +! if(present(iostr_val) .and. present(iotype_name))then +! +! ! Tag in this case is dimsize or offset +! select case (trim(tag)) +! +! case('offset') +! ityp=iotype_index(trim(iotype_name)) +! iovar_str(ityp)%offset = iostr_val +! write(*,*) 'Transfering offset for IOTYPE',iotype_name,' to FATES' + +! case('dimsize1') +! ityp=iotype_index(trim(iotype_name)) +! iovar_str(ityp)%dimsize(1) = iostr_val +! write(*,*) 'Transfering 1st dimension size for IOTYPE',iotype_name,' to FATES' + +! case('dimsize2') +! ityp=iotype_index(trim(iotype_name)) +! if(ubound(iovar_str(ityp)%dimsize,1)==1)then +! write(iulog,*) 'Transfering second dimensional bound to unallocated space' +! write(iulog,*) 'type:',iotype_name +! ! end_run +! end if +! iovar_str(ityp)%dimsize(2) = iostr_val +! write(*,*) 'Transfering 2nd dimension size for IOTYPE',iotype_name,' to FATES' + +! case('dimsize3') +! ityp=iotype_index(trim(iotype_name)) +! if(ubound(iovar_str(ityp)%dimsize,1)<3)then +! write(iulog,*) 'Transfering third dimensional bound to unallocated space' +! write(iulog,*) 'type:',iotype_name +! ! end_run +! end if +! iovar_str(ityp)%dimsize(3) = iostr_val +! write(*,*) 'Transfering 3rd dimension size for IOTYPE',iotype_name,' to FATES' + +! case default +! write(*,*) 'IO parameter not recognized:',trim(tag) +! ! end_run +! end select +! else +! write(*,*) 'no value was provided for the tag' +! end if +! +! end select +! return +! end subroutine set_fates_hio_str + + + +end module HistoryIOMod From 0d67859b47f8d9c797b98b11828d0c52298cc07d Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 18 Aug 2016 17:52:00 -0700 Subject: [PATCH 159/437] Made some syntactical improvements, also expanded dimensions to accomodate 2d variables, including ground and the scpf as registered types. 1x1 case builds and runs, no new variables entered or tested yet. --- main/HistoryIOMod.F90 | 236 ++++++++++++++++++++++++++++++++---------- 1 file changed, 180 insertions(+), 56 deletions(-) diff --git a/main/HistoryIOMod.F90 b/main/HistoryIOMod.F90 index 8ade582d..ae6b20c8 100644 --- a/main/HistoryIOMod.F90 +++ b/main/HistoryIOMod.F90 @@ -16,18 +16,19 @@ Module HistoryIOMod integer, private :: ind_hio_area_plant_pa integer, private :: ind_hio_area_treespread_pa - - integer, parameter :: n_iovar_dk = 2 - - ! This structure is allocated by thread, and there are two instances: patch and site - type iovar_bounds_type - integer :: lb1 - integer :: ub1 - integer,allocatable :: clump_lb1(:) ! lower bound of thread's portion of HIO array - integer,allocatable :: clump_ub1(:) ! upper bound of thread's portion of HIO array - end type iovar_bounds_type - + integer, parameter :: n_iovar_dk = 6 + + ! This structure is not allocated by thread, but the upper and lower boundaries + ! of the dimension for each thread is saved in the clump_ entry + type iovar_dim_type + character(len=32) :: name ! This should match the name of the dimension + integer :: lb ! lower bound + integer :: ub ! upper bound + integer,allocatable :: clump_lb(:) ! lower bound of thread's portion of HIO array + integer,allocatable :: clump_ub(:) ! upper bound of thread's portion of HIO array + end type iovar_dim_type + ! This structure is allocated by thread, and must be calculated after the FATES @@ -48,7 +49,8 @@ Module HistoryIOMod integer :: ndims ! number of dimensions in this IO type integer, allocatable :: dimsize(:) ! The size of each dimension logical :: active - type(iovar_bounds_type), pointer :: bounds_ptr + type(iovar_dim_type), pointer :: dim1_ptr + type(iovar_dim_type), pointer :: dim2_ptr end type iovar_dimkind_type @@ -58,7 +60,7 @@ Module HistoryIOMod character(len=32) :: vname character(len=24) :: units character(len=128) :: long - character(len=16) :: vtype + character(len=24) :: vtype character(len=1) :: avgflag type(iovar_dimkind_type),pointer :: iovar_dk_ptr ! Pointers (only one of these is allocated per variable) @@ -84,13 +86,22 @@ Module HistoryIOMod ! This is a structure that explains where FATES patch boundaries ! on each thread point to in the host IO array, this structure ! is allocated by number of threads - type(iovar_bounds_type) :: iopa_bounds + type(iovar_dim_type) :: iopa_dim ! This is a structure that explains where FATES patch boundaries ! on each thread point to in the host IO array, this structure ! is allocated by number of threads - type(iovar_bounds_type) :: iosi_bounds + type(iovar_dim_type) :: iosi_dim + ! This is a structure that contains the boundaries for the + ! ground level (includes rock) dimension + type(iovar_dim_type) :: iogrnd_dim + + ! This is a structure that contains the boundaries for the + ! number of size-class x pft dimension + type(iovar_dim_type) :: ioscpf_dim + + type(iovar_map_type), pointer :: iovar_map(:) contains @@ -100,8 +111,9 @@ Module HistoryIOMod procedure, public :: set_history_var procedure, public :: init_iovar_dk_maps procedure, public :: iotype_index - procedure, public :: set_bounds_map_ptrs - + procedure, public :: set_dim_ptrs + procedure, public :: get_hvar_bounds + end type fates_hio_interface_type @@ -135,8 +147,8 @@ subroutine update_history_variables(this,nc,sites,nsites,fcolumn) integer :: io_pa ! The patch index of the IO array integer :: io_pa1 ! The first patch index in the IO array for each site integer :: io_soipa - integer :: lb1,ub1 ! IO array bounds for the calling thread - integer :: ivar ! index of IO variable object vector + integer :: lb1,ub1,lb2,ub2 ! IO array bounds for the calling thread + integer :: ivar ! index of IO variable object vector type(ed_patch_type),pointer :: cpatch ! --------------------------------------------------------------------------------- @@ -146,14 +158,21 @@ subroutine update_history_variables(this,nc,sites,nsites,fcolumn) ! --------------------------------------------------------------------------------- do ivar=1,ubound(this%hvars,1) - lb1 = this%hvars(ivar)%iovar_dk_ptr%bounds_ptr%clump_lb1(nc) - ub1 = this%hvars(ivar)%iovar_dk_ptr%bounds_ptr%clump_ub1(nc) + call this%get_hvar_bounds(this%hvars(ivar),nc,lb1,ub1,lb2,ub2) select case(trim(this%hvars(ivar)%iovar_dk_ptr%name)) case('PA_R8') this%hvars(ivar)%r81d(lb1:ub1) = 0.0_r8 case('SI_R8') this%hvars(ivar)%r81d(lb1:ub1) = 0.0_r8 + case('PA_GRND_R8') + this%hvars(ivar)%r82d(lb1:ub1,lb2:ub2) = 0.0_r8 + case('PA_SCPF_R8') + this%hvars(ivar)%r82d(lb1:ub1,lb2:ub2) = 0.0_r8 + case('SI_GRND_R8') + this%hvars(ivar)%r82d(lb1:ub1,lb2:ub2) = 0.0_r8 + case('SI_SCPF_R8') + this%hvars(ivar)%r82d(lb1:ub1,lb2:ub2) = 0.0_r8 case default write(iulog,*) 'iotyp undefined while flushing history variables' stop @@ -163,16 +182,12 @@ subroutine update_history_variables(this,nc,sites,nsites,fcolumn) end do ! Perform any special flushes - - lb1 = this%hvars(ind_hio_trimming_pa)%iovar_dk_ptr%bounds_ptr%clump_lb1(nc) - ub1 = this%hvars(ind_hio_trimming_pa)%iovar_dk_ptr%bounds_ptr%clump_ub1(nc) + call this%get_hvar_bounds(this%hvars(ind_hio_trimming_pa),nc,lb1,ub1,lb2,ub2) this%hvars(ind_hio_trimming_pa)%r81d(lb1:ub1) = 1.0_r8 ! --------------------------------------------------------------------------------- ! Loop through the FATES scale hierarchy and fill the history IO arrays ! --------------------------------------------------------------------------------- - - do s = 1,nsites @@ -247,13 +262,11 @@ subroutine define_history_vars(this,callstep,nvar) avgflag='A',vtype='PA_R8',hlms='CLM:ALM',ivar=ivar, & callstep=callstep,index = ind_hio_trimming_pa) - call this%set_history_var(vname='AREA_PLANT2',units='m2', & long='area occupied by all plants', & avgflag='A',vtype='PA_R8',hlms='CLM:ALM',ivar=ivar, & callstep=callstep,index = ind_hio_area_plant_pa) - call this%set_history_var(vname='AREA_TREES2',units='m2', & long='area occupied by woody plants', & avgflag='A',vtype='PA_R8',hlms='CLM:ALM',ivar=ivar, & @@ -293,7 +306,7 @@ subroutine set_history_var(this,vname,units,long,avgflag,vtype,hlms,ivar,callste ! locals type(iovar_def_type),pointer :: hvar - integer :: ub1,lb1,ub2,ub3 ! Bounds for allocating the var + integer :: ub1,lb1,ub2,lb2 ! Bounds for allocating the var integer :: ityp if( check_hlm_list(trim(hlms),trim(cp_hlm_name)) ) then @@ -321,14 +334,21 @@ subroutine set_history_var(this,vname,units,long,avgflag,vtype,hlms,ivar,callste nullify(hvar%int2d) nullify(hvar%int3d) - lb1 = hvar%iovar_dk_ptr%bounds_ptr%lb1 - ub1 = hvar%iovar_dk_ptr%bounds_ptr%ub1 + call this%get_hvar_bounds(hvar,0,lb1,ub1,lb2,ub2) select case(trim(vtype)) case('PA_R8') allocate(hvar%r81d(lb1:ub1)) case('SI_R8') allocate(hvar%r81d(lb1:ub1)) + case('PA_GRND_R8') + allocate(hvar%r82d(lb1:ub1,lb2:ub2)) + case('PA_SCPF_R8') + allocate(hvar%r82d(lb1:ub1,lb2:ub2)) + case('SI_GRND_R8') + allocate(hvar%r82d(lb1:ub1,lb2:ub2)) + case('SI_SCPF_R8') + allocate(hvar%r82d(lb1:ub1,lb2:ub2)) case default write(iulog,*) 'Incompatible vtype passed to set_history_var' write(iulog,*) 'vtype = ',trim(vtype),' ?' @@ -345,6 +365,49 @@ subroutine set_history_var(this,vname,units,long,avgflag,vtype,hlms,ivar,callste return end subroutine set_history_var + ! ===================================================================================== + + subroutine get_hvar_bounds(this,hvar,thread,lb1,ub1,lb2,ub2) + + class(fates_hio_interface_type) :: this + type(iovar_def_type),target,intent(in) :: hvar + integer,intent(in) :: thread + integer,intent(out) :: lb1 + integer,intent(out) :: ub1 + integer,intent(out) :: lb2 + integer,intent(out) :: ub2 + + ! local + integer :: ndims + + lb1 = 0 + ub1 = 0 + lb2 = 0 + ub2 = 0 + + ndims = hvar%iovar_dk_ptr%ndims + + ! The thread = 0 case is the boundaries for the whole proc/node + if (thread==0) then + lb1 = hvar%iovar_dk_ptr%dim1_ptr%lb + ub1 = hvar%iovar_dk_ptr%dim1_ptr%ub + if(ndims>1)then + lb2 = hvar%iovar_dk_ptr%dim2_ptr%lb + ub2 = hvar%iovar_dk_ptr%dim2_ptr%ub + end if + else + lb1 = hvar%iovar_dk_ptr%dim1_ptr%clump_lb(thread) + ub1 = hvar%iovar_dk_ptr%dim1_ptr%clump_ub(thread) + if(ndims>1)then + lb2 = hvar%iovar_dk_ptr%dim2_ptr%clump_lb(thread) + ub2 = hvar%iovar_dk_ptr%dim2_ptr%clump_ub(thread) + end if + end if + + return + end subroutine get_hvar_bounds + + ! ==================================================================================== subroutine init_iovar_dk_maps(this,nclumps) @@ -374,37 +437,84 @@ subroutine init_iovar_dk_maps(this,nclumps) integer, parameter :: unset_int = -999 allocate(this%iovar_dk(n_iovar_dk)) - print*,"1" + ! 1d Patch ityp = 1 this%iovar_dk(ityp)%name = 'PA_R8' - print*,"2" this%iovar_dk(ityp)%ndims = 1 - print*,"3" allocate(this%iovar_dk(ityp)%dimsize(this%iovar_dk(ityp)%ndims)) - print*,"4" this%iovar_dk(ityp)%dimsize(:) = unset_int - print*,"5" this%iovar_dk(ityp)%active = .false. - print*,"6" - nullify(this%iovar_dk(ityp)%bounds_ptr) - print*,"7" - + nullify(this%iovar_dk(ityp)%dim1_ptr) + nullify(this%iovar_dk(ityp)%dim2_ptr) + + ! 1d Site ityp = 2 this%iovar_dk(ityp)%name = 'SI_R8' this%iovar_dk(ityp)%ndims = 1 allocate(this%iovar_dk(ityp)%dimsize(this%iovar_dk(ityp)%ndims)) this%iovar_dk(ityp)%dimsize(:) = unset_int this%iovar_dk(ityp)%active = .false. - nullify(this%iovar_dk(ityp)%bounds_ptr) + nullify(this%iovar_dk(ityp)%dim1_ptr) + nullify(this%iovar_dk(ityp)%dim2_ptr) + + ! patch x ground + ityp = 3 + this%iovar_dk(ityp)%name = 'PA_GRND_R8' + this%iovar_dk(ityp)%ndims = 2 + allocate(this%iovar_dk(ityp)%dimsize(this%iovar_dk(ityp)%ndims)) + this%iovar_dk(ityp)%dimsize(:) = unset_int + this%iovar_dk(ityp)%active = .false. + nullify(this%iovar_dk(ityp)%dim1_ptr) + nullify(this%iovar_dk(ityp)%dim2_ptr) + + ! patch x size-class/pft + ityp = 4 + this%iovar_dk(ityp)%name = 'PA_SCPF_R8' + this%iovar_dk(ityp)%ndims = 2 + allocate(this%iovar_dk(ityp)%dimsize(this%iovar_dk(ityp)%ndims)) + this%iovar_dk(ityp)%dimsize(:) = unset_int + this%iovar_dk(ityp)%active = .false. + nullify(this%iovar_dk(ityp)%dim1_ptr) + nullify(this%iovar_dk(ityp)%dim2_ptr) + + ! site x ground + ityp = 5 + this%iovar_dk(ityp)%name = 'SI_GRND_R8' + this%iovar_dk(ityp)%ndims = 2 + allocate(this%iovar_dk(ityp)%dimsize(this%iovar_dk(ityp)%ndims)) + this%iovar_dk(ityp)%dimsize(:) = unset_int + this%iovar_dk(ityp)%active = .false. + nullify(this%iovar_dk(ityp)%dim1_ptr) + nullify(this%iovar_dk(ityp)%dim2_ptr) + + ! site x size-class/pft + ityp = 6 + this%iovar_dk(ityp)%name = 'SI_SCPF_R8' + this%iovar_dk(ityp)%ndims = 2 + allocate(this%iovar_dk(ityp)%dimsize(this%iovar_dk(ityp)%ndims)) + this%iovar_dk(ityp)%dimsize(:) = unset_int + this%iovar_dk(ityp)%active = .false. + nullify(this%iovar_dk(ityp)%dim1_ptr) + nullify(this%iovar_dk(ityp)%dim2_ptr) - ! Allocate bounds associated with patches - allocate(this%iopa_bounds%clump_lb1(nclumps)) - allocate(this%iopa_bounds%clump_ub1(nclumps)) - ! Allocate bounds associated with sites - allocate(this%iosi_bounds%clump_lb1(nclumps)) - allocate(this%iosi_bounds%clump_ub1(nclumps)) + ! Allocate thread bounds associated with patches + allocate(this%iopa_dim%clump_lb(nclumps)) + allocate(this%iopa_dim%clump_ub(nclumps)) + + ! Allocate thread bounds associated with sites + allocate(this%iosi_dim%clump_lb(nclumps)) + allocate(this%iosi_dim%clump_ub(nclumps)) + + ! Allocate thread bounds associated with ground levels + allocate(this%iogrnd_dim%clump_lb(nclumps)) + allocate(this%iogrnd_dim%clump_ub(nclumps)) + + ! Allocate thread bounds associated with size-class/pft + allocate(this%ioscpf_dim%clump_lb(nclumps)) + allocate(this%ioscpf_dim%clump_ub(nclumps)) + ! Allocate the mapping between FATES indices and the IO indices allocate(this%iovar_map(nclumps)) @@ -414,27 +524,41 @@ end subroutine init_iovar_dk_maps ! =================================================================================== - subroutine set_bounds_map_ptrs(this,iovar_dk_name,map_ptr) + subroutine set_dim_ptrs(this,dk_name,idim,dim_target) ! arguments class(fates_hio_interface_type) :: this - character(len=*),intent(in) :: iovar_dk_name - type(iovar_bounds_type),target :: map_ptr + character(len=*),intent(in) :: dk_name + integer,intent(in) :: idim ! dimension index + type(iovar_dim_type),target :: dim_target + ! local integer :: ityp - ityp = this%iotype_index(trim(iovar_dk_name)) + ityp = this%iotype_index(trim(dk_name)) - this%iovar_dk(ityp)%bounds_ptr => map_ptr + ! First check to see if the dimension is allocated + if(this%iovar_dk(ityp)%ndims dim_target + elseif(idim==2) then + this%iovar_dk(ityp)%dim2_ptr => dim_target + end if + + ! With the map, we can set the dimension size + this%iovar_dk(ityp)%dimsize(idim) = dim_target%ub - dim_target%lb + 1 return - end subroutine set_bounds_map_ptrs + end subroutine set_dim_ptrs ! ==================================================================================== From e4098b528f9607bfbe23f3aabbf18d61b7f4adf7 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 19 Aug 2016 00:19:35 -0700 Subject: [PATCH 160/437] Added some functions in the interface for setting dimension info. --- main/HistoryIOMod.F90 | 58 +++++++++++++++++++++++++++++-------------- 1 file changed, 39 insertions(+), 19 deletions(-) diff --git a/main/HistoryIOMod.F90 b/main/HistoryIOMod.F90 index ae6b20c8..c550f9d8 100644 --- a/main/HistoryIOMod.F90 +++ b/main/HistoryIOMod.F90 @@ -113,6 +113,8 @@ Module HistoryIOMod procedure, public :: iotype_index procedure, public :: set_dim_ptrs procedure, public :: get_hvar_bounds + procedure, public :: dim_init + procedure, public :: set_dim_thread_bounds end type fates_hio_interface_type @@ -410,7 +412,7 @@ end subroutine get_hvar_bounds ! ==================================================================================== - subroutine init_iovar_dk_maps(this,nclumps) + subroutine init_iovar_dk_maps(this) ! ---------------------------------------------------------------------------------- ! This subroutine simply initializes the structures that define the different @@ -430,7 +432,6 @@ subroutine init_iovar_dk_maps(this,nclumps) ! Arguments class(fates_hio_interface_type) :: this - integer,intent(in) :: nclumps ! Locals integer :: ityp @@ -499,25 +500,9 @@ subroutine init_iovar_dk_maps(this,nclumps) nullify(this%iovar_dk(ityp)%dim2_ptr) - ! Allocate thread bounds associated with patches - allocate(this%iopa_dim%clump_lb(nclumps)) - allocate(this%iopa_dim%clump_ub(nclumps)) - - ! Allocate thread bounds associated with sites - allocate(this%iosi_dim%clump_lb(nclumps)) - allocate(this%iosi_dim%clump_ub(nclumps)) - - ! Allocate thread bounds associated with ground levels - allocate(this%iogrnd_dim%clump_lb(nclumps)) - allocate(this%iogrnd_dim%clump_ub(nclumps)) + - ! Allocate thread bounds associated with size-class/pft - allocate(this%ioscpf_dim%clump_lb(nclumps)) - allocate(this%ioscpf_dim%clump_ub(nclumps)) - - ! Allocate the mapping between FATES indices and the IO indices - allocate(this%iovar_map(nclumps)) return end subroutine init_iovar_dk_maps @@ -581,8 +566,43 @@ function iotype_index(this,iotype_name) result(ityp) end function iotype_index + ! ===================================================================================== + subroutine dim_init(this,iovar_dim,dim_name,nthreads,lb_in,ub_in) + + ! arguments + class(fates_hio_interface_type) :: this + type(iovar_dim_type),target :: iovar_dim + character(len=*),intent(in) :: dim_name + integer,intent(in) :: nthreads + integer,intent(in) :: lb_in + integer,intent(in) :: ub_in + + allocate(iovar_dim%clump_lb(nthreads)) + allocate(iovar_dim%clump_ub(nthreads)) + + iovar_dim%name = trim(dim_name) + iovar_dim%lb = lb_in + iovar_dim%ub = ub_in + return + end subroutine dim_init + + ! ===================================================================================== + + subroutine set_dim_thread_bounds(this,iovar_dim,nc,lb_in,ub_in) + + class(fates_hio_interface_type) :: this + type(iovar_dim_type),target :: iovar_dim + integer,intent(in) :: nc ! Thread index + integer,intent(in) :: lb_in + integer,intent(in) :: ub_in + + iovar_dim%clump_lb(nc) = lb_in + iovar_dim%clump_ub(nc) = ub_in + + return + end subroutine set_dim_thread_bounds ! ==================================================================================== ! DEPRECATED, TRANSITIONAL OR FUTURE CODE SECTION From 0051af736f3a33e2f8f90af7d155c28565c7be34 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 19 Aug 2016 14:40:40 -0700 Subject: [PATCH 161/437] incremental changes towards adding more variables, and adding a flushing specifier. --- main/HistoryIOMod.F90 | 222 +++++++++++++++++++++++++++++++++--------- 1 file changed, 174 insertions(+), 48 deletions(-) diff --git a/main/HistoryIOMod.F90 b/main/HistoryIOMod.F90 index c550f9d8..cb0f2945 100644 --- a/main/HistoryIOMod.F90 +++ b/main/HistoryIOMod.F90 @@ -1,24 +1,127 @@ Module HistoryIOMod - use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_kind_mod , only : r8 => shr_kind_r8 use clm_varctl , only : iulog implicit none - ! These variables hold the index of the history output structure so we don't ! have to constantly do name lookup when we want to populate the dataset ! These indices are set during "define_history_vars()" call to "set_history_var()" - ! during the initialize phase. + ! during the initialize phase. Definitions are not provide, for an explanation of + ! the variable go to its registry. (IH_ signifies "index history") - integer, private :: ind_hio_trimming_pa - integer, private :: ind_hio_area_plant_pa - integer, private :: ind_hio_area_treespread_pa - - + ! Indices to 1D Patch variables + + integer, private :: ih_trimming_pa + integer, private :: ih_area_plant_pa + integer, private :: ih_area_treespread_pa + integer, private :: ih_canopy_spread_pa + integer, private :: ih_nesterov_fire_danger_pa + integer, private :: ih_spitfire_ROS_pa + integer, private :: ih_effect_wspeed_pa + integer, private :: ih_TFC_ROS_pa + integer, private :: ih_fire_intensity_pa + integer, private :: ih_fire_area_pa + integer, private :: ih_scorch_height_pa + integer, private :: ih_fire_fuel_bulkd_pa + integer, private :: ih_fire_fuel_eff_moist_pa + integer, private :: ih_fire_fuel_sav_pa + integer, private :: ih_fire_fuel_mef_pa + integer, private :: ih_sum_fuel_pa + integer, private :: ih_litter_in_pa + integer, private :: ih_litter_out_pa + integer, private :: ih_efpot_pa ! NA + integer, private :: ih_rb_pa ! NA + integer, private :: ih_daily_temp + integer, private :: ih_daily_rh + integer, private :: ih_daily_prec + integer, private :: ih_seed_bank + integer, private :: ih_seeds_in + integer, private :: ih_seed_decay + integer, private :: ih_seed_germination + integer, private :: ih_bstore + integer, private :: ih_bdead + integer, private :: ih_balive + integer, private :: ih_bleaf + integer, private :: ih_biomass + integer, private :: ih_npp + integer, private :: ih_gpp + integer, private :: ih_autotr_resp + integer, private :: ih_maint_resp + integer, private :: ih_growth_resp + + ! Indices to (patch x pft) variables (using nlevgrnd as surrogate) + + integer, private :: ih_biomass_pa_pft + integer, private :: ih_leafbiomass_pa_pft + integer, private :: ih_storebiomass_pa_pft + integer, private :: ih_nindivs_pa_pft + + ! Indices to (site) variables + + integer, private :: ih_nep_si + integer, private :: ih_nep_timeintegrated_si + integer, private :: ih_npp_timeintegrated_si + integer, private :: ih_hr_timeintegrated_si + integer, private :: ih_nbp_si + integer, private :: ih_npp_si + integer, private :: ih_fire_c_to_atm_si + integer, private :: ih_ed_to_bgc_this_edts_si + integer, private :: ih_ed_to_bgc_last_edts_si + integer, private :: ih_seed_rain_flux_si + integer, private :: ih_totecosysc_si + integer, private :: ih_totecosysc_old_si + integer, private :: ih_totedc_si + integer, private :: ih_totedc_old_si + integer, private :: ih_totbgcc_si + integer, private :: ih_totbgcc_old_si + integer, private :: ih_biomass_stock_si + integer, private :: ih_ed_litter_stock_si + integer, private :: ih_cwd_stock_si + integer, private :: ih_seed_stock_si + integer, private :: ih_cbalance_error_ed_si + integer, private :: ih_cbalance_error_bgc_si + integer, private :: ih_cbalance_error_total_si + integer, private :: ih_ed_npatches_si + integer, private :: ih_ed_ncohorts_si + + ! Indices to (site x scpf) variables + + integer, private :: ih_gpp_si_scpf + integer, private :: ih_npp_totl_si_scpf + integer, private :: ih_npp_leaf_si_scpf + integer, private :: ih_npp_seed_si_scpf + integer, private :: ih_npp_fnrt_si_scpf + integer, private :: ih_npp_bgsw_si_scpf + integer, private :: ih_npp_bgdw_si_scpf + integer, private :: ih_npp_agsw_si_scpf + integer, private :: ih_npp_agdw_si_scpf + integer, private :: ih_npp_stor_si_scpf + integer, private :: ih_litt_leaf_si_scpf + integer, private :: ih_litt_fnrt_si_scpf + integer, private :: ih_litt_sawd_si_scpf + integer, private :: ih_litt_ddwd_si_scpf + integer, private :: ih_r_leaf_si_scpf + integer, private :: ih_r_stem_si_scpf + integer, private :: ih_r_root_si_scpf + integer, private :: ih_r_stor_si_scpf + + integer, private :: ih_ddbh_si_scpf + integer, private :: ih_ba_si_scpf + integer, private :: ih_np_si_scpf + integer, private :: ih_m1_si_scpf + integer, private :: ih_m2_si_scpf + integer, private :: ih_m3_si_scpf + integer, private :: ih_m4_si_scpf + integer, private :: ih_m5_si_scpf + + + ! The number of variable dim/kind types we have defined (static) integer, parameter :: n_iovar_dk = 6 + ! This structure is not allocated by thread, but the upper and lower boundaries ! of the dimension for each thread is saved in the clump_ entry type iovar_dim_type @@ -62,6 +165,7 @@ Module HistoryIOMod character(len=128) :: long character(len=24) :: vtype character(len=1) :: avgflag + real(r8) :: flushval type(iovar_dimkind_type),pointer :: iovar_dk_ptr ! Pointers (only one of these is allocated per variable) real(r8), pointer :: r81d(:) @@ -144,48 +248,50 @@ subroutine update_history_variables(this,nc,sites,nsites,fcolumn) ! Locals integer :: s ! The local site index - integer :: io_s ! The site index of the IO array + integer :: io_si ! The site index of the IO array integer :: ipa ! The local "I"ndex of "PA"tches integer :: io_pa ! The patch index of the IO array integer :: io_pa1 ! The first patch index in the IO array for each site integer :: io_soipa integer :: lb1,ub1,lb2,ub2 ! IO array bounds for the calling thread integer :: ivar ! index of IO variable object vector + type(iovar_def_type),pointer :: hvar type(ed_patch_type),pointer :: cpatch ! --------------------------------------------------------------------------------- - ! Flush arrays to zero + ! Flush arrays to pre-defined values ! INTERF-TODO: We need to define a flush type, some variables may not want to ! average in zero's for patches that are ! --------------------------------------------------------------------------------- do ivar=1,ubound(this%hvars,1) - - call this%get_hvar_bounds(this%hvars(ivar),nc,lb1,ub1,lb2,ub2) - - select case(trim(this%hvars(ivar)%iovar_dk_ptr%name)) + hvar => this%hvars(ivar) + call this%get_hvar_bounds(hvar,nc,lb1,ub1,lb2,ub2) + select case(trim(hvar%iovar_dk_ptr%name)) case('PA_R8') - this%hvars(ivar)%r81d(lb1:ub1) = 0.0_r8 + hvar%r81d(lb1:ub1) = hvar%flushval case('SI_R8') - this%hvars(ivar)%r81d(lb1:ub1) = 0.0_r8 + hvar%r81d(lb1:ub1) = hvar%flushval case('PA_GRND_R8') - this%hvars(ivar)%r82d(lb1:ub1,lb2:ub2) = 0.0_r8 + hvar%r82d(lb1:ub1,lb2:ub2) = hvar%flushval case('PA_SCPF_R8') - this%hvars(ivar)%r82d(lb1:ub1,lb2:ub2) = 0.0_r8 + hvar%r82d(lb1:ub1,lb2:ub2) = hvar%flushval case('SI_GRND_R8') - this%hvars(ivar)%r82d(lb1:ub1,lb2:ub2) = 0.0_r8 + hvar%r82d(lb1:ub1,lb2:ub2) = hvar%flushval case('SI_SCPF_R8') - this%hvars(ivar)%r82d(lb1:ub1,lb2:ub2) = 0.0_r8 + hvar%r82d(lb1:ub1,lb2:ub2) = hvar%flushval + case('PA_INT') + hvar%int1d(lb1:ub1) = nint(hvar%flushval) case default write(iulog,*) 'iotyp undefined while flushing history variables' stop !end_run end select - end do - ! Perform any special flushes - call this%get_hvar_bounds(this%hvars(ind_hio_trimming_pa),nc,lb1,ub1,lb2,ub2) - this%hvars(ind_hio_trimming_pa)%r81d(lb1:ub1) = 1.0_r8 + + ! Perform flushes or initializations over the FATES-only space? + ! --------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------- ! Loop through the FATES scale hierarchy and fill the history IO arrays @@ -193,12 +299,12 @@ subroutine update_history_variables(this,nc,sites,nsites,fcolumn) do s = 1,nsites - io_s = this%iovar_map(nc)%site_index(s) + io_si = this%iovar_map(nc)%site_index(s) io_pa1 = this%iovar_map(nc)%patch1_index(s) io_soipa = io_pa1-1 - ! TRIMMING2 (soil patch): ind_hio_trimming_pa - this%hvars(ind_hio_trimming_pa)%r81d(io_soipa) = 1.0_r8 + ! TRIMMING2 (soil patch): ih_trimming_pa + this%hvars(ih_trimming_pa)%r81d(io_soipa) = 1.0_r8 ipa = 0 cpatch => sites(s)%oldest_patch @@ -206,22 +312,22 @@ subroutine update_history_variables(this,nc,sites,nsites,fcolumn) io_pa = io_pa1 + ipa - ! TRIMMING2: ind_hio_trimming_pa + ! ih_trimming_pa if(associated(cpatch%tallest))then - this%hvars(ind_hio_trimming_pa)%r81d(io_pa) = cpatch%tallest%canopy_trim + this%hvars(ih_trimming_pa)%r81d(io_pa) = cpatch%tallest%canopy_trim else - this%hvars(ind_hio_trimming_pa)%r81d(io_pa) = 0.0_r8 + this%hvars(ih_trimming_pa)%r81d(io_pa) = 0.0_r8 endif - ! AREA_PLANT2: ind_hio_area_plant_pa - this%hvars(ind_hio_area_plant_pa)%r81d(io_pa) = 1._r8 + ! ih_area_plant_pa + this%hvars(ih_area_plant_pa)%r81d(io_pa) = 1._r8 - ! AREA_TREES: ind_hio_area_treespread_pa + ! AREA_TREES: ih_area_treespread_pa if (min(cpatch%total_canopy_area,cpatch%area)>0.0_r8) then - this%hvars(ind_hio_area_treespread_pa)%r81d(io_pa) = cpatch%total_tree_area & + this%hvars(ih_area_treespread_pa)%r81d(io_pa) = cpatch%total_tree_area & / min(cpatch%total_canopy_area,cpatch%area) else - this%hvars(ind_hio_area_treespread_pa)%r81d(io_pa) = 0.0_r8 + this%hvars(ih_area_treespread_pa)%r81d(io_pa) = 0.0_r8 end if @@ -239,6 +345,9 @@ end subroutine update_history_variables subroutine define_history_vars(this,callstep,nvar) ! --------------------------------------------------------------------------------- + ! + ! REGISTRY OF HISTORY OUTPUT VARIABLES + ! ! This subroutine is called in two contexts, either in count mode or inialize mode ! In count mode, we just walk through the list of registerred variables, compare ! if the variable of interest list the current host model and add it to the count @@ -246,7 +355,22 @@ subroutine define_history_vars(this,callstep,nvar) ! has been done, we go through the list a second time populating a memory structure. ! This phase is the "initialize" phase. These two phases are differntiated by the ! string "callstep", which should be either "count" or "initialize". + ! + ! Note 1 there are different ways you can flush or initialize the output fields. + ! If you flush to a native type, (such as zero), the entire slab which covers + ! indices which may not be relevant to FATES, are flushed to this value. So + ! in that case, lakes and crops that are not controlled by FATES will zero'd + ! and when values are scaled up to the land-grid, the zero's for non FATES will + ! be included. This is good and correct if nothing is there. + ! + ! But, what if crops exist in the host model and occupy a fraction of the land-surface + ! shared with natural vegetation? In that case, you want to flush your arrays + ! with a value that the HLM treats as "do not average" + ! + ! If your HLM makes use of, and you want, INTEGER OUTPUT, pass the flushval as + ! a real. The applied flush value will use the NINT() intrinsic function ! --------------------------------------------------------------------------------- + class(fates_hio_interface_type) :: this character(len=*),intent(in) :: callstep ! are we 'count'ing or 'initializ'ing? integer,optional,intent(out) :: nvar @@ -259,20 +383,20 @@ subroutine define_history_vars(this,callstep,nvar) end if ivar=0 - call this%set_history_var(vname='TRIMMING2',units='none', & - long='Degree to which canopy expansion is limited by leaf economics', & - avgflag='A',vtype='PA_R8',hlms='CLM:ALM',ivar=ivar, & - callstep=callstep,index = ind_hio_trimming_pa) + call this%set_history_var(vname='TRIMMING2',units='none', & + long='Degree to which canopy expansion is limited by leaf economics', & + avgflag='A',vtype='PA_R8',hlms='CLM:ALM',flushval=1.0_r8, ivar=ivar, & + callstep=callstep,index = ih_trimming_pa) - call this%set_history_var(vname='AREA_PLANT2',units='m2', & - long='area occupied by all plants', & - avgflag='A',vtype='PA_R8',hlms='CLM:ALM',ivar=ivar, & - callstep=callstep,index = ind_hio_area_plant_pa) + call this%set_history_var(vname='AREA_PLANT2',units='m2', & + long='area occupied by all plants', & + avgflag='A',vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8,ivar=ivar, & + callstep=callstep,index = ih_area_plant_pa) - call this%set_history_var(vname='AREA_TREES2',units='m2', & - long='area occupied by woody plants', & - avgflag='A',vtype='PA_R8',hlms='CLM:ALM',ivar=ivar, & - callstep=callstep,index = ind_hio_area_treespread_pa) + call this%set_history_var(vname='AREA_TREES2',units='m2', & + long='area occupied by woody plants', & + avgflag='A',vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8,ivar=ivar, & + callstep=callstep,index = ih_area_treespread_pa) ! Must be last thing before return @@ -284,7 +408,7 @@ end subroutine define_history_vars ! ===================================================================================== - subroutine set_history_var(this,vname,units,long,avgflag,vtype,hlms,ivar,callstep,index) + subroutine set_history_var(this,vname,units,long,avgflag,vtype,hlms,flushval,ivar,callstep,index) use FatesUtilsMod, only : check_hlm_list @@ -298,6 +422,7 @@ subroutine set_history_var(this,vname,units,long,avgflag,vtype,hlms,ivar,callste character(len=*),intent(in) :: avgflag character(len=*),intent(in) :: vtype character(len=*),intent(in) :: hlms + real(r8),intent(in) :: flushval ! IF THE TYPE IS AN INT WE WILL round with NINT character(len=*),intent(in) :: callstep integer, intent(inout) :: ivar integer, intent(inout) :: index ! This is the index for the variable of @@ -324,6 +449,7 @@ subroutine set_history_var(this,vname,units,long,avgflag,vtype,hlms,ivar,callste hvar%long = long hvar%vtype = vtype hvar%avgflag = avgflag + hvar%flushval = flushval ityp=this%iotype_index(trim(vtype)) hvar%iovar_dk_ptr => this%iovar_dk(ityp) From f9ad677096d139242b7e923867f073e71ed2d2ca Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 22 Aug 2016 14:31:43 -0700 Subject: [PATCH 162/437] Added patchxpft variables to the update function, added aliases to the update function. Testing' --- main/HistoryIOMod.F90 | 128 +++++++++++++++++++++++++++++++++--------- 1 file changed, 103 insertions(+), 25 deletions(-) diff --git a/main/HistoryIOMod.F90 b/main/HistoryIOMod.F90 index cb0f2945..eee9efb1 100644 --- a/main/HistoryIOMod.F90 +++ b/main/HistoryIOMod.F90 @@ -238,7 +238,8 @@ subroutine update_history_variables(this,nc,sites,nsites,fcolumn) use EDtypesMod , only : ed_site_type, & ed_cohort_type, & - ed_patch_type + ed_patch_type, & + AREA ! Arguments class(fates_hio_interface_type) :: this integer , intent(in) :: nc ! clump index @@ -255,14 +256,29 @@ subroutine update_history_variables(this,nc,sites,nsites,fcolumn) integer :: io_soipa integer :: lb1,ub1,lb2,ub2 ! IO array bounds for the calling thread integer :: ivar ! index of IO variable object vector + integer :: ft ! functional type index + real(r8) :: n_density ! individual of cohort per m2. + real(r8) :: n_perm2 ! individuals per m2 for the whole column + real(r8) :: patch_scaling_scalar ! ratio of canopy to patch area for counteracting patch scaling + type(iovar_def_type),pointer :: hvar - type(ed_patch_type),pointer :: cpatch + type(ed_patch_type),pointer :: cpatch + type(ed_cohort_type),pointer :: ccohort + + associate( hio_trimming_pa => this%hvars(ih_trimming_pa)%r81d, & + hio_area_plant_pa => this%hvars(ih_area_plant_pa)%r81d, & + hio_area_treespread_pa => this%hvars(ih_area_treespread_pa)%r81d, & + hio_biomass_pa_pft => this%hvars(ih_biomass_pa_pft)%r82d, & + hio_leafbiomass_pa_pft => this%hvars(ih_leafbiomass_pa_pft)%r82d, & + hio_storebiomass_pa_pft => this%hvars(ih_storebiomass_pa_pft)%r82d, & + hio_nindivs_pa_pft => this%hvars(ih_nindivs_pa_pft)%r82d ) + ! --------------------------------------------------------------------------------- - ! Flush arrays to pre-defined values - ! INTERF-TODO: We need to define a flush type, some variables may not want to - ! average in zero's for patches that are + ! Flush arrays to values defined by %flushval (see registry entry in + ! subroutine define_history_vars() ! --------------------------------------------------------------------------------- + do ivar=1,ubound(this%hvars,1) hvar => this%hvars(ivar) call this%get_hvar_bounds(hvar,nc,lb1,ub1,lb2,ub2) @@ -303,8 +319,10 @@ subroutine update_history_variables(this,nc,sites,nsites,fcolumn) io_pa1 = this%iovar_map(nc)%patch1_index(s) io_soipa = io_pa1-1 - ! TRIMMING2 (soil patch): ih_trimming_pa - this%hvars(ih_trimming_pa)%r81d(io_soipa) = 1.0_r8 + + ! Set trimming on the soil patch to 1.0 + hio_trimming_pa(io_soipa) = 1.0_r8 + ipa = 0 cpatch => sites(s)%oldest_patch @@ -312,24 +330,58 @@ subroutine update_history_variables(this,nc,sites,nsites,fcolumn) io_pa = io_pa1 + ipa - ! ih_trimming_pa - if(associated(cpatch%tallest))then - this%hvars(ih_trimming_pa)%r81d(io_pa) = cpatch%tallest%canopy_trim - else - this%hvars(ih_trimming_pa)%r81d(io_pa) = 0.0_r8 - endif - - ! ih_area_plant_pa - this%hvars(ih_area_plant_pa)%r81d(io_pa) = 1._r8 - - ! AREA_TREES: ih_area_treespread_pa - if (min(cpatch%total_canopy_area,cpatch%area)>0.0_r8) then - this%hvars(ih_area_treespread_pa)%r81d(io_pa) = cpatch%total_tree_area & - / min(cpatch%total_canopy_area,cpatch%area) - else - this%hvars(ih_area_treespread_pa)%r81d(io_pa) = 0.0_r8 - end if - + ccohort => cpatch%shortest + do while(associated(ccohort)) + + ft = ccohort%pft + + if ((cpatch%area .gt. 0._r8) .and. (cpatch%total_canopy_area .gt. 0._r8)) then + + ! for quantities that are at the CLM patch level, because of the way + ! that CLM patches are weighted for radiative purposes this # density needs + ! to be over either ED patch canopy area or ED patch total area, whichever is less + n_density = ccohort%n/min(cpatch%area,cpatch%total_canopy_area) + + ! for quantities that are natively at column level, calculate plant + ! density using whole area + n_perm2 = ccohort%n/AREA + + else + n_density = 0.0_r8 + n_perm2 = 0.0_r8 + endif + + if(associated(cpatch%tallest))then + hio_trimming_pa(io_pa) = cpatch%tallest%canopy_trim + else + hio_trimming_pa(io_pa) = 0.0_r8 + endif + + hio_area_plant_pa(io_pa) = 1.0_r8 + + if (min(cpatch%total_canopy_area,cpatch%area)>0.0_r8) then + hio_area_treespread_pa(io_pa) = cpatch%total_tree_area & + / min(cpatch%total_canopy_area,cpatch%area) + else + hio_area_treespread_pa(io_pa) = 0.0_r8 + end if + + + hio_biomass_pa_pft(io_pa,ft) = hio_biomass_pa_pft(io_pa,ft) + & + n_density * ccohort%b * 1.e3_r8 + + hio_leafbiomass_pa_pft(io_pa,ft) = hio_leafbiomass_pa_pft(io_pa,ft) + & + n_density * ccohort%bl * 1.e3_r8 + + hio_storebiomass_pa_pft(io_pa,ft) = hio_storebiomass_pa_pft(io_pa,ft) + & + n_density * ccohort%bstore * 1.e3_r8 + + hio_nindivs_pa_pft(io_pa,ft) = hio_nindivs_pa_pft(io_pa,ft) + & + ccohort%n + + + ccohort => ccohort%taller + enddo ! cohort loop ipa = ipa + 1 cpatch => cpatch%younger @@ -337,6 +389,8 @@ subroutine update_history_variables(this,nc,sites,nsites,fcolumn) enddo ! site loop + end associate + return end subroutine update_history_variables @@ -398,6 +452,30 @@ subroutine define_history_vars(this,callstep,nvar) avgflag='A',vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8,ivar=ivar, & callstep=callstep,index = ih_area_treespread_pa) + call this%set_history_var(vname='CANOPY_SPREAD2',units='0-1', & + long='Scaling factor between tree basal area and canopy area', & + avgflag='A',vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8,ivar=ivar, & + callstep=callstep,index = ih_canopy_spread_pa) + + call this%set_history_var(vname='PFTBIOMASS2',units='gC/m2', & + long='total PFT level biomass', & + avgflag='A', vtype='PA_GRND_R8',hlms='CLM:ALM',flushval=0.0_r8, & + ivar=ivar,callstep=callstep, index = ih_biomass_pa_pft ) + + call this%set_history_var(vname='PFTLEAFBIOMASS2', units='gC/m2', & + long='total PFT level leaf biomass', & + avgflag='A', vtype='PA_GRND_R8',hlms='CLM:ALM',flushval=0.0_r8, & + ivar=ivar,callstep=callstep, index = ih_leafbiomass_pa_pft ) + + call this%set_history_var(vname='PFTSTOREBIOMASS2', units='gC/m2', & + long='total PFT level stored biomass', & + avgflag='A', vtype='PA_GRND_R8',hlms='CLM:ALM',flushval=0.0_r8, & + ivar=ivar,callstep=callstep, index = ih_storebiomass_pa_pft ) + + call this%set_history_var(vname='PFTNINDIVS2', units='indiv / m2', & + long='total PFT level number of individuals', & + avgflag='A', vtype='PA_GRND_R8',hlms='CLM:ALM',flushval=0.0_r8, & + ivar=ivar,callstep=callstep, index = ih_nindivs_pa_pft ) ! Must be last thing before return if(present(nvar)) nvar = ivar From c3717f07455baa2329942ca96a1c5525e558e5f8 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 22 Aug 2016 15:37:35 -0700 Subject: [PATCH 163/437] intoduced some 2d variables. Testing started by comparing new variables with old. Simple python script was created to go through each variable and calculate an RMS, much like cprnc, but just more simple. --- main/HistoryIOMod.F90 | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/main/HistoryIOMod.F90 b/main/HistoryIOMod.F90 index eee9efb1..e4102584 100644 --- a/main/HistoryIOMod.F90 +++ b/main/HistoryIOMod.F90 @@ -268,7 +268,8 @@ subroutine update_history_variables(this,nc,sites,nsites,fcolumn) associate( hio_trimming_pa => this%hvars(ih_trimming_pa)%r81d, & hio_area_plant_pa => this%hvars(ih_area_plant_pa)%r81d, & - hio_area_treespread_pa => this%hvars(ih_area_treespread_pa)%r81d, & + hio_area_treespread_pa => this%hvars(ih_area_treespread_pa)%r81d, & + hio_canopy_spread_pa => this%hvars(ih_canopy_spread_pa)%r81d, & hio_biomass_pa_pft => this%hvars(ih_biomass_pa_pft)%r82d, & hio_leafbiomass_pa_pft => this%hvars(ih_leafbiomass_pa_pft)%r82d, & hio_storebiomass_pa_pft => this%hvars(ih_storebiomass_pa_pft)%r82d, & @@ -383,6 +384,12 @@ subroutine update_history_variables(this,nc,sites,nsites,fcolumn) ccohort => ccohort%taller enddo ! cohort loop + + hio_canopy_spread_pa(io_pa) = cpatch%spread(1) + + + + ipa = ipa + 1 cpatch => cpatch%younger end do !patch loop From f3e3728bd29e2c76332a5a3f6fd5b339901fa688 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 22 Aug 2016 16:36:05 -0700 Subject: [PATCH 164/437] added a block of fire history variables. Tests passed. --- main/HistoryIOMod.F90 | 102 +++++++++++++++++++++++++++++++++++++++--- 1 file changed, 97 insertions(+), 5 deletions(-) diff --git a/main/HistoryIOMod.F90 b/main/HistoryIOMod.F90 index e4102584..6cca651a 100644 --- a/main/HistoryIOMod.F90 +++ b/main/HistoryIOMod.F90 @@ -273,7 +273,19 @@ subroutine update_history_variables(this,nc,sites,nsites,fcolumn) hio_biomass_pa_pft => this%hvars(ih_biomass_pa_pft)%r82d, & hio_leafbiomass_pa_pft => this%hvars(ih_leafbiomass_pa_pft)%r82d, & hio_storebiomass_pa_pft => this%hvars(ih_storebiomass_pa_pft)%r82d, & - hio_nindivs_pa_pft => this%hvars(ih_nindivs_pa_pft)%r82d ) + hio_nindivs_pa_pft => this%hvars(ih_nindivs_pa_pft)%r82d, & + hio_nesterov_fire_danger_pa => this%hvars(ih_nesterov_fire_danger_pa)%r81d, & + hio_spitfire_ros_pa => this%hvars(ih_spitfire_ROS_pa)%r81d, & + hio_tfc_ros_pa => this%hvars(ih_TFC_ROS_pa)%r81d, & + hio_effect_wspeed_pa => this%hvars(ih_effect_wspeed_pa)%r81d, & + hio_fire_intensity_pa => this%hvars(ih_fire_intensity_pa)%r81d, & + hio_fire_area_pa => this%hvars(ih_fire_area_pa)%r81d, & + hio_scorch_height_pa => this%hvars(ih_scorch_height_pa)%r81d, & + hio_fire_fuel_bulkd_pa => this%hvars(ih_fire_fuel_bulkd_pa)%r81d, & + hio_fire_fuel_eff_moist_pa => this%hvars(ih_fire_fuel_eff_moist_pa)%r81d, & + hio_fire_fuel_sav_pa => this%hvars(ih_fire_fuel_sav_pa)%r81d, & + hio_fire_fuel_mef_pa => this%hvars(ih_fire_fuel_mef_pa)%r81d, & + hio_sum_fuel_pa => this%hvars(ih_sum_fuel_pa)%r81d ) ! --------------------------------------------------------------------------------- ! Flush arrays to values defined by %flushval (see registry entry in @@ -384,10 +396,30 @@ subroutine update_history_variables(this,nc,sites,nsites,fcolumn) ccohort => ccohort%taller enddo ! cohort loop - - hio_canopy_spread_pa(io_pa) = cpatch%spread(1) - - + ! Patch specific variables that are already calculated + ! These things are all duplicated. Should they all be converted to LL or array structures RF? + ! define scalar to counteract the patch albedo scaling logic for conserved quantities + + if (cpatch%area .gt. 0._r8 .and. cpatch%total_canopy_area .gt.0 ) then + patch_scaling_scalar = min(1._r8, cpatch%area / cpatch%total_canopy_area) + else + patch_scaling_scalar = 0._r8 + endif + + hio_nesterov_fire_danger_pa(io_pa) = sites(s)%acc_NI + hio_spitfire_ros_pa(io_pa) = cpatch%ROS_front + hio_effect_wspeed_pa(io_pa) = cpatch%effect_wspeed + hio_tfc_ros_pa(io_pa) = cpatch%TFC_ROS + hio_fire_intensity_pa(io_pa) = cpatch%FI + hio_fire_area_pa(io_pa) = cpatch%frac_burnt + hio_scorch_height_pa(io_pa) = cpatch%SH + hio_fire_fuel_bulkd_pa(io_pa) = cpatch%fuel_bulkd + hio_fire_fuel_eff_moist_pa(io_pa) = cpatch%fuel_eff_moist + hio_fire_fuel_sav_pa(io_pa) = cpatch%fuel_sav + hio_fire_fuel_mef_pa(io_pa) = cpatch%fuel_mef + hio_sum_fuel_pa(io_pa) = cpatch%sum_fuel * 1.e3_r8 * patch_scaling_scalar + + hio_canopy_spread_pa(io_pa) = cpatch%spread(1) ipa = ipa + 1 @@ -484,6 +516,66 @@ subroutine define_history_vars(this,callstep,nvar) avgflag='A', vtype='PA_GRND_R8',hlms='CLM:ALM',flushval=0.0_r8, & ivar=ivar,callstep=callstep, index = ih_nindivs_pa_pft ) + call this%set_history_var(vname='FIRE_NESTEROV_INDEX2', units='none', & + long='nesterov_fire_danger index', & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, & + ivar=ivar,callstep=callstep, index = ih_nesterov_fire_danger_pa) + + call this%set_history_var(vname='FIRE_ROS2', units='m/min', & + long='fire rate of spread m/min', & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, & + ivar=ivar,callstep=callstep, index = ih_spitfire_ROS_pa) + + call this%set_history_var(vname='EFFECT_WSPEED2', units='none', & + long ='effective windspeed for fire spread', & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, & + ivar=ivar,callstep=callstep, index = ih_effect_wspeed_pa ) + + call this%set_history_var(vname='FIRE_TFC_ROS2', units='none', & + long ='total fuel consumed', & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, & + ivar=ivar,callstep=callstep, index = ih_TFC_ROS_pa ) + + call this%set_history_var(vname='FIRE_INTENSITY2', units='kJ/m/s', & + long='spitfire fire intensity: kJ/m/s', & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, & + ivar=ivar,callstep=callstep, index = ih_fire_intensity_pa ) + + call this%set_history_var(vname='FIRE_AREA2', units='fraction', & + long='spitfire fire area:m2', & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, & + ivar=ivar,callstep=callstep, index = ih_fire_area_pa ) + + call this%set_history_var(vname='SCORCH_HEIGHT2', units='m', & + long='spitfire fire area:m2', & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, & + ivar=ivar,callstep=callstep, index = ih_scorch_height_pa ) + + call this%set_history_var(vname='FIRE_FUEL_MEF2', units='m', & + long='spitfire fuel moisture', & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, & + ivar=ivar,callstep=callstep, index = ih_fire_fuel_mef_pa ) + + call this%set_history_var(vname='FIRE_FUEL_BULKD2', units='m', & + long='spitfire fuel bulk density', & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, & + ivar=ivar,callstep=callstep, index = ih_fire_fuel_bulkd_pa ) + + call this%set_history_var(vname='FIRE_FUEL_EFF_MOIST2', units='m', & + long='spitfire fuel moisture', & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, & + ivar=ivar,callstep=callstep, index = ih_fire_fuel_eff_moist_pa ) + + call this%set_history_var(vname='FIRE_FUEL_SAV2', units='m', & + long='spitfire fuel surface/volume ', & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, & + ivar=ivar,callstep=callstep, index = ih_fire_fuel_sav_pa ) + + call this%set_history_var(vname='SUM_FUEL2', units='gC m-2', & + long='total ground fuel related to ros (omits 1000hr fuels)', & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, & + ivar=ivar,callstep=callstep, index = ih_sum_fuel_pa ) + ! Must be last thing before return if(present(nvar)) nvar = ivar From 471187c6957d1029f8f654eba63599b3b6c08ffa Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 22 Aug 2016 17:24:48 -0700 Subject: [PATCH 165/437] added litter flux variables (1dpatch). Tests passed. --- main/HistoryIOMod.F90 | 90 ++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 84 insertions(+), 6 deletions(-) diff --git a/main/HistoryIOMod.F90 b/main/HistoryIOMod.F90 index 6cca651a..e73889e7 100644 --- a/main/HistoryIOMod.F90 +++ b/main/HistoryIOMod.F90 @@ -3,6 +3,7 @@ Module HistoryIOMod use shr_kind_mod , only : r8 => shr_kind_r8 use clm_varctl , only : iulog + implicit none @@ -32,15 +33,17 @@ Module HistoryIOMod integer, private :: ih_sum_fuel_pa integer, private :: ih_litter_in_pa integer, private :: ih_litter_out_pa + integer, private :: ih_efpot_pa ! NA integer, private :: ih_rb_pa ! NA + integer, private :: ih_daily_temp integer, private :: ih_daily_rh integer, private :: ih_daily_prec - integer, private :: ih_seed_bank - integer, private :: ih_seeds_in - integer, private :: ih_seed_decay - integer, private :: ih_seed_germination + integer, private :: ih_seed_bank_pa + integer, private :: ih_seeds_in_pa + integer, private :: ih_seed_decay_pa + integer, private :: ih_seed_germination_pa integer, private :: ih_bstore integer, private :: ih_bdead integer, private :: ih_balive @@ -265,6 +268,8 @@ subroutine update_history_variables(this,nc,sites,nsites,fcolumn) type(ed_patch_type),pointer :: cpatch type(ed_cohort_type),pointer :: ccohort + real(r8), parameter :: daysecs = 86400.0_r8 ! What modeler doesn't recognize 86400? + real(r8), parameter :: yeardays = 365.0_r8 ! Should this be 365.25? associate( hio_trimming_pa => this%hvars(ih_trimming_pa)%r81d, & hio_area_plant_pa => this%hvars(ih_area_plant_pa)%r81d, & @@ -285,7 +290,13 @@ subroutine update_history_variables(this,nc,sites,nsites,fcolumn) hio_fire_fuel_eff_moist_pa => this%hvars(ih_fire_fuel_eff_moist_pa)%r81d, & hio_fire_fuel_sav_pa => this%hvars(ih_fire_fuel_sav_pa)%r81d, & hio_fire_fuel_mef_pa => this%hvars(ih_fire_fuel_mef_pa)%r81d, & - hio_sum_fuel_pa => this%hvars(ih_sum_fuel_pa)%r81d ) + hio_sum_fuel_pa => this%hvars(ih_sum_fuel_pa)%r81d, & + hio_litter_in_pa => this%hvars(ih_litter_in_pa)%r81d, & + hio_litter_out_pa => this%hvars(ih_litter_out_pa)%r81d, & + hio_seed_bank_pa => this%hvars(ih_seed_bank_pa)%r81d, & + hio_seeds_in_pa => this%hvars(ih_seeds_in_pa)%r81d, & + hio_seed_decay_pa => this%hvars(ih_seed_decay_pa)%r81d, & + hio_seed_germination_pa => this%hvars(ih_seed_germination_pa)%r81d ) ! --------------------------------------------------------------------------------- ! Flush arrays to values defined by %flushval (see registry entry in @@ -406,6 +417,7 @@ subroutine update_history_variables(this,nc,sites,nsites,fcolumn) patch_scaling_scalar = 0._r8 endif + ! Update Fire Variables hio_nesterov_fire_danger_pa(io_pa) = sites(s)%acc_NI hio_spitfire_ros_pa(io_pa) = cpatch%ROS_front hio_effect_wspeed_pa(io_pa) = cpatch%effect_wspeed @@ -419,6 +431,17 @@ subroutine update_history_variables(this,nc,sites,nsites,fcolumn) hio_fire_fuel_mef_pa(io_pa) = cpatch%fuel_mef hio_sum_fuel_pa(io_pa) = cpatch%sum_fuel * 1.e3_r8 * patch_scaling_scalar + ! Update Litter Flux Variables + hio_litter_in_pa(io_pa) = (sum(cpatch%CWD_AG_in) +sum(cpatch%leaf_litter_in)) & + * 1.e3_r8 * 365.0_r8 * daysecs * patch_scaling_scalar + hio_litter_out_pa(io_pa) = (sum(cpatch%CWD_AG_out)+sum(cpatch%leaf_litter_out)) & + * 1.e3_r8 * 365.0_r8 * daysecs * patch_scaling_scalar + hio_seed_bank_pa(io_pa) = sum(cpatch%seed_bank) * 1.e3_r8 * patch_scaling_scalar + hio_seeds_in_pa(io_pa) = sum(cpatch%seeds_in) * 1.e3_r8 * 365.0_r8 * daysecs * patch_scaling_scalar + hio_seed_decay_pa(io_pa) = sum(cpatch%seed_decay) * 1.e3_r8 * 365.0_r8 * daysecs * patch_scaling_scalar + hio_seed_germination_pa(io_pa) = sum(cpatch%seed_germination) * 1.e3_r8 * 365.0_r8 * daysecs * patch_scaling_scalar + + hio_canopy_spread_pa(io_pa) = cpatch%spread(1) @@ -516,6 +539,8 @@ subroutine define_history_vars(this,callstep,nvar) avgflag='A', vtype='PA_GRND_R8',hlms='CLM:ALM',flushval=0.0_r8, & ivar=ivar,callstep=callstep, index = ih_nindivs_pa_pft ) + ! Fire Variables + call this%set_history_var(vname='FIRE_NESTEROV_INDEX2', units='none', & long='nesterov_fire_danger index', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, & @@ -571,11 +596,64 @@ subroutine define_history_vars(this,callstep,nvar) avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, & ivar=ivar,callstep=callstep, index = ih_fire_fuel_sav_pa ) - call this%set_history_var(vname='SUM_FUEL2', units='gC m-2', & + call this%set_history_var(vname='SUM_FUEL2', units='gC m-2', & long='total ground fuel related to ros (omits 1000hr fuels)', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, & ivar=ivar,callstep=callstep, index = ih_sum_fuel_pa ) + ! Litter Variables + + call this%set_history_var(vname='LITTER_IN2', units='gC m-2 s-1', & + long='Litter flux in leaves', & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, & + ivar=ivar,callstep=callstep, index = ih_litter_in_pa ) + + call this%set_history_var(vname='LITTER_OUT2', units='gC m-2 s-1', & + long='Litter flux out leaves', & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, & + ivar=ivar,callstep=callstep, index = ih_litter_out_pa ) + + call this%set_history_var(vname='SEED_BANK2', units='gC m-2', & + long='Total Seed Mass of all PFTs', & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, & + ivar=ivar,callstep=callstep, index = ih_seed_bank_pa ) + + call this%set_history_var(vname='SEEDS_IN2', units='gC m-2 s-1', & + long='Seed Production Rate', & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, & + ivar=ivar,callstep=callstep, index = ih_seeds_in_pa ) + + call this%set_history_var(vname='SEED_GERMINATION2', units='gC m-2 s-1', & + long='Seed mass converted into new cohorts', & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, & + ivar=ivar,callstep=callstep, index = ih_seed_germination_pa ) + + call this%set_history_var(vname='SEED_DECAY2', units='gC m-2 s-1', & + long='Seed mass decay', & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, & + ivar=ivar,callstep=callstep, index = ih_seed_decay_pa ) + +! call hist_addfld1d (fname='ED_bstore', units='gC 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='gC 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='gC 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='gC 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='gC m-2', & +! avgflag='A', long_name='ED total biomass', & +! ptr_patch=this%ED_biomass_patch, set_lake=0._r8, set_urb=0._r8) + + ! Must be last thing before return if(present(nvar)) nvar = ivar From 837fdd639f6a1d5a49e16cefd97ac66186edeb9b Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 22 Aug 2016 17:48:15 -0700 Subject: [PATCH 166/437] Added block of biomass variables, tests passed. --- main/HistoryIOMod.F90 | 62 ++++++++++++++++++++++++++++--------------- 1 file changed, 40 insertions(+), 22 deletions(-) diff --git a/main/HistoryIOMod.F90 b/main/HistoryIOMod.F90 index e73889e7..16179526 100644 --- a/main/HistoryIOMod.F90 +++ b/main/HistoryIOMod.F90 @@ -44,11 +44,11 @@ Module HistoryIOMod integer, private :: ih_seeds_in_pa integer, private :: ih_seed_decay_pa integer, private :: ih_seed_germination_pa - integer, private :: ih_bstore - integer, private :: ih_bdead - integer, private :: ih_balive - integer, private :: ih_bleaf - integer, private :: ih_biomass + integer, private :: ih_bstore_pa + integer, private :: ih_bdead_pa + integer, private :: ih_balive_pa + integer, private :: ih_bleaf_pa + integer, private :: ih_btotal_pa integer, private :: ih_npp integer, private :: ih_gpp integer, private :: ih_autotr_resp @@ -296,7 +296,13 @@ subroutine update_history_variables(this,nc,sites,nsites,fcolumn) hio_seed_bank_pa => this%hvars(ih_seed_bank_pa)%r81d, & hio_seeds_in_pa => this%hvars(ih_seeds_in_pa)%r81d, & hio_seed_decay_pa => this%hvars(ih_seed_decay_pa)%r81d, & - hio_seed_germination_pa => this%hvars(ih_seed_germination_pa)%r81d ) + hio_seed_germination_pa => this%hvars(ih_seed_germination_pa)%r81d, & + hio_bstore_pa => this%hvars(ih_bstore_pa)%r81d, & + hio_bdead_pa => this%hvars(ih_bdead_pa)%r81d, & + hio_balive_pa => this%hvars(ih_balive_pa)%r81d, & + hio_bleaf_pa => this%hvars(ih_bleaf_pa)%r81d, & + hio_btotal_pa => this%hvars(ih_btotal_pa)%r81d ) + ! --------------------------------------------------------------------------------- ! Flush arrays to values defined by %flushval (see registry entry in @@ -390,7 +396,14 @@ subroutine update_history_variables(this,nc,sites,nsites,fcolumn) hio_area_treespread_pa(io_pa) = 0.0_r8 end if - + ! Update biomass components + hio_bleaf_pa(io_pa) = hio_bleaf_pa(io_pa) + n_density * ccohort%bl * 1.e3_r8 + hio_bstore_pa(io_pa) = hio_bstore_pa(io_pa) + n_density * ccohort%bstore * 1.e3_r8 + hio_btotal_pa(io_pa) = hio_btotal_pa(io_pa) + n_density * ccohort%b * 1.e3_r8 + hio_bdead_pa(io_pa) = hio_bdead_pa(io_pa) + n_density * ccohort%bdead * 1.e3_r8 + hio_balive_pa(io_pa) = hio_balive_pa(io_pa) + n_density * ccohort%balive * 1.e3_r8 + + ! Update PFT partitioned biomass components hio_biomass_pa_pft(io_pa,ft) = hio_biomass_pa_pft(io_pa,ft) + & n_density * ccohort%b * 1.e3_r8 @@ -633,25 +646,30 @@ subroutine define_history_vars(this,callstep,nvar) avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, & ivar=ivar,callstep=callstep, index = ih_seed_decay_pa ) -! call hist_addfld1d (fname='ED_bstore', units='gC m-2', & -! avgflag='A', long_name='ED stored biomass', & -! ptr_patch=this%ED_bstore_patch, set_lake=0._r8, set_urb=0._r8) + call this%set_history_var(vname='BSTORE2', units='gC m-2', & + long='Storage biomass', & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, & + ivar=ivar,callstep=callstep, index = ih_bstore_pa ) -! call hist_addfld1d (fname='ED_bdead', units='gC m-2', & -! avgflag='A', long_name='ED dead biomass', & -! ptr_patch=this%ED_bdead_patch, set_lake=0._r8, set_urb=0._r8) + call this%set_history_var(vname='BDEAD2', units='gC m-2', & + long='Dead (structural) biomass (live trees, not CWD)', & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, & + ivar=ivar,callstep=callstep, index = ih_bdead_pa ) -! call hist_addfld1d (fname='ED_balive', units='gC m-2', & -! avgflag='A', long_name='ED live biomass', & -! ptr_patch=this%ED_balive_patch, set_lake=0._r8, set_urb=0._r8) + call this%set_history_var(vname='BALIVE2', units='gC m-2', & + long='Live biomass', & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, & + ivar=ivar,callstep=callstep, index = ih_balive_pa ) -! call hist_addfld1d (fname='ED_bleaf', units='gC m-2', & -! avgflag='A', long_name='ED leaf biomass', & -! ptr_patch=this%ED_bleaf_patch, set_lake=0._r8, set_urb=0._r8) + call this%set_history_var(vname='BLEAF2', units='gC m-2', & + long='Leaf biomass', & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, & + ivar=ivar,callstep=callstep, index = ih_bleaf_pa ) -! call hist_addfld1d (fname='ED_biomass', units='gC m-2', & -! avgflag='A', long_name='ED total biomass', & -! ptr_patch=this%ED_biomass_patch, set_lake=0._r8, set_urb=0._r8) + call this%set_history_var(vname='BTOTAL2', units='gC m-2', & + long='Total biomass', & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, & + ivar=ivar,callstep=callstep, index = ih_btotal_pa ) ! Must be last thing before return From 74743bacc8f190153ffc247bcc49fdb8b58c01ae Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 22 Aug 2016 18:43:19 -0700 Subject: [PATCH 167/437] partial progress on rapidly updated diagnostics in summarizeproductivity fluxes. --- main/EDCLMLinkMod.F90 | 2 +- main/EDTypesMod.F90 | 7 ++ main/FatesInterfaceMod.F90 | 51 ++++++++---- main/HistoryIOMod.F90 | 154 +++++++++++++++++++++++++++++++++---- 4 files changed, 185 insertions(+), 29 deletions(-) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 3b839cbc..55b0273f 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -564,7 +564,7 @@ subroutine InitHistory(this, bounds) ptr_col=this%seed_stock_col) - ! Carbon Flux (grid dimension x scpf) + ! Carbon Flux (grid dimension x scpf) ! ============================================================== call hist_addfld2d (fname='ED_GPP_COL_SCPF',units='kgC/m2/yr',type2d='levscpf',& diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 3ac8080b..4086690b 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -138,8 +138,15 @@ module EDTypesMod ! or the total number of soil layers integer :: cp_numlevdecomp + ! This character string passed by the HLM is used during the processing of IO + ! data, so that FATES knows which IO variables it should prepare. For instance + ! ATS, ALM and CLM will only want variables specficially packaged for them. + ! This string will dictate which filter is enacted. character(len=16) :: cp_hlm_name + ! This value can be flushed to history diagnostics, such that the + ! HLM will interpret that the value should not be included in the average. + real(r8) :: cp_hio_ignore_val !************************************ !** COHORT type structure ** diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 017a15d5..05f8937c 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -426,7 +426,7 @@ end subroutine zero_bcs ! ==================================================================================== - subroutine set_fates_ctrlparms(tag,idimval,cdimval) + subroutine set_fates_ctrlparms(tag,ival,rval,cval) ! --------------------------------------------------------------------------------- ! INTERF-TODO: NEED ALLOWANCES FOR REAL AND CHARACTER ARGS.. @@ -450,10 +450,13 @@ subroutine set_fates_ctrlparms(tag,idimval,cdimval) ! ! RGK-2016 ! --------------------------------------------------------------------------------- + + 'hio_ignore_val',rdimval=spval) ! Arguments - integer, optional, intent(in) :: idimval - character(len=*),optional, intent(in) :: cdimval + integer, optional, intent(in) :: ival + real(r8), optional, intent(in) :: rval + character(len=*),optional, intent(in) :: cval character(len=*),intent(in) :: tag ! local variables @@ -461,6 +464,7 @@ subroutine set_fates_ctrlparms(tag,idimval,cdimval) integer, parameter :: unset_int = -999 real(r8), parameter :: unset_double = -999.9 + select case (trim(tag)) case('flush_to_unset') @@ -471,6 +475,7 @@ subroutine set_fates_ctrlparms(tag,idimval,cdimval) cp_numlevdecomp_full = unset_int cp_numlevdecomp = unset_int cp_hlm_name = 'unset' + cp_hio_ignore = unset_double case('check_allset') @@ -515,32 +520,38 @@ subroutine set_fates_ctrlparms(tag,idimval,cdimval) ! end_run('MESSAGE') end if + if( abs(cp_hio_ignore-unset_double)<1e-10 ) then + write(*,*) 'FATES dimension/parameter unset: hio_ignore' + ! INTERF-TODO: FATES NEEDS INTERNAL end_run + ! end_run('MESSAGE') + end if + write(*,*) 'Checked. All control parameters sent to FATES.' case default - if(present(idimval))then + if(present(ival))then select case (trim(tag)) case('num_sw_bbands') - cp_numSwb = idimval - write(*,*) 'Transfering num_sw_bbands = ',idimval,' to FATES' + cp_numSwb = ival + write(*,*) 'Transfering num_sw_bbands = ',ival,' to FATES' case('num_lev_ground') - cp_numlevgrnd = idimval - write(*,*) 'Transfering num_lev_ground = ',idimval,' to FATES' + cp_numlevgrnd = ival + write(*,*) 'Transfering num_lev_ground = ',ival,' to FATES' case('num_levdecomp_full') - cp_numlevdecomp_full = idimval - write(*,*) 'Transfering num_levdecomp_full = ',idimval,' to FATES' + cp_numlevdecomp_full = ival + write(*,*) 'Transfering num_levdecomp_full = ',ival,' to FATES' case('num_levdecomp') - cp_numlevdecomp = idimval - write(*,*) 'Transfering num_levdecomp = ',idimval,' to FATES' + cp_numlevdecomp = ival + write(*,*) 'Transfering num_levdecomp = ',ival,' to FATES' case default write(*,*) 'tag not recognized:',trim(tag) @@ -548,12 +559,22 @@ subroutine set_fates_ctrlparms(tag,idimval,cdimval) end select end if - if(present(cdimval))then + if(present(rval))then + select case (trim(tag)) + cp_hio_ignore_val = rval + write(*,*) 'Transfering hio_ignore_val = ',rval,' to FATES' + case default + write(*,*) 'tag not recognized:',trim(tag) + ! end_run + end select + end if + + if(present(cval))then select case (trim(tag)) case('hlm_name') - cp_hlm_name = trim(cdimval) - write(*,*) 'Transfering the HLM name = ',trim(cdimval) + cp_hlm_name = trim(cval) + write(*,*) 'Transfering the HLM name = ',trim(cval) case default write(*,*) 'tag not recognized:',trim(tag) diff --git a/main/HistoryIOMod.F90 b/main/HistoryIOMod.F90 index 16179526..1902702c 100644 --- a/main/HistoryIOMod.F90 +++ b/main/HistoryIOMod.F90 @@ -3,7 +3,7 @@ Module HistoryIOMod use shr_kind_mod , only : r8 => shr_kind_r8 use clm_varctl , only : iulog - + use EDTypes , only : cp_hio_ignore_val implicit none @@ -49,11 +49,11 @@ Module HistoryIOMod integer, private :: ih_balive_pa integer, private :: ih_bleaf_pa integer, private :: ih_btotal_pa - integer, private :: ih_npp - integer, private :: ih_gpp - integer, private :: ih_autotr_resp - integer, private :: ih_maint_resp - integer, private :: ih_growth_resp + integer, private :: ih_npp_pa + integer, private :: ih_gpp_pa + integer, private :: ih_autotr_resp_pa + integer, private :: ih_maint_resp_pa + integer, private :: ih_growth_resp_pa ! Indices to (patch x pft) variables (using nlevgrnd as surrogate) @@ -213,7 +213,8 @@ Module HistoryIOMod contains - procedure, public :: update_history_variables + procedure, public :: update_history_dyn_tscale + procedure, public :: update_history_rapid_tscale procedure, public :: define_history_vars procedure, public :: set_history_var procedure, public :: init_iovar_dk_maps @@ -232,11 +233,11 @@ Module HistoryIOMod ! ==================================================================================== - subroutine update_history_variables(this,nc,sites,nsites,fcolumn) + subroutine update_history_dyn_tscale(this,nc,sites,nsites,fcolumn) ! --------------------------------------------------------------------------------- - ! This is the main call to update the history IO arrays that are registerred with - ! the Host Model. + ! This is the call to update the history IO arrays that are expected to only change + ! after Ecosystem Dynamics have been processed. ! --------------------------------------------------------------------------------- use EDtypesMod , only : ed_site_type, & @@ -467,9 +468,109 @@ subroutine update_history_variables(this,nc,sites,nsites,fcolumn) end associate return - end subroutine update_history_variables - - ! ==================================================================================== + end subroutine update_history_dyn_tscale + + ! ====================================================================================== + + subroutine update_history_rapid_tscale(this,nc,sites,nsites,fcolumn,dt_tstep) + + ! --------------------------------------------------------------------------------- + ! This is the call to update the history IO arrays that are expected to only change + ! after Ecosystem Dynamics have been processed. + ! --------------------------------------------------------------------------------- + + use EDtypesMod , only : ed_site_type, & + ed_cohort_type, & + ed_patch_type, & + AREA + ! Arguments + class(fates_hio_interface_type) :: this + integer , intent(in) :: nc ! clump index + type(ed_site_type) , intent(inout), target :: sites(nsites) + integer , intent(in) :: nsites + integer , intent(in) :: fcolumn(nsites) + real(r8) , intent(in) :: dt_tstep + + ! Locals + integer :: s ! The local site index + integer :: io_si ! The site index of the IO array + integer :: ipa ! The local "I"ndex of "PA"tches + integer :: io_pa ! The patch index of the IO array + integer :: io_pa1 ! The first patch index in the IO array for each site + integer :: io_soipa + integer :: lb1,ub1,lb2,ub2 ! IO array bounds for the calling thread + integer :: ivar ! index of IO variable object vector + + real(r8) :: n_density ! individual of cohort per m2. + real(r8) :: n_perm2 ! individuals per m2 for the whole column + + type(iovar_def_type),pointer :: hvar + type(ed_patch_type),pointer :: cpatch + type(ed_cohort_type),pointer :: ccohort + + real(r8), parameter :: daysecs = 86400.0_r8 ! What modeler doesn't recognize 86400? + real(r8), parameter :: yeardays = 365.0_r8 ! Should this be 365.25? + + associate( hio_gpp_pa => this%hvars(ih_gpp_pa)%r81d, & + hio_npp_pa => this%hvars(ih_npp_pa)%r81d, & + hio_ar_pa => this%hvars(ih_ar_pa)%r81d, & + hio_maint_resp => this%hvars(ih_maint_resp_pa)%r81d, & + hio_growth_resp => this%hvars(ih_growth_resp_pa)%r81d ) + + + do s = 1,nsites + + io_si = this%iovar_map(nc)%site_index(s) + io_pa1 = this%iovar_map(nc)%patch1_index(s) + io_soipa = io_pa1-1 + + ipa = 0 + cpatch => sites(s)%oldest_patch + do while(associated(cpatch)) + + io_pa = io_pa1 + ipa + + ccohort => cpatch%shortest + do while(associated(ccohort)) + + ! TODO: we need a standardized logical function on this (used lots, RGK) + if ((cpatch%area .gt. 0._r8) .and. (cpatch%total_canopy_area .gt. 0._r8)) then + n_density = ccohort%n/min(currentPatch%area,currentPatch%total_canopy_area) + n_perm2 = ccohort%n/AREA + else + n_density = 0.0_r8 + n_perm2 = 0.0_r8 + endif + + if ( .not. ccohort%isnew ) then + + ! scale up cohort fluxes to their patches + hio_npp_pa(io_pa) = hio_npp_pa(io_pa) + & + ccohort%npp_tstep * 1.e3_r8 * n_density / dt_tstep + hio_gpp_pa(io_pa) = hio_gpp_pa(io_pa) + & + ccohort%gpp_tstep * 1.e3_r8 * n_density / dt_tstep + hio_ar_pa(io_pa) = hio_ar_pa(io_pa) + & + ccohort%resp_tstep * 1.e3_r8 * n_density / dt_tstep + hio_growth_resp_pa(io_pa) = hio_growth_resp_pa(io_pa) + & + ccohort%resp_g * 1.e3_r8 * n_density / dt_tstep + hio_maint_resp_pa(io_pa) = hio_maint_resp_pa(io_pa) + & + ccohort%resp_m * 1.e3_r8 * n_density / dt_tstep + + endif + + ccohort => ccohort%taller + enddo ! cohort loop + ipa = ipa + 1 + cpatch => cpatch%younger + end do !patch loop + + enddo ! site loop + + end associate + + end subroutine update_history_rapid_tscale + + ! ==================================================================================== subroutine define_history_vars(this,callstep,nvar) @@ -670,7 +771,34 @@ subroutine define_history_vars(this,callstep,nvar) long='Total biomass', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, & ivar=ivar,callstep=callstep, index = ih_btotal_pa ) + + ! Ecosystem Carbon Fluxes (updated rapidly) + call this%set_history_var(vname='GPP2', units='gC/m^2/s', & + long='gross primary production', & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, !cp_hio_ignore_val, & + ivar=ivar,callstep=callstep, index = ih_gpp_pa ) + + call this%set_history_var(vname='NPP2', units='gC/m^2/s', & + long='net primary production', & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, !cp_hio_ignore_val, & + ivar=ivar,callstep=callstep, index = ih_npp_pa ) + + call this%set_history_var(vname='AR2', units='gC/m^2/s', & + long='autotrophic respiration', & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, !cp_hio_ignore_val, & + ivar=ivar,callstep=callstep, index = ih_ar_pa ) + + call this%set_history_var(vname='GROWTH_RESP2', units='gC/m^2/s', & + long='growth respiration', & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, !cp_hio_ignore_val, & + ivar=ivar,callstep=callstep, index = ih_growth_resp_pa ) + + call this%set_history_var(vname='MAINT_RESP2', units='gC/m^2/s', & + long='maintenance respiration', & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, !cp_hio_ignore_val, & + ivar=ivar,callstep=callstep, index = ih_maint_resp_pa ) + ! Must be last thing before return if(present(nvar)) nvar = ivar From f700b8f8782a3e762938fc47d42c19e9f7e49d7e Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 22 Aug 2016 22:33:02 -0700 Subject: [PATCH 168/437] Prototype for rapidly updating history variables complete, ie those in summarizeproductiveityfluxes. Tests seem to think it works. --- main/FatesInterfaceMod.F90 | 2 +- main/HistoryIOMod.F90 | 504 +++++++++++++++++++------------------ 2 files changed, 263 insertions(+), 243 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 05f8937c..0c3333d4 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -451,7 +451,6 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) ! RGK-2016 ! --------------------------------------------------------------------------------- - 'hio_ignore_val',rdimval=spval) ! Arguments integer, optional, intent(in) :: ival @@ -561,6 +560,7 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) if(present(rval))then select case (trim(tag)) + case ('hio_ignore_val') cp_hio_ignore_val = rval write(*,*) 'Transfering hio_ignore_val = ',rval,' to FATES' case default diff --git a/main/HistoryIOMod.F90 b/main/HistoryIOMod.F90 index 1902702c..d0d87d1f 100644 --- a/main/HistoryIOMod.F90 +++ b/main/HistoryIOMod.F90 @@ -3,7 +3,7 @@ Module HistoryIOMod use shr_kind_mod , only : r8 => shr_kind_r8 use clm_varctl , only : iulog - use EDTypes , only : cp_hio_ignore_val + use EDTypesMod , only : cp_hio_ignore_val implicit none @@ -51,7 +51,7 @@ Module HistoryIOMod integer, private :: ih_btotal_pa integer, private :: ih_npp_pa integer, private :: ih_gpp_pa - integer, private :: ih_autotr_resp_pa + integer, private :: ih_aresp_pa integer, private :: ih_maint_resp_pa integer, private :: ih_growth_resp_pa @@ -168,6 +168,9 @@ Module HistoryIOMod character(len=128) :: long character(len=24) :: vtype character(len=1) :: avgflag + integer :: upfreq ! Update frequency (this is for checks and flushing) + ! 1 = dynamics step (daily) + ! 2 = rapid timestep (aka model time-step) real(r8) :: flushval type(iovar_dimkind_type),pointer :: iovar_dk_ptr ! Pointers (only one of these is allocated per variable) @@ -213,8 +216,8 @@ Module HistoryIOMod contains - procedure, public :: update_history_dyn_tscale - procedure, public :: update_history_rapid_tscale + procedure, public :: update_history_dyn + procedure, public :: update_history_rapid procedure, public :: define_history_vars procedure, public :: set_history_var procedure, public :: init_iovar_dk_maps @@ -223,6 +226,7 @@ Module HistoryIOMod procedure, public :: get_hvar_bounds procedure, public :: dim_init procedure, public :: set_dim_thread_bounds + procedure, private :: flush_hvars end type fates_hio_interface_type @@ -233,7 +237,7 @@ Module HistoryIOMod ! ==================================================================================== - subroutine update_history_dyn_tscale(this,nc,sites,nsites,fcolumn) + subroutine update_history_dyn(this,nc,sites,nsites,fcolumn) ! --------------------------------------------------------------------------------- ! This is the call to update the history IO arrays that are expected to only change @@ -304,175 +308,146 @@ subroutine update_history_dyn_tscale(this,nc,sites,nsites,fcolumn) hio_bleaf_pa => this%hvars(ih_bleaf_pa)%r81d, & hio_btotal_pa => this%hvars(ih_btotal_pa)%r81d ) - - ! --------------------------------------------------------------------------------- - ! Flush arrays to values defined by %flushval (see registry entry in - ! subroutine define_history_vars() - ! --------------------------------------------------------------------------------- - - do ivar=1,ubound(this%hvars,1) - hvar => this%hvars(ivar) - call this%get_hvar_bounds(hvar,nc,lb1,ub1,lb2,ub2) - select case(trim(hvar%iovar_dk_ptr%name)) - case('PA_R8') - hvar%r81d(lb1:ub1) = hvar%flushval - case('SI_R8') - hvar%r81d(lb1:ub1) = hvar%flushval - case('PA_GRND_R8') - hvar%r82d(lb1:ub1,lb2:ub2) = hvar%flushval - case('PA_SCPF_R8') - hvar%r82d(lb1:ub1,lb2:ub2) = hvar%flushval - case('SI_GRND_R8') - hvar%r82d(lb1:ub1,lb2:ub2) = hvar%flushval - case('SI_SCPF_R8') - hvar%r82d(lb1:ub1,lb2:ub2) = hvar%flushval - case('PA_INT') - hvar%int1d(lb1:ub1) = nint(hvar%flushval) - case default - write(iulog,*) 'iotyp undefined while flushing history variables' - stop - !end_run - end select - end do - - - ! Perform flushes or initializations over the FATES-only space? - ! --------------------------------------------------------------------------------- - - - ! --------------------------------------------------------------------------------- - ! Loop through the FATES scale hierarchy and fill the history IO arrays - ! --------------------------------------------------------------------------------- - - do s = 1,nsites - - io_si = this%iovar_map(nc)%site_index(s) - io_pa1 = this%iovar_map(nc)%patch1_index(s) - io_soipa = io_pa1-1 - - - ! Set trimming on the soil patch to 1.0 - hio_trimming_pa(io_soipa) = 1.0_r8 - - - ipa = 0 - cpatch => sites(s)%oldest_patch - do while(associated(cpatch)) - - io_pa = io_pa1 + ipa - - ccohort => cpatch%shortest - do while(associated(ccohort)) - - ft = ccohort%pft - - if ((cpatch%area .gt. 0._r8) .and. (cpatch%total_canopy_area .gt. 0._r8)) then - - ! for quantities that are at the CLM patch level, because of the way - ! that CLM patches are weighted for radiative purposes this # density needs - ! to be over either ED patch canopy area or ED patch total area, whichever is less - n_density = ccohort%n/min(cpatch%area,cpatch%total_canopy_area) - - ! for quantities that are natively at column level, calculate plant - ! density using whole area - n_perm2 = ccohort%n/AREA - - else - n_density = 0.0_r8 - n_perm2 = 0.0_r8 - endif - - if(associated(cpatch%tallest))then - hio_trimming_pa(io_pa) = cpatch%tallest%canopy_trim - else - hio_trimming_pa(io_pa) = 0.0_r8 - endif - - hio_area_plant_pa(io_pa) = 1.0_r8 - - if (min(cpatch%total_canopy_area,cpatch%area)>0.0_r8) then - hio_area_treespread_pa(io_pa) = cpatch%total_tree_area & - / min(cpatch%total_canopy_area,cpatch%area) - else - hio_area_treespread_pa(io_pa) = 0.0_r8 - end if - - ! Update biomass components - hio_bleaf_pa(io_pa) = hio_bleaf_pa(io_pa) + n_density * ccohort%bl * 1.e3_r8 - hio_bstore_pa(io_pa) = hio_bstore_pa(io_pa) + n_density * ccohort%bstore * 1.e3_r8 - hio_btotal_pa(io_pa) = hio_btotal_pa(io_pa) + n_density * ccohort%b * 1.e3_r8 - hio_bdead_pa(io_pa) = hio_bdead_pa(io_pa) + n_density * ccohort%bdead * 1.e3_r8 - hio_balive_pa(io_pa) = hio_balive_pa(io_pa) + n_density * ccohort%balive * 1.e3_r8 - - ! Update PFT partitioned biomass components - hio_biomass_pa_pft(io_pa,ft) = hio_biomass_pa_pft(io_pa,ft) + & - n_density * ccohort%b * 1.e3_r8 - - hio_leafbiomass_pa_pft(io_pa,ft) = hio_leafbiomass_pa_pft(io_pa,ft) + & - n_density * ccohort%bl * 1.e3_r8 - - hio_storebiomass_pa_pft(io_pa,ft) = hio_storebiomass_pa_pft(io_pa,ft) + & - n_density * ccohort%bstore * 1.e3_r8 - - hio_nindivs_pa_pft(io_pa,ft) = hio_nindivs_pa_pft(io_pa,ft) + & - ccohort%n + ! --------------------------------------------------------------------------------- + ! Flush arrays to values defined by %flushval (see registry entry in + ! subroutine define_history_vars() + ! --------------------------------------------------------------------------------- + + call this%flush_hvars(nc,upfreq_in=1) + + ! --------------------------------------------------------------------------------- + ! Loop through the FATES scale hierarchy and fill the history IO arrays + ! --------------------------------------------------------------------------------- + + do s = 1,nsites + + io_si = this%iovar_map(nc)%site_index(s) + io_pa1 = this%iovar_map(nc)%patch1_index(s) + io_soipa = io_pa1-1 + + + ! Set trimming on the soil patch to 1.0 + hio_trimming_pa(io_soipa) = 1.0_r8 + + + ipa = 0 + cpatch => sites(s)%oldest_patch + do while(associated(cpatch)) + + io_pa = io_pa1 + ipa + + ccohort => cpatch%shortest + do while(associated(ccohort)) + + ft = ccohort%pft + + if ((cpatch%area .gt. 0._r8) .and. (cpatch%total_canopy_area .gt. 0._r8)) then + + ! for quantities that are at the CLM patch level, because of the way + ! that CLM patches are weighted for radiative purposes this # density needs + ! to be over either ED patch canopy area or ED patch total area, whichever is less + n_density = ccohort%n/min(cpatch%area,cpatch%total_canopy_area) + + ! for quantities that are natively at column level, calculate plant + ! density using whole area + n_perm2 = ccohort%n/AREA + + else + n_density = 0.0_r8 + n_perm2 = 0.0_r8 + endif + + if(associated(cpatch%tallest))then + hio_trimming_pa(io_pa) = cpatch%tallest%canopy_trim + else + hio_trimming_pa(io_pa) = 0.0_r8 + endif + + hio_area_plant_pa(io_pa) = 1.0_r8 + + if (min(cpatch%total_canopy_area,cpatch%area)>0.0_r8) then + hio_area_treespread_pa(io_pa) = cpatch%total_tree_area & + / min(cpatch%total_canopy_area,cpatch%area) + else + hio_area_treespread_pa(io_pa) = 0.0_r8 + end if + + ! Update biomass components + hio_bleaf_pa(io_pa) = hio_bleaf_pa(io_pa) + n_density * ccohort%bl * 1.e3_r8 + hio_bstore_pa(io_pa) = hio_bstore_pa(io_pa) + n_density * ccohort%bstore * 1.e3_r8 + hio_btotal_pa(io_pa) = hio_btotal_pa(io_pa) + n_density * ccohort%b * 1.e3_r8 + hio_bdead_pa(io_pa) = hio_bdead_pa(io_pa) + n_density * ccohort%bdead * 1.e3_r8 + hio_balive_pa(io_pa) = hio_balive_pa(io_pa) + n_density * ccohort%balive * 1.e3_r8 + + ! Update PFT partitioned biomass components + hio_biomass_pa_pft(io_pa,ft) = hio_biomass_pa_pft(io_pa,ft) + & + n_density * ccohort%b * 1.e3_r8 + + hio_leafbiomass_pa_pft(io_pa,ft) = hio_leafbiomass_pa_pft(io_pa,ft) + & + n_density * ccohort%bl * 1.e3_r8 + hio_storebiomass_pa_pft(io_pa,ft) = hio_storebiomass_pa_pft(io_pa,ft) + & + n_density * ccohort%bstore * 1.e3_r8 + + hio_nindivs_pa_pft(io_pa,ft) = hio_nindivs_pa_pft(io_pa,ft) + & + ccohort%n + + + ccohort => ccohort%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? + ! define scalar to counteract the patch albedo scaling logic for conserved quantities + + if (cpatch%area .gt. 0._r8 .and. cpatch%total_canopy_area .gt.0 ) then + patch_scaling_scalar = min(1._r8, cpatch%area / cpatch%total_canopy_area) + else + patch_scaling_scalar = 0._r8 + endif + + ! Update Fire Variables + hio_nesterov_fire_danger_pa(io_pa) = sites(s)%acc_NI + hio_spitfire_ros_pa(io_pa) = cpatch%ROS_front + hio_effect_wspeed_pa(io_pa) = cpatch%effect_wspeed + hio_tfc_ros_pa(io_pa) = cpatch%TFC_ROS + hio_fire_intensity_pa(io_pa) = cpatch%FI + hio_fire_area_pa(io_pa) = cpatch%frac_burnt + hio_scorch_height_pa(io_pa) = cpatch%SH + hio_fire_fuel_bulkd_pa(io_pa) = cpatch%fuel_bulkd + hio_fire_fuel_eff_moist_pa(io_pa) = cpatch%fuel_eff_moist + hio_fire_fuel_sav_pa(io_pa) = cpatch%fuel_sav + hio_fire_fuel_mef_pa(io_pa) = cpatch%fuel_mef + hio_sum_fuel_pa(io_pa) = cpatch%sum_fuel * 1.e3_r8 * patch_scaling_scalar + + ! Update Litter Flux Variables + hio_litter_in_pa(io_pa) = (sum(cpatch%CWD_AG_in) +sum(cpatch%leaf_litter_in)) & + * 1.e3_r8 * 365.0_r8 * daysecs * patch_scaling_scalar + hio_litter_out_pa(io_pa) = (sum(cpatch%CWD_AG_out)+sum(cpatch%leaf_litter_out)) & + * 1.e3_r8 * 365.0_r8 * daysecs * patch_scaling_scalar + hio_seed_bank_pa(io_pa) = sum(cpatch%seed_bank) * 1.e3_r8 * patch_scaling_scalar + hio_seeds_in_pa(io_pa) = sum(cpatch%seeds_in) * 1.e3_r8 * 365.0_r8 * daysecs * patch_scaling_scalar + hio_seed_decay_pa(io_pa) = sum(cpatch%seed_decay) * 1.e3_r8 * 365.0_r8 * daysecs * patch_scaling_scalar + hio_seed_germination_pa(io_pa) = sum(cpatch%seed_germination) * 1.e3_r8 * 365.0_r8 * daysecs * patch_scaling_scalar - ccohort => ccohort%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? - ! define scalar to counteract the patch albedo scaling logic for conserved quantities - - if (cpatch%area .gt. 0._r8 .and. cpatch%total_canopy_area .gt.0 ) then - patch_scaling_scalar = min(1._r8, cpatch%area / cpatch%total_canopy_area) - else - patch_scaling_scalar = 0._r8 - endif - - ! Update Fire Variables - hio_nesterov_fire_danger_pa(io_pa) = sites(s)%acc_NI - hio_spitfire_ros_pa(io_pa) = cpatch%ROS_front - hio_effect_wspeed_pa(io_pa) = cpatch%effect_wspeed - hio_tfc_ros_pa(io_pa) = cpatch%TFC_ROS - hio_fire_intensity_pa(io_pa) = cpatch%FI - hio_fire_area_pa(io_pa) = cpatch%frac_burnt - hio_scorch_height_pa(io_pa) = cpatch%SH - hio_fire_fuel_bulkd_pa(io_pa) = cpatch%fuel_bulkd - hio_fire_fuel_eff_moist_pa(io_pa) = cpatch%fuel_eff_moist - hio_fire_fuel_sav_pa(io_pa) = cpatch%fuel_sav - hio_fire_fuel_mef_pa(io_pa) = cpatch%fuel_mef - hio_sum_fuel_pa(io_pa) = cpatch%sum_fuel * 1.e3_r8 * patch_scaling_scalar - - ! Update Litter Flux Variables - hio_litter_in_pa(io_pa) = (sum(cpatch%CWD_AG_in) +sum(cpatch%leaf_litter_in)) & - * 1.e3_r8 * 365.0_r8 * daysecs * patch_scaling_scalar - hio_litter_out_pa(io_pa) = (sum(cpatch%CWD_AG_out)+sum(cpatch%leaf_litter_out)) & - * 1.e3_r8 * 365.0_r8 * daysecs * patch_scaling_scalar - hio_seed_bank_pa(io_pa) = sum(cpatch%seed_bank) * 1.e3_r8 * patch_scaling_scalar - hio_seeds_in_pa(io_pa) = sum(cpatch%seeds_in) * 1.e3_r8 * 365.0_r8 * daysecs * patch_scaling_scalar - hio_seed_decay_pa(io_pa) = sum(cpatch%seed_decay) * 1.e3_r8 * 365.0_r8 * daysecs * patch_scaling_scalar - hio_seed_germination_pa(io_pa) = sum(cpatch%seed_germination) * 1.e3_r8 * 365.0_r8 * daysecs * patch_scaling_scalar - - - hio_canopy_spread_pa(io_pa) = cpatch%spread(1) - - - ipa = ipa + 1 - cpatch => cpatch%younger - end do !patch loop + + hio_canopy_spread_pa(io_pa) = cpatch%spread(1) + + + ipa = ipa + 1 + cpatch => cpatch%younger + end do !patch loop - enddo ! site loop - - end associate + enddo ! site loop + + end associate return - end subroutine update_history_dyn_tscale + end subroutine update_history_dyn ! ====================================================================================== - subroutine update_history_rapid_tscale(this,nc,sites,nsites,fcolumn,dt_tstep) + subroutine update_history_rapid(this,nc,sites,nsites,fcolumn,dt_tstep) ! --------------------------------------------------------------------------------- ! This is the call to update the history IO arrays that are expected to only change @@ -511,13 +486,15 @@ subroutine update_history_rapid_tscale(this,nc,sites,nsites,fcolumn,dt_tstep) real(r8), parameter :: daysecs = 86400.0_r8 ! What modeler doesn't recognize 86400? real(r8), parameter :: yeardays = 365.0_r8 ! Should this be 365.25? - associate( hio_gpp_pa => this%hvars(ih_gpp_pa)%r81d, & - hio_npp_pa => this%hvars(ih_npp_pa)%r81d, & - hio_ar_pa => this%hvars(ih_ar_pa)%r81d, & - hio_maint_resp => this%hvars(ih_maint_resp_pa)%r81d, & - hio_growth_resp => this%hvars(ih_growth_resp_pa)%r81d ) - - + associate( hio_gpp_pa => this%hvars(ih_gpp_pa)%r81d, & + hio_npp_pa => this%hvars(ih_npp_pa)%r81d, & + hio_aresp_pa => this%hvars(ih_aresp_pa)%r81d, & + hio_maint_resp_pa => this%hvars(ih_maint_resp_pa)%r81d, & + hio_growth_resp_pa => this%hvars(ih_growth_resp_pa)%r81d ) + + ! Flush the relevant history variables + call this%flush_hvars(nc,upfreq_in=2) + do s = 1,nsites io_si = this%iovar_map(nc)%site_index(s) @@ -535,7 +512,7 @@ subroutine update_history_rapid_tscale(this,nc,sites,nsites,fcolumn,dt_tstep) ! TODO: we need a standardized logical function on this (used lots, RGK) if ((cpatch%area .gt. 0._r8) .and. (cpatch%total_canopy_area .gt. 0._r8)) then - n_density = ccohort%n/min(currentPatch%area,currentPatch%total_canopy_area) + n_density = ccohort%n/min(cpatch%area,cpatch%total_canopy_area) n_perm2 = ccohort%n/AREA else n_density = 0.0_r8 @@ -549,7 +526,7 @@ subroutine update_history_rapid_tscale(this,nc,sites,nsites,fcolumn,dt_tstep) ccohort%npp_tstep * 1.e3_r8 * n_density / dt_tstep hio_gpp_pa(io_pa) = hio_gpp_pa(io_pa) + & ccohort%gpp_tstep * 1.e3_r8 * n_density / dt_tstep - hio_ar_pa(io_pa) = hio_ar_pa(io_pa) + & + hio_aresp_pa(io_pa) = hio_aresp_pa(io_pa) + & ccohort%resp_tstep * 1.e3_r8 * n_density / dt_tstep hio_growth_resp_pa(io_pa) = hio_growth_resp_pa(io_pa) + & ccohort%resp_g * 1.e3_r8 * n_density / dt_tstep @@ -568,7 +545,49 @@ subroutine update_history_rapid_tscale(this,nc,sites,nsites,fcolumn,dt_tstep) end associate - end subroutine update_history_rapid_tscale + end subroutine update_history_rapid + + ! ====================================================================================== + + subroutine flush_hvars(this,nc,upfreq_in) + + class(fates_hio_interface_type) :: this + integer,intent(in) :: nc + integer,intent(in) :: upfreq_in + + integer :: ivar + type(iovar_def_type),pointer :: hvar + integer :: lb1,ub1,lb2,ub2 + + + do ivar=1,ubound(this%hvars,1) + hvar => this%hvars(ivar) + if (hvar%upfreq==upfreq_in) then ! Only flush variables with update on dynamics step + call this%get_hvar_bounds(hvar,nc,lb1,ub1,lb2,ub2) + select case(trim(hvar%iovar_dk_ptr%name)) + case('PA_R8') + hvar%r81d(lb1:ub1) = hvar%flushval + case('SI_R8') + hvar%r81d(lb1:ub1) = hvar%flushval + case('PA_GRND_R8') + hvar%r82d(lb1:ub1,lb2:ub2) = hvar%flushval + case('PA_SCPF_R8') + hvar%r82d(lb1:ub1,lb2:ub2) = hvar%flushval + case('SI_GRND_R8') + hvar%r82d(lb1:ub1,lb2:ub2) = hvar%flushval + case('SI_SCPF_R8') + hvar%r82d(lb1:ub1,lb2:ub2) = hvar%flushval + case('PA_INT') + hvar%int1d(lb1:ub1) = nint(hvar%flushval) + case default + write(iulog,*) 'iotyp undefined while flushing history variables' + stop + !end_run + end select + end if + end do + + end subroutine flush_hvars ! ==================================================================================== @@ -603,8 +622,7 @@ subroutine define_history_vars(this,callstep,nvar) class(fates_hio_interface_type) :: this character(len=*),intent(in) :: callstep ! are we 'count'ing or 'initializ'ing? - integer,optional,intent(out) :: nvar - + integer,optional,intent(out) :: nvar integer :: ivar if(.not. (trim(callstep).eq.'count' .or. trim(callstep).eq.'initialize') ) then @@ -615,188 +633,188 @@ subroutine define_history_vars(this,callstep,nvar) ivar=0 call this%set_history_var(vname='TRIMMING2',units='none', & long='Degree to which canopy expansion is limited by leaf economics', & - avgflag='A',vtype='PA_R8',hlms='CLM:ALM',flushval=1.0_r8, ivar=ivar, & - callstep=callstep,index = ih_trimming_pa) + avgflag='A',vtype='PA_R8',hlms='CLM:ALM',flushval=1.0_r8, upfreq=1, & + ivar=ivar, callstep=callstep,index = ih_trimming_pa) call this%set_history_var(vname='AREA_PLANT2',units='m2', & long='area occupied by all plants', & - avgflag='A',vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8,ivar=ivar, & - callstep=callstep,index = ih_area_plant_pa) + avgflag='A',vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & + ivar=ivar, callstep=callstep,index = ih_area_plant_pa) call this%set_history_var(vname='AREA_TREES2',units='m2', & long='area occupied by woody plants', & - avgflag='A',vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8,ivar=ivar, & - callstep=callstep,index = ih_area_treespread_pa) + avgflag='A',vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & + ivar=ivar, callstep=callstep,index = ih_area_treespread_pa) call this%set_history_var(vname='CANOPY_SPREAD2',units='0-1', & long='Scaling factor between tree basal area and canopy area', & - avgflag='A',vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8,ivar=ivar, & - callstep=callstep,index = ih_canopy_spread_pa) + avgflag='A',vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & + ivar=ivar, callstep=callstep,index = ih_canopy_spread_pa) - call this%set_history_var(vname='PFTBIOMASS2',units='gC/m2', & - long='total PFT level biomass', & - avgflag='A', vtype='PA_GRND_R8',hlms='CLM:ALM',flushval=0.0_r8, & - ivar=ivar,callstep=callstep, index = ih_biomass_pa_pft ) + call this%set_history_var(vname='PFTBIOMASS2',units='gC/m2', & + long='total PFT level biomass', & + avgflag='A', vtype='PA_GRND_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & + ivar=ivar, callstep=callstep, index = ih_biomass_pa_pft ) - call this%set_history_var(vname='PFTLEAFBIOMASS2', units='gC/m2', & - long='total PFT level leaf biomass', & - avgflag='A', vtype='PA_GRND_R8',hlms='CLM:ALM',flushval=0.0_r8, & - ivar=ivar,callstep=callstep, index = ih_leafbiomass_pa_pft ) + call this%set_history_var(vname='PFTLEAFBIOMASS2', units='gC/m2', & + long='total PFT level leaf biomass', & + avgflag='A', vtype='PA_GRND_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & + ivar=ivar, callstep=callstep, index = ih_leafbiomass_pa_pft ) - call this%set_history_var(vname='PFTSTOREBIOMASS2', units='gC/m2', & - long='total PFT level stored biomass', & - avgflag='A', vtype='PA_GRND_R8',hlms='CLM:ALM',flushval=0.0_r8, & - ivar=ivar,callstep=callstep, index = ih_storebiomass_pa_pft ) + call this%set_history_var(vname='PFTSTOREBIOMASS2', units='gC/m2', & + long='total PFT level stored biomass', & + avgflag='A', vtype='PA_GRND_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & + ivar=ivar, callstep=callstep, index = ih_storebiomass_pa_pft ) - call this%set_history_var(vname='PFTNINDIVS2', units='indiv / m2', & - long='total PFT level number of individuals', & - avgflag='A', vtype='PA_GRND_R8',hlms='CLM:ALM',flushval=0.0_r8, & - ivar=ivar,callstep=callstep, index = ih_nindivs_pa_pft ) + call this%set_history_var(vname='PFTNINDIVS2', units='indiv / m2', & + long='total PFT level number of individuals', & + avgflag='A', vtype='PA_GRND_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & + ivar=ivar, callstep=callstep, index = ih_nindivs_pa_pft ) ! Fire Variables call this%set_history_var(vname='FIRE_NESTEROV_INDEX2', units='none', & long='nesterov_fire_danger index', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_nesterov_fire_danger_pa) call this%set_history_var(vname='FIRE_ROS2', units='m/min', & long='fire rate of spread m/min', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_spitfire_ROS_pa) call this%set_history_var(vname='EFFECT_WSPEED2', units='none', & long ='effective windspeed for fire spread', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_effect_wspeed_pa ) call this%set_history_var(vname='FIRE_TFC_ROS2', units='none', & long ='total fuel consumed', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_TFC_ROS_pa ) - call this%set_history_var(vname='FIRE_INTENSITY2', units='kJ/m/s', & + call this%set_history_var(vname='FIRE_INTENSITY2', units='kJ/m/s', & long='spitfire fire intensity: kJ/m/s', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_fire_intensity_pa ) - call this%set_history_var(vname='FIRE_AREA2', units='fraction', & + call this%set_history_var(vname='FIRE_AREA2', units='fraction', & long='spitfire fire area:m2', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_fire_area_pa ) - call this%set_history_var(vname='SCORCH_HEIGHT2', units='m', & + call this%set_history_var(vname='SCORCH_HEIGHT2', units='m', & long='spitfire fire area:m2', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_scorch_height_pa ) - call this%set_history_var(vname='FIRE_FUEL_MEF2', units='m', & + call this%set_history_var(vname='FIRE_FUEL_MEF2', units='m', & long='spitfire fuel moisture', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_fire_fuel_mef_pa ) - call this%set_history_var(vname='FIRE_FUEL_BULKD2', units='m', & + call this%set_history_var(vname='FIRE_FUEL_BULKD2', units='m', & long='spitfire fuel bulk density', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_fire_fuel_bulkd_pa ) - call this%set_history_var(vname='FIRE_FUEL_EFF_MOIST2', units='m', & + call this%set_history_var(vname='FIRE_FUEL_EFF_MOIST2', units='m', & long='spitfire fuel moisture', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_fire_fuel_eff_moist_pa ) - call this%set_history_var(vname='FIRE_FUEL_SAV2', units='m', & + call this%set_history_var(vname='FIRE_FUEL_SAV2', units='m', & long='spitfire fuel surface/volume ', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_fire_fuel_sav_pa ) call this%set_history_var(vname='SUM_FUEL2', units='gC m-2', & long='total ground fuel related to ros (omits 1000hr fuels)', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_sum_fuel_pa ) ! Litter Variables call this%set_history_var(vname='LITTER_IN2', units='gC m-2 s-1', & long='Litter flux in leaves', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_litter_in_pa ) call this%set_history_var(vname='LITTER_OUT2', units='gC m-2 s-1', & long='Litter flux out leaves', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_litter_out_pa ) call this%set_history_var(vname='SEED_BANK2', units='gC m-2', & long='Total Seed Mass of all PFTs', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_seed_bank_pa ) call this%set_history_var(vname='SEEDS_IN2', units='gC m-2 s-1', & long='Seed Production Rate', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_seeds_in_pa ) call this%set_history_var(vname='SEED_GERMINATION2', units='gC m-2 s-1', & long='Seed mass converted into new cohorts', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_seed_germination_pa ) call this%set_history_var(vname='SEED_DECAY2', units='gC m-2 s-1', & long='Seed mass decay', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_seed_decay_pa ) call this%set_history_var(vname='BSTORE2', units='gC m-2', & long='Storage biomass', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_bstore_pa ) call this%set_history_var(vname='BDEAD2', units='gC m-2', & long='Dead (structural) biomass (live trees, not CWD)', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_bdead_pa ) call this%set_history_var(vname='BALIVE2', units='gC m-2', & long='Live biomass', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_balive_pa ) call this%set_history_var(vname='BLEAF2', units='gC m-2', & long='Leaf biomass', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_bleaf_pa ) call this%set_history_var(vname='BTOTAL2', units='gC m-2', & long='Total biomass', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_btotal_pa ) - ! Ecosystem Carbon Fluxes (updated rapidly) + ! Ecosystem Carbon Fluxes (updated rapidly, upfreq=2) call this%set_history_var(vname='GPP2', units='gC/m^2/s', & long='gross primary production', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, !cp_hio_ignore_val, & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=2, & ivar=ivar,callstep=callstep, index = ih_gpp_pa ) call this%set_history_var(vname='NPP2', units='gC/m^2/s', & long='net primary production', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, !cp_hio_ignore_val, & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=2, & ivar=ivar,callstep=callstep, index = ih_npp_pa ) - call this%set_history_var(vname='AR2', units='gC/m^2/s', & + call this%set_history_var(vname='ARESP2', units='gC/m^2/s', & long='autotrophic respiration', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, !cp_hio_ignore_val, & - ivar=ivar,callstep=callstep, index = ih_ar_pa ) + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=2, & + ivar=ivar,callstep=callstep, index = ih_aresp_pa ) call this%set_history_var(vname='GROWTH_RESP2', units='gC/m^2/s', & long='growth respiration', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, !cp_hio_ignore_val, & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=2, & ivar=ivar,callstep=callstep, index = ih_growth_resp_pa ) call this%set_history_var(vname='MAINT_RESP2', units='gC/m^2/s', & long='maintenance respiration', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, !cp_hio_ignore_val, & + avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=2, & ivar=ivar,callstep=callstep, index = ih_maint_resp_pa ) @@ -809,7 +827,8 @@ end subroutine define_history_vars ! ===================================================================================== - subroutine set_history_var(this,vname,units,long,avgflag,vtype,hlms,flushval,ivar,callstep,index) + subroutine set_history_var(this,vname,units,long,avgflag,vtype,hlms, & + flushval,upfreq,ivar,callstep,index) use FatesUtilsMod, only : check_hlm_list @@ -824,6 +843,7 @@ subroutine set_history_var(this,vname,units,long,avgflag,vtype,hlms,flushval,iva character(len=*),intent(in) :: vtype character(len=*),intent(in) :: hlms real(r8),intent(in) :: flushval ! IF THE TYPE IS AN INT WE WILL round with NINT + integer,intent(in) :: upfreq character(len=*),intent(in) :: callstep integer, intent(inout) :: ivar integer, intent(inout) :: index ! This is the index for the variable of @@ -851,7 +871,7 @@ subroutine set_history_var(this,vname,units,long,avgflag,vtype,hlms,flushval,iva hvar%vtype = vtype hvar%avgflag = avgflag hvar%flushval = flushval - + hvar%upfreq = upfreq ityp=this%iotype_index(trim(vtype)) hvar%iovar_dk_ptr => this%iovar_dk(ityp) this%iovar_dk(ityp)%active = .true. From a4c6baa2c8c94b21ec53a7d67f7b16b5068b80ce Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 23 Aug 2016 16:23:08 -0700 Subject: [PATCH 169/437] Implemented history updates to dynamics and productivity. Testing prior to removing existing code --- main/EDCLMLinkMod.F90 | 15 +- main/HistoryIOMod.F90 | 319 +++++++++++++++++++++++++++++++++++------- 2 files changed, 277 insertions(+), 57 deletions(-) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 55b0273f..6a4e1789 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -1119,11 +1119,6 @@ subroutine ed_update_history_variables( this, bounds, sites, nsites, fcolumn, ca ed_m3_col_scpf => this%ed_m3_col_scpf , & ed_m4_col_scpf => this%ed_m4_col_scpf , & ed_m5_col_scpf => this%ed_m5_col_scpf , & - - 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 & @@ -1229,10 +1224,6 @@ subroutine ed_update_history_variables( this, bounds, sites, nsites, fcolumn, ca ED_bdead(p) = 0.0_r8 ED_bstore(p) = 0.0_r8 ED_bleaf(p) = 0.0_r8 - elai(p) = 0.0_r8 - tlai(p) = 0.0_r8 - tsai(p) = 0.0_r8 - esai(p) = 0.0_r8 ED_bleaf(p) = 0.0_r8 sum_fuel(p) = 0.0_r8 @@ -1480,6 +1471,12 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, colindex, waterstate_ins p = col%patchi(colindex) ! first patch of the column of interest, for vegetated ! columns this is the non-veg patch + ! Zero some soil values + tlai(p) = 0.0_r8 + elai(p) = 0.0_r8 + tsai(p) = 0.0_r8 + esai(p) = 0.0_r8 + do while(associated(currentPatch)) p = p + 1 ! First CLM/ALM patch is non-veg, increment at loop start diff --git a/main/HistoryIOMod.F90 b/main/HistoryIOMod.F90 index d0d87d1f..b8cec3ee 100644 --- a/main/HistoryIOMod.F90 +++ b/main/HistoryIOMod.F90 @@ -4,6 +4,7 @@ Module HistoryIOMod use shr_kind_mod , only : r8 => shr_kind_r8 use clm_varctl , only : iulog use EDTypesMod , only : cp_hio_ignore_val + use pftconMod , only : pftcon implicit none @@ -87,11 +88,11 @@ Module HistoryIOMod integer, private :: ih_cbalance_error_ed_si integer, private :: ih_cbalance_error_bgc_si integer, private :: ih_cbalance_error_total_si - integer, private :: ih_ed_npatches_si - integer, private :: ih_ed_ncohorts_si + integer, private :: ih_npatches_si + integer, private :: ih_ncohorts_si ! Indices to (site x scpf) variables - + integer, private :: ih_nplant_si_scpf integer, private :: ih_gpp_si_scpf integer, private :: ih_npp_totl_si_scpf integer, private :: ih_npp_leaf_si_scpf @@ -113,7 +114,6 @@ Module HistoryIOMod integer, private :: ih_ddbh_si_scpf integer, private :: ih_ba_si_scpf - integer, private :: ih_np_si_scpf integer, private :: ih_m1_si_scpf integer, private :: ih_m2_si_scpf integer, private :: ih_m3_si_scpf @@ -166,6 +166,10 @@ Module HistoryIOMod character(len=32) :: vname character(len=24) :: units character(len=128) :: long + character(len=24) :: use_default ! States whether a variable should be turned + ! on the output files by default (active/inactive) + ! It is a good idea to set inactive for very large + ! or infrequently used output datasets character(len=24) :: vtype character(len=1) :: avgflag integer :: upfreq ! Update frequency (this is for checks and flushing) @@ -247,7 +251,11 @@ subroutine update_history_dyn(this,nc,sites,nsites,fcolumn) use EDtypesMod , only : ed_site_type, & ed_cohort_type, & ed_patch_type, & - AREA + AREA, & + sclass_ed, & + nlevsclass_ed + use EDParamsMod , only : ED_val_ag_biomass + ! Arguments class(fates_hio_interface_type) :: this integer , intent(in) :: nc ! clump index @@ -265,9 +273,13 @@ subroutine update_history_dyn(this,nc,sites,nsites,fcolumn) integer :: lb1,ub1,lb2,ub2 ! IO array bounds for the calling thread integer :: ivar ! index of IO variable object vector integer :: ft ! functional type index + integer :: scpf ! index of the size-class x pft bin + integer :: sc ! index of the size-class bin + real(r8) :: n_density ! individual of cohort per m2. real(r8) :: n_perm2 ! individuals per m2 for the whole column real(r8) :: patch_scaling_scalar ! ratio of canopy to patch area for counteracting patch scaling + real(r8) :: dbh ! diameter ("at breast height") type(iovar_def_type),pointer :: hvar type(ed_patch_type),pointer :: cpatch @@ -276,7 +288,9 @@ subroutine update_history_dyn(this,nc,sites,nsites,fcolumn) real(r8), parameter :: daysecs = 86400.0_r8 ! What modeler doesn't recognize 86400? real(r8), parameter :: yeardays = 365.0_r8 ! Should this be 365.25? - associate( hio_trimming_pa => this%hvars(ih_trimming_pa)%r81d, & + associate( hio_npatches_si => this%hvars(ih_npatches_si)%r81d, & + hio_ncohorts_si => this%hvars(ih_ncohorts_si)%r81d, & + hio_trimming_pa => this%hvars(ih_trimming_pa)%r81d, & hio_area_plant_pa => this%hvars(ih_area_plant_pa)%r81d, & hio_area_treespread_pa => this%hvars(ih_area_treespread_pa)%r81d, & hio_canopy_spread_pa => this%hvars(ih_canopy_spread_pa)%r81d, & @@ -306,15 +320,32 @@ subroutine update_history_dyn(this,nc,sites,nsites,fcolumn) hio_bdead_pa => this%hvars(ih_bdead_pa)%r81d, & hio_balive_pa => this%hvars(ih_balive_pa)%r81d, & hio_bleaf_pa => this%hvars(ih_bleaf_pa)%r81d, & - hio_btotal_pa => this%hvars(ih_btotal_pa)%r81d ) + hio_btotal_pa => this%hvars(ih_btotal_pa)%r81d, & + hio_gpp_si_scpf => this%hvars(ih_gpp_si_scpf)%r82d, & + hio_npp_totl_si_scpf => this%hvars(ih_npp_totl_si_scpf)%r82d, & + hio_npp_leaf_si_scpf => this%hvars(ih_npp_leaf_si_scpf)%r82d, & + hio_npp_seed_si_scpf => this%hvars(ih_npp_seed_si_scpf)%r82d, & + hio_npp_fnrt_si_scpf => this%hvars(ih_npp_fnrt_si_scpf)%r82d, & + hio_npp_bgsw_si_scpf => this%hvars(ih_npp_bgsw_si_scpf)%r82d, & + hio_npp_bgdw_si_scpf => this%hvars(ih_npp_bgdw_si_scpf)%r82d, & + hio_npp_agsw_si_scpf => this%hvars(ih_npp_agsw_si_scpf)%r82d, & + hio_npp_agdw_si_scpf => this%hvars(ih_npp_agdw_si_scpf)%r82d, & + hio_npp_stor_si_scpf => this%hvars(ih_npp_stor_si_scpf)%r82d, & + hio_ddbh_si_scpf => this%hvars(ih_ddbh_si_scpf)%r82d, & + hio_ba_si_scpf => this%hvars(ih_ba_si_scpf)%r82d, & + hio_nplant_si_scpf => this%hvars(ih_nplant_si_scpf)%r82d, & + hio_m1_si_scpf => this%hvars(ih_m1_si_scpf)%r82d, & + hio_m2_si_scpf => this%hvars(ih_m2_si_scpf)%r82d, & + hio_m3_si_scpf => this%hvars(ih_m3_si_scpf)%r82d, & + hio_m4_si_scpf => this%hvars(ih_m4_si_scpf)%r82d, & + hio_m5_si_scpf => this%hvars(ih_m5_si_scpf)%r82d ) ! --------------------------------------------------------------------------------- ! Flush arrays to values defined by %flushval (see registry entry in ! subroutine define_history_vars() ! --------------------------------------------------------------------------------- - call this%flush_hvars(nc,upfreq_in=1) - + ! --------------------------------------------------------------------------------- ! Loop through the FATES scale hierarchy and fill the history IO arrays ! --------------------------------------------------------------------------------- @@ -325,22 +356,26 @@ subroutine update_history_dyn(this,nc,sites,nsites,fcolumn) io_pa1 = this%iovar_map(nc)%patch1_index(s) io_soipa = io_pa1-1 - ! Set trimming on the soil patch to 1.0 hio_trimming_pa(io_soipa) = 1.0_r8 - ipa = 0 cpatch => sites(s)%oldest_patch do while(associated(cpatch)) io_pa = io_pa1 + ipa + + ! Increment the number of patches per site + hio_npatches_si(io_si) = hio_npatches_si(io_si) + 1._r8 ccohort => cpatch%shortest do while(associated(ccohort)) ft = ccohort%pft + ! Increment the number of cohorts per site + hio_ncohorts_si(io_si) = hio_ncohorts_si(io_si) + 1._r8 + if ((cpatch%area .gt. 0._r8) .and. (cpatch%total_canopy_area .gt. 0._r8)) then ! for quantities that are at the CLM patch level, because of the way @@ -391,7 +426,70 @@ subroutine update_history_dyn(this,nc,sites,nsites,fcolumn) hio_nindivs_pa_pft(io_pa,ft) = hio_nindivs_pa_pft(io_pa,ft) + & ccohort%n - + + ! Site by Size-Class x PFT (SCPF) + ! ------------------------------------------------------------------------ + + dbh = ccohort%dbh !-0.5*(1./365.25)*ccohort%ddbhdt + sc = count(dbh-sclass_ed.ge.0.0) + scpf = (ft-1)*nlevsclass_ed+sc + + ! Flux Variables (cohorts must had experienced a day before any of these values + ! have any meaning, otherwise they are just inialization values + if( .not.(ccohort%isnew) ) then + + hio_gpp_si_scpf(io_si,scpf) = hio_gpp_si_scpf(io_si,scpf) + n_perm2*ccohort%gpp ! [kgC/m2/yr] + hio_npp_totl_si_scpf(io_si,scpf) = hio_npp_totl_si_scpf(io_si,scpf) + ccohort%npp*n_perm2 + hio_npp_leaf_si_scpf(io_si,scpf) = hio_npp_leaf_si_scpf(io_si,scpf) + ccohort%npp_leaf*n_perm2 + hio_npp_fnrt_si_scpf(io_si,scpf) = hio_npp_fnrt_si_scpf(io_si,scpf) + ccohort%npp_froot*n_perm2 + hio_npp_bgsw_si_scpf(io_si,scpf) = hio_npp_bgsw_si_scpf(io_si,scpf) + ccohort%npp_bsw*(1._r8-ED_val_ag_biomass)*n_perm2 + hio_npp_agsw_si_scpf(io_si,scpf) = hio_npp_agsw_si_scpf(io_si,scpf) + ccohort%npp_bsw*ED_val_ag_biomass*n_perm2 + hio_npp_bgdw_si_scpf(io_si,scpf) = hio_npp_bgdw_si_scpf(io_si,scpf) + ccohort%npp_bdead*(1._r8-ED_val_ag_biomass)*n_perm2 + hio_npp_agdw_si_scpf(io_si,scpf) = hio_npp_agdw_si_scpf(io_si,scpf) + ccohort%npp_bdead*ED_val_ag_biomass*n_perm2 + hio_npp_seed_si_scpf(io_si,scpf) = hio_npp_seed_si_scpf(io_si,scpf) + ccohort%npp_bseed*n_perm2 + hio_npp_stor_si_scpf(io_si,scpf) = hio_npp_stor_si_scpf(io_si,scpf) + ccohort%npp_store*n_perm2 + + if( abs(ccohort%npp-(ccohort%npp_leaf+ccohort%npp_froot+ & + ccohort%npp_bsw+ccohort%npp_bdead+ & + ccohort%npp_bseed+ccohort%npp_store))>1.e-9) then + write(iulog,*) 'NPP Partitions are not balancing' + write(iulog,*) 'Fractional Error: ',abs(ccohort%npp-(ccohort%npp_leaf+ccohort%npp_froot+ & + ccohort%npp_bsw+ccohort%npp_bdead+ & + ccohort%npp_bseed+ccohort%npp_store))/ccohort%npp + write(iulog,*) 'Terms: ',ccohort%npp,ccohort%npp_leaf,ccohort%npp_froot, & + ccohort%npp_bsw,ccohort%npp_bdead, & + ccohort%npp_bseed,ccohort%npp_store + write(iulog,*) ' NPP components during FATES-HLM linking does not balance ' + stop ! we need termination control for FATES!!! + ! call endrun(msg=errMsg(__FILE__, __LINE__)) + end if + + ! Woody State Variables (basal area and number density and mortality) + if (pftcon%woody(ft) == 1) then + + hio_m1_si_scpf(io_si,scpf) = hio_m1_si_scpf(io_si,scpf) + ccohort%bmort*n_perm2*AREA + hio_m2_si_scpf(io_si,scpf) = hio_m2_si_scpf(io_si,scpf) + ccohort%hmort*n_perm2*AREA + hio_m3_si_scpf(io_si,scpf) = hio_m3_si_scpf(io_si,scpf) + ccohort%cmort*n_perm2*AREA + hio_m4_si_scpf(io_si,scpf) = hio_m4_si_scpf(io_si,scpf) + ccohort%imort*n_perm2*AREA + hio_m5_si_scpf(io_si,scpf) = hio_m5_si_scpf(io_si,scpf) + ccohort%fmort*n_perm2*AREA + + ! basal area [m2/ha] + hio_ba_si_scpf(io_si,scpf) = hio_ba_si_scpf(io_si,scpf) + & + 0.25_r8*3.14159_r8*((dbh/100.0_r8)**2.0_r8)*n_perm2*AREA + + ! number density [/ha] + hio_nplant_si_scpf(io_si,scpf) = hio_nplant_si_scpf(io_si,scpf) + AREA*n_perm2 + + ! Growth Incrments must have NaN check and woody check + if(ccohort%ddbhdt == ccohort%ddbhdt) then + hio_ddbh_si_scpf(io_si,scpf) = hio_ddbh_si_scpf(io_si,scpf) + & + ccohort%ddbhdt*n_perm2*AREA + else + hio_ddbh_si_scpf(io_si,scpf) = -999.9 + end if + end if + + end if ccohort => ccohort%taller enddo ! cohort loop @@ -490,7 +588,8 @@ subroutine update_history_rapid(this,nc,sites,nsites,fcolumn,dt_tstep) hio_npp_pa => this%hvars(ih_npp_pa)%r81d, & hio_aresp_pa => this%hvars(ih_aresp_pa)%r81d, & hio_maint_resp_pa => this%hvars(ih_maint_resp_pa)%r81d, & - hio_growth_resp_pa => this%hvars(ih_growth_resp_pa)%r81d ) + hio_growth_resp_pa => this%hvars(ih_growth_resp_pa)%r81d, & + hio_npp_si => this%hvars(ih_npp_si)%r81d ) ! Flush the relevant history variables call this%flush_hvars(nc,upfreq_in=2) @@ -533,6 +632,9 @@ subroutine update_history_rapid(this,nc,sites,nsites,fcolumn,dt_tstep) hio_maint_resp_pa(io_pa) = hio_maint_resp_pa(io_pa) + & ccohort%resp_m * 1.e3_r8 * n_density / dt_tstep + ! map ed cohort-level npp fluxes to clm column fluxes + hio_npp_si(io_si) = hio_npp_si(io_si) + ccohort%npp_tstep * n_perm2 * 1.e3_r8 /dt_tstep + endif ccohort => ccohort%taller @@ -631,193 +733,312 @@ subroutine define_history_vars(this,callstep,nvar) end if ivar=0 + + ! Site level counting variables + call this%set_history_var(vname='ED_NPATCHES2',units='none', & + long='Total number of ED patches per site', use_default='active', & + avgflag='A',vtype='SI_R8',hlms='CLM:ALM',flushval=1.0_r8, upfreq=1, & + ivar=ivar, callstep=callstep,index = ih_npatches_si) + + call this%set_history_var(vname='ED_NCOHORTS2',units='none', & + long='Total number of ED cohorts per site', use_default='active', & + avgflag='A',vtype='SI_R8',hlms='CLM:ALM',flushval=1.0_r8, upfreq=1, & + ivar=ivar, callstep=callstep,index = ih_ncohorts_si) + + ! Patch variables call this%set_history_var(vname='TRIMMING2',units='none', & - long='Degree to which canopy expansion is limited by leaf economics', & + long='Degree to which canopy expansion is limited by leaf economics', & + use_default='active', & avgflag='A',vtype='PA_R8',hlms='CLM:ALM',flushval=1.0_r8, upfreq=1, & ivar=ivar, callstep=callstep,index = ih_trimming_pa) call this%set_history_var(vname='AREA_PLANT2',units='m2', & - long='area occupied by all plants', & + long='area occupied by all plants', use_default='active', & avgflag='A',vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar, callstep=callstep,index = ih_area_plant_pa) call this%set_history_var(vname='AREA_TREES2',units='m2', & - long='area occupied by woody plants', & + long='area occupied by woody plants', use_default='active', & avgflag='A',vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar, callstep=callstep,index = ih_area_treespread_pa) call this%set_history_var(vname='CANOPY_SPREAD2',units='0-1', & long='Scaling factor between tree basal area and canopy area', & + use_default='active', & avgflag='A',vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar, callstep=callstep,index = ih_canopy_spread_pa) call this%set_history_var(vname='PFTBIOMASS2',units='gC/m2', & - long='total PFT level biomass', & + long='total PFT level biomass', use_default='active', & avgflag='A', vtype='PA_GRND_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar, callstep=callstep, index = ih_biomass_pa_pft ) call this%set_history_var(vname='PFTLEAFBIOMASS2', units='gC/m2', & - long='total PFT level leaf biomass', & + long='total PFT level leaf biomass', use_default='active', & avgflag='A', vtype='PA_GRND_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar, callstep=callstep, index = ih_leafbiomass_pa_pft ) call this%set_history_var(vname='PFTSTOREBIOMASS2', units='gC/m2', & - long='total PFT level stored biomass', & + long='total PFT level stored biomass', use_default='active', & avgflag='A', vtype='PA_GRND_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar, callstep=callstep, index = ih_storebiomass_pa_pft ) call this%set_history_var(vname='PFTNINDIVS2', units='indiv / m2', & - long='total PFT level number of individuals', & + long='total PFT level number of individuals', use_default='active', & avgflag='A', vtype='PA_GRND_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar, callstep=callstep, index = ih_nindivs_pa_pft ) ! Fire Variables call this%set_history_var(vname='FIRE_NESTEROV_INDEX2', units='none', & - long='nesterov_fire_danger index', & + long='nesterov_fire_danger index', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_nesterov_fire_danger_pa) call this%set_history_var(vname='FIRE_ROS2', units='m/min', & - long='fire rate of spread m/min', & + long='fire rate of spread m/min', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_spitfire_ROS_pa) call this%set_history_var(vname='EFFECT_WSPEED2', units='none', & - long ='effective windspeed for fire spread', & + long ='effective windspeed for fire spread', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_effect_wspeed_pa ) call this%set_history_var(vname='FIRE_TFC_ROS2', units='none', & - long ='total fuel consumed', & + long ='total fuel consumed', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_TFC_ROS_pa ) call this%set_history_var(vname='FIRE_INTENSITY2', units='kJ/m/s', & - long='spitfire fire intensity: kJ/m/s', & + long='spitfire fire intensity: kJ/m/s', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_fire_intensity_pa ) call this%set_history_var(vname='FIRE_AREA2', units='fraction', & - long='spitfire fire area:m2', & + long='spitfire fire area:m2', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_fire_area_pa ) call this%set_history_var(vname='SCORCH_HEIGHT2', units='m', & - long='spitfire fire area:m2', & + long='spitfire fire area:m2', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_scorch_height_pa ) call this%set_history_var(vname='FIRE_FUEL_MEF2', units='m', & - long='spitfire fuel moisture', & + long='spitfire fuel moisture', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_fire_fuel_mef_pa ) call this%set_history_var(vname='FIRE_FUEL_BULKD2', units='m', & - long='spitfire fuel bulk density', & + long='spitfire fuel bulk density', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_fire_fuel_bulkd_pa ) call this%set_history_var(vname='FIRE_FUEL_EFF_MOIST2', units='m', & - long='spitfire fuel moisture', & + long='spitfire fuel moisture', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_fire_fuel_eff_moist_pa ) call this%set_history_var(vname='FIRE_FUEL_SAV2', units='m', & - long='spitfire fuel surface/volume ', & + long='spitfire fuel surface/volume ', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_fire_fuel_sav_pa ) call this%set_history_var(vname='SUM_FUEL2', units='gC m-2', & - long='total ground fuel related to ros (omits 1000hr fuels)', & + long='total ground fuel related to ros (omits 1000hr fuels)', & + use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_sum_fuel_pa ) ! Litter Variables call this%set_history_var(vname='LITTER_IN2', units='gC m-2 s-1', & - long='Litter flux in leaves', & + long='Litter flux in leaves', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_litter_in_pa ) call this%set_history_var(vname='LITTER_OUT2', units='gC m-2 s-1', & - long='Litter flux out leaves', & + long='Litter flux out leaves', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_litter_out_pa ) call this%set_history_var(vname='SEED_BANK2', units='gC m-2', & - long='Total Seed Mass of all PFTs', & + long='Total Seed Mass of all PFTs', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_seed_bank_pa ) call this%set_history_var(vname='SEEDS_IN2', units='gC m-2 s-1', & - long='Seed Production Rate', & + long='Seed Production Rate', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_seeds_in_pa ) call this%set_history_var(vname='SEED_GERMINATION2', units='gC m-2 s-1', & - long='Seed mass converted into new cohorts', & + long='Seed mass converted into new cohorts', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_seed_germination_pa ) call this%set_history_var(vname='SEED_DECAY2', units='gC m-2 s-1', & - long='Seed mass decay', & + long='Seed mass decay', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_seed_decay_pa ) call this%set_history_var(vname='BSTORE2', units='gC m-2', & - long='Storage biomass', & + long='Storage biomass', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_bstore_pa ) call this%set_history_var(vname='BDEAD2', units='gC m-2', & long='Dead (structural) biomass (live trees, not CWD)', & + use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_bdead_pa ) call this%set_history_var(vname='BALIVE2', units='gC m-2', & - long='Live biomass', & + long='Live biomass', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_balive_pa ) call this%set_history_var(vname='BLEAF2', units='gC m-2', & - long='Leaf biomass', & + long='Leaf biomass', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_bleaf_pa ) call this%set_history_var(vname='BTOTAL2', units='gC m-2', & - long='Total biomass', & + long='Total biomass', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_btotal_pa ) ! Ecosystem Carbon Fluxes (updated rapidly, upfreq=2) + + call this%set_history_var(vname='NPP_SI2', units='gC/m^2/s', & + long='net primary production on the site', use_default='active', & + avgflag='A', vtype='SI_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=2, & + ivar=ivar,callstep=callstep, index = ih_npp_si ) + call this%set_history_var(vname='GPP2', units='gC/m^2/s', & - long='gross primary production', & + long='gross primary production', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=2, & ivar=ivar,callstep=callstep, index = ih_gpp_pa ) call this%set_history_var(vname='NPP2', units='gC/m^2/s', & - long='net primary production', & + long='net primary production', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=2, & ivar=ivar,callstep=callstep, index = ih_npp_pa ) call this%set_history_var(vname='ARESP2', units='gC/m^2/s', & - long='autotrophic respiration', & + long='autotrophic respiration', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=2, & ivar=ivar,callstep=callstep, index = ih_aresp_pa ) call this%set_history_var(vname='GROWTH_RESP2', units='gC/m^2/s', & - long='growth respiration', & + long='growth respiration', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=2, & ivar=ivar,callstep=callstep, index = ih_growth_resp_pa ) call this%set_history_var(vname='MAINT_RESP2', units='gC/m^2/s', & - long='maintenance respiration', & + long='maintenance respiration', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=2, & ivar=ivar,callstep=callstep, index = ih_maint_resp_pa ) + ! Carbon Flux (grid dimension x scpf) (THESE ARE DEFAULT INACTIVE!!! + ! (BECAUSE THEY TAKE UP SPACE!!! + ! =================================================================================== + + call this%set_history_var(vname='GPP_SCPF',units='kgC/m2/yr', & + long='gross primary production', use_default='inactive', & + avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & + upfreq=1, ivar=ivar,callstep=callstep, index = ih_gpp_si_scpf ) + + call this%set_history_var(vname='NPP_SCPF',units='kgC/m2/yr', & + long='total net primary production', use_default='inactive', & + avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & + upfreq=1, ivar=ivar,callstep=callstep, index = ih_npp_totl_si_scpf ) + + + call this%set_history_var(vname='NPP_LEAF_SCPF',units='kgC/m2/yr', & + long='NPP flux into leaves', use_default='inactive', & + avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & + upfreq=1, ivar=ivar,callstep=callstep, index = ih_npp_leaf_si_scpf ) + + call this%set_history_var(vname='NPP_SEED_SCPF',units='kgC/m2/yr', & + long='NPP flux into seeds', use_default='inactive', & + avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & + upfreq=1, ivar=ivar,callstep=callstep, index = ih_npp_seed_si_scpf ) + + call this%set_history_var(vname='NPP_FNRT_SCPF',units='kgC/m2/yr', & + long='NPP flux into fine roots', use_default='inactive', & + avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & + upfreq=1, ivar=ivar,callstep=callstep, index = ih_npp_fnrt_si_scpf ) + + call this%set_history_var(vname='NPP_BGSW_SCPF',units='kgC/m2/yr', & + long='NPP flux into below-ground sapwood', use_default='inactive', & + avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & + upfreq=1, ivar=ivar,callstep=callstep, index = ih_npp_bgsw_si_scpf ) + + call this%set_history_var(vname='NPP_BGDW_SCPF',units='kgC/m2/yr', & + long='NPP flux into below-ground deadwood', use_default='inactive',& + avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & + upfreq=1, ivar=ivar,callstep=callstep, index = ih_npp_bgdw_si_scpf ) + + call this%set_history_var(vname='NPP_AGSW_SCPF',units='kgC/m2/yr', & + long='NPP flux into above-ground sapwood', use_default='inactive', & + avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & + upfreq=1, ivar=ivar,callstep=callstep, index = ih_npp_agsw_si_scpf ) + + call this%set_history_var(vname = 'NPP_AGDW_SCPF', units='kgC/m2/yr', & + long='NPP flux into above-ground deadwood', use_default='inactive',& + avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & + upfreq=1, ivar=ivar,callstep=callstep, index = ih_npp_agdw_si_scpf ) + + call this%set_history_var(vname = 'NPP_STOR_SCPF', units='kgC/m2/yr', & + long='NPP flux into storage', use_default='inactive', & + avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & + upfreq=1, ivar=ivar,callstep=callstep, index = ih_npp_stor_si_scpf ) + + call this%set_history_var(vname='DDBH_SCPF', units = 'cm/yr/ha', & + long='diameter growth increment and pft/size',use_default='inactive',& + avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & + upfreq=1, ivar=ivar,callstep=callstep, index = ih_ddbh_si_scpf ) + + call this%set_history_var(vname='BA_SCPF',units = 'm2/ha', & + long='basal area by patch and pft/size', use_default='inactive', & + avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & + upfreq=1, ivar=ivar,callstep=callstep, index = ih_ba_si_scpf ) + + call this%set_history_var(vname='NPLANT_SCPF',units = 'N/ha', & + long='stem number density by patch and pft/size', use_default='inactive', & + avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & + upfreq=1, ivar=ivar,callstep=callstep, index = ih_nplant_si_scpf ) + + call this%set_history_var(vname='M1_SCPF',units = 'N/ha/yr', & + long='background mortality count by patch and pft/size', use_default='inactive',& + avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & + upfreq=1, ivar=ivar,callstep=callstep, index = ih_m1_si_scpf ) + + call this%set_history_var(vname='M2_SCPF',units = 'N/ha/yr', & + long='hydraulic mortality count by patch and pft/size',use_default='inactive',& + avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & + upfreq=1, ivar=ivar,callstep=callstep, index = ih_m2_si_scpf ) + + call this%set_history_var(vname='M3_SCPF',units = 'N/ha/yr', & + long='carbon starvation mortality count by patch and pft/size',use_default='inactive', & + avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & + upfreq=1, ivar=ivar,callstep=callstep, index = ih_m3_si_scpf ) + + call this%set_history_var(vname='M4_SCPF',units = 'N/ha/yr', & + long='impact mortality count by patch and pft/size',use_default='inactive',& + avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & + upfreq=1, ivar=ivar,callstep=callstep, index = ih_m4_si_scpf ) + + call this%set_history_var(vname='M5_SCPF',units = 'N/ha/yr', & + long='fire mortality count by patch and pft/size',use_default='inactive',& + avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & + upfreq=1, ivar=ivar,callstep=callstep, index = ih_m5_si_scpf ) + + ! Must be last thing before return if(present(nvar)) nvar = ivar @@ -827,7 +1048,7 @@ end subroutine define_history_vars ! ===================================================================================== - subroutine set_history_var(this,vname,units,long,avgflag,vtype,hlms, & + subroutine set_history_var(this,vname,units,long,use_default,avgflag,vtype,hlms, & flushval,upfreq,ivar,callstep,index) @@ -839,6 +1060,7 @@ subroutine set_history_var(this,vname,units,long,avgflag,vtype,hlms, & character(len=*),intent(in) :: vname character(len=*),intent(in) :: units character(len=*),intent(in) :: long + character(len=*),intent(in) :: use_default character(len=*),intent(in) :: avgflag character(len=*),intent(in) :: vtype character(len=*),intent(in) :: hlms @@ -868,6 +1090,7 @@ subroutine set_history_var(this,vname,units,long,avgflag,vtype,hlms, & hvar%vname = vname hvar%units = units hvar%long = long + hvar%use_default = use_default hvar%vtype = vtype hvar%avgflag = avgflag hvar%flushval = flushval From ef879353a7219486bfd7ed203e0f6410ee834152 Mon Sep 17 00:00:00 2001 From: Ben Andre Date: Wed, 24 Aug 2016 10:27:14 -0600 Subject: [PATCH 170/437] Fix nag compiler errors NAG is a much stricter compiler than our usual development and testing compilers. Shorten a bunch of excessively long lines to meet the 132 character limit. When passing a sized array and a size, e.g. sites(num_sites), into a subroutine, the array size arguement must be first so it is properly declared before the array referencing the size. Testing: SMS_D_Mmpi-serial_Ld5.5x5_amazon.ICLM45ED.hobart_nag.clm-edTest compiles but dies at runtime. intel and pgi versions of the above test run to completion on hobart. SMS_D_Mmpi-serial_Ld5.5x5_amazon.ICLM45BGC.hobart_nag.clm-default runs to completion. --- biogeochem/EDCohortDynamicsMod.F90 | 3 +- biogeochem/EDPatchDynamicsMod.F90 | 4 +- biogeochem/EDPhysiologyMod.F90 | 46 +++++++++++++-------- biogeophys/EDAccumulateFluxesMod.F90 | 4 +- biogeophys/EDBtranMod.F90 | 8 ++-- biogeophys/EDPhotosynthesisMod.F90 | 29 +++++++++----- biogeophys/EDSurfaceAlbedoMod.F90 | 49 ++++++++++++++--------- main/EDCLMLinkMod.F90 | 60 ++++++++++++++++++---------- main/EDInitMod.F90 | 8 ++-- main/EDRestVectorMod.F90 | 50 +++++++++++------------ 10 files changed, 158 insertions(+), 103 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index ba76735f..fca32709 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -219,7 +219,8 @@ subroutine allocate_live_biomass(cc_p,mode) if(mode==1)then currentcohort%npp_froot = currentcohort%npp_froot + & - max(0._r8,pftcon%froot_leaf(ft)*(currentcohort%balive+currentcohort%laimemory)*leaf_frac - currentcohort%br)/udata%deltat + max(0._r8,pftcon%froot_leaf(ft)*(currentcohort%balive+currentcohort%laimemory)*leaf_frac - currentcohort%br) / & + udata%deltat currentcohort%npp_bsw = max(0._r8,EDecophyscon%sapwood_ratio(ft) * currentcohort%hite *(currentcohort%balive + & currentcohort%laimemory)*leaf_frac - currentcohort%bsw)/udata%deltat diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index d38e868d..c011b7d4 100755 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -1480,7 +1480,7 @@ subroutine patch_pft_size_profile(cp_pnt) end subroutine patch_pft_size_profile ! ============================================================================ - function countPatches( bounds, sites, nsites ) result ( totNumPatches ) + function countPatches( bounds, nsites, sites ) result ( totNumPatches ) ! ! !DESCRIPTION: ! Loop over all Patches to count how many there are @@ -1492,8 +1492,8 @@ function countPatches( bounds, sites, nsites ) result ( totNumPatches ) ! ! !ARGUMENTS: type(bounds_type) , intent(in) :: bounds - type(ed_site_type) , intent(inout), target :: sites(nsites) integer, intent(in) :: nsites + type(ed_site_type) , intent(inout), target :: sites(nsites) ! ! !LOCAL VARIABLES: type (ed_patch_type), pointer :: currentPatch diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 1dff2f2e..4bdbef36 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1270,7 +1270,7 @@ end subroutine cwd_out - subroutine flux_into_litter_pools(sites, nsites, bc_in, bc_out) + subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) ! Created by Charlie Koven and Rosie Fisher, 2014-2015 ! take the flux out of the fragmenting litter pools and port into the decomposing litter pools. ! in this implementation, decomposing pools are assumed to be humus and non-flammable, whereas fragmenting pools @@ -1303,8 +1303,8 @@ subroutine flux_into_litter_pools(sites, nsites, bc_in, bc_out) implicit none ! ! !ARGUMENTS - type(ed_site_type) , intent(inout), target :: sites(nsites) integer , intent(in) :: nsites + type(ed_site_type) , intent(inout), target :: sites(nsites) type(bc_in_type) , intent(in) :: bc_in(:) type(bc_out_type) , intent(inout) :: bc_out(:) ! @@ -1536,7 +1536,8 @@ subroutine flux_into_litter_pools(sites, nsites, bc_in, bc_out) biomass_bg_ft(1:numpft_ed) = 0._r8 currentCohort => currentPatch%tallest do while(associated(currentCohort)) - biomass_bg_ft(currentCohort%pft) = biomass_bg_ft(currentCohort%pft) + currentCohort%b * (currentCohort%n / currentPatch%area) * (1.0_r8-ED_val_ag_biomass) + biomass_bg_ft(currentCohort%pft) = biomass_bg_ft(currentCohort%pft) + & + currentCohort%b * (currentCohort%n / currentPatch%area) * (1.0_r8-ED_val_ag_biomass) currentCohort => currentCohort%shorter enddo !currentCohort ! @@ -1580,29 +1581,42 @@ subroutine flux_into_litter_pools(sites, nsites, bc_in, bc_out) ! CWD pools fragmenting into decomposing litter pools. do ci = 1, ncwd do j = 1, cp_numlevdecomp - bc_out(s)%FATES_c_to_litr_cel_c_col(j) = bc_out(s)%FATES_c_to_litr_cel_c_col(j) + currentpatch%CWD_AG_out(ci) * cwd_fcel_ed * currentpatch%area/AREA * stem_prof(s,j) - bc_out(s)%FATES_c_to_litr_lig_c_col(j) = bc_out(s)%FATES_c_to_litr_lig_c_col(j) + currentpatch%CWD_AG_out(ci) * cwd_flig_ed * currentpatch%area/AREA * stem_prof(s,j) + bc_out(s)%FATES_c_to_litr_cel_c_col(j) = bc_out(s)%FATES_c_to_litr_cel_c_col(j) + & + currentpatch%CWD_AG_out(ci) * cwd_fcel_ed * currentpatch%area/AREA * stem_prof(s,j) + bc_out(s)%FATES_c_to_litr_lig_c_col(j) = bc_out(s)%FATES_c_to_litr_lig_c_col(j) + & + currentpatch%CWD_AG_out(ci) * cwd_flig_ed * currentpatch%area/AREA * stem_prof(s,j) ! - bc_out(s)%FATES_c_to_litr_cel_c_col(j) = bc_out(s)%FATES_c_to_litr_cel_c_col(j) + currentpatch%CWD_BG_out(ci) * cwd_fcel_ed * currentpatch%area/AREA * croot_prof_perpatch(j) - bc_out(s)%FATES_c_to_litr_lig_c_col(j) = bc_out(s)%FATES_c_to_litr_lig_c_col(j) + currentpatch%CWD_BG_out(ci) * cwd_flig_ed * currentpatch%area/AREA * croot_prof_perpatch(j) + bc_out(s)%FATES_c_to_litr_cel_c_col(j) = bc_out(s)%FATES_c_to_litr_cel_c_col(j) + & + currentpatch%CWD_BG_out(ci) * cwd_fcel_ed * currentpatch%area/AREA * croot_prof_perpatch(j) + bc_out(s)%FATES_c_to_litr_lig_c_col(j) = bc_out(s)%FATES_c_to_litr_lig_c_col(j) + & + currentpatch%CWD_BG_out(ci) * cwd_flig_ed * currentpatch%area/AREA * croot_prof_perpatch(j) end do end do ! leaf and fine root pools. do ft = 1,numpft_ed do j = 1, cp_numlevdecomp - bc_out(s)%FATES_c_to_litr_lab_c_col(j) = bc_out(s)%FATES_c_to_litr_lab_c_col(j) + currentpatch%leaf_litter_out(ft) * pftcon%lf_flab(ft) * currentpatch%area/AREA * leaf_prof(s,j) - bc_out(s)%FATES_c_to_litr_cel_c_col(j) = bc_out(s)%FATES_c_to_litr_cel_c_col(j) + currentpatch%leaf_litter_out(ft) * pftcon%lf_fcel(ft) * currentpatch%area/AREA * leaf_prof(s,j) - bc_out(s)%FATES_c_to_litr_lig_c_col(j) = bc_out(s)%FATES_c_to_litr_lig_c_col(j) + currentpatch%leaf_litter_out(ft) * pftcon%lf_flig(ft) * currentpatch%area/AREA * leaf_prof(s,j) + bc_out(s)%FATES_c_to_litr_lab_c_col(j) = bc_out(s)%FATES_c_to_litr_lab_c_col(j) + & + currentpatch%leaf_litter_out(ft) * pftcon%lf_flab(ft) * currentpatch%area/AREA * leaf_prof(s,j) + bc_out(s)%FATES_c_to_litr_cel_c_col(j) = bc_out(s)%FATES_c_to_litr_cel_c_col(j) + & + currentpatch%leaf_litter_out(ft) * pftcon%lf_fcel(ft) * currentpatch%area/AREA * leaf_prof(s,j) + bc_out(s)%FATES_c_to_litr_lig_c_col(j) = bc_out(s)%FATES_c_to_litr_lig_c_col(j) + & + currentpatch%leaf_litter_out(ft) * pftcon%lf_flig(ft) * currentpatch%area/AREA * leaf_prof(s,j) ! - bc_out(s)%FATES_c_to_litr_lab_c_col(j) = bc_out(s)%FATES_c_to_litr_lab_c_col(j) + currentpatch%root_litter_out(ft) * pftcon%fr_flab(ft) * currentpatch%area/AREA * froot_prof(s,ft,j) - bc_out(s)%FATES_c_to_litr_cel_c_col(j) = bc_out(s)%FATES_c_to_litr_cel_c_col(j) + currentpatch%root_litter_out(ft) * pftcon%fr_fcel(ft) * currentpatch%area/AREA * froot_prof(s,ft,j) - bc_out(s)%FATES_c_to_litr_lig_c_col(j) = bc_out(s)%FATES_c_to_litr_lig_c_col(j) + currentpatch%root_litter_out(ft) * pftcon%fr_flig(ft) * currentpatch%area/AREA * froot_prof(s,ft,j) + bc_out(s)%FATES_c_to_litr_lab_c_col(j) = bc_out(s)%FATES_c_to_litr_lab_c_col(j) + & + currentpatch%root_litter_out(ft) * pftcon%fr_flab(ft) * currentpatch%area/AREA * froot_prof(s,ft,j) + bc_out(s)%FATES_c_to_litr_cel_c_col(j) = bc_out(s)%FATES_c_to_litr_cel_c_col(j) + & + currentpatch%root_litter_out(ft) * pftcon%fr_fcel(ft) * currentpatch%area/AREA * froot_prof(s,ft,j) + bc_out(s)%FATES_c_to_litr_lig_c_col(j) = bc_out(s)%FATES_c_to_litr_lig_c_col(j) + & + currentpatch%root_litter_out(ft) * pftcon%fr_flig(ft) * currentpatch%area/AREA * froot_prof(s,ft,j) ! !! and seed_decay too. for now, use the same lability fractions as for leaf litter - bc_out(s)%FATES_c_to_litr_lab_c_col(j) = bc_out(s)%FATES_c_to_litr_lab_c_col(j) + currentpatch%seed_decay(ft) * pftcon%lf_flab(ft) * currentpatch%area/AREA * leaf_prof(s,j) - bc_out(s)%FATES_c_to_litr_cel_c_col(j) = bc_out(s)%FATES_c_to_litr_cel_c_col(j) + currentpatch%seed_decay(ft) * pftcon%lf_fcel(ft) * currentpatch%area/AREA * leaf_prof(s,j) - bc_out(s)%FATES_c_to_litr_lig_c_col(j) = bc_out(s)%FATES_c_to_litr_lig_c_col(j) + currentpatch%seed_decay(ft) * pftcon%lf_flig(ft) * currentpatch%area/AREA * leaf_prof(s,j) + bc_out(s)%FATES_c_to_litr_lab_c_col(j) = bc_out(s)%FATES_c_to_litr_lab_c_col(j) + & + currentpatch%seed_decay(ft) * pftcon%lf_flab(ft) * currentpatch%area/AREA * leaf_prof(s,j) + bc_out(s)%FATES_c_to_litr_cel_c_col(j) = bc_out(s)%FATES_c_to_litr_cel_c_col(j) + & + currentpatch%seed_decay(ft) * pftcon%lf_fcel(ft) * currentpatch%area/AREA * leaf_prof(s,j) + bc_out(s)%FATES_c_to_litr_lig_c_col(j) = bc_out(s)%FATES_c_to_litr_lig_c_col(j) + & + currentpatch%seed_decay(ft) * pftcon%lf_flig(ft) * currentpatch%area/AREA * leaf_prof(s,j) ! enddo end do diff --git a/biogeophys/EDAccumulateFluxesMod.F90 b/biogeophys/EDAccumulateFluxesMod.F90 index 807b614f..f44a2029 100644 --- a/biogeophys/EDAccumulateFluxesMod.F90 +++ b/biogeophys/EDAccumulateFluxesMod.F90 @@ -20,7 +20,7 @@ module EDAccumulateFluxesMod contains !------------------------------------------------------------------------------ - subroutine AccumulateFluxes_ED(sites, nsites, bc_in, bc_out) + subroutine AccumulateFluxes_ED(nsites, sites, bc_in, bc_out) ! ! !DESCRIPTION: ! see above @@ -32,8 +32,8 @@ subroutine AccumulateFluxes_ED(sites, nsites, bc_in, bc_out) use FatesInterfaceMod , only : bc_in_type,bc_out_type ! ! !ARGUMENTS - type(ed_site_type), intent(inout), target :: sites(nsites) integer, intent(in) :: nsites + type(ed_site_type), intent(inout), target :: sites(nsites) type(bc_in_type), intent(in) :: bc_in(nsites) type(bc_out_type), intent(inout) :: bc_out(nsites) ! diff --git a/biogeophys/EDBtranMod.F90 b/biogeophys/EDBtranMod.F90 index 53d2816e..8ac4a51b 100644 --- a/biogeophys/EDBtranMod.F90 +++ b/biogeophys/EDBtranMod.F90 @@ -47,12 +47,12 @@ end function check_layer_water ! ===================================================================================== - subroutine get_active_suction_layers(sites,nsites,bc_in,bc_out) + subroutine get_active_suction_layers(nsites, sites, bc_in, bc_out) ! Arguments - type(ed_site_type),intent(inout),target :: sites(nsites) integer,intent(in) :: nsites + type(ed_site_type),intent(inout),target :: sites(nsites) type(bc_in_type),intent(in) :: bc_in(nsites) type(bc_out_type),intent(inout) :: bc_out(nsites) @@ -75,7 +75,7 @@ end subroutine get_active_suction_layers ! ===================================================================================== - subroutine btran_ed( sites, nsites, bc_in, bc_out) + subroutine btran_ed( nsites, sites, bc_in, bc_out) ! --------------------------------------------------------------------------------- ! Calculate the transpiration wetness function (BTRAN) and the root uptake @@ -90,8 +90,8 @@ subroutine btran_ed( sites, nsites, bc_in, bc_out) ! Arguments - type(ed_site_type),intent(inout),target :: sites(nsites) integer,intent(in) :: nsites + type(ed_site_type),intent(inout),target :: sites(nsites) type(bc_in_type),intent(in) :: bc_in(nsites) type(bc_out_type),intent(inout) :: bc_out(nsites) diff --git a/biogeophys/EDPhotosynthesisMod.F90 b/biogeophys/EDPhotosynthesisMod.F90 index 94b4e805..4d2e924c 100644 --- a/biogeophys/EDPhotosynthesisMod.F90 +++ b/biogeophys/EDPhotosynthesisMod.F90 @@ -26,7 +26,7 @@ module EDPhotosynthesisMod contains !--------------------------------------------------------- - subroutine Photosynthesis_ED (sites,nsites,bc_in,bc_out,dtime) + subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) ! @@ -55,8 +55,8 @@ subroutine Photosynthesis_ED (sites,nsites,bc_in,bc_out,dtime) ! ! !ARGUMENTS: - type(ed_site_type),intent(inout),target :: sites(nsites) integer,intent(in) :: nsites + type(ed_site_type),intent(inout),target :: sites(nsites) type(bc_in_type),intent(in) :: bc_in(nsites) type(bc_out_type),intent(inout) :: bc_out(nsites) real(r8),intent(in) :: dtime @@ -467,7 +467,8 @@ subroutine Photosynthesis_ED (sites,nsites,bc_in,bc_out,dtime) lmr25 = lmr25top(FT) * nscaler if (nint(c3psn(FT)) == 1)then - lmr_z(CL,FT,iv) = lmr25 * ft1_f(bc_in(s)%t_veg_pa(ifp), lmrha) * fth_f(bc_in(s)%t_veg_pa(ifp), lmrhd, lmrse, lmrc) + lmr_z(CL,FT,iv) = lmr25 * ft1_f(bc_in(s)%t_veg_pa(ifp), lmrha) * & + fth_f(bc_in(s)%t_veg_pa(ifp), lmrhd, lmrse, lmrc) else lmr_z(CL,FT,iv) = lmr25 * 2._r8**((bc_in(s)%t_veg_pa(ifp)-(tfrz+25._r8))/10._r8) lmr_z(CL,FT,iv) = lmr_z(CL,FT,iv) / (1._r8 + exp( 1.3_r8*(bc_in(s)%t_veg_pa(ifp)-(tfrz+55._r8)) )) @@ -485,14 +486,19 @@ subroutine Photosynthesis_ED (sites,nsites,bc_in,bc_out,dtime) kp25 = kp25top(FT) * nscaler ! Adjust for temperature - vcmax_z(CL,FT,iv) = vcmax25 * ft1_f(bc_in(s)%t_veg_pa(ifp), vcmaxha) * fth_f(bc_in(s)%t_veg_pa(ifp), vcmaxhd, vcmaxse, vcmaxc) - jmax_z(CL,FT,iv) = jmax25 * ft1_f(bc_in(s)%t_veg_pa(ifp), jmaxha) * fth_f(bc_in(s)%t_veg_pa(ifp), jmaxhd, jmaxse, jmaxc) - tpu_z(CL,FT,iv) = tpu25 * ft1_f(bc_in(s)%t_veg_pa(ifp), tpuha) * fth_f(bc_in(s)%t_veg_pa(ifp), tpuhd, tpuse, tpuc) + vcmax_z(CL,FT,iv) = vcmax25 * ft1_f(bc_in(s)%t_veg_pa(ifp), vcmaxha) * & + fth_f(bc_in(s)%t_veg_pa(ifp), vcmaxhd, vcmaxse, vcmaxc) + jmax_z(CL,FT,iv) = jmax25 * ft1_f(bc_in(s)%t_veg_pa(ifp), jmaxha) * & + fth_f(bc_in(s)%t_veg_pa(ifp), jmaxhd, jmaxse, jmaxc) + tpu_z(CL,FT,iv) = tpu25 * ft1_f(bc_in(s)%t_veg_pa(ifp), tpuha) * & + fth_f(bc_in(s)%t_veg_pa(ifp), tpuhd, tpuse, tpuc) if (nint(c3psn(FT)) /= 1) then vcmax_z(CL,FT,iv) = vcmax25 * 2._r8**((bc_in(s)%t_veg_pa(ifp)-(tfrz+25._r8))/10._r8) - vcmax_z(CL,FT,iv) = vcmax_z(CL,FT,iv) / (1._r8 + exp( 0.2_r8*((tfrz+15._r8)-bc_in(s)%t_veg_pa(ifp)) )) - vcmax_z(CL,FT,iv) = vcmax_z(CL,FT,iv) / (1._r8 + exp( 0.3_r8*(bc_in(s)%t_veg_pa(ifp)-(tfrz+40._r8)) )) + vcmax_z(CL,FT,iv) = vcmax_z(CL,FT,iv) / (1._r8 + & + exp( 0.2_r8*((tfrz+15._r8)-bc_in(s)%t_veg_pa(ifp)) )) + vcmax_z(CL,FT,iv) = vcmax_z(CL,FT,iv) / (1._r8 + & + exp( 0.3_r8*(bc_in(s)%t_veg_pa(ifp)-(tfrz+40._r8)) )) end if kp_z(CL,FT,iv) = kp25 * 2._r8**((bc_in(s)%t_veg_pa(ifp)-(tfrz+25._r8))/10._r8) !q10 response of product limited psn. end if @@ -669,7 +675,8 @@ subroutine Photosynthesis_ED (sites,nsites,bc_in,bc_out,dtime) cs = max(cs,1.e-06_r8) aquad = cs bquad = cs*(gb_mol - bbb(FT)) - bb_slope(ft)*an(cl,ft,iv)*bc_in(s)%forc_pbot - cquad = -gb_mol*(cs*bbb(FT) + bb_slope(ft)*an(cl,ft,iv)*bc_in(s)%forc_pbot*ceair/bc_in(s)%esat_tv_pa(ifp)) + cquad = -gb_mol*(cs*bbb(FT) + & + bb_slope(ft)*an(cl,ft,iv)*bc_in(s)%forc_pbot*ceair/bc_in(s)%esat_tv_pa(ifp)) call quadratic_f (aquad, bquad, cquad, r1, r2) gs_mol = max(r1,r2) @@ -694,8 +701,8 @@ subroutine Photosynthesis_ED (sites,nsites,bc_in,bc_out,dtime) ! Final estimates for cs and ci (needed for early exit of ci iteration when an < 0) cs = bc_in(s)%cair_pa(ifp) - 1.4_r8/gb_mol * an(cl,ft,iv) * bc_in(s)%forc_pbot cs = max(cs,1.e-06_r8) - ci(cl,ft,iv) = bc_in(s)%cair_pa(ifp) - an(cl,ft,iv) * bc_in(s)%forc_pbot * (1.4_r8*gs_mol+1.6_r8*gb_mol) / & - (gb_mol*gs_mol) + ci(cl,ft,iv) = bc_in(s)%cair_pa(ifp) - & + an(cl,ft,iv) * bc_in(s)%forc_pbot * (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 diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index 005f7cec..c4bdd45d 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -40,7 +40,7 @@ module EDSurfaceRadiationMod contains - subroutine ED_Norman_Radiation (sites, nsites, bc_in, bc_out ) + subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) ! ! @@ -53,8 +53,8 @@ subroutine ED_Norman_Radiation (sites, nsites, bc_in, bc_out ) ! !ARGUMENTS: - type(ed_site_type), intent(inout), target :: sites(nsites) ! FATES site vector integer, intent(in) :: nsites + type(ed_site_type), intent(inout), target :: sites(nsites) ! FATES site vector type(bc_in_type), intent(in) :: bc_in(nsites) type(bc_out_type), intent(inout) :: bc_out(nsites) @@ -505,7 +505,8 @@ subroutine ED_Norman_Radiation (sites, nsites, bc_in, bc_out ) 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_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) * & @@ -621,7 +622,8 @@ subroutine ED_Norman_Radiation (sites, nsites, bc_in, bc_out ) !reflection of the lower layer, up_rad = Dif_dn(L,ft,iv) * refl_dif(L,ft,iv,ib) up_rad = up_rad + forc_dir(ifp,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) + (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) @@ -686,7 +688,8 @@ subroutine ED_Norman_Radiation (sites, nsites, bc_in, bc_out ) if (radtype==1) then if ( DEBUG ) then write(iulog,*) 'EDsurfAlb 730 ',Abs_dif_z(ft,iv),currentPatch%f_sun(L,ft,iv) - write(iulog,*) 'EDsurfAlb 731 ',currentPatch%fabd_sha_z(L,ft,iv),currentPatch%fabd_sun_z(L,ft,iv) + write(iulog,*) 'EDsurfAlb 731 ', currentPatch%fabd_sha_z(L,ft,iv), & + currentPatch%fabd_sun_z(L,ft,iv) endif currentPatch%fabd_sha_z(L,ft,iv) = Abs_dif_z(ft,iv) * & (1._r8 - currentPatch%f_sun(L,ft,iv)) @@ -700,7 +703,8 @@ subroutine ED_Norman_Radiation (sites, nsites, bc_in, bc_out ) currentPatch%f_sun(L,ft,iv) endif if ( DEBUG ) then - write(iulog,*) 'EDsurfAlb 740 ',currentPatch%fabd_sha_z(L,ft,iv),currentPatch%fabd_sun_z(L,ft,iv) + write(iulog,*) 'EDsurfAlb 740 ', currentPatch%fabd_sha_z(L,ft,iv), & + currentPatch%fabd_sun_z(L,ft,iv) endif end do endif ! ib @@ -726,9 +730,11 @@ subroutine ED_Norman_Radiation (sites, nsites, bc_in, bc_out ) ! Albefor if (L==1)then !top canopy layer. if (radtype == 1)then - bc_out(s)%albd_parb(ifp,ib) = bc_out(s)%albd_parb(ifp,ib) + Dif_up(L,ft,1) * ftweight(L,ft,1) + bc_out(s)%albd_parb(ifp,ib) = bc_out(s)%albd_parb(ifp,ib) + & + Dif_up(L,ft,1) * ftweight(L,ft,1) else - bc_out(s)%albi_parb(ifp,ib) = bc_out(s)%albi_parb(ifp,ib) + Dif_up(L,ft,1) * ftweight(L,ft,1) + bc_out(s)%albi_parb(ifp,ib) = bc_out(s)%albi_parb(ifp,ib) + & + Dif_up(L,ft,1) * ftweight(L,ft,1) end if end if end if ! present @@ -771,8 +777,9 @@ subroutine ED_Norman_Radiation (sites, nsites, bc_in, bc_out ) ! Total radiation balance: absorbed = incoming - outgoing if (radtype == 1)then - error = abs(currentPatch%sabs_dir(ib)-(currentPatch%tr_soil_dir(ib)*(1.0_r8-bc_in(s)%albgr_dir_rb(ib))+ & - currentPatch%tr_soil_dir_dif(ib)*(1.0_r8-bc_in(s)%albgr_dif_rb(ib)))) + error = abs(currentPatch%sabs_dir(ib) - (currentPatch%tr_soil_dir(ib) * & + (1.0_r8-bc_in(s)%albgr_dir_rb(ib)) + & + currentPatch%tr_soil_dir_dif(ib) * (1.0_r8-bc_in(s)%albgr_dif_rb(ib)))) if ( abs(error) > 0.0001)then write(iulog,*)'dir ground absorption error',ifp,s,error,currentPatch%sabs_dir(ib), & currentPatch%tr_soil_dir(ib)* & @@ -796,9 +803,11 @@ subroutine ED_Norman_Radiation (sites, nsites, bc_in, bc_out ) endif if (radtype == 1)then - error = (forc_dir(ifp,ib) + forc_dif(ifp,ib)) - (bc_out(s)%fabd_parb(ifp,ib) + bc_out(s)%albd_parb(ifp,ib) + currentPatch%sabs_dir(ib)) + error = (forc_dir(ifp,ib) + forc_dif(ifp,ib)) - & + (bc_out(s)%fabd_parb(ifp,ib) + bc_out(s)%albd_parb(ifp,ib) + currentPatch%sabs_dir(ib)) else - error = (forc_dir(ifp,ib) + forc_dif(ifp,ib)) - (bc_out(s)%fabi_parb(ifp,ib) + bc_out(s)%albi_parb(ifp,ib) + currentPatch%sabs_dif(ib)) + error = (forc_dir(ifp,ib) + forc_dif(ifp,ib)) - & + (bc_out(s)%fabi_parb(ifp,ib) + bc_out(s)%albi_parb(ifp,ib) + currentPatch%sabs_dif(ib)) endif lai_reduction(:) = 0.0_r8 do L = 1, currentPatch%NCL_p @@ -845,7 +854,8 @@ subroutine ED_Norman_Radiation (sites, nsites, bc_in, bc_out ) end if if (abs(error) > 0.15_r8)then write(iulog,*) 'Large Dir Radn consvn error',error ,ifp,ib - write(iulog,*) 'diags',bc_out(s)%albd_parb(ifp,ib),bc_out(s)%ftdd_parb(ifp,ib),bc_out(s)%ftid_parb(ifp,ib),bc_out(s)%fabd_parb(ifp,ib) + write(iulog,*) 'diags', bc_out(s)%albd_parb(ifp,ib), bc_out(s)%ftdd_parb(ifp,ib), & + bc_out(s)%ftid_parb(ifp,ib), bc_out(s)%fabd_parb(ifp,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) @@ -863,7 +873,8 @@ subroutine ED_Norman_Radiation (sites, nsites, bc_in, bc_out ) if (abs(error) > 0.15_r8)then write(iulog,*) '>5% Dif Radn consvn error',error ,ifp,ib - write(iulog,*) 'diags',bc_out(s)%albi_parb(ifp,ib),bc_out(s)%ftii_parb(ifp,ib),bc_out(s)%fabi_parb(ifp,ib) + write(iulog,*) 'diags', bc_out(s)%albi_parb(ifp,ib), bc_out(s)%ftii_parb(ifp,ib), & + bc_out(s)%fabi_parb(ifp,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) @@ -879,9 +890,11 @@ subroutine ED_Norman_Radiation (sites, nsites, bc_in, bc_out ) end if if (radtype == 1)then - error = (forc_dir(ifp,ib) + forc_dif(ifp,ib)) - (bc_out(s)%fabd_parb(ifp,ib) + bc_out(s)%albd_parb(ifp,ib) + currentPatch%sabs_dir(ib)) + error = (forc_dir(ifp,ib) + forc_dif(ifp,ib)) - & + (bc_out(s)%fabd_parb(ifp,ib) + bc_out(s)%albd_parb(ifp,ib) + currentPatch%sabs_dir(ib)) else - error = (forc_dir(ifp,ib) + forc_dif(ifp,ib)) - (bc_out(s)%fabi_parb(ifp,ib) + bc_out(s)%albi_parb(ifp,ib) + currentPatch%sabs_dif(ib)) + error = (forc_dir(ifp,ib) + forc_dif(ifp,ib)) - & + (bc_out(s)%fabi_parb(ifp,ib) + bc_out(s)%albi_parb(ifp,ib) + currentPatch%sabs_dif(ib)) endif if (abs(error) > 0.00000001_r8)then @@ -906,15 +919,15 @@ end subroutine ED_Norman_Radiation ! ====================================================================================== - subroutine ED_SunShadeFracs(sites,nsites,bc_in,bc_out) + subroutine ED_SunShadeFracs(nsites, sites,bc_in,bc_out) use clm_varctl , only : iulog implicit none ! Arguments - type(ed_site_type),intent(inout),target :: sites(nsites) integer,intent(in) :: nsites + type(ed_site_type),intent(inout),target :: sites(nsites) type(bc_in_type),intent(in) :: bc_in(nsites) type(bc_out_type),intent(inout) :: bc_out(nsites) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 3b839cbc..0b771ebd 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -785,7 +785,7 @@ end subroutine SetValues !----------------------------------------------------------------------- - subroutine ed_clm_link( this, bounds, sites, nsites, fcolumn, waterstate_inst, canopystate_inst) + subroutine ed_clm_link( this, bounds, nsites, sites, fcolumn, waterstate_inst, canopystate_inst) ! ! !USES: use landunit_varcon , only : istsoil @@ -801,8 +801,8 @@ subroutine ed_clm_link( this, bounds, sites, nsites, fcolumn, waterstate_inst, c ! !ARGUMENTS class(ed_clm_type) :: this type(bounds_type) , intent(in) :: bounds - type(ed_site_type) , intent(inout), target :: sites(nsites) integer , intent(in) :: nsites + type(ed_site_type) , intent(inout), target :: sites(nsites) integer , intent(in) :: fcolumn(nsites) type(waterstate_type) , intent(inout) :: waterstate_inst type(canopystate_type) , intent(inout) :: canopystate_inst @@ -1027,14 +1027,14 @@ subroutine ed_clm_link( this, bounds, sites, nsites, fcolumn, waterstate_inst, c end do ! column loop - call this%ed_update_history_variables(bounds, sites(:), nsites, fcolumn(:), canopystate_inst) + call this%ed_update_history_variables(bounds, nsites, sites(:), fcolumn(:), canopystate_inst) end associate end subroutine ed_clm_link !----------------------------------------------------------------------- - subroutine ed_update_history_variables( this, bounds, sites, nsites, fcolumn, canopystate_inst) + subroutine ed_update_history_variables( this, bounds, nsites, sites, fcolumn, canopystate_inst) ! ! !USES: use CanopyStateType , only : canopystate_type @@ -1045,8 +1045,8 @@ subroutine ed_update_history_variables( this, bounds, sites, nsites, fcolumn, ca ! !ARGUMENTS: class(ed_clm_type) :: this type(bounds_type) , intent(in) :: bounds ! clump bounds - type(ed_site_type) , intent(inout), target :: sites(nsites) integer , intent(in) :: nsites + type(ed_site_type) , intent(inout), target :: sites(nsites) integer , intent(in) :: fcolumn(nsites) type(ed_patch_type) , pointer :: currentPatch type(ed_cohort_type) , pointer :: currentCohort @@ -1369,12 +1369,22 @@ subroutine ed_update_history_variables( this, bounds, sites, nsites, fcolumn, ca fire_fuel_sav(p) = currentPatch%fuel_sav fire_fuel_mef(p) = currentPatch%fuel_mef sum_fuel(p) = currentPatch%sum_fuel * 1.e3_r8 * patch_scaling_scalar - litter_in(p) = (sum(currentPatch%CWD_AG_in) +sum(currentPatch%leaf_litter_in)) * 1.e3_r8 * 365.0_r8 * SHR_CONST_CDAY * patch_scaling_scalar - litter_out(p) = (sum(currentPatch%CWD_AG_out)+sum(currentPatch%leaf_litter_out)) * 1.e3_r8 * 365.0_r8 * SHR_CONST_CDAY * patch_scaling_scalar + + litter_in(p) = (sum(currentPatch%CWD_AG_in) + sum(currentPatch%leaf_litter_in)) * & + 1.e3_r8 * 365.0_r8 * SHR_CONST_CDAY * patch_scaling_scalar + + litter_out(p) = (sum(currentPatch%CWD_AG_out) + sum(currentPatch%leaf_litter_out)) * & + 1.e3_r8 * 365.0_r8 * SHR_CONST_CDAY * patch_scaling_scalar + seed_bank(p) = sum(currentPatch%seed_bank) * 1.e3_r8 * patch_scaling_scalar - seeds_in(p) = sum(currentPatch%seeds_in) * 1.e3_r8 * 365.0_r8 * SHR_CONST_CDAY * patch_scaling_scalar - seed_decay(p) = sum(currentPatch%seed_decay) * 1.e3_r8 * 365.0_r8 * SHR_CONST_CDAY * patch_scaling_scalar - seed_germination(p) = sum(currentPatch%seed_germination) * 1.e3_r8 * 365.0_r8 * SHR_CONST_CDAY * patch_scaling_scalar + + seeds_in(p) = sum(currentPatch%seeds_in) * 1.e3_r8 * 365.0_r8 * SHR_CONST_CDAY * patch_scaling_scalar + + seed_decay(p) = sum(currentPatch%seed_decay) * 1.e3_r8 * 365.0_r8 * SHR_CONST_CDAY * patch_scaling_scalar + + seed_germination(p) = sum(currentPatch%seed_germination) * & + 1.e3_r8 * 365.0_r8 * SHR_CONST_CDAY * patch_scaling_scalar + canopy_spread(p) = currentPatch%spread(1) area_plant(p) = 1._r8 if (min(currentPatch%total_canopy_area,currentPatch%area)>0.0_r8) then @@ -1917,7 +1927,7 @@ end subroutine ed_clm_leaf_area_profile ! ===================================================================================== - subroutine SummarizeProductivityFluxes(this, bounds, sites, nsites, fcolumn) + subroutine SummarizeProductivityFluxes(this, bounds, nsites, sites, fcolumn) ! Summarize the fast production inputs from fluxes per ED individual to fluxes per CLM patch and column ! Must be called between calculation of productivity fluxes and daily ED calls @@ -1935,8 +1945,8 @@ subroutine SummarizeProductivityFluxes(this, bounds, sites, nsites, fcolumn) ! !ARGUMENTS class(ed_clm_type) :: this type(bounds_type) , intent(in) :: bounds - type(ed_site_type) , intent(in), target :: sites(nsites) integer , intent(in) :: nsites + type(ed_site_type) , intent(in), target :: sites(nsites) integer , intent(in) :: fcolumn(nsites) ! ! !LOCAL VARIABLES: @@ -2036,7 +2046,7 @@ end subroutine SummarizeProductivityFluxes !------------------------------------------------------------------------ subroutine SummarizeNetFluxes(this, bounds, num_soilc, filter_soilc, & - sites, nsites, fcolumn, soilbiogeochem_carbonflux_inst, & + nsites, sites, fcolumn, soilbiogeochem_carbonflux_inst, & soilbiogeochem_carbonstate_inst) ! Summarize the combined production and decomposition fluxes into net fluxes @@ -2056,8 +2066,8 @@ subroutine SummarizeNetFluxes(this, bounds, num_soilc, filter_soilc, & type(bounds_type) , intent(in) :: bounds integer , intent(in) :: num_soilc ! number of soil columns in filter integer , intent(in) :: filter_soilc(:) ! filter for soil columns - type(ed_site_type) , intent(in), target :: sites(nsites) integer , intent(in) :: nsites + type(ed_site_type) , intent(in), target :: sites(nsites) integer , intent(in) :: fcolumn(nsites) type(soilbiogeochem_carbonflux_type) , intent(inout) :: soilbiogeochem_carbonflux_inst type(soilbiogeochem_carbonstate_type) , intent(inout) :: soilbiogeochem_carbonstate_inst @@ -2182,9 +2192,11 @@ subroutine SummarizeNetFluxes(this, bounds, num_soilc, filter_soilc, & currentPatch => sites(s)%oldest_patch do while(associated(currentPatch)) ! - ed_to_bgc_this_edts(c) = ed_to_bgc_this_edts(c) + (sum(currentPatch%CWD_AG_out) + sum(currentPatch%CWD_BG_out) + & - + sum(currentPatch%seed_decay) + sum(currentPatch%leaf_litter_out) + sum(currentPatch%root_litter_out)) & - * ( currentPatch%area/AREA ) * 1.e3_r8 / ( 365.0_r8*SHR_CONST_CDAY ) + ed_to_bgc_this_edts(c) = ed_to_bgc_this_edts(c) + & + (sum(currentPatch%CWD_AG_out) + sum(currentPatch%CWD_BG_out) + & + sum(currentPatch%seed_decay) + sum(currentPatch%leaf_litter_out) + & + sum(currentPatch%root_litter_out)) * & + ( currentPatch%area/AREA ) * 1.e3_r8 / ( 365.0_r8*SHR_CONST_CDAY ) ! seed_rain_flux(c) = seed_rain_flux(c) + sum(currentPatch%seed_rain_flux) * 1.e3_r8 / ( 365.0_r8*SHR_CONST_CDAY ) ! @@ -2296,9 +2308,17 @@ subroutine ED_BGC_Carbon_Balancecheck(this, bounds, num_soilc, filter_soilc, soi ! next compare the change in carbon and calculate the error do fc = 1,num_soilc c = filter_soilc(fc) - error_ed(c) = totedc(c) - totedc_old(c) - (npp_timeintegrated(c) + seed_rain_flux(c)* SHR_CONST_CDAY - ed_to_bgc_this_edts(c)* SHR_CONST_CDAY - fire_c_to_atm(c) * SHR_CONST_CDAY) - error_bgc(c) = totbgcc(c) - totbgcc_old(c) - (ed_to_bgc_last_edts(c)* SHR_CONST_CDAY - hr_timeintegrated(c)) - error_total(c) = totecosysc(c) - totecosysc_old(c) - (nbp_integrated(c) + ed_to_bgc_last_edts(c)* SHR_CONST_CDAY - ed_to_bgc_this_edts(c)* SHR_CONST_CDAY) + error_ed(c) = totedc(c) - totedc_old(c) - & + (npp_timeintegrated(c) + seed_rain_flux(c) * SHR_CONST_CDAY - & + ed_to_bgc_this_edts(c) * SHR_CONST_CDAY - & + fire_c_to_atm(c) * SHR_CONST_CDAY) + + error_bgc(c) = totbgcc(c) - totbgcc_old(c) - & + (ed_to_bgc_last_edts(c) * SHR_CONST_CDAY - hr_timeintegrated(c)) + + error_total(c) = totecosysc(c) - totecosysc_old(c) - & + (nbp_integrated(c) + ed_to_bgc_last_edts(c) * SHR_CONST_CDAY - & + ed_to_bgc_this_edts(c)* SHR_CONST_CDAY) end do ! ! put in consistent flux units and send to history so we can keep track of the errors diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 29a370c0..dd263295 100755 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -82,7 +82,7 @@ subroutine zero_site( site_in ) end subroutine zero_site ! ============================================================================ - subroutine set_site_properties( sites, nsites) + subroutine set_site_properties( nsites, sites) ! ! !DESCRIPTION: ! @@ -90,8 +90,8 @@ subroutine set_site_properties( sites, nsites) ! ! !ARGUMENTS - type(ed_site_type) , intent(inout), target :: sites(nsites) integer, intent(in) :: nsites + type(ed_site_type) , intent(inout), target :: sites(nsites) ! ! !LOCAL VARIABLES: integer :: s @@ -160,7 +160,7 @@ subroutine set_site_properties( sites, nsites) end subroutine set_site_properties ! ============================================================================ - subroutine init_patches( sites, nsites) + subroutine init_patches( nsites, sites) ! ! !DESCRIPTION: !initialize patches on new ground @@ -169,8 +169,8 @@ subroutine init_patches( sites, nsites) use EDParamsMod , only : ED_val_maxspread ! ! !ARGUMENTS - type(ed_site_type) , intent(inout), target :: sites(nsites) integer, intent(in) :: nsites + type(ed_site_type) , intent(inout), target :: sites(nsites) ! ! !LOCAL VARIABLES: integer :: s diff --git a/main/EDRestVectorMod.F90 b/main/EDRestVectorMod.F90 index 3f37c521..030dd5a5 100755 --- a/main/EDRestVectorMod.F90 +++ b/main/EDRestVectorMod.F90 @@ -597,7 +597,7 @@ function newEDRestartVectorClass( bounds ) end function newEDRestartVectorClass !-------------------------------------------------------------------------------! - subroutine setVectors( this, bounds, sites, nsites, fcolumn ) + subroutine setVectors( this, bounds, nsites, sites, fcolumn ) ! ! !DESCRIPTION: ! implement setVectors @@ -608,8 +608,8 @@ subroutine setVectors( this, bounds, sites, nsites, fcolumn ) ! !ARGUMENTS: class(EDRestartVectorClass) , intent(inout) :: this type(bounds_type) , intent(in) :: bounds - type(ed_site_type) , intent(in), target :: sites(nsites) integer , intent(in) :: nsites + type(ed_site_type) , intent(in), target :: sites(nsites) integer , intent(in) :: fcolumn(nsites) ! ! !LOCAL VARIABLES: @@ -622,11 +622,11 @@ subroutine setVectors( this, bounds, sites, nsites, fcolumn ) ! call this%printDataInfoLL ( bounds, sites, nsites ) !end if - call this%convertCohortListToVector ( bounds, sites, nsites, fcolumn ) + call this%convertCohortListToVector ( bounds, nsites, sites, fcolumn ) if (this%DEBUG) then - call this%printIoInfoLL ( bounds, sites, nsites, fcolumn ) - call this%printDataInfoLL ( bounds, sites, nsites ) + call this%printIoInfoLL ( bounds, nsites, sites, fcolumn ) + call this%printDataInfoLL ( bounds, nsites, sites ) ! RGK: Commenting this out because it is calling several ! variables over the wrong indices @@ -636,7 +636,7 @@ subroutine setVectors( this, bounds, sites, nsites, fcolumn ) end subroutine setVectors !-------------------------------------------------------------------------------! - subroutine getVectors( this, bounds, sites, nsites, fcolumn) + subroutine getVectors( this, bounds, nsites, sites, fcolumn) ! ! !DESCRIPTION: ! implement getVectors @@ -649,8 +649,8 @@ subroutine getVectors( this, bounds, sites, nsites, fcolumn) ! !ARGUMENTS: class(EDRestartVectorClass) , intent(inout) :: this type(bounds_type) , intent(in) :: bounds - type(ed_site_type) , intent(inout), target :: sites(nsites) integer , intent(in) :: nsites + type(ed_site_type) , intent(inout), target :: sites(nsites) integer , intent(in) :: fcolumn(nsites) ! ! !LOCAL VARIABLES: @@ -661,17 +661,17 @@ subroutine getVectors( this, bounds, sites, nsites, fcolumn) write(iulog,*) 'edtime getVectors ',get_nstep() end if - call this%createPatchCohortStructure ( bounds, sites, nsites, fcolumn ) + call this%createPatchCohortStructure ( bounds, nsites, sites, fcolumn ) - call this%convertCohortVectorToList ( bounds, sites , nsites, fcolumn) + call this%convertCohortVectorToList ( bounds, nsites , sites, fcolumn) do s = 1,nsites call ed_update_site( sites(s) ) end do if (this%DEBUG) then - call this%printIoInfoLL ( bounds, sites, nsites, fcolumn ) - call this%printDataInfoLL ( bounds, sites, nsites ) + call this%printIoInfoLL ( bounds, nsites, sites, fcolumn ) + call this%printDataInfoLL ( bounds, nsites, sites ) call this%printDataInfoVector ( ) end if @@ -1257,7 +1257,7 @@ subroutine printDataInfoVector( this ) end subroutine printDataInfoVector !-------------------------------------------------------------------------------! - subroutine printDataInfoLL( this, bounds, sites, nsites ) + subroutine printDataInfoLL( this, bounds, nsites, sites ) ! ! !DESCRIPTION: ! counts the total number of cohorts over all p levels (ed_patch_type) so we @@ -1268,8 +1268,8 @@ subroutine printDataInfoLL( this, bounds, sites, nsites ) ! !ARGUMENTS: class(EDRestartVectorClass) , intent(inout) :: this type(bounds_type) , intent(in) :: bounds - type(ed_site_type) , intent(in), target :: sites(nsites) integer , intent(in) :: nsites + type(ed_site_type) , intent(in), target :: sites(nsites) ! ! !LOCAL VARIABLES: type (ed_patch_type), pointer :: currentPatch @@ -1389,7 +1389,7 @@ subroutine printDataInfoLL( this, bounds, sites, nsites ) end subroutine printDataInfoLL !-------------------------------------------------------------------------------! - subroutine printIoInfoLL( this, bounds, sites, nsites, fcolumn ) + subroutine printIoInfoLL( this, bounds, nsites, sites, fcolumn ) !! ! !DESCRIPTION: ! for debugging. prints some IO info regarding cohorts/patches @@ -1400,8 +1400,8 @@ subroutine printIoInfoLL( this, bounds, sites, nsites, fcolumn ) ! !ARGUMENTS: class(EDRestartVectorClass) , intent(inout) :: this type(bounds_type) , intent(in) :: bounds - type(ed_site_type) , intent(in), target :: sites(nsites) integer , intent(in) :: nsites + type(ed_site_type) , intent(in), target :: sites(nsites) integer , intent(in) :: fcolumn(nsites) ! ! !LOCAL VARIABLES: @@ -1488,7 +1488,7 @@ subroutine printIoInfoLL( this, bounds, sites, nsites, fcolumn ) end subroutine printIoInfoLL !-------------------------------------------------------------------------------! - subroutine convertCohortListToVector( this, bounds, sites, nsites, fcolumn ) + subroutine convertCohortListToVector( this, bounds, nsites, sites, fcolumn ) ! ! !DESCRIPTION: ! counts the total number of cohorts over all p levels (ed_patch_type) so we @@ -1500,8 +1500,8 @@ subroutine convertCohortListToVector( this, bounds, sites, nsites, fcolumn ) ! !ARGUMENTS: class(EDRestartVectorClass) , intent(inout) :: this type(bounds_type) , intent(in) :: bounds - type(ed_site_type) , intent(in), target :: sites(nsites) integer , intent(in) :: nsites + type(ed_site_type) , intent(in), target :: sites(nsites) integer , intent(in) :: fcolumn(nsites) ! ! !LOCAL VARIABLES: @@ -1743,7 +1743,7 @@ subroutine convertCohortListToVector( this, bounds, sites, nsites, fcolumn ) end subroutine convertCohortListToVector !-------------------------------------------------------------------------------! - subroutine createPatchCohortStructure( this, bounds, sites, nsites, fcolumn ) + subroutine createPatchCohortStructure( this, bounds, nsites, sites, fcolumn ) ! ! !DESCRIPTION: ! counts the total number of cohorts over all p levels (ed_patch_type) so we @@ -1762,8 +1762,8 @@ subroutine createPatchCohortStructure( this, bounds, sites, nsites, fcolumn ) ! !ARGUMENTS: class(EDRestartVectorClass) , intent(inout) :: this type(bounds_type) , intent(in) :: bounds - type(ed_site_type) , intent(inout), target :: sites(nsites) integer , intent(in) :: nsites + type(ed_site_type) , intent(inout), target :: sites(nsites) integer , intent(in) :: fcolumn(nsites) ! ! !LOCAL VARIABLES: @@ -1931,7 +1931,7 @@ subroutine createPatchCohortStructure( this, bounds, sites, nsites, fcolumn ) end subroutine createPatchCohortStructure !-------------------------------------------------------------------------------! - subroutine convertCohortVectorToList( this, bounds, sites, nsites, fcolumn ) + subroutine convertCohortVectorToList( this, bounds, nsites, sites, fcolumn ) ! ! !DESCRIPTION: ! counts the total number of cohorts over all p levels (ed_patch_type) so we @@ -1942,8 +1942,8 @@ subroutine convertCohortVectorToList( this, bounds, sites, nsites, fcolumn ) ! !ARGUMENTS: class(EDRestartVectorClass) , intent(inout) :: this type(bounds_type) , intent(in) :: bounds - type(ed_site_type) , intent(inout), target :: sites(nsites) integer , intent(in) :: nsites + type(ed_site_type) , intent(inout), target :: sites(nsites) integer , intent(in) :: fcolumn(nsites) ! @@ -2165,7 +2165,7 @@ end subroutine convertCohortVectorToList !--------------------------------------------! !-------------------------------------------------------------------------------! - subroutine EDRest ( bounds, sites, nsites, fcolumn, ncid, flag ) + subroutine EDRest ( bounds, nsites, sites, fcolumn, ncid, flag ) ! ! !DESCRIPTION: ! Read/write ED restart data @@ -2179,8 +2179,8 @@ subroutine EDRest ( bounds, sites, nsites, fcolumn, ncid, flag ) ! !ARGUMENTS: type(bounds_type) , intent(in) :: bounds ! bounds type(file_desc_t) , intent(inout) :: ncid ! netcdf id - type(ed_site_type) , intent(inout) :: sites(nsites) ! The site vector integer , intent(in) :: nsites + type(ed_site_type) , intent(inout) :: sites(nsites) ! The site vector integer , intent(in) :: fcolumn(nsites) character(len=*) , intent(in) :: flag !'read' or 'write' ! @@ -2199,13 +2199,13 @@ subroutine EDRest ( bounds, sites, nsites, fcolumn, ncid, flag ) end if if ( flag == 'write' ) then - call ervc%setVectors( bounds, sites, nsites, fcolumn ) + call ervc%setVectors( bounds, nsites, sites, fcolumn ) endif call ervc%doVectorIO( ncid, flag ) if ( flag == 'read' ) then - call ervc%getVectors( bounds, sites, nsites, fcolumn ) + call ervc%getVectors( bounds, nsites, sites, fcolumn ) endif call ervc%deleteEDRestartVectorClass () From 5d7180b055b9be5b48b7337d67f5cca4682ff502 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 24 Aug 2016 15:16:49 -0700 Subject: [PATCH 171/437] removing obsolete EDCLMLInk code that is deprecated by the history io functions. Moved npp_col(c) calculation to summarizenetfluxes from summarizeproductivity fluxes. --- main/EDCLMLinkMod.F90 | 928 ++---------------------------------------- main/HistoryIOMod.F90 | 90 ++-- 2 files changed, 69 insertions(+), 949 deletions(-) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 6a4e1789..fae9f1e7 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -36,32 +36,6 @@ module EDCLMLinkMod 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 @@ -69,54 +43,24 @@ module EDCLMLinkMod !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. - - ! vegetation carbon fluxes at the patch scale - 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 - real(r8), pointer, private :: ar_patch (:) ! (gC/m2/s) patch autotrophic respiration - real(r8), pointer, private :: maint_resp_patch (:) ! (gC/m2/s) patch maintenance respiration - real(r8), pointer, private :: growth_resp_patch (:) ! (gC/m2/s) patch growth respiration + ! RGK: LEAVING SOME OLD DEFINITIONS IN UNTIL UNIT DISCREPANCIES ARE RECTIFIED + +! 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. +! Vegetation carbon fluxes at the patch scale +! 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 +! real(r8), pointer, private :: ar_patch (:) ! (gC/m2/s) patch autotrophic respiration +! real(r8), pointer, private :: maint_resp_patch (:) ! (gC/m2/s) patch maintenance respiration +! real(r8), pointer, private :: growth_resp_patch (:) ! (gC/m2/s) patch growth respiration - real(r8), pointer :: ed_gpp_col_scpf (:,:) ! [kg/m2/yr] gross primary production - real(r8), pointer :: ed_npp_totl_col_scpf (:,:) ! [kg/m2/yr] net primary production (npp) - real(r8), pointer :: ed_npp_leaf_col_scpf (:,:) ! [kg/m2/yr] npp flux into leaf pool - real(r8), pointer :: ed_npp_seed_col_scpf (:,:) ! [kg/m2/yr] npp flux into flower,fruit,nut,seed - real(r8), pointer :: ed_npp_fnrt_col_scpf (:,:) ! [kg/m2/yr] npp flux into fine roots - real(r8), pointer :: ed_npp_bgsw_col_scpf (:,:) ! [kg/m2/yr] npp flux into below ground sapwood - real(r8), pointer :: ed_npp_bgdw_col_scpf (:,:) ! [kg/m2/yr] npp flux into below ground structural (dead) wood - real(r8), pointer :: ed_npp_agsw_col_scpf (:,:) ! [kg/m2/yr] npp flux into above ground sapwood - real(r8), pointer :: ed_npp_agdw_col_scpf (:,:) ! [kg/m2/yr] npp flux into below ground structural (dead) wood - real(r8), pointer :: ed_npp_stor_col_scpf (:,:) ! [kg/m2/yr] npp flux through the storage pool - real(r8), pointer :: ed_litt_leaf_col_scpf (:,:) ! [kg/m2/yr] carbon flux of live leaves to litter - real(r8), pointer :: ed_litt_fnrt_col_scpf (:,:) ! [kg/m2/yr] carbon flux of fine roots to litter - real(r8), pointer :: ed_litt_sawd_col_scpf (:,:) ! [kg/m2/yr] carbon flux of sapwood to litter (above+below) - real(r8), pointer :: ed_litt_ddwd_col_scpf (:,:) ! [kg/m2/yr] carbon flux of dead wood (above+below) to litter - real(r8), pointer :: ed_r_leaf_col_scpf (:,:) ! [kg/m2/yr] total leaf respiration - real(r8), pointer :: ed_r_stem_col_scpf (:,:) ! [kg/m2/yr] total above ground live wood (stem) respiration - real(r8), pointer :: ed_r_root_col_scpf (:,:) ! [kg/m2/yr] total below ground live wood (root) respiration - real(r8), pointer :: ed_r_stor_col_scpf (:,:) ! [kg/m2/yr] total storage respiration - - ! Carbon State Variables for direct comparison to inventory - dimensions: (disturbance patch, pft x size) - - real(r8), pointer :: ed_ddbh_col_scpf (:,:) ! [cm/yr] diameter increment - real(r8), pointer :: ed_ba_col_scpf (:,:) ! [m2/ha] basal area - real(r8), pointer :: ed_np_col_scpf (:,:) ! [/m2] number of plants - real(r8), pointer :: ed_m1_col_scpf (:,:) ! [Stems/ha/yr] Mean Background Mortality - real(r8), pointer :: ed_m2_col_scpf (:,:) ! [Stems/ha/yr] Mean Hydraulic Mortaliry - real(r8), pointer :: ed_m3_col_scpf (:,:) ! [Stems/ha/yr] Mean Carbon Starvation Mortality - real(r8), pointer :: ed_m4_col_scpf (:,:) ! [Stems/ha/yr] Mean Impact Mortality - real(r8), pointer :: ed_m5_col_scpf (:,:) ! [Stems/ha/yr] Mean Fire Mortality - ! summary carbon fluxes at the column level real(r8), pointer, private :: nep_col(:) ! [gC/m2/s] Net ecosystem production, i.e. fast-timescale carbon balance that does not include disturbance real(r8), pointer, private :: nep_timeintegrated_col(:) ! [gC/m2/s] Net ecosystem production, i.e. fast-timescale carbon balance that does not include disturbance @@ -155,18 +99,15 @@ module EDCLMLinkMod ! Public routines procedure , public :: Init procedure , public :: Restart - procedure , public :: SetValues procedure , public :: ed_clm_link procedure , public :: SummarizeNetFluxes - procedure , public :: SummarizeProductivityFluxes +! procedure , public :: SummarizeProductivityFluxes procedure , public :: ED_BGC_Carbon_Balancecheck ! 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 @@ -188,7 +129,6 @@ subroutine Init(this, bounds) call this%InitAllocate(bounds) call this%InitHistory(bounds) - !call this%InitCold(bounds) end subroutine Init @@ -213,47 +153,6 @@ subroutine InitAllocate(this, bounds) begp = bounds%begp; endp = bounds%endp begc = bounds%begc; endc = bounds%endc - - 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%gpp_patch (begp:endp)) ; this%gpp_patch (:) = nan - allocate(this%npp_patch (begp:endp)) ; this%npp_patch (:) = nan - allocate(this%ar_patch (begp:endp)) ; this%ar_patch (:) = nan - allocate(this%maint_resp_patch (begp:endp)) ; this%maint_resp_patch (:) = nan - allocate(this%growth_resp_patch (begp:endp)) ; this%growth_resp_patch (:) = nan - allocate(this%ed_to_bgc_this_edts_col (begc:endc)) ; this%ed_to_bgc_this_edts_col (:) = nan allocate(this%ed_to_bgc_last_edts_col (begc:endc)) ; this%ed_to_bgc_last_edts_col (:) = nan allocate(this%seed_rain_flux_col (begc:endc)) ; this%seed_rain_flux_col (:) = nan @@ -282,38 +181,6 @@ subroutine InitAllocate(this, bounds) allocate(this%cbalance_error_bgc_col (begc:endc)) ; this%cbalance_error_bgc_col (:) = nan allocate(this%cbalance_error_total_col (begc:endc)) ; this%cbalance_error_total_col (:) = nan - allocate(this%ed_npatches_col (begc:endc)) ; this%ed_npatches_col (:) = nan - allocate(this%ed_ncohorts_col (begc:endc)) ; this%ed_ncohorts_col (:) = nan - - allocate(this%ed_gpp_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_gpp_col_scpf (:,:) = 0.0_r8 - allocate(this%ed_npp_totl_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_npp_totl_col_scpf (:,:) = 0.0_r8 - allocate(this%ed_npp_leaf_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_npp_leaf_col_scpf (:,:) = 0.0_r8 - allocate(this%ed_npp_seed_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_npp_seed_col_scpf (:,:) = 0.0_r8 - allocate(this%ed_npp_fnrt_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_npp_fnrt_col_scpf (:,:) = 0.0_r8 - allocate(this%ed_npp_bgsw_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_npp_bgsw_col_scpf (:,:) = 0.0_r8 - allocate(this%ed_npp_bgdw_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_npp_bgdw_col_scpf (:,:) = 0.0_r8 - allocate(this%ed_npp_agsw_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_npp_agsw_col_scpf (:,:) = 0.0_r8 - allocate(this%ed_npp_agdw_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_npp_agdw_col_scpf (:,:) = 0.0_r8 - allocate(this%ed_npp_stor_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_npp_stor_col_scpf (:,:) = 0.0_r8 - allocate(this%ed_litt_leaf_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_litt_leaf_col_scpf (:,:) = 0.0_r8 - allocate(this%ed_litt_fnrt_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_litt_fnrt_col_scpf (:,:) = 0.0_r8 - allocate(this%ed_litt_sawd_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_litt_sawd_col_scpf (:,:) = 0.0_r8 - allocate(this%ed_litt_ddwd_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_litt_ddwd_col_scpf (:,:) = 0.0_r8 - allocate(this%ed_r_leaf_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_r_leaf_col_scpf (:,:) = 0.0_r8 - allocate(this%ed_r_stem_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_r_stem_col_scpf (:,:) = 0.0_r8 - allocate(this%ed_r_root_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_r_root_col_scpf (:,:) = 0.0_r8 - allocate(this%ed_r_stor_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_r_stor_col_scpf (:,:) = 0.0_r8 - - ! Carbon State Variables for direct comparison to inventory - dimensions: (disturbance patch, pft x size) - allocate(this%ed_ddbh_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)) ; this%ed_ddbh_col_scpf (:,:) = 0.0_r8 - allocate(this%ed_ba_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)) ; this%ed_ba_col_scpf (:,:) = 0.0_r8 - allocate(this%ed_np_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)) ; this%ed_np_col_scpf (:,:) = 0.0_r8 - allocate(this%ed_m1_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)) ; this%ed_m1_col_scpf (:,:) = 0.0_r8 - allocate(this%ed_m2_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)) ; this%ed_m2_col_scpf (:,:) = 0.0_r8 - allocate(this%ed_m3_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)) ; this%ed_m3_col_scpf (:,:) = 0.0_r8 - allocate(this%ed_m4_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)) ; this%ed_m4_col_scpf (:,:) = 0.0_r8 - allocate(this%ed_m5_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)) ; this%ed_m5_col_scpf (:,:) = 0.0_r8 - end subroutine InitAllocate !------------------------------------------------------------------------ @@ -346,163 +213,6 @@ subroutine InitHistory(this, bounds) 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='gC/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='gC/m2', type2d='levgrnd', & - avgflag='A', long_name='total PFT level leaf biomass', & - ptr_patch=this%PFTleafbiomass_patch, set_lake=0._r8, set_urb=0._r8) - - call hist_addfld2d (fname='PFTstorebiomass', units='gC/m2', type2d='levgrnd', & - avgflag='A', long_name='total PFT level stored biomass', & - ptr_patch=this%PFTstorebiomass_patch, set_lake=0._r8, set_urb=0._r8) - - call hist_addfld2d (fname='PFTnindivs', units='indiv / m2', type2d='levgrnd', & - avgflag='A', long_name='total PFT level number of individuals', & - 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='SUM_FUEL', units='gC m-2', & - avgflag='A', long_name='total ground fuel related to ros (omits 1000hr fuels)', & - ptr_patch=this%sum_fuel_patch, set_lake=0._r8, set_urb=0._r8) - - call hist_addfld1d (fname='LITTER_IN', units='gC m-2 s-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='gC m-2 s-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='gC 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='gC m-2 s-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='gC m-2 s-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='gC m-2 s-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='gC 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='gC 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='gC 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='gC 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='gC 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%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) - - this%ar_patch(begp:endp) = spval - call hist_addfld1d (fname='AR', units='gC/m^2/s', & - avgflag='A', long_name='autotrophic respiration', & - ptr_patch=this%ar_patch) - - this%growth_resp_patch(begp:endp) = spval - call hist_addfld1d (fname='GROWTH_RESP', units='gC/m^2/s', & - avgflag='A', long_name='growth respiration', & - ptr_patch=this%growth_resp_patch) - - this%maint_resp_patch(begp:endp) = spval - call hist_addfld1d (fname='MAINT_RESP', units='gC/m^2/s', & - avgflag='A', long_name='maintenance respiration', & - ptr_patch=this%maint_resp_patch) - this%nep_col(begc:endc) = spval call hist_addfld1d (fname='NEP', units='gC/m^2/s', & avgflag='A', long_name='net ecosystem production', & @@ -518,11 +228,6 @@ subroutine InitHistory(this, bounds) avgflag='A', long_name='net biosphere production', & ptr_col=this%nbp_col) - this%npp_col(begc:endc) = spval - call hist_addfld1d (fname='NPP_column', units='gC/m^2/s', & - avgflag='A', long_name='net primary production on column level', & - ptr_col=this%npp_col,default='inactive') - this%totecosysc_col(begc:endc) = spval call hist_addfld1d (fname='TOTECOSYSC', units='gC/m^2', & avgflag='A', long_name='total ecosystem carbon', & @@ -563,88 +268,6 @@ subroutine InitHistory(this, bounds) avgflag='A', long_name='total seed carbon at the column level', & ptr_col=this%seed_stock_col) - - ! Carbon Flux (grid dimension x scpf) - ! ============================================================== - - call hist_addfld2d (fname='ED_GPP_COL_SCPF',units='kgC/m2/yr',type2d='levscpf',& - avgflag='A', long_name='gross primary production', & - ptr_gcell=this%ed_gpp_col_scpf,default='inactive') - - call hist_addfld2d (fname='ED_NPP_LEAF_COL_SCPF',units='kgC/m2/yr',type2d='levscpf',& - avgflag='A', long_name='NPP flux into leaves', & - ptr_gcell=this%ed_npp_leaf_col_scpf,default='inactive') - - call hist_addfld2d (fname='ED_NPP_SEED_COL_SCPF',units='kgC/m2/yr',type2d='levscpf',& - avgflag='A', long_name='NPP flux into seeds', & - ptr_gcell=this%ed_npp_seed_col_scpf,default='inactive') - - call hist_addfld2d (fname='ED_NPP_FNRT_COL_SCPF',units='kgC/m2/yr',type2d='levscpf',& - avgflag='A', long_name='NPP flux into fine roots', & - ptr_gcell=this%ed_npp_fnrt_col_scpf,default='inactive') - - call hist_addfld2d (fname='ED_NPP_BGSW_COL_SCPF',units='kgC/m2/yr',type2d='levscpf',& - avgflag='A', long_name='NPP flux into below-ground sapwood', & - ptr_gcell=this%ed_npp_bgsw_col_scpf,default='inactive') - - call hist_addfld2d (fname='ED_NPP_BGDW_COL_SCPF',units='kgC/m2/yr',type2d='levscpf',& - avgflag='A', long_name='NPP flux into below-ground deadwood', & - ptr_gcell=this%ed_npp_bgdw_col_scpf,default='inactive') - - call hist_addfld2d (fname='ED_NPP_AGSW_COL_SCPF',units='kgC/m2/yr',type2d='levscpf',& - avgflag='A', long_name='NPP flux into above-ground sapwood', & - ptr_gcell=this%ed_npp_agsw_col_scpf,default='inactive') - - call hist_addfld2d ( fname = 'ED_NPP_AGDW_COL_SCPF', units='kgC/m2/yr',type2d='levscpf',& - avgflag='A', long_name='NPP flux into above-ground deadwood', & - ptr_gcell=this%ed_npp_agdw_col_scpf,default='inactive') - - call hist_addfld2d ( fname = 'ED_NPP_STOR_COL_SCPF', units='kgC/m2/yr',type2d='levscpf',& - avgflag='A', long_name='NPP flux into storage', & - ptr_gcell=this%ed_npp_stor_col_scpf,default='inactive') - - call hist_addfld2d (fname='ED_DDBH_COL_SCPF', units = 'cm/yr/ha', type2d = 'levscpf', & - avgflag='A', long_name='diameter growth increment and pft/size', & - ptr_gcell=this%ed_ddbh_col_scpf, default='inactive') - - call hist_addfld2d (fname='ED_BA_COL_SCPF',units = 'm2/ha', type2d = 'levscpf', & - avgflag='A', long_name='basal area by patch and pft/size', & - ptr_gcell=this%ed_ba_col_scpf, default='inactive') - - call hist_addfld2d (fname='ED_NPLANT_COL_SCPF',units = 'N/ha', type2d = 'levscpf', & - avgflag='A', long_name='stem number density by patch and pft/size', & - ptr_gcell=this%ed_np_col_scpf, default='inactive') - - call hist_addfld2d (fname='ED_M1_COL_SCPF',units = 'N/ha/yr', type2d = 'levscpf', & - avgflag='A', long_name='background mortality count by patch and pft/size', & - ptr_gcell=this%ed_m1_col_scpf, default='inactive') - - call hist_addfld2d (fname='ED_M2_COL_SCPF',units = 'N/ha/yr', type2d = 'levscpf', & - avgflag='A', long_name='hydraulic mortality count by patch and pft/size', & - ptr_gcell=this%ed_m2_col_scpf, default='inactive') - - call hist_addfld2d (fname='ED_M3_COL_SCPF',units = 'N/ha/yr', type2d = 'levscpf', & - avgflag='A', long_name='carbon starvation mortality count by patch and pft/size', & - ptr_gcell=this%ed_m3_col_scpf, default='inactive') - - call hist_addfld2d (fname='ED_M4_COL_SCPF',units = 'N/ha/yr', type2d = 'levscpf', & - avgflag='A', long_name='impact mortality count by patch and pft/size', & - ptr_gcell=this%ed_m4_col_scpf, default='inactive') - - call hist_addfld2d (fname='ED_M5_COL_SCPF',units = 'N/ha/yr', type2d = 'levscpf', & - avgflag='A', long_name='fire mortality count by patch and pft/size', & - ptr_gcell=this%ed_m5_col_scpf, default='inactive') - - this%ed_npatches_col(begc:endc) = spval - call hist_addfld1d (fname='ED_NPATCHES', units='unitless', & - avgflag='A', long_name='ED total number of patches per site', & - ptr_col=this%ed_npatches_col) - - this%ed_ncohorts_col(begc:endc) = spval - call hist_addfld1d (fname='ED_NCOHORTS', units='unitless', & - avgflag='A', long_name='ED total number of cohorts per site', & - ptr_col=this%ed_ncohorts_col) - end subroutine InitHistory !----------------------------------------------------------------------- @@ -756,33 +379,6 @@ subroutine Restart ( this, bounds, ncid, flag ) 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, sites, nsites, fcolumn, waterstate_inst, canopystate_inst) @@ -1027,371 +623,10 @@ subroutine ed_clm_link( this, bounds, sites, nsites, fcolumn, waterstate_inst, c end do ! column loop - call this%ed_update_history_variables(bounds, sites(:), nsites, fcolumn(:), canopystate_inst) - end associate end subroutine ed_clm_link - !----------------------------------------------------------------------- - subroutine ed_update_history_variables( this, bounds, sites, nsites, fcolumn, canopystate_inst) - ! - ! !USES: - use CanopyStateType , only : canopystate_type - use PatchType , only : clmpatch => patch - use pftconMod , only : pftcon - - ! - ! !ARGUMENTS: - class(ed_clm_type) :: this - type(bounds_type) , intent(in) :: bounds ! clump bounds - type(ed_site_type) , intent(inout), target :: sites(nsites) - integer , intent(in) :: nsites - integer , intent(in) :: fcolumn(nsites) - type(ed_patch_type) , pointer :: currentPatch - type(ed_cohort_type) , pointer :: currentCohort - type(canopystate_type) , intent(inout) :: canopystate_inst - ! - ! !LOCAL VARIABLES: - integer :: p,ft,c,s -! integer :: firstsoilpatch(bounds%begg:bounds%endg) - real(r8) :: n_density ! individual of cohort per m2. - real(r8) :: n_perm2 ! individuals per m2 for the whole column - real(r8) :: patch_scaling_scalar ! ratio of canopy to patch area for counteracting patch scaling - real(r8) :: dbh ! actual dbh used to identify relevant size class - integer :: scpf ! size class x pft index - integer :: sc - !----------------------------------------------------------------------- - - 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: - - ed_gpp_scpf => this%ed_gpp_col_scpf , & - ed_npp_totl_scpf => this%ed_npp_totl_col_scpf , & - ed_npp_leaf_scpf => this%ed_npp_leaf_col_scpf , & - ed_npp_seed_scpf => this%ed_npp_seed_col_scpf , & - ed_npp_fnrt_scpf => this%ed_npp_fnrt_col_scpf , & - ed_npp_bgsw_scpf => this%ed_npp_bgsw_col_scpf , & - ed_npp_bgdw_scpf => this%ed_npp_bgdw_col_scpf , & - ed_npp_agsw_scpf => this%ed_npp_agsw_col_scpf , & - ed_npp_agdw_scpf => this%ed_npp_agdw_col_scpf , & - ed_npp_stor_scpf => this%ed_npp_stor_col_scpf , & - - ed_npatches => this%ed_npatches_col , & - ed_ncohorts => this%ed_ncohorts_col , & - - ed_ddbh_col_scpf => this%ed_ddbh_col_scpf , & - ed_ba_col_scpf => this%ed_ba_col_scpf , & - ed_np_col_scpf => this%ed_np_col_scpf , & - ed_m1_col_scpf => this%ed_m1_col_scpf , & - ed_m2_col_scpf => this%ed_m2_col_scpf , & - ed_m3_col_scpf => this%ed_m3_col_scpf , & - ed_m4_col_scpf => this%ed_m4_col_scpf , & - ed_m5_col_scpf => this%ed_m5_col_scpf , & - - 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 - 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 - - ed_gpp_scpf(:,:) = 0.0_r8 - ed_npp_totl_scpf(:,:) = 0.0_r8 - ed_npp_leaf_scpf(:,:) = 0.0_r8 - ed_npp_seed_scpf(:,:) = 0.0_r8 - ed_npp_fnrt_scpf(:,:) = 0.0_r8 - ed_npp_bgsw_scpf(:,:) = 0.0_r8 - ed_npp_bgdw_scpf(:,:) = 0.0_r8 - ed_npp_agsw_scpf(:,:) = 0.0_r8 - ed_npp_agdw_scpf(:,:) = 0.0_r8 - ed_npp_stor_scpf(:,:) = 0.0_r8 - - ed_ddbh_col_scpf(:,:) = 0.0_r8 - ed_ba_col_scpf(:,:) = 0.0_r8 - ed_np_col_scpf(:,:) = 0.0_r8 - ed_m1_col_scpf(:,:) = 0.0_r8 - ed_m2_col_scpf(:,:) = 0.0_r8 - ed_m3_col_scpf(:,:) = 0.0_r8 - ed_m4_col_scpf(:,:) = 0.0_r8 - ed_m5_col_scpf(:,:) = 0.0_r8 - - ed_npatches(:) = 0._r8 - ed_ncohorts(:) = 0._r8 - - do s = 1,nsites - - c = fcolumn(s) - - ! ============================================================================ - ! Zero the bare ground tile BGC variables. - ! ============================================================================ - - p = col%patchi(c) - - ! INTERF-TODO: THIS ZERO'ING IS REDUNDANT, THE WHOLE PATCH CLUMP IS ALREADY ZERO'D - - trimming(p) = 1.0_r8 - canopy_spread(p) = 0.0_r8 - PFTbiomass(p,:) = 0.0_r8 - PFTleafbiomass(p,:) = 0.0_r8 - PFTstorebiomass(p,:) = 0.0_r8 - PFTnindivs(p,:) = 0.0_r8 - area_plant(p) = 0.0_r8 - area_trees(p) = 0.0_r8 - nesterov_fire_danger(p) = 0.0_r8 - spitfire_ROS(p) = 0.0_r8 - TFC_ROS(p) = 0.0_r8 - effect_wspeed(p) = 0.0_r8 - fire_intensity(p) = 0.0_r8 - fire_area(p) = 0.0_r8 - scorch_height(p) = 0.0_r8 - fire_fuel_bulkd(p) = 0.0_r8 - fire_fuel_eff_moist(p) = 0.0_r8 - fire_fuel_sav(p) = 0.0_r8 - fire_fuel_mef(p) = 0.0_r8 - litter_in(p) = 0.0_r8 - litter_out(p) = 0.0_r8 - seed_bank(p) = 0.0_r8 - seeds_in(p) = 0.0_r8 - seed_decay(p) = 0.0_r8 - seed_germination(p) = 0.0_r8 - ED_biomass(p) = 0.0_r8 - ED_balive(p) = 0.0_r8 - ED_bdead(p) = 0.0_r8 - ED_bstore(p) = 0.0_r8 - ED_bleaf(p) = 0.0_r8 - ED_bleaf(p) = 0.0_r8 - sum_fuel(p) = 0.0_r8 - - currentPatch => sites(s)%oldest_patch - do while(associated(currentPatch)) - - ! INTERF-TODO: THIS LOGIC SHOULDN'T BE NECESSARY, SHOULD BE CHECKED AT THE BEGINNING - ! OF LINKING, ONCE - ! %patchno is the local index of the ED/FATES patches, starting at 1 - if(currentPatch%patchno <= numpft - numcft)then !don't expand into crop patches. - - ! Increment CLM/ALM patch index, first was non-veg, these are veg - p = p + 1 - - ed_npatches(c) = ed_npatches(c) + 1._r8 - - currentCohort => currentPatch%shortest - do while(associated(currentCohort)) - !accumulate into history variables. - - ft = currentCohort%pft - - ed_ncohorts(c) = ed_ncohorts(c) + 1._r8 - - if ((currentPatch%area .gt. 0._r8) .and. (currentPatch%total_canopy_area .gt. 0._r8)) then - - ! for quantities that are at the CLM patch level, because of the way that CLM patches are weighted for radiative purposes - ! this # density needs to be over either ED patch canopy area or ED patch total area, whichever is less - n_density = currentCohort%n/min(currentPatch%area,currentPatch%total_canopy_area) - - ! for quantities that are natively at column level, calculate plant density using whole area - n_perm2 = currentCohort%n/AREA - - else - n_density = 0.0_r8 - n_perm2 = 0.0_r8 - endif - - if ( DEBUG ) then - write(iulog,*) 'EDCLMLinkMod I ',currentCohort%bstore - write(iulog,*) 'EDCLMLinkMod II ',p,ED_bstore(p) - endif - - ED_bleaf(p) = ED_bleaf(p) + n_density * currentCohort%bl * 1.e3_r8 - ED_bstore(p) = ED_bstore(p) + n_density * currentCohort%bstore * 1.e3_r8 - ED_biomass(p) = ED_biomass(p) + n_density * currentCohort%b * 1.e3_r8 - ED_bdead(p) = ED_bdead(p) + n_density * currentCohort%bdead * 1.e3_r8 - ED_balive(p) = ED_balive(p) + n_density * currentCohort%balive * 1.e3_r8 - PFTbiomass(p,ft) = PFTbiomass(p,ft) + n_density * currentCohort%b * 1.e3_r8 - PFTleafbiomass(p,ft) = PFTleafbiomass(p,ft) + n_density * currentCohort%bl * 1.e3_r8 - PFTstorebiomass(p,ft) = PFTstorebiomass(p,ft) + n_density * currentCohort%bstore * 1.e3_r8 - PFTnindivs(p,ft) = PFTnindivs(p,ft) + currentCohort%n - - dbh = currentCohort%dbh !-0.5*(1./365.25)*currentCohort%ddbhdt - sc = count(dbh-sclass_ed.ge.0.0) - scpf = (ft-1)*nlevsclass_ed+sc - - ! Flux Variables (must pass a NaN check on growth increment and not be recruits) - if( .not.(currentCohort%isnew) ) then - ed_gpp_scpf(c,scpf) = ed_gpp_scpf(c,scpf) + n_perm2*currentCohort%gpp ! [kgC/m2/yr] - ed_npp_totl_scpf(c,scpf) = ed_npp_totl_scpf(c,scpf) + currentcohort%npp*n_perm2 - ed_npp_leaf_scpf(c,scpf) = ed_npp_leaf_scpf(c,scpf) + currentcohort%npp_leaf*n_perm2 - ed_npp_fnrt_scpf(c,scpf) = ed_npp_fnrt_scpf(c,scpf) + currentcohort%npp_froot*n_perm2 - ed_npp_bgsw_scpf(c,scpf) = ed_npp_bgsw_scpf(c,scpf) + currentcohort%npp_bsw*(1._r8-ED_val_ag_biomass)*n_perm2 - ed_npp_agsw_scpf(c,scpf) = ed_npp_agsw_scpf(c,scpf) + currentcohort%npp_bsw*ED_val_ag_biomass*n_perm2 - ed_npp_bgdw_scpf(c,scpf) = ed_npp_bgdw_scpf(c,scpf) + currentcohort%npp_bdead*(1._r8-ED_val_ag_biomass)*n_perm2 - ed_npp_agdw_scpf(c,scpf) = ed_npp_agdw_scpf(c,scpf) + currentcohort%npp_bdead*ED_val_ag_biomass*n_perm2 - ed_npp_seed_scpf(c,scpf) = ed_npp_seed_scpf(c,scpf) + currentcohort%npp_bseed*n_perm2 - ed_npp_stor_scpf(c,scpf) = ed_npp_stor_scpf(c,scpf) + currentcohort%npp_store*n_perm2 - if( abs(currentcohort%npp-(currentcohort%npp_leaf+currentcohort%npp_froot+ & - currentcohort%npp_bsw+currentcohort%npp_bdead+ & - currentcohort%npp_bseed+currentcohort%npp_store))>1.e-9) then - write(iulog,*) 'NPP Partitions are not balancing' - write(iulog,*) 'Fractional Error: ',abs(currentcohort%npp-(currentcohort%npp_leaf+currentcohort%npp_froot+ & - currentcohort%npp_bsw+currentcohort%npp_bdead+ & - currentcohort%npp_bseed+currentcohort%npp_store))/currentcohort%npp - write(iulog,*) 'Terms: ',currentcohort%npp,currentcohort%npp_leaf,currentcohort%npp_froot, & - currentcohort%npp_bsw,currentcohort%npp_bdead, & - currentcohort%npp_bseed,currentcohort%npp_store - write(iulog,*) ' NPP components during FATES-HLM linking does not balance ' - call endrun(msg=errMsg(__FILE__, __LINE__)) - end if - - ! Woody State Variables (basal area and number density and mortality) - if (pftcon%woody(ft) == 1) then - - ed_m1_col_scpf(c,scpf) = ed_m1_col_scpf(c,scpf) + currentcohort%bmort*n_perm2*AREA - ed_m2_col_scpf(c,scpf) = ed_m2_col_scpf(c,scpf) + currentcohort%hmort*n_perm2*AREA - ed_m3_col_scpf(c,scpf) = ed_m3_col_scpf(c,scpf) + currentcohort%cmort*n_perm2*AREA - ed_m4_col_scpf(c,scpf) = ed_m4_col_scpf(c,scpf) + currentcohort%imort*n_perm2*AREA - ed_m5_col_scpf(c,scpf) = ed_m5_col_scpf(c,scpf) + currentcohort%fmort*n_perm2*AREA - - ! basal area [m2/ha] - ed_ba_col_scpf(c,scpf) = ed_ba_col_scpf(c,scpf) + & - 0.25*3.14159*((dbh/100.0)**2.0)*n_perm2*AREA - - ! number density [/ha] - ed_np_col_scpf(c,scpf) = ed_np_col_scpf(c,scpf) + AREA*n_perm2 - - ! Growth Incrments must have NaN check and woody check - if(currentCohort%ddbhdt == currentCohort%ddbhdt) then - ed_ddbh_col_scpf(c,scpf) = ed_ddbh_col_scpf(c,scpf) + & - currentCohort%ddbhdt*n_perm2*AREA - else - ed_ddbh_col_scpf(c,scpf) = -999.9 - end if - end if - - end if - - 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? - ! define scalar to counteract the patch albedo scaling logic for conserved quantities - - if (currentPatch%area .gt. 0._r8 .and. currentPatch%total_canopy_area .gt.0 ) then - patch_scaling_scalar = min(1._r8, currentPatch%area / currentPatch%total_canopy_area) - else - patch_scaling_scalar = 0._r8 - endif - - nesterov_fire_danger(p) = sites(s)%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 * 1.e3_r8 * patch_scaling_scalar - litter_in(p) = (sum(currentPatch%CWD_AG_in) +sum(currentPatch%leaf_litter_in)) * 1.e3_r8 * 365.0_r8 * SHR_CONST_CDAY * patch_scaling_scalar - litter_out(p) = (sum(currentPatch%CWD_AG_out)+sum(currentPatch%leaf_litter_out)) * 1.e3_r8 * 365.0_r8 * SHR_CONST_CDAY * patch_scaling_scalar - seed_bank(p) = sum(currentPatch%seed_bank) * 1.e3_r8 * patch_scaling_scalar - seeds_in(p) = sum(currentPatch%seeds_in) * 1.e3_r8 * 365.0_r8 * SHR_CONST_CDAY * patch_scaling_scalar - seed_decay(p) = sum(currentPatch%seed_decay) * 1.e3_r8 * 365.0_r8 * SHR_CONST_CDAY * patch_scaling_scalar - seed_germination(p) = sum(currentPatch%seed_germination) * 1.e3_r8 * 365.0_r8 * SHR_CONST_CDAY * patch_scaling_scalar - canopy_spread(p) = currentPatch%spread(1) - area_plant(p) = 1._r8 - if (min(currentPatch%total_canopy_area,currentPatch%area)>0.0_r8) then - area_trees(p) = currentPatch%total_tree_area / min(currentPatch%total_canopy_area,currentPatch%area) - else - area_trees(p) = 0.0_r8 - end if - 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 - - enddo ! site loop - - end associate - - end subroutine ed_update_history_variables - !------------------------------------------------------------------------ ! INTERF-TODO: THIS ROUTINE COULD BE SPLIT. IT CALCULATES BOTH FATES/ED INTERNALS @@ -1912,127 +1147,9 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, colindex, waterstate_ins end subroutine ed_clm_leaf_area_profile - ! ===================================================================================== - - subroutine SummarizeProductivityFluxes(this, bounds, sites, nsites, fcolumn) - - ! Summarize the fast production inputs from fluxes per ED individual to fluxes per CLM patch and column - ! Must be called between calculation of productivity fluxes and daily ED calls - ! (since daily ED calls reorganize the patch / cohort structure) - - ! Written By Charlie Koven, April 2016 - ! - ! !USES: - use LandunitType , only : lun - use landunit_varcon , only : istsoil - !use subgridAveMod , only : p2c - ! - implicit none - ! - ! !ARGUMENTS - class(ed_clm_type) :: this - type(bounds_type) , intent(in) :: bounds - type(ed_site_type) , intent(in), target :: sites(nsites) - integer , intent(in) :: nsites - integer , intent(in) :: fcolumn(nsites) - ! - ! !LOCAL VARIABLES: - real(r8) :: dt ! radiation time step (seconds) - integer :: c, fc, l, p, s - type (ed_patch_type) , pointer :: currentPatch - type (ed_cohort_type) , pointer :: currentCohort - integer :: firstsoilpatch(bounds%begg:bounds%endg) ! the first patch in this gridcell that is soil and thus bare... - real(r8) :: n_density ! individual of cohort per m2. - real(r8) :: n_perm2 ! individuals per m2 of the whole column - - associate(& - npp_col => this%npp_col, & - npp => this%npp_patch, & - gpp => this%gpp_patch, & - ar => this%ar_patch, & - growth_resp => this%growth_resp_patch, & - maint_resp => this%maint_resp_patch & - ) - - ! set time steps - dt = real( get_step_size(), r8 ) - - ! zero variables first - ! column variables - do c = bounds%begc,bounds%endc - ! summary flux variables - npp_col(c) = 0._r8 - end do - - ! patch variables - do p = bounds%begp,bounds%endp - npp(p) = 0._r8 - gpp(p) = 0._r8 - ar(p) = 0._r8 - growth_resp(p) = 0._r8 - maint_resp(p) = 0._r8 - end do - - ! retrieve the first soil patch associated with each gridcell. - ! make sure we only get the first patch value for places which have soil. - - do s = 1,nsites - - c = fcolumn(s) - p = col%patchi(c) - - currentPatch => sites(s)%oldest_patch - do while(associated(currentPatch)) - - p = p + 1 - - currentCohort => currentPatch%tallest - do while(associated(currentCohort)) - - if ((currentPatch%area .gt. 0._r8) .and. (currentPatch%total_canopy_area .gt. 0._r8)) then - - ! for quantities that are at the CLM patch level, because of the way that CLM patches are weighted for radiative purposes - ! this # density needs to be over either ED patch canopy area or ED patch total area, whichever is less - n_density = currentCohort%n/min(currentPatch%area,currentPatch%total_canopy_area) - - ! for quantities that are natively at column level or higher, calculate plant density using whole area (for grid cell averages) - n_perm2 = currentCohort%n/AREA - - else - n_density = 0.0_r8 - n_perm2 = 0.0_r8 - endif - - if ( .not. currentCohort%isnew ) then - - ! map ed cohort-level fluxes to clm patch fluxes - npp(p) = npp(p) + currentCohort%npp_tstep * 1.e3_r8 * n_density / dt - gpp(p) = gpp(p) + currentCohort%gpp_tstep * 1.e3_r8 * n_density / dt - ar(p) = ar(p) + currentCohort%resp_tstep * 1.e3_r8 * n_density / dt - growth_resp(p) = growth_resp(p) + currentCohort%resp_g * 1.e3_r8 * n_density / dt - maint_resp(p) = maint_resp(p) + currentCohort%resp_m * 1.e3_r8 * n_density / dt - - ! map ed cohort-level npp fluxes to clm column fluxes - npp_col(c) = npp_col(c) + currentCohort%npp_tstep * n_perm2 * 1.e3_r8 /dt - - endif - - currentCohort => currentCohort%shorter - enddo !currentCohort - currentPatch => currentPatch%younger - end do !currentPatch - - end do ! site loop - - ! leaving this as a comment here. it should produce same answer for npp_col as above, - ! so it may be useful to try as a check to make sure machinery is working proerly - !call p2c(bounds,num_soilc, filter_soilc, npp(bounds%begp:bounds%endp), npp_col(bounds%begc:bounds%endc)) - - end associate -end subroutine SummarizeProductivityFluxes - !------------------------------------------------------------------------ - subroutine SummarizeNetFluxes(this, bounds, num_soilc, filter_soilc, & + + subroutine SummarizeNetFluxes(this, bounds, num_soilc, filter_soilc, & sites, nsites, fcolumn, soilbiogeochem_carbonflux_inst, & soilbiogeochem_carbonstate_inst) @@ -2102,6 +1219,7 @@ subroutine SummarizeNetFluxes(this, bounds, num_soilc, filter_soilc, & cwd_stock(c) = 0._r8 seed_stock(c) = 0._r8 biomass_stock(c) = 0._r8 + npp_col(c) = 0.0_r8 end do do s = 1, nsites @@ -2134,6 +1252,8 @@ subroutine SummarizeNetFluxes(this, bounds, num_soilc, filter_soilc, & biomass_stock(c) = biomass_stock(c) + (currentCohort%bdead + currentCohort%balive + & currentCohort%bstore) * n_perm2 * 1.e3_r8 + npp_col(c) = npp_col(c) + currentCohort%npp_tstep * n_perm2 * 1.e3_r8 /dt + currentCohort => currentCohort%shorter enddo !currentCohort currentPatch => currentPatch%younger @@ -2179,7 +1299,7 @@ subroutine SummarizeNetFluxes(this, bounds, num_soilc, filter_soilc, & currentPatch => sites(s)%oldest_patch do while(associated(currentPatch)) ! - ed_to_bgc_this_edts(c) = ed_to_bgc_this_edts(c) + (sum(currentPatch%CWD_AG_out) + sum(currentPatch%CWD_BG_out) + & + ed_to_bgc_this_edts(c) = ed_to_bgc_this_edts(c) + (sum(currentPatch%CWD_AG_out) + sum(currentPatch%CWD_BG_out) & + sum(currentPatch%seed_decay) + sum(currentPatch%leaf_litter_out) + sum(currentPatch%root_litter_out)) & * ( currentPatch%area/AREA ) * 1.e3_r8 / ( 365.0_r8*SHR_CONST_CDAY ) ! diff --git a/main/HistoryIOMod.F90 b/main/HistoryIOMod.F90 index b8cec3ee..593c15c3 100644 --- a/main/HistoryIOMod.F90 +++ b/main/HistoryIOMod.F90 @@ -173,8 +173,8 @@ Module HistoryIOMod character(len=24) :: vtype character(len=1) :: avgflag integer :: upfreq ! Update frequency (this is for checks and flushing) - ! 1 = dynamics step (daily) - ! 2 = rapid timestep (aka model time-step) + ! 1 = dynamics "dyn" (daily) + ! 2 = production "prod" (prob model tstep) real(r8) :: flushval type(iovar_dimkind_type),pointer :: iovar_dk_ptr ! Pointers (only one of these is allocated per variable) @@ -221,7 +221,7 @@ Module HistoryIOMod contains procedure, public :: update_history_dyn - procedure, public :: update_history_rapid + procedure, public :: update_history_prod procedure, public :: define_history_vars procedure, public :: set_history_var procedure, public :: init_iovar_dk_maps @@ -545,7 +545,7 @@ end subroutine update_history_dyn ! ====================================================================================== - subroutine update_history_rapid(this,nc,sites,nsites,fcolumn,dt_tstep) + subroutine update_history_prod(this,nc,sites,nsites,fcolumn,dt_tstep) ! --------------------------------------------------------------------------------- ! This is the call to update the history IO arrays that are expected to only change @@ -647,7 +647,7 @@ subroutine update_history_rapid(this,nc,sites,nsites,fcolumn,dt_tstep) end associate - end subroutine update_history_rapid + end subroutine update_history_prod ! ====================================================================================== @@ -735,117 +735,117 @@ subroutine define_history_vars(this,callstep,nvar) ivar=0 ! Site level counting variables - call this%set_history_var(vname='ED_NPATCHES2',units='none', & + call this%set_history_var(vname='ED_NPATCHES',units='none', & long='Total number of ED patches per site', use_default='active', & avgflag='A',vtype='SI_R8',hlms='CLM:ALM',flushval=1.0_r8, upfreq=1, & ivar=ivar, callstep=callstep,index = ih_npatches_si) - call this%set_history_var(vname='ED_NCOHORTS2',units='none', & + call this%set_history_var(vname='ED_NCOHORTS',units='none', & long='Total number of ED cohorts per site', use_default='active', & avgflag='A',vtype='SI_R8',hlms='CLM:ALM',flushval=1.0_r8, upfreq=1, & ivar=ivar, callstep=callstep,index = ih_ncohorts_si) ! Patch variables - call this%set_history_var(vname='TRIMMING2',units='none', & + call this%set_history_var(vname='TRIMMING',units='none', & long='Degree to which canopy expansion is limited by leaf economics', & use_default='active', & avgflag='A',vtype='PA_R8',hlms='CLM:ALM',flushval=1.0_r8, upfreq=1, & ivar=ivar, callstep=callstep,index = ih_trimming_pa) - call this%set_history_var(vname='AREA_PLANT2',units='m2', & + call this%set_history_var(vname='AREA_PLANT',units='m2', & long='area occupied by all plants', use_default='active', & avgflag='A',vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar, callstep=callstep,index = ih_area_plant_pa) - call this%set_history_var(vname='AREA_TREES2',units='m2', & + call this%set_history_var(vname='AREA_TREES',units='m2', & long='area occupied by woody plants', use_default='active', & avgflag='A',vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar, callstep=callstep,index = ih_area_treespread_pa) - call this%set_history_var(vname='CANOPY_SPREAD2',units='0-1', & + call this%set_history_var(vname='CANOPY_SPREAD',units='0-1', & long='Scaling factor between tree basal area and canopy area', & use_default='active', & avgflag='A',vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar, callstep=callstep,index = ih_canopy_spread_pa) - call this%set_history_var(vname='PFTBIOMASS2',units='gC/m2', & + call this%set_history_var(vname='PFTbiomass',units='gC/m2', & long='total PFT level biomass', use_default='active', & avgflag='A', vtype='PA_GRND_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar, callstep=callstep, index = ih_biomass_pa_pft ) - call this%set_history_var(vname='PFTLEAFBIOMASS2', units='gC/m2', & + call this%set_history_var(vname='PFTleafbiomass', units='gC/m2', & long='total PFT level leaf biomass', use_default='active', & avgflag='A', vtype='PA_GRND_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar, callstep=callstep, index = ih_leafbiomass_pa_pft ) - call this%set_history_var(vname='PFTSTOREBIOMASS2', units='gC/m2', & + call this%set_history_var(vname='PFTstorebiomass', units='gC/m2', & long='total PFT level stored biomass', use_default='active', & avgflag='A', vtype='PA_GRND_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar, callstep=callstep, index = ih_storebiomass_pa_pft ) - - call this%set_history_var(vname='PFTNINDIVS2', units='indiv / m2', & + + call this%set_history_var(vname='PFTnindivs', units='indiv / m2', & long='total PFT level number of individuals', use_default='active', & avgflag='A', vtype='PA_GRND_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar, callstep=callstep, index = ih_nindivs_pa_pft ) ! Fire Variables - call this%set_history_var(vname='FIRE_NESTEROV_INDEX2', units='none', & + call this%set_history_var(vname='FIRE_NESTEROV_INDEX', units='none', & long='nesterov_fire_danger index', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_nesterov_fire_danger_pa) - call this%set_history_var(vname='FIRE_ROS2', units='m/min', & + call this%set_history_var(vname='FIRE_ROS', units='m/min', & long='fire rate of spread m/min', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_spitfire_ROS_pa) - call this%set_history_var(vname='EFFECT_WSPEED2', units='none', & + call this%set_history_var(vname='EFFECT_WSPEED', units='none', & long ='effective windspeed for fire spread', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_effect_wspeed_pa ) - call this%set_history_var(vname='FIRE_TFC_ROS2', units='none', & + call this%set_history_var(vname='FIRE_TFC_ROS', units='none', & long ='total fuel consumed', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_TFC_ROS_pa ) - call this%set_history_var(vname='FIRE_INTENSITY2', units='kJ/m/s', & + call this%set_history_var(vname='FIRE_INTENSITY', units='kJ/m/s', & long='spitfire fire intensity: kJ/m/s', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_fire_intensity_pa ) - call this%set_history_var(vname='FIRE_AREA2', units='fraction', & + call this%set_history_var(vname='FIRE_AREA', units='fraction', & long='spitfire fire area:m2', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_fire_area_pa ) - call this%set_history_var(vname='SCORCH_HEIGHT2', units='m', & + call this%set_history_var(vname='SCORCH_HEIGHT', units='m', & long='spitfire fire area:m2', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_scorch_height_pa ) - call this%set_history_var(vname='FIRE_FUEL_MEF2', units='m', & + call this%set_history_var(vname='FIRE_FUEL_MEF', units='m', & long='spitfire fuel moisture', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_fire_fuel_mef_pa ) - call this%set_history_var(vname='FIRE_FUEL_BULKD2', units='m', & + call this%set_history_var(vname='FIRE_FUEL_BULKD', units='m', & long='spitfire fuel bulk density', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_fire_fuel_bulkd_pa ) - call this%set_history_var(vname='FIRE_FUEL_EFF_MOIST2', units='m', & + call this%set_history_var(vname='FIRE_FUEL_EFF_MOIST', units='m', & long='spitfire fuel moisture', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_fire_fuel_eff_moist_pa ) - call this%set_history_var(vname='FIRE_FUEL_SAV2', units='m', & + call this%set_history_var(vname='FIRE_FUEL_SAV', units='m', & long='spitfire fuel surface/volume ', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_fire_fuel_sav_pa ) - call this%set_history_var(vname='SUM_FUEL2', units='gC m-2', & + call this%set_history_var(vname='SUM_FUEL', units='gC m-2', & long='total ground fuel related to ros (omits 1000hr fuels)', & use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & @@ -853,58 +853,58 @@ subroutine define_history_vars(this,callstep,nvar) ! Litter Variables - call this%set_history_var(vname='LITTER_IN2', units='gC m-2 s-1', & + call this%set_history_var(vname='LITTER_IN', units='gC m-2 s-1', & long='Litter flux in leaves', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_litter_in_pa ) - call this%set_history_var(vname='LITTER_OUT2', units='gC m-2 s-1', & + call this%set_history_var(vname='LITTER_OUT', units='gC m-2 s-1', & long='Litter flux out leaves', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_litter_out_pa ) - call this%set_history_var(vname='SEED_BANK2', units='gC m-2', & + call this%set_history_var(vname='SEED_BANK', units='gC m-2', & long='Total Seed Mass of all PFTs', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_seed_bank_pa ) - call this%set_history_var(vname='SEEDS_IN2', units='gC m-2 s-1', & + call this%set_history_var(vname='SEEDS_IN', units='gC m-2 s-1', & long='Seed Production Rate', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_seeds_in_pa ) - call this%set_history_var(vname='SEED_GERMINATION2', units='gC m-2 s-1', & + call this%set_history_var(vname='SEED_GERMINATION', units='gC m-2 s-1', & long='Seed mass converted into new cohorts', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_seed_germination_pa ) - call this%set_history_var(vname='SEED_DECAY2', units='gC m-2 s-1', & + call this%set_history_var(vname='SEED_DECAY', units='gC m-2 s-1', & long='Seed mass decay', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_seed_decay_pa ) - call this%set_history_var(vname='BSTORE2', units='gC m-2', & + call this%set_history_var(vname='ED_bstore', units='gC m-2', & long='Storage biomass', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_bstore_pa ) - call this%set_history_var(vname='BDEAD2', units='gC m-2', & + call this%set_history_var(vname='ED_bdead', units='gC m-2', & long='Dead (structural) biomass (live trees, not CWD)', & use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_bdead_pa ) - call this%set_history_var(vname='BALIVE2', units='gC m-2', & + call this%set_history_var(vname='ED_balive', units='gC m-2', & long='Live biomass', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_balive_pa ) - call this%set_history_var(vname='BLEAF2', units='gC m-2', & + call this%set_history_var(vname='ED_bleaf', units='gC m-2', & long='Leaf biomass', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_bleaf_pa ) - call this%set_history_var(vname='BTOTAL2', units='gC m-2', & + call this%set_history_var(vname='ED_biomass', units='gC m-2', & long='Total biomass', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_btotal_pa ) @@ -912,32 +912,32 @@ subroutine define_history_vars(this,callstep,nvar) ! Ecosystem Carbon Fluxes (updated rapidly, upfreq=2) - call this%set_history_var(vname='NPP_SI2', units='gC/m^2/s', & + call this%set_history_var(vname='NPP_column', units='gC/m^2/s', & long='net primary production on the site', use_default='active', & avgflag='A', vtype='SI_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=2, & ivar=ivar,callstep=callstep, index = ih_npp_si ) - call this%set_history_var(vname='GPP2', units='gC/m^2/s', & + call this%set_history_var(vname='GPP', units='gC/m^2/s', & long='gross primary production', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=2, & ivar=ivar,callstep=callstep, index = ih_gpp_pa ) - call this%set_history_var(vname='NPP2', units='gC/m^2/s', & + call this%set_history_var(vname='NPP', units='gC/m^2/s', & long='net primary production', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=2, & ivar=ivar,callstep=callstep, index = ih_npp_pa ) - call this%set_history_var(vname='ARESP2', units='gC/m^2/s', & + call this%set_history_var(vname='AR', units='gC/m^2/s', & long='autotrophic respiration', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=2, & ivar=ivar,callstep=callstep, index = ih_aresp_pa ) - call this%set_history_var(vname='GROWTH_RESP2', units='gC/m^2/s', & + call this%set_history_var(vname='GROWTH_RESP', units='gC/m^2/s', & long='growth respiration', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=2, & ivar=ivar,callstep=callstep, index = ih_growth_resp_pa ) - call this%set_history_var(vname='MAINT_RESP2', units='gC/m^2/s', & + call this%set_history_var(vname='MAINT_RESP', units='gC/m^2/s', & long='maintenance respiration', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=2, & ivar=ivar,callstep=callstep, index = ih_maint_resp_pa ) From a755c470de0be822d1601399e10c9ab96230fdf9 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 24 Aug 2016 16:05:12 -0700 Subject: [PATCH 172/437] added the new cohort filter to the migrated calculation of npp_col. --- main/EDCLMLinkMod.F90 | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index fae9f1e7..ba5ca06d 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -1244,15 +1244,17 @@ subroutine SummarizeNetFluxes(this, bounds, num_soilc, filter_soilc, & currentCohort => currentPatch%tallest do while(associated(currentCohort)) - - ! for quantities that are natively at column level or higher, calculate plant density using whole area (for grid cell averages) - n_perm2 = currentCohort%n/AREA - - ! map biomass pools to column level - biomass_stock(c) = biomass_stock(c) + (currentCohort%bdead + currentCohort%balive + & - currentCohort%bstore) * n_perm2 * 1.e3_r8 - npp_col(c) = npp_col(c) + currentCohort%npp_tstep * n_perm2 * 1.e3_r8 /dt + if ( .not. currentCohort%isnew ) then + ! for quantities that are natively at column level or higher, calculate plant density using whole area (for grid cell averages) + n_perm2 = currentCohort%n/AREA + + ! map biomass pools to column level + biomass_stock(c) = biomass_stock(c) + (currentCohort%bdead + currentCohort%balive + & + currentCohort%bstore) * n_perm2 * 1.e3_r8 + + npp_col(c) = npp_col(c) + currentCohort%npp_tstep * n_perm2 * 1.e3_r8 /dt + end if currentCohort => currentCohort%shorter enddo !currentCohort From c554d4e05b49ffc9858276a7bd0188c453f9aa09 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 24 Aug 2016 20:42:10 -0700 Subject: [PATCH 173/437] Temporary modifications to maintain b4b regressions with NEP. --- biogeophys/EDAccumulateFluxesMod.F90 | 20 +++++++++++++++-- main/EDCLMLinkMod.F90 | 32 +++++++++++++++++++--------- main/EDTypesMod.F90 | 1 + 3 files changed, 41 insertions(+), 12 deletions(-) diff --git a/biogeophys/EDAccumulateFluxesMod.F90 b/biogeophys/EDAccumulateFluxesMod.F90 index 807b614f..bc756f4d 100644 --- a/biogeophys/EDAccumulateFluxesMod.F90 +++ b/biogeophys/EDAccumulateFluxesMod.F90 @@ -20,7 +20,7 @@ module EDAccumulateFluxesMod contains !------------------------------------------------------------------------------ - subroutine AccumulateFluxes_ED(sites, nsites, bc_in, bc_out) + subroutine AccumulateFluxes_ED(sites, nsites, bc_in, bc_out, dt_time) ! ! !DESCRIPTION: ! see above @@ -28,7 +28,8 @@ subroutine AccumulateFluxes_ED(sites, nsites, bc_in, bc_out) ! !USES: use shr_kind_mod , only : r8 => shr_kind_r8 use clm_varctl , only : iulog - use EDTypesMod , only : ed_patch_type, ed_cohort_type, ed_site_type + use EDTypesMod , only : ed_patch_type, ed_cohort_type, & + ed_site_type, AREA use FatesInterfaceMod , only : bc_in_type,bc_out_type ! ! !ARGUMENTS @@ -36,6 +37,7 @@ subroutine AccumulateFluxes_ED(sites, nsites, bc_in, bc_out) integer, intent(in) :: nsites type(bc_in_type), intent(in) :: bc_in(nsites) type(bc_out_type), intent(inout) :: bc_out(nsites) + real(r8), intent(in) :: dt_time ! timestep interval ! ! !LOCAL VARIABLES: type(ed_cohort_type), pointer :: ccohort ! current cohort @@ -44,11 +46,13 @@ subroutine AccumulateFluxes_ED(sites, nsites, bc_in, bc_out) integer :: c ! clm/alm column integer :: s ! ed site integer :: ifp ! index fates patch + real(r8):: n_perm2 !---------------------------------------------------------------------- do s = 1, nsites ifp = 0 + sites(s)%npp = 0.0_r8 cpatch => sites(s)%oldest_patch do while (associated(cpatch)) ifp = ifp+1 @@ -71,6 +75,18 @@ subroutine AccumulateFluxes_ED(sites, nsites, bc_in, bc_out) ccohort%gpp_acc = ccohort%gpp_acc + ccohort%gpp_tstep ccohort%resp_acc = ccohort%resp_acc + ccohort%resp_tstep + !----- THE FOLLOWING IS ONLY IMPLEMENTED TEMPORARILY FOR B4B reproducibility + !----- ALSO, THERE IS NO REASON TO USE THE ISNEW FLAG HERE + if ((cpatch%area .gt. 0._r8) .and. (cpatch%total_canopy_area .gt. 0._r8)) then + n_perm2 = ccohort%n/AREA + else + n_perm2 = 0.0_r8 + endif + if ( .not. ccohort%isnew ) then + sites(s)%npp = sites(s)%npp + ccohort%npp_tstep * n_perm2 * 1.e3_r8 / dt_time + + endif + do iv=1,ccohort%nv if(ccohort%year_net_uptake(iv) == 999._r8)then ! note that there were leaves in this layer this year. ccohort%year_net_uptake(iv) = 0._r8 diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index ba5ca06d..177eb948 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -1227,6 +1227,9 @@ subroutine SummarizeNetFluxes(this, bounds, num_soilc, filter_soilc, & c = fcolumn(s) p = col%patchi(c) + ! Temporary + npp_col(c) = sites(s)%npp + ! map ed site-level fire fluxes to clm column fluxes fire_c_to_atm(c) = sites(s)%total_burn_flux_to_atm / ( AREA * SHR_CONST_CDAY * 1.e3_r8) @@ -1244,17 +1247,26 @@ subroutine SummarizeNetFluxes(this, bounds, num_soilc, filter_soilc, & currentCohort => currentPatch%tallest do while(associated(currentCohort)) - - if ( .not. currentCohort%isnew ) then - ! for quantities that are natively at column level or higher, calculate plant density using whole area (for grid cell averages) - n_perm2 = currentCohort%n/AREA - - ! map biomass pools to column level - biomass_stock(c) = biomass_stock(c) + (currentCohort%bdead + currentCohort%balive + & - currentCohort%bstore) * n_perm2 * 1.e3_r8 + ! for quantities that are natively at column level or higher, calculate plant density using whole area (for grid cell averages) + n_perm2 = currentCohort%n/AREA + + ! map biomass pools to column level + biomass_stock(c) = biomass_stock(c) + (currentCohort%bdead + currentCohort%balive + & + currentCohort%bstore) * n_perm2 * 1.e3_r8 + + ! if ( .not. currentCohort%isnew ) then + ! + ! The following implementation to calculation n_perm2 is necessary for b4b reproducibility + ! while restructuring a large amount of code. This should be re-visited and we should be + ! more consistent in how n_perm2 is calculated for different cases + ! if ((currentPatch%area .gt. 0._r8) .and. (currentPatch%total_canopy_area .gt. 0._r8)) then + ! n_perm2 = currentCohort%n/AREA + ! else + ! n_perm2 = 0.0_r8 + ! endif - npp_col(c) = npp_col(c) + currentCohort%npp_tstep * n_perm2 * 1.e3_r8 /dt - end if + ! npp_col(c) = npp_col(c) + currentCohort%npp_tstep * n_perm2 * 1.e3_r8 /dt + ! end if currentCohort => currentCohort%shorter enddo !currentCohort diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 4086690b..4398c264 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -445,6 +445,7 @@ module EDTypesMod 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 + real(r8) :: npp ! used for calculating NEP and NBP during BGC summarization phase ! DISTURBANCE real(r8) :: disturbance_mortality ! site level disturbance rates from mortality. From 4572841e0ef233f0f7bd956cf96ccc2908a65f89 Mon Sep 17 00:00:00 2001 From: Ben Andre Date: Thu, 25 Aug 2016 11:47:13 -0600 Subject: [PATCH 174/437] Bugfix for nag: dangling pointer to fates sites Creating a pointer to an object, such as currentCohort%siteptr, requires that the target be defined as a target or pointer. Since sites are a dynamic array inside a derived type and 'allocatable, target' doesn't appear to be a valid variable attribute, the only way I see to make this work is with change fates sites to a pointer. Tests: SMS_D_Mmpi-serial_Ld5.5x5_amazon.ICLM45ED.hobart_nag.clm-edTest gets past the danging pointer runtime error. --- main/FatesInterfaceMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 0d3a4336..7cd975e1 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -230,7 +230,7 @@ module FatesInterfaceMod integer :: nsites - type(ed_site_type), allocatable :: sites(:) + type(ed_site_type), pointer :: sites(:) ! These are boundary conditions that the FATES models are required to be filled. ! These values are filled by the driver or HLM. Once filled, these have an From 4a54ac31b849ab76311e870a83b18f9a722d7a7c Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 25 Aug 2016 12:42:17 -0700 Subject: [PATCH 175/437] Reverted some variable names for testing consistency. Added the use_ed check the the history_io_vars initialization (to avoid doubled variables) and fixed an OPENMP pragma. --- main/HistoryIOMod.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/main/HistoryIOMod.F90 b/main/HistoryIOMod.F90 index 593c15c3..afbfd4b7 100644 --- a/main/HistoryIOMod.F90 +++ b/main/HistoryIOMod.F90 @@ -825,12 +825,12 @@ subroutine define_history_vars(this,callstep,nvar) avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_scorch_height_pa ) - call this%set_history_var(vname='FIRE_FUEL_MEF', units='m', & + call this%set_history_var(vname='fire_fuel_mef', units='m', & long='spitfire fuel moisture', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_fire_fuel_mef_pa ) - call this%set_history_var(vname='FIRE_FUEL_BULKD', units='m', & + call this%set_history_var(vname='fire_fuel_bulkd', units='m', & long='spitfire fuel bulk density', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_fire_fuel_bulkd_pa ) @@ -840,7 +840,7 @@ subroutine define_history_vars(this,callstep,nvar) avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_fire_fuel_eff_moist_pa ) - call this%set_history_var(vname='FIRE_FUEL_SAV', units='m', & + call this%set_history_var(vname='fire_fuel_sav', units='m', & long='spitfire fuel surface/volume ', use_default='active', & avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & ivar=ivar,callstep=callstep, index = ih_fire_fuel_sav_pa ) From 95ffe48cd840376fd00afd38d4ed08c768cce9fd Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 25 Aug 2016 15:06:13 -0700 Subject: [PATCH 176/437] Updated some comments --- main/HistoryIOMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/HistoryIOMod.F90 b/main/HistoryIOMod.F90 index afbfd4b7..c0ef7c0f 100644 --- a/main/HistoryIOMod.F90 +++ b/main/HistoryIOMod.F90 @@ -549,7 +549,7 @@ subroutine update_history_prod(this,nc,sites,nsites,fcolumn,dt_tstep) ! --------------------------------------------------------------------------------- ! This is the call to update the history IO arrays that are expected to only change - ! after Ecosystem Dynamics have been processed. + ! after rapid timescale productivity calculations (gpp and respiration). ! --------------------------------------------------------------------------------- use EDtypesMod , only : ed_site_type, & From 190d01e28aa0aaa1a3fe2d4ae0585c53e5482e26 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 25 Aug 2016 17:27:58 -0700 Subject: [PATCH 177/437] Added an update to a cohorts site pointer when cohorts are transferred from a donor to recipient patch during fusion. --- biogeochem/EDPatchDynamicsMod.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index d38e868d..74063488 100755 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -1255,6 +1255,8 @@ subroutine fuse_2_patches(dp, rp) rp%shortest => storesmallcohort currentCohort%patchptr => rp + currentCohort%siteptr => rp%siteptr + currentCohort => nextc dp%shortest => currentCohort From 0e052a40872e5a789b737c64fd020f6fb96e36c9 Mon Sep 17 00:00:00 2001 From: Ben Andre Date: Sun, 21 Aug 2016 22:15:30 -0600 Subject: [PATCH 178/437] Start refactoring to control fates output to stdout. Create a new global variable to control output unit used by fates modules, and a new control flag to manage output. Only used in a couple of modules that are writing to stdout (cesm.log). Test suite: SMS_D_Ld3.f10_f10.ICLM45ED.yellowstone_intel.clm-edTest Test status: passed functionality test. --- biogeochem/EDGrowthFunctionsMod.F90 | 2 +- main/EDCLMLinkMod.F90 | 66 +++++++++++----------- main/FatesGlobals.F90 | 38 +++++++++++++ main/FatesInterfaceMod.F90 | 86 +++++++++++++++++++++-------- 4 files changed, 137 insertions(+), 55 deletions(-) create mode 100644 main/FatesGlobals.F90 diff --git a/biogeochem/EDGrowthFunctionsMod.F90 b/biogeochem/EDGrowthFunctionsMod.F90 index a4ccdb2d..a400f46a 100755 --- a/biogeochem/EDGrowthFunctionsMod.F90 +++ b/biogeochem/EDGrowthFunctionsMod.F90 @@ -117,7 +117,7 @@ real(r8) function Bleaf( cohort_in ) slascaler = 0.03_r8/pftcon%slatop(cohort_in%pft) bleaf = bleaf * slascaler - !write(*,*) 'bleaf',bleaf, slascaler,cohort_in%pft + !write(iulog,*) 'bleaf',bleaf, slascaler,cohort_in%pft !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 diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 0b771ebd..517d1829 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -1422,7 +1422,9 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, colindex, waterstate_ins ! !DESCRIPTION: ! Load LAI in each layer into array to send to CLM ! - ! !USES: + ! !USES: + use FatesGlobals, only : fates_log + 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 @@ -1585,7 +1587,7 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, colindex, waterstate_ins currentCohort%sai !snow burial -!write(*,*) 'calc snow' +!write(fates_log(), *) 'calc snow' snow_depth_col = snow_depth(colindex) * frac_sno_eff(colindex) if(snow_depth_col > maxh(iv))then fraction_exposed = 0._r8 @@ -1600,12 +1602,12 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, colindex, waterstate_ins ! no m2 of leaf per m2 of ground in each height class ! FIX(SPM,032414) these should be uncommented this and double check - if ( DEBUG ) write(iulog,*) 'EDCLMLink 1154 ', currentPatch%elai_profile(1,ft,iv) + if ( DEBUG ) write(fates_log(), *) 'EDCLMLink 1154 ', currentPatch%elai_profile(1,ft,iv) currentPatch%elai_profile(1,ft,iv) = currentPatch%tlai_profile(1,ft,iv) * fraction_exposed currentPatch%esai_profile(1,ft,iv) = currentPatch%tsai_profile(1,ft,iv) * fraction_exposed - if ( DEBUG ) write(iulog,*) 'EDCLMLink 1159 ', currentPatch%elai_profile(1,ft,iv) + if ( DEBUG ) write(fates_log(), *) 'EDCLMLink 1159 ', currentPatch%elai_profile(1,ft,iv) enddo ! (iv) hite bins @@ -1626,7 +1628,7 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, colindex, waterstate_ins enddo if(lai > currentPatch%lai)then - write(iulog,*) 'ED: problem with lai assignments' + write(fates_log(), *) 'ED: problem with lai assignments' endif @@ -1652,14 +1654,14 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, colindex, waterstate_ins fleaf = currentCohort%lai / (currentCohort%lai + currentCohort%sai) else fleaf = 0._r8 - write(iulog,*) 'ED: no stem or leaf area' ,currentCohort%pft,currentCohort%bl, & + write(fates_log(), *) 'ED: 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,*) 'ED: issue with NV',currentCohort%NV,currentCohort%pft,currentCohort%canopy_layer + write(fates_log(), *) 'ED: issue with NV',currentCohort%NV,currentCohort%pft,currentCohort%canopy_layer endif ! c = clmpatch%column(currentPatch%clm_pno) @@ -1667,7 +1669,7 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, colindex, waterstate_ins ! COLUMNIZATION IS COMPLETE if( clmpatch%column(currentPatch%clm_pno) .ne. colindex .or. currentPatch%clm_pno .ne. p )then ! ERROR - write(iulog,*) ' clmpatch%column(currentPatch%clm_pno) .ne. colindex .or. currentPatch%clm_pno .ne. p ' + write(fates_log(), *) ' clmpatch%column(currentPatch%clm_pno) .ne. colindex .or. currentPatch%clm_pno .ne. p ' call endrun(msg=errMsg(__FILE__, __LINE__)) end if @@ -1683,7 +1685,7 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, colindex, waterstate_ins layer_bottom_hite = currentCohort%hite-(((iv+1)/currentCohort%NV) * currentCohort%hite * & EDecophyscon%crown(currentCohort%pft)) ! pftcon%vertical_canopy_frac(ft)) - write(*,*) 'calc snow 2', colindex, snow_depth(colindex) , frac_sno_eff(colindex) + write(fates_log(), *) 'calc snow 2', colindex, snow_depth(colindex) , frac_sno_eff(colindex) ! fraction_exposed = 1.0_r8 !default. ! snow_depth_col = snow_depth(c) ! * frac_sno_eff(c) @@ -1714,8 +1716,8 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, colindex, waterstate_ins currentPatch%layer_height_profile(L,ft,iv) = currentPatch%layer_height_profile(L,ft,iv) + (dinc_ed * fleaf * & currentCohort%c_area/currentPatch%total_canopy_area *(layer_top_hite+layer_bottom_hite)/2.0_r8) !average height of layer. - write(*,*) 'LHP', currentPatch%layer_height_profile(L,ft,iv) - if ( DEBUG ) write(iulog,*) 'EDCLMLink 1246 ', currentPatch%elai_profile(1,ft,iv) + write(fates_log(), *) 'LHP', currentPatch%layer_height_profile(L,ft,iv) + if ( DEBUG ) write(fates_log(), *) 'EDCLMLink 1246 ', currentPatch%elai_profile(1,ft,iv) end do @@ -1728,7 +1730,7 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, colindex, waterstate_ins layer_bottom_hite = currentCohort%hite-(((iv+1)/currentCohort%NV) * currentCohort%hite * & EDecophyscon%crown(currentCohort%pft)) -!write(*,*) 'calc snow 3', snow_depth(c) , frac_sno_eff(c) +!write(fates_log(), *) 'calc snow 3', snow_depth(c) , frac_sno_eff(c) fraction_exposed = 1.0_r8 !default. snow_depth_col = snow_depth(colindex) * frac_sno_eff(colindex) if(snow_depth_col > layer_top_hite)then @@ -1747,7 +1749,7 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, colindex, waterstate_ins remainder = (currentCohort%treelai + currentCohort%treesai) - (dinc_ed*(currentCohort%NV-1)) if(remainder > 1.0_r8)then - write(iulog,*)'ED: issue with remainder',currentCohort%treelai,currentCohort%treesai,dinc_ed, & + write(fates_log(), *)'ED: issue with remainder',currentCohort%treelai,currentCohort%treesai,dinc_ed, & currentCohort%NV endif !assumes that fleaf is unchanging FIX(RF,032414) @@ -1767,15 +1769,15 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, colindex, waterstate_ins currentCohort%c_area/currentPatch%total_canopy_area) currentPatch%layer_height_profile(L,ft,iv) = currentPatch%layer_height_profile(L,ft,iv) + (remainder * fleaf * & currentCohort%c_area/currentPatch%total_canopy_area*(layer_top_hite+layer_bottom_hite)/2.0_r8) - write(*,*) 'LHP', currentPatch%layer_height_profile(L,ft,iv) + write(fates_log(), *) 'LHP', currentPatch%layer_height_profile(L,ft,iv) 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 + write(fates_log(), *) '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 + write(fates_log(), *) '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 + write(fates_log(), *) 'ED: balive is zero in clmedlink',currentCohort%balive,currentCohort%bl endif currentCohort => currentCohort%taller @@ -1791,7 +1793,7 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, colindex, waterstate_ins currentPatch%tsai_profile(L,ft,iv) = currentPatch%tsai_profile(L,ft,iv) / & currentPatch%canopy_area_profile(L,ft,iv) - if ( DEBUG ) write(iulog,*) 'EDCLMLink 1293 ', currentPatch%elai_profile(L,ft,iv) + if ( DEBUG ) write(fates_log(), *) 'EDCLMLink 1293 ', currentPatch%elai_profile(L,ft,iv) currentPatch%elai_profile(L,ft,iv) = currentPatch%elai_profile(L,ft,iv) / & currentPatch%canopy_area_profile(L,ft,iv) @@ -1836,12 +1838,12 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, colindex, waterstate_ins ! p = currentPatch%clm_pno if(abs(tlai(p)-tlai_temp) > 0.0001_r8) then - write(iulog,*) 'ED: error with tlai calcs',& + write(fates_log(), *) 'ED: error with tlai calcs',& NC,colindex, abs(tlai(p)-tlai_temp), tlai_temp,tlai(p) do L = 1,currentPatch%NCL_p - write(iulog,*) 'ED: carea profile',L,currentPatch%canopy_area_profile(L,1,1:currentPatch%nrad(L,1)) - write(iulog,*) 'ED: tlai profile',L,currentPatch%tlai_profile(L,1,1:currentPatch%nrad(L,1)) + write(fates_log(), *) 'ED: carea profile',L,currentPatch%canopy_area_profile(L,1,1:currentPatch%nrad(L,1)) + write(fates_log(), *) 'ED: tlai profile',L,currentPatch%tlai_profile(L,1,1:currentPatch%nrad(L,1)) end do endif @@ -1862,7 +1864,7 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, colindex, waterstate_ins do L = 1,currentPatch%NCL_p do ft = 1,numpft_ed if(currentPatch%nrad(L,ft) > 30)then - write(iulog,*) 'ED: issue w/ nrad' + write(fates_log(), *) 'ED: issue w/ nrad' endif currentPatch%present(L,ft) = 0 do iv = 1, currentPatch%nrad(L,ft); @@ -1874,30 +1876,32 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, colindex, waterstate_ins 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,*) 'ED: canopy area too small',sum(currentPatch%canopy_area_profile(1,1:numpft_ed,1)) - write(iulog,*) 'ED: cohort areas', currentPatch%canopy_area_profile(1,1:numpft_ed,:) + write(fates_log(), *) 'ED: canopy area too small',sum(currentPatch%canopy_area_profile(1,1:numpft_ed,1)) + write(fates_log(), *) 'ED: 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,*) 'ED: not enough area in the top canopy', & + write(fates_log(), *) 'ED: not enough area in the top canopy', & sum(currentPatch%canopy_area_profile(L,1:numpft_ed,1)), & currentPatch%canopy_area_profile(L,1:numpft_ed,1) endif if(abs(sum(currentPatch%canopy_area_profile(L,1:numpft_ed,1))) > 1.00001)then - write(iulog,*) 'ED: canopy-area-profile wrong',sum(currentPatch%canopy_area_profile(L,1:numpft_ed,1)), & - colindex,currentPatch%patchno,L - write(iulog,*) 'ED: areas',currentPatch%canopy_area_profile(L,1:2,1),currentPatch%patchno + write(fates_log(), *) 'ED: canopy-area-profile wrong', & + sum(currentPatch%canopy_area_profile(L,1:numpft_ed,1)), & + colindex, currentPatch%patchno, L + write(fates_log(), *) 'ED: 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,*) 'ED: cohorts',currentCohort%dbh,currentCohort%c_area, & + write(fates_log(), *) 'ED: cohorts',currentCohort%dbh,currentCohort%c_area, & currentPatch%total_canopy_area,currentPatch%area,currentPatch%canopy_area - write(iulog,*) 'ED: fracarea',currentCohort%pft, currentCohort%c_area/currentPatch%total_canopy_area + write(fates_log(), *) 'ED: fracarea', currentCohort%pft, & + currentCohort%c_area/currentPatch%total_canopy_area endif currentCohort => currentCohort%taller @@ -1909,7 +1913,7 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, colindex, waterstate_ins do L = 1,currentPatch%NCL_p do ft = 1,numpft_ed if(currentPatch%present(L,FT) > 1)then - write(iulog,*) 'ED: present issue',currentPatch%clm_pno,L,ft,currentPatch%present(L,FT) + write(fates_log(), *) 'ED: present issue',currentPatch%clm_pno,L,ft,currentPatch%present(L,FT) currentPatch%present(L,ft) = 1 endif enddo diff --git a/main/FatesGlobals.F90 b/main/FatesGlobals.F90 new file mode 100644 index 00000000..9ae06e20 --- /dev/null +++ b/main/FatesGlobals.F90 @@ -0,0 +1,38 @@ +module FatesGlobals + ! NOTE(bja, 201608) This is a temporary hack module to store global + ! data used inside fates. It's main use it to explicitly call out + ! global data that needs to be dealt with, but doesn't have an + ! immediately obvious home. + + implicit none + + integer, private :: fates_log_ + logical, private :: fates_global_verbose_ + + public :: FatesGlobalsInit + public :: fates_log + public :: fates_global_verbose + +contains + + subroutine FatesGlobalsInit(log_unit, global_verbose) + + implicit none + + integer, intent(in) :: log_unit + logical, intent(in) :: global_verbose + + fates_log_ = log_unit + fates_global_verbose_ = global_verbose + + end subroutine FatesGlobalsInit + + integer function fates_log() + fates_log = fates_log_ + end function fates_log + + logical function fates_global_verbose() + fates_global_verbose = fates_global_verbose_ + end function fates_global_verbose + +end module FatesGlobals diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 7cd975e1..776e4cdc 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -253,13 +253,27 @@ module FatesInterfaceMod end type fates_interface_type - + public :: FatesInterfaceInit public :: set_fates_ctrlparms contains ! ==================================================================================== + subroutine FatesInterfaceInit(log_unit, global_verbose) + + use FatesGlobals, only : FatesGlobalsInit + + implicit none + + integer, intent(in) :: log_unit + logical, intent(in) :: global_verbose + + call FatesGlobalsInit(log_unit, global_verbose) + + end subroutine FatesInterfaceInit + + ! ==================================================================================== ! INTERF-TODO: THIS IS A PLACE-HOLDER ROUTINE, NOT CALLED YET... subroutine fates_clean(this) @@ -449,7 +463,8 @@ subroutine set_fates_ctrlparms(tag,dimval) ! ! RGK-2016 ! --------------------------------------------------------------------------------- - + use FatesGlobals, only : fates_log, fates_global_verbose + ! Arguments integer, optional, intent(in) :: dimval character(len=*),intent(in) :: tag @@ -461,9 +476,9 @@ subroutine set_fates_ctrlparms(tag,dimval) select case (trim(tag)) case('flush_to_unset') - - write(*,*) 'Flushing FATES control parameters prior to transfer from host' - + if (fates_global_verbose()) then + write(fates_log(), *) 'Flushing FATES control parameters prior to transfer from host' + end if cp_numSwb = unset_int cp_numlevgrnd = unset_int cp_numlevdecomp_full = unset_int @@ -473,41 +488,53 @@ subroutine set_fates_ctrlparms(tag,dimval) case('check_allset') if(cp_numSWb .eq. unset_int) then - write(*,*) 'FATES dimension/parameter unset: num_sw_rad_bbands' + if (fates_global_verbose()) then + write(fates_log(), *) 'FATES dimension/parameter unset: num_sw_rad_bbands' + end if ! INTERF-TODO: FATES NEEDS INTERNAL end_run ! end_run('MESSAGE') end if if(cp_numSWb > cp_maxSWb) then - write(*,*) 'FATES sets a maximum number of shortwave bands' - write(*,*) 'for some scratch-space, cp_maxSWb' - write(*,*) 'it defaults to 2, but can be increased as needed' - write(*,*) 'your driver or host model is intending to drive' - write(*,*) 'FATES with:',cp_numSWb,' bands.' - write(*,*) 'please increase cp_maxSWb in EDTypes to match' - write(*,*) 'or exceed this value' + if (fates_global_verbose()) then + write(fates_log(), *) 'FATES sets a maximum number of shortwave bands' + write(fates_log(), *) 'for some scratch-space, cp_maxSWb' + write(fates_log(), *) 'it defaults to 2, but can be increased as needed' + write(fates_log(), *) 'your driver or host model is intending to drive' + write(fates_log(), *) 'FATES with:',cp_numSWb,' bands.' + write(fates_log(), *) 'please increase cp_maxSWb in EDTypes to match' + write(fates_log(), *) 'or exceed this value' + end if ! end_run('MESSAGE') end if if(cp_numlevgrnd .eq. unset_int) then - write(*,*) 'FATES dimension/parameter unset: numlevground' + if (fates_global_verbose()) then + write(fates_log(), *) 'FATES dimension/parameter unset: numlevground' + end if ! INTERF-TODO: FATES NEEDS INTERNAL end_run ! end_run('MESSAGE') end if if(cp_numlevdecomp_full .eq. unset_int) then - write(*,*) 'FATES dimension/parameter unset: numlevdecomp_full' + if (fates_global_verbose()) then + write(fates_log(), *) 'FATES dimension/parameter unset: numlevdecomp_full' + end if ! INTERF-TODO: FATES NEEDS INTERNAL end_run ! end_run('MESSAGE') end if if(cp_numlevdecomp .eq. unset_int) then - write(*,*) 'FATES dimension/parameter unset: numlevdecomp' + if (fates_global_verbose()) then + write(fates_log(), *) 'FATES dimension/parameter unset: numlevdecomp' + end if ! INTERF-TODO: FATES NEEDS INTERNAL end_run ! end_run('MESSAGE') end if - write(*,*) 'Checked. All control parameters sent to FATES.' + if (fates_global_verbose()) then + write(fates_log(), *) 'Checked. All control parameters sent to FATES.' + end if case default @@ -517,29 +544,42 @@ subroutine set_fates_ctrlparms(tag,dimval) case('num_sw_bbands') cp_numSwb = dimval - write(*,*) 'Transfering num_sw_bbands = ',dimval,' to FATES' + if (fates_global_verbose()) then + write(fates_log(), *) 'Transfering num_sw_bbands = ',dimval,' to FATES' + end if case('num_lev_ground') cp_numlevgrnd = dimval - write(*,*) 'Transfering num_lev_ground = ',dimval,' to FATES' + if (fates_global_verbose()) then + + write(fates_log(), *) 'Transfering num_lev_ground = ',dimval,' to FATES' + end if case('num_levdecomp_full') cp_numlevdecomp_full = dimval - write(*,*) 'Transfering num_levdecomp_full = ',dimval,' to FATES' + if (fates_global_verbose()) then + write(fates_log(), *) 'Transfering num_levdecomp_full = ',dimval,' to FATES' + end if case('num_levdecomp') cp_numlevdecomp = dimval - write(*,*) 'Transfering num_levdecomp = ',dimval,' to FATES' + if (fates_global_verbose()) then + write(fates_log(), *) 'Transfering num_levdecomp = ',dimval,' to FATES' + end if case default - write(*,*) 'tag not recognized:',trim(tag) + if (fates_global_verbose()) then + write(fates_log(), *) 'tag not recognized:',trim(tag) + end if ! end_run end select else - write(*,*) 'no value was provided for the tag' + if (fates_global_verbose()) then + write(fates_log(), *) 'no value was provided for the tag' + end if end if end select From eb7978267641489bafdb9dc9acb8307b5a25c195 Mon Sep 17 00:00:00 2001 From: Ben Andre Date: Fri, 26 Aug 2016 08:29:20 -0600 Subject: [PATCH 179/437] Bugfix nag: fix danging pointer runtime error Fix a nag dangling pointer runtime error during ED restart that was missed in 9b079f5. Testing: ERS_D_Ld5.f10_f10.ICLM45ED.hobart_nag.clm-edTest ERS_D_Mmpi-serial_Ld5.1x1_brazil.ICLM45ED.hobart_nag.clm-edTest Test status: pass --- main/EDRestVectorMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/EDRestVectorMod.F90 b/main/EDRestVectorMod.F90 index 030dd5a5..89d485be 100755 --- a/main/EDRestVectorMod.F90 +++ b/main/EDRestVectorMod.F90 @@ -2180,7 +2180,7 @@ subroutine EDRest ( bounds, nsites, sites, fcolumn, ncid, flag ) type(bounds_type) , intent(in) :: bounds ! bounds type(file_desc_t) , intent(inout) :: ncid ! netcdf id integer , intent(in) :: nsites - type(ed_site_type) , intent(inout) :: sites(nsites) ! The site vector + type(ed_site_type) , intent(inout), target :: sites(nsites) ! The site vector integer , intent(in) :: fcolumn(nsites) character(len=*) , intent(in) :: flag !'read' or 'write' ! From f32c216e27e700bbd1ebf4b85352b89cf9c0cb96 Mon Sep 17 00:00:00 2001 From: Ben Andre Date: Mon, 29 Aug 2016 14:57:06 -0600 Subject: [PATCH 180/437] 'pull clm4_5_12_r192 tags from svn' --- biogeochem/EDCanopyStructureMod.F90 | 110 +- biogeochem/EDCohortDynamicsMod.F90 | 372 +++-- biogeochem/EDGrowthFunctionsMod.F90 | 67 +- biogeochem/EDPatchDynamicsMod.F90 | 324 +++- biogeochem/EDPhenologyType.F90 | 277 ---- biogeochem/EDPhysiologyMod.F90 | 668 +++++++-- biogeophys/EDAccumulateFluxesMod.F90 | 111 +- biogeophys/EDBtranMod.F90 | 637 ++++---- biogeophys/EDPhotosynthesisMod.F90 | 909 ++++++----- biogeophys/EDSurfaceAlbedoMod.F90 | 2017 +++++++++++++------------ fire/SFMainMod.F90 | 13 +- main/CMakeLists.txt | 1 + main/EDCLMLinkMod.F90 | 2073 +++++++++++++++++++------- main/EDInitMod.F90 | 253 +--- main/EDMainMod.F90 | 186 +-- main/EDParamsMod.F90 | 3 +- main/EDPftvarcon.F90 | 5 + main/EDRestVectorMod.F90 | 1755 +++++++++++++++------- main/EDTypesMod.F90 | 232 ++- main/EDVecCohortType.F90 | 6 +- main/FatesGlobals.F90 | 38 + main/FatesInterfaceMod.F90 | 593 ++++++++ 22 files changed, 6906 insertions(+), 3744 deletions(-) delete mode 100644 biogeochem/EDPhenologyType.F90 create mode 100644 main/FatesGlobals.F90 create mode 100644 main/FatesInterfaceMod.F90 diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 133639fc..44cb1b99 100755 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1,4 +1,3 @@ - module EDCanopyStructureMod ! ============================================================================ @@ -7,18 +6,22 @@ module EDCanopyStructureMod ! ============================================================================ 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 + use EDtypesMod , only : cp_nclmax + use EDtypesMod , only : numpft_ed + use shr_log_mod , only : errMsg => shr_log_errMsg + use abortutils , only : endrun implicit none private public :: canopy_structure public :: canopy_spread + public :: calc_areaindex ! 10/30/09: Created by Rosie Fisher ! ============================================================================ @@ -65,10 +68,10 @@ subroutine canopy_structure( currentSite ) ! 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 + use EDtypesMod , only : ncwd, min_patch_area, cp_nlevcan ! ! !ARGUMENTS type(ed_site_type) , intent(inout), target :: currentSite @@ -82,10 +85,10 @@ subroutine canopy_structure( currentSite ) 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) :: arealayer(cp_nlevcan) ! Amount of plant area currently in each canopy layer + real(r8) :: sumdiff(cp_nlevcan) ! 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) :: sum_weights(cp_nlevcan) real(r8) :: new_total_area_check real(r8) :: missing_area, promarea,cc_gain,sumgain integer :: promswitch,lower_cohort_switch @@ -100,12 +103,15 @@ subroutine canopy_structure( currentSite ) new_total_area_check = 0._r8 do while (associated(currentPatch)) ! Patch loop + + if (currentPatch%area .gt. min_patch_area) then ! avoid numerical weirdness that shouldn't be happening anyway + 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 @@ -124,7 +130,7 @@ subroutine canopy_structure( currentSite ) z = z + 1 endif - currentPatch%NCL_p = min(nclmax,z) ! Set current canopy layer occupancy indicator. + currentPatch%NCL_p = min(cp_nclmax,z) ! Set current canopy layer occupancy indicator. do i = 1,z ! Loop around the currently occupied canopy layers. @@ -185,7 +191,7 @@ subroutine canopy_structure( currentSite ) 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 + if(i+1 > cp_nclmax)then !put the litter from the terminated cohorts into the fragmenting pools ! write(iulog,*) '3rd canopy layer' do c=1,ncwd @@ -230,8 +236,8 @@ subroutine canopy_structure( currentSite ) 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 + !kill the ones which go into canopy layers that are not allowed... (default cp_nclmax=2) + if(i+1 > cp_nclmax)then !put the litter from the terminated cohorts into the fragmenting pools do c=1,ncwd @@ -303,7 +309,7 @@ subroutine canopy_structure( currentSite ) excess_area = arealayer(j)-currentPatch%area endif enddo - currentPatch%ncl_p = min(z,nclmax) + currentPatch%ncl_p = min(z,cp_nclmax) enddo !is there still excess area in any layer? @@ -505,7 +511,7 @@ subroutine canopy_structure( currentSite ) endif endif enddo - currentPatch%ncl_p = min(z,nclmax) + currentPatch%ncl_p = min(z,cp_nclmax) if(promswitch == 1)then ! write(iulog,*) 'missingarea loop',arealayer(1:3),currentPatch%patchno,missing_area,z endif @@ -556,6 +562,11 @@ subroutine canopy_structure( currentSite ) ! write(iulog,*) 'end patch loop',currentSite%clmgcell endif + else !terminate logic to only do if patch_area_sufficiently large + write(iulog,*) 'canopy_structure: patch area too small.', currentPatch%area + end if + + currentPatch => currentPatch%younger enddo !patch @@ -572,7 +583,7 @@ subroutine canopy_spread( currentSite ) ! Calculates the spatial spread of tree canopies based on canopy closure. ! ! !USES: - use clm_varpar , only : nlevcan_ed + use EDTypesMod , only : cp_nlevcan use EDParamsMod , only : ED_val_maxspread, ED_val_minspread ! ! !ARGUMENTS @@ -581,7 +592,7 @@ subroutine canopy_spread( 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) :: arealayer(cp_nlevcan) ! Amount of canopy in each layer. real(r8) :: inc ! Arbitrary daily incremental change in canopy area integer :: z !---------------------------------------------------------------------- @@ -604,7 +615,7 @@ subroutine canopy_spread( currentSite ) enddo !If the canopy area is approaching closure, squash the tree canopies and make them taller and thinner - do z = 1,nclmax + do z = 1,cp_nclmax if(arealayer(z)/currentPatch%area > 0.9_r8)then currentPatch%spread(z) = currentPatch%spread(z) - inc @@ -628,4 +639,69 @@ subroutine canopy_spread( currentSite ) end subroutine canopy_spread + ! ===================================================================================== + + function calc_areaindex(cpatch,ai_type) result(ai) + + ! ---------------------------------------------------------------------------------- + ! This subroutine calculates the exposed leaf area index of a patch + ! this is the square meters of leaf per square meter of ground area + ! It does so by integrating over the depth and functional type profile of leaf area + ! which are per area of crown. This value has to be scaled by crown area to convert + ! to ground area. + ! ---------------------------------------------------------------------------------- + + ! Arguments + type(ed_patch_type),intent(in), target :: cpatch + character(len=*),intent(in) :: ai_type + + integer :: cl,ft + real(r8) :: ai + ! TODO: THIS MIN LAI IS AN ARTIFACT FROM TESTING LONG-AGO AND SHOULD BE REMOVED + ! THIS HAS BEEN KEPT THUS FAR TO MAINTAIN B4B IN TESTING OTHER COMMITS + real(r8),parameter :: ai_min = 0.1_r8 + real(r8),pointer :: ai_profile + + ai = 0._r8 + if (trim(ai_type) == 'elai') then + do cl = 1,cpatch%NCL_p + do ft = 1,numpft_ed + ai = ai + sum(cpatch%canopy_area_profile(cl,ft,1:cpatch%nrad(cl,ft)) * & + cpatch%elai_profile(cl,ft,1:cpatch%nrad(cl,ft))) + enddo + enddo + elseif (trim(ai_type) == 'tlai') then + do cl = 1,cpatch%NCL_p + do ft = 1,numpft_ed + ai = ai + sum(cpatch%canopy_area_profile(cl,ft,1:cpatch%nrad(cl,ft)) * & + cpatch%tlai_profile(cl,ft,1:cpatch%nrad(cl,ft))) + enddo + enddo + elseif (trim(ai_type) == 'esai') then + do cl = 1,cpatch%NCL_p + do ft = 1,numpft_ed + ai = ai + sum(cpatch%canopy_area_profile(cl,ft,1:cpatch%nrad(cl,ft)) * & + cpatch%esai_profile(cl,ft,1:cpatch%nrad(cl,ft))) + enddo + enddo + elseif (trim(ai_type) == 'tsai') then + do cl = 1,cpatch%NCL_p + do ft = 1,numpft_ed + ai = ai + sum(cpatch%canopy_area_profile(cl,ft,1:cpatch%nrad(cl,ft)) * & + cpatch%tsai_profile(cl,ft,1:cpatch%nrad(cl,ft))) + enddo + enddo + else + write(iulog,*) 'Unsupported area index sent to calc_areaindex' + call endrun(msg=errMsg(__FILE__, __LINE__)) + end if + + ai = max(ai_min,ai) + + return + + end function calc_areaindex + + + end module EDCanopyStructureMod diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 7fe96b45..fca32709 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -10,8 +10,10 @@ module EDCohortDynamicsMod 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 : fusetol, cp_nclmax use EDtypesMod , only : ncwd, numcohortsperpatch, udata + use EDtypesMod , only : sclass_ed,nlevsclass_ed,AREA + use EDtypesMod , only : min_npm2, min_nppatch, min_n_safemath ! implicit none private @@ -25,9 +27,11 @@ module EDCohortDynamicsMod public :: sort_cohorts public :: copy_cohort public :: count_cohorts - public :: countCohorts +! public :: countCohorts public :: allocate_live_biomass + logical, parameter :: DEBUG = .false. ! local debug flag + ! 10/30/09: Created by Rosie Fisher !-------------------------------------------------------------------------------------! @@ -62,10 +66,10 @@ subroutine create_cohort(patchptr, pft, nn, hite, dbh, & 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. - + 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. @@ -88,20 +92,25 @@ subroutine create_cohort(patchptr, pft, nn, hite, dbh, & new_cohort%balive = balive new_cohort%bstore = bstore + if ( DEBUG ) write(iulog,*) 'EDCohortDyn I ',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 + 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 + + 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 + + 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) + call allocate_live_biomass(new_cohort,0) ! Assign canopy extent and depth new_cohort%c_area = c_area(new_cohort) @@ -127,6 +136,13 @@ subroutine create_cohort(patchptr, pft, nn, hite, dbh, & patchptr%shortest => new_cohort endif + ! Recuits do not have mortality rates, nor have they moved any + ! carbon when they are created. They will bias our statistics + ! until they have experienced a full day. We need a newly recruited flag. + ! This flag will be set to false after it has experienced + ! growth, disturbance and mortality. + new_cohort%isnew = .true. + call insert_cohort(new_cohort, patchptr%tallest, patchptr%shortest, tnull, snull, & storebigcohort, storesmallcohort) @@ -136,7 +152,7 @@ subroutine create_cohort(patchptr, pft, nn, hite, dbh, & end subroutine create_cohort !-------------------------------------------------------------------------------------! - subroutine allocate_live_biomass(cc_p) + subroutine allocate_live_biomass(cc_p,mode) ! ! !DESCRIPTION: ! Divide alive biomass between leaf, root and sapwood parts. @@ -146,6 +162,7 @@ subroutine allocate_live_biomass(cc_p) ! ! !ARGUMENTS type (ed_cohort_type), intent(inout), target :: cc_p ! current cohort pointer + integer , intent(in) :: mode ! ! !LOCAL VARIABLES: type (ed_cohort_type), pointer :: currentCohort @@ -163,8 +180,7 @@ subroutine allocate_live_biomass(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 + !currentcohort%bl = currentcohort%balive*leaf_frac !for deciduous trees, there are no leaves if (pftcon%evergreen(ft) == 1) then @@ -172,11 +188,11 @@ subroutine allocate_live_biomass(cc_p) currentcohort%status_coh = 2 endif - !diagnore the root and stem biomass from the functional balance hypothesis. This is used when the leaves are + ! iagnore 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 + !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 @@ -186,13 +202,47 @@ subroutine allocate_live_biomass(cc_p) leaves_off_switch = 1 !cold decid endif - if (leaves_off_switch==1) then + ! Use different proportions if the leaves are on vs off + if(leaves_off_switch==0)then + + ! Tracking npp/gpp diagnostics only occur after growth derivatives is called + if(mode==1)then + ! it will not be able to put out as many leaves as it had previous timestep + currentcohort%npp_leaf = currentcohort%npp_leaf + & + max(0.0_r8,currentcohort%balive*leaf_frac - currentcohort%bl)/udata%deltat + end if + + currentcohort%bl = currentcohort%balive*leaf_frac + + !diagnose the root and stem biomass from the functional balance hypothesis. This is used when the leaves are + !fully on. + if(mode==1)then + + currentcohort%npp_froot = currentcohort%npp_froot + & + max(0._r8,pftcon%froot_leaf(ft)*(currentcohort%balive+currentcohort%laimemory)*leaf_frac - currentcohort%br) / & + udata%deltat + + currentcohort%npp_bsw = max(0._r8,EDecophyscon%sapwood_ratio(ft) * currentcohort%hite *(currentcohort%balive + & + currentcohort%laimemory)*leaf_frac - currentcohort%bsw)/udata%deltat + + currentcohort%npp_bdead = currentCohort%dbdeaddt + + end if + + 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 + + + else ! Leaves are on (leaves_off_switch==1) !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 @@ -202,15 +252,31 @@ subroutine allocate_live_biomass(cc_p) ratio_balive = currentcohort%balive / ideal_balive currentcohort%br = currentcohort%br * ratio_balive - currentcohort%bsw = currentcohort%bsw * ratio_balive - endif + currentcohort%bsw = currentcohort%bsw * ratio_balive + + ! Diagnostics + if(mode==1)then + + currentcohort%npp_froot = currentcohort%npp_froot + & + max(0.0_r8,pftcon%froot_leaf(ft)*(ideal_balive + & + currentcohort%laimemory)*leaf_frac*ratio_balive-currentcohort%br)/udata%deltat + + currentcohort%npp_bsw = max(0.0_r8,EDecophyscon%sapwood_ratio(ft) * currentcohort%hite *(ideal_balive + & + currentcohort%laimemory)*leaf_frac*ratio_balive - currentcohort%bsw)/udata%deltat + currentcohort%npp_bdead = currentCohort%dbdeaddt + + end if + + 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,*) 'issue with carbon allocation in create_cohort,allocate_live_biomass',& + 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 + write(iulog,*) 'pft',ft,pftcon%evergreen(ft),pftcon%season_decid(ft),leaves_off_switch endif currentCohort%b = currentCohort%bdead + currentCohort%balive @@ -275,17 +341,25 @@ subroutine nan_cohort(cc_p) ! CARBON FLUXES currentCohort%gpp = nan ! GPP: kgC/indiv/year - currentCohort%gpp_clm = nan ! GPP: kgC/indiv/timestep + currentCohort%gpp_tstep = 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_tstep = 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_tstep = nan ! RESP: kgC/indiv/timestep currentCohort%resp_acc = nan ! RESP: kGC/cohort/day + currentCohort%npp_leaf = nan + currentCohort%npp_froot = nan + currentCohort%npp_bsw = nan + currentCohort%npp_bdead = nan + currentCohort%npp_bseed = nan + currentCohort%npp_store = nan + + !RESPIRATION currentCohort%rd = nan currentCohort%resp_m = nan ! Maintenance respiration. kGC/cohort/year @@ -359,9 +433,9 @@ subroutine zero_cohort(cc_p) 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%npp_tstep = 0._r8 + currentcohort%gpp_tstep = 0._r8 + currentcohort%resp_tstep = 0._r8 currentcohort%resp = 0._r8 currentcohort%carbon_balance = 0._r8 currentcohort%leaf_litter = 0._r8 @@ -379,6 +453,13 @@ subroutine zero_cohort(cc_p) currentcohort%gscan = 0._r8 currentcohort%treesai = 0._r8 + ! currentCohort%npp_leaf = 0._r8 + ! currentCohort%npp_froot = 0._r8 + ! currentCohort%npp_bsw = 0._r8 + ! currentCohort%npp_bdead = 0._r8 + ! currentCohort%npp_bseed = 0._r8 + ! currentCohort%npp_store = 0._r8 + end subroutine zero_cohort !-------------------------------------------------------------------------------------! @@ -409,34 +490,57 @@ subroutine terminate_cohorts( patchptr ) 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 + ! Check if number density is so low is breaks math + if (currentcohort%n < min_n_safemath) then + terminate = 1 + if ( DEBUG ) then + write(iulog,*) 'terminating cohorts 0',currentCohort%n/currentPatch%area,currentCohort%dbh + endif endif - ! In the third canopy layer - if (currentCohort%canopy_layer > NCLMAX) then - terminate = 1 - ! write(iulog,*) 'terminating cohorts 2', currentCohort%canopy_layer + ! The rest of these are only allowed if we are not dealing with a recruit + if (.not.currentCohort%isnew) then + + ! Not enough n or dbh + if (currentCohort%n/currentPatch%area <= min_npm2 .or. & ! + currentCohort%n <= min_nppatch .or. & + (currentCohort%dbh < 0.00001_r8.and.currentCohort%bstore < 0._r8) ) then + terminate = 1 + + if ( DEBUG ) then + write(iulog,*) 'terminating cohorts 1',currentCohort%n/currentPatch%area,currentCohort%dbh + endif + endif + + ! In the third canopy layer + if (currentCohort%canopy_layer > cp_nclmax ) then + terminate = 1 + if ( DEBUG ) then + write(iulog,*) 'terminating cohorts 2', currentCohort%canopy_layer + endif + endif + + ! live biomass pools are terminally depleted + if (currentCohort%balive < 1e-10_r8 .or. currentCohort%bstore < 1e-10_r8) then + terminate = 1 + if ( DEBUG ) then + write(iulog,*) 'terminating cohorts 3', currentCohort%balive,currentCohort%bstore + endif + endif + + ! Total cohort biomass is negative + if (currentCohort%balive+currentCohort%bdead+currentCohort%bstore < 0._r8) then + terminate = 1 + if ( DEBUG ) then + write(iulog,*) 'terminating cohorts 4', currentCohort%balive, & + currentCohort%bstore, currentCohort%bdead, & + currentCohort%balive+currentCohort%bdead+& + currentCohort%bstore, currentCohort%n + endif + + endif 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 @@ -481,7 +585,7 @@ subroutine fuse_cohorts(patchptr) ! Join similar cohorts to reduce total number ! ! !USES: - use clm_varpar , only : nlevcan_ed + use EDTypesMod , only : cp_nlevcan ! ! !ARGUMENTS type (ed_patch_type), intent(inout), target :: patchptr @@ -510,7 +614,8 @@ subroutine fuse_cohorts(patchptr) iterate = 1 fusion_took_place = 0 currentPatch => patchptr - maxcohorts = currentPatch%NCL_p * numCohortsPerPatch + maxcohorts = numCohortsPerPatch + !---------------------------------------------------------------------! ! Keep doing this until nocohorts <= maxcohorts ! !---------------------------------------------------------------------! @@ -519,8 +624,13 @@ subroutine fuse_cohorts(patchptr) currentCohort => currentPatch%tallest - !CHANGED FROM C VERSION loop from tallest to smallest, fusing if they are similar - do while (currentCohort%indexnumber /= currentPatch%shortest%indexnumber) + ! The following logic continues the loop while the current cohort is not the shortest cohort + ! if they point to the same target (ie equivalence), then the loop ends. + ! This loop is different than the simple "continue while associated" loop in that + ! it omits the last cohort (because it has already been compared by that point) + + do while ( .not.associated(currentCohort,currentPatch%shortest) ) + nextc => currentPatch%tallest do while (associated(nextc)) @@ -531,18 +641,36 @@ subroutine fuse_cohorts(patchptr) if (diff < dynamic_fusion_tolerance) then - if (currentCohort%indexnumber /= nextc%indexnumber) then + ! Don't fuse a cohort with itself! + if (.not.associated(currentCohort,nextc) ) then if (currentCohort%pft == nextc%pft) then ! check cohorts in same c. layer. before fusing + if (currentCohort%canopy_layer == nextc%canopy_layer) then + + ! Note: because newly recruited cohorts that have not experienced + ! a day yet will have un-known flux quantities or change rates + ! we don't want them fusing with non-new cohorts. We allow them + ! to fuse with other new cohorts to keep the total number of cohorts + ! down. + + if( .not.(currentCohort%isnew) .and. .not.(nextc%isnew) ) then + + newn = currentCohort%n + nextc%n 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 + + if ( DEBUG ) write(iulog,*) 'EDcohortDyn I ',currentCohort%bstore + currentCohort%bstore = (currentCohort%n*currentCohort%bstore + nextc%n*nextc%bstore)/newn + + if ( DEBUG ) write(iulog,*) 'EDcohortDyn II ',currentCohort%bstore + 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 @@ -551,27 +679,58 @@ subroutine fuse_cohorts(patchptr) 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 + + if ( DEBUG ) write(iulog,*) 'EDcohortDyn 569 ',currentCohort%br + if ( DEBUG ) write(iulog,*) 'EDcohortDyn 570 ',currentCohort%n + if ( DEBUG ) write(iulog,*) 'EDcohortDyn 571 ',nextc%br + if ( DEBUG ) write(iulog,*) 'EDcohortDyn 572 ',nextc%n + 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 + + if ( DEBUG ) write(iulog,*) 'EDcohortDyn III ',currentCohort%npp_acc + if ( DEBUG ) write(iulog,*) 'EDcohortDyn IV ',currentCohort%resp_acc + 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 + + if ( DEBUG ) write(iulog,*) 'EDcohortDyn V ',currentCohort%npp_acc + if ( DEBUG ) write(iulog,*) 'EDcohortDyn VI ',currentCohort%resp_acc + 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%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 + ! mortality diagnostics + currentCohort%cmort = (currentCohort%n*currentCohort%cmort + nextc%n*nextc%cmort)/newn + currentCohort%hmort = (currentCohort%n*currentCohort%hmort + nextc%n*nextc%hmort)/newn + currentCohort%bmort = (currentCohort%n*currentCohort%bmort + nextc%n*nextc%bmort)/newn + currentCohort%imort = (currentCohort%n*currentCohort%imort + nextc%n*nextc%imort)/newn + currentCohort%fmort = (currentCohort%n*currentCohort%fmort + nextc%n*nextc%fmort)/newn + + ! npp diagnostics + currentCohort%npp_leaf = (currentCohort%n*currentCohort%npp_leaf + nextc%n*nextc%npp_leaf)/newn + currentCohort%npp_froot = (currentCohort%n*currentCohort%npp_froot + nextc%n*nextc%npp_froot)/newn + currentCohort%npp_bsw = (currentCohort%n*currentCohort%npp_bsw + nextc%n*nextc%npp_bsw)/newn + currentCohort%npp_bdead = (currentCohort%n*currentCohort%npp_bdead + nextc%n*nextc%npp_bdead)/newn + currentCohort%npp_bseed = (currentCohort%n*currentCohort%npp_bseed + nextc%n*nextc%npp_bseed)/newn + currentCohort%npp_store = (currentCohort%n*currentCohort%npp_store + nextc%n*nextc%npp_store)/newn + + do i=1, cp_nlevcan 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 @@ -579,7 +738,7 @@ subroutine fuse_cohorts(patchptr) nextc%n*nextc%year_net_uptake(i))/newn endif enddo - + currentCohort%n = newn !remove fused cohort from the list nextc%taller%shorter => nextnextc @@ -588,9 +747,13 @@ subroutine fuse_cohorts(patchptr) else nextnextc%taller => nextc%taller endif + if (associated(nextc)) then deallocate(nextc) endif + + endif ! Not a recruit + endif !canopy layer endif !pft endif !index no. @@ -601,6 +764,7 @@ subroutine fuse_cohorts(patchptr) else nextc => nextnextc !if we have removed next endif + enddo !end checking nextc cohort loop if (associated (currentCohort%shorter)) then @@ -620,11 +784,13 @@ subroutine fuse_cohorts(patchptr) 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 ! !---------------------------------------------------------------------! + dynamic_fusion_tolerance = dynamic_fusion_tolerance * 1.1_r8 + + write(iulog,*) 'maxcohorts exceeded',dynamic_fusion_tolerance + else iterate = 0 endif @@ -822,8 +988,8 @@ subroutine copy_cohort( currentCohort,copyc ) n => copyc udata%cohort_number = udata%cohort_number + 1 - n%indexnumber = udata%cohort_number - + n%indexnumber = udata%cohort_number + ! VEGETATION STRUCTURE n%pft = o%pft n%n = o%n @@ -852,16 +1018,27 @@ subroutine copy_cohort( currentCohort,copyc ) ! CARBON FLUXES n%gpp = o%gpp n%gpp_acc = o%gpp_acc - n%gpp_clm = o%gpp_clm + n%gpp_tstep = o%gpp_tstep n%npp = o%npp - n%npp_clm = o%npp_clm + n%npp_tstep = o%npp_tstep + + if ( DEBUG ) write(iulog,*) 'EDcohortDyn Ia ',o%npp_acc + if ( DEBUG ) write(iulog,*) 'EDcohortDyn Ib ',o%resp_acc + n%npp_acc = o%npp_acc - n%resp_clm = o%resp_clm + n%resp_tstep = o%resp_tstep 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 + n%npp_leaf = o%npp_leaf + n%npp_froot = o%npp_froot + n%npp_bsw = o%npp_bsw + n%npp_bdead = o%npp_bdead + n%npp_bseed = o%npp_bseed + n%npp_store = o%npp_store + !RESPIRATION n%rd = o%rd n%resp_m = o%resp_m @@ -888,6 +1065,16 @@ subroutine copy_cohort( currentCohort,copyc ) n%c_area = o%c_area n%woody_turnover = o%woody_turnover + ! Mortality diagnostics + n%cmort = o%cmort + n%bmort = o%bmort + n%imort = o%imort + n%fmort = o%fmort + n%hmort = o%hmort + + ! Flags + n%isnew = o%isnew + ! VARIABLES NEEDED FOR INTEGRATION n%dndt = o%dndt n%dhdt = o%dhdt @@ -895,6 +1082,9 @@ subroutine copy_cohort( currentCohort,copyc ) n%dbalivedt = o%dbalivedt n%dbdeaddt = o%dbdeaddt n%dbstoredt = o%dbstoredt + + if ( DEBUG ) write(iulog,*) 'EDCohortDyn dpstoredt ',o%dbstoredt + n%storage_flux = o%storage_flux ! FIRE @@ -948,46 +1138,46 @@ function count_cohorts( currentPatch ) result ( backcount ) end function count_cohorts !-------------------------------------------------------------------------------------! - function countCohorts( bounds, ed_allsites_inst ) result ( totNumCohorts ) +! 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 +! use decompMod, only : bounds_type ! ! !ARGUMENTS - type(bounds_type) , intent(in) :: bounds - type(ed_site_type) , intent(inout), target :: ed_allsites_inst( bounds%begg: ) +! 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 +! type (ed_patch_type) , pointer :: currentPatch +! type (ed_cohort_type) , pointer :: currentCohort +! integer :: g, totNumCohorts +! logical :: error !---------------------------------------------------------------------- - totNumCohorts = 0 +! totNumCohorts = 0 - do g = bounds%begg,bounds%endg +! do g = bounds%begg,bounds%endg - if (ed_allsites_inst(g)%istheresoil) then +! if (ed_allsites_inst(g)%istheresoil) then - currentPatch => ed_allsites_inst(g)%oldest_patch - do while(associated(currentPatch)) +! 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 +! 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 if +! end do - end function countCohorts +! end function countCohorts end module EDCohortDynamicsMod diff --git a/biogeochem/EDGrowthFunctionsMod.F90 b/biogeochem/EDGrowthFunctionsMod.F90 index a497df20..a400f46a 100755 --- a/biogeochem/EDGrowthFunctionsMod.F90 +++ b/biogeochem/EDGrowthFunctionsMod.F90 @@ -10,7 +10,7 @@ module EDGrowthFunctionsMod use clm_varctl , only : iulog use pftconMod , only : pftcon use EDEcophysContype , only : EDecophyscon - use EDTypesMod , only : ed_cohort_type, nlevcan_ed, dinc_ed + use EDTypesMod , only : ed_cohort_type, cp_nlevcan, dinc_ed implicit none private @@ -103,6 +103,7 @@ real(r8) function Bleaf( cohort_in ) ! ============================================================================ type(ed_cohort_type), intent(in) :: cohort_in + real(r8) :: slascaler ! changes the target biomass according to the SLA 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 @@ -111,12 +112,17 @@ real(r8) function Bleaf( cohort_in ) 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 - + bleaf = 0.0419_r8 * (EDecophyscon%max_dbh(cohort_in%pft)**1.56) * EDecophyscon%wood_density(cohort_in%pft)**0.55_r8 + endif + slascaler = 0.03_r8/pftcon%slatop(cohort_in%pft) + bleaf = bleaf * slascaler + + !write(iulog,*) 'bleaf',bleaf, slascaler,cohort_in%pft + !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 + + bleaf = bleaf * cohort_in%canopy_trim return end function Bleaf @@ -140,7 +146,7 @@ real(r8) function tree_lai( cohort_in ) 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 + 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 @@ -153,10 +159,10 @@ real(r8) function tree_lai( cohort_in ) 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 + ! at the moments cp_nlevcan 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 + if(cohort_in%treelai > cp_nlevcan*dinc_ed)then + write(iulog,*) 'too much lai' , cohort_in%treelai , cohort_in%pft , cp_nlevcan * dinc_ed endif return @@ -190,10 +196,10 @@ real(r8) function tree_sai( cohort_in ) 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 + ! at the moments cp_nlevcan 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 + if(cohort_in%treesai > cp_nlevcan*dinc_ed)then + write(iulog,*) 'too much sai' , cohort_in%treesai , cohort_in%pft , cp_nlevcan * dinc_ed endif return @@ -316,7 +322,11 @@ real(r8) function dDbhdBl( cohort_in ) 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 + if( cohort_in%dbh 0._r8 ) then - if(Bleaf(cohort_in) > 0._r8.and.cohort_in%bstore <= Bleaf(cohort_in))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)) + cmort = max(0.0_r8,ED_val_stress_mort*(1.0_r8 - frac)) + else + cmort = 0.0_r8 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 + !mortality_rates = bmort + hmort + cmort - end function mortality_rates + end subroutine mortality_rates ! ============================================================================ diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 826e7a60..c011b7d4 100755 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -5,11 +5,13 @@ module EDPatchDynamicsMod ! ============================================================================ use shr_kind_mod , only : r8 => shr_kind_r8; + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) 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 : ncwd, n_dbh_bins, ntol, numpft_ed, area, dbhmax, numPatchesPerCol use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type, udata + use EDTypesMod , only : min_patch_area, cp_numlevgrnd, cp_numSWb ! implicit none private @@ -26,6 +28,7 @@ module EDPatchDynamicsMod private:: fuse_2_patches + ! 10/30/09: Created by Rosie Fisher ! ============================================================================ @@ -50,6 +53,9 @@ subroutine disturbance_rates( site_in) ! !LOCAL VARIABLES: type (ed_patch_type) , pointer :: currentPatch type (ed_cohort_type), pointer :: currentCohort + real(r8) :: cmort + real(r8) :: bmort + real(r8) :: hmort !--------------------------------------------------------------------- !MORTALITY @@ -65,9 +71,17 @@ subroutine disturbance_rates( site_in) ! Mortality for trees in the understorey. currentCohort%patchptr => currentPatch - currentCohort%dmort = mortality_rates(currentCohort) + call mortality_rates(currentCohort,cmort,hmort,bmort) + currentCohort%dmort = cmort+hmort+bmort currentCohort%c_area = c_area(currentCohort) + ! Initialize diagnostic mortality rates + currentCohort%cmort = cmort + currentCohort%bmort = bmort + currentCohort%hmort = hmort + currentCohort%imort = 0.0_r8 ! Impact mortality is always zero except in new patches + currentCohort%fmort = 0.0_r8 ! Fire mortality is initialized as zero, but may be changed + if(currentCohort%canopy_layer == 1)then currentPatch%disturbance_rates(1) = currentPatch%disturbance_rates(1) + & @@ -91,6 +105,27 @@ subroutine disturbance_rates( site_in) !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) + + ! RGK 02-18-2014 + ! Since treefall mortality is not actually being applied + ! Go through and zero the diagnostic rates + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + if(currentCohort%canopy_layer == 1)then + currentCohort%cmort=0.0_r8 + currentCohort%hmort=0.0_r8 + currentCohort%bmort=0.0_r8 + end if + + ! This may be counter-intuitive, but the diagnostic fire-mortality rate + ! will stay zero in the patch that undergoes fire, this is because + ! the actual cohorts who experience the fire are only those in the + ! newly created patch so currentCohort%fmort = 0.0_r8 + ! Don't worry, the cohorts in the newly created patch will reflect burn + + currentCohort => currentCohort%taller + enddo !currentCohort + else currentPatch%disturbance_rate = currentPatch%disturbance_rates(1) ! DISTURBANCE IS MORTALITY endif @@ -133,7 +168,7 @@ subroutine spawn_patches( currentSite ) ! 10) Area checked, and patchno recalculated. ! ! !USES: - use clm_varpar , only : nclmax + use EDTypesMod , only : cp_nclmax use EDParamsMod , only : ED_val_maxspread, ED_val_understorey_death use EDCohortDynamicsMod , only : zero_cohort, copy_cohort, terminate_cohorts ! @@ -157,7 +192,7 @@ subroutine spawn_patches( currentSite ) 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 + real(r8) :: spread_local(cp_nclmax) ! initial value of canopy spread parameter.no units !--------------------------------------------------------------------- storesmallcohort => null() ! storage of the smallest cohort for insertion routine @@ -165,8 +200,11 @@ subroutine spawn_patches( currentSite ) ! calculate area of disturbed land, in this timestep, by summing contributions from each existing patch. currentPatch => currentSite%youngest_patch + + ! zero site-level fire fluxes currentSite%cwd_ag_burned = 0.0_r8 currentSite%leaf_litter_burned = 0.0_r8 + currentSite%total_burn_flux_to_atm = 0.0_r8 site_areadis = 0.0_r8 do while(associated(currentPatch)) @@ -182,13 +220,16 @@ subroutine spawn_patches( currentSite ) 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 + spread_local(1:cp_nclmax) = ED_val_maxspread age = 0.0_r8 seed_bank_local = 0.0_r8 allocate(new_patch) - call zero_patch(new_patch) +! This is called inside "create_patch" +! create_patch must first allocate some vector spaces before +! zero'ing can occur (RGK) +! 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, & @@ -202,7 +243,7 @@ subroutine spawn_patches( currentSite ) 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) + call average_patch_properties(currentPatch, new_patch, patch_site_areadis) ! MAY BE REDUNDANT CALL if (currentSite%disturbance_mortality > currentSite%disturbance_fire) then !mortality is dominant disturbance call mortality_litter_fluxes(currentPatch, new_patch, patch_site_areadis) else @@ -226,35 +267,83 @@ subroutine spawn_patches( currentSite ) !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 + if(currentCohort%canopy_layer == 1)then + ! In the donor patch we are left with fewer trees because the area has decreased + ! the plant density for large trees does not actually decrease in the donor patch + ! because this is the part of the original patch where no trees have actually fallen + ! The diagnostic cmort,bmort and hmort rates have already been saved + 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 + + nc%n = 0.0_r8 ! kill all of the trees who caused the disturbance. + nc%cmort = nan ! The mortality diagnostics are set to nan because the cohort should dissappear + nc%hmort = nan + nc%bmort = nan + nc%fmort = nan + nc%imort = nan + else + ! small trees if(pftcon%woody(currentCohort%pft) == 1)then + ! Number of trees in the understory of new patch, before we impose impact mortality and survivorship + nc%n = currentCohort%n * patch_site_areadis/currentPatch%area + ! 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 + + ! since the donor patch split and sent a fraction of its members + ! to the new patch and a fraction to be preserved in itself, + ! when reporting diagnostic rates, we must carry over the mortality rates from + ! the donor that were applied before the patch split. Remember this is only + ! for diagnostics. But think of it this way, the rates are weighted by + ! number density in EDCLMLink, and the number density of this new patch is donated + ! so with the number density must come the effective mortality rates. + + nc%fmort = 0.0_r8 ! Should had also been zero in the donor + nc%imort = ED_val_understorey_death/udata%deltat ! This was zero in the donor + nc%cmort = currentCohort%cmort + nc%hmort = currentCohort%hmort + nc%bmort = currentCohort%bmort + ! 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. + ! The existing (donor) patch should not have any impact mortality, it should + ! only lose cohorts due to the decrease in area. This is not mortality. + ! Besides, the current and newly created patch sum to unity + currentCohort%n = currentCohort%n * (1._r8 - patch_site_areadis/currentPatch%area) else + ! grass is not killed by mortality disturbance events. Just move it into the new patch area. + ! Just split the grass into the existing and new patch structures + nc%n = currentCohort%n * patch_site_areadis/currentPatch%area - ! 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. + ! Those remaining in the existing currentCohort%n = currentCohort%n * (1._r8 - patch_site_areadis/currentPatch%area) + nc%fmort = nan ! These should not make it to the diagnostics + nc%imort = nan ! If they do.. they should invalidate it + nc%cmort = nan ! + nc%hmort = nan ! + nc%bmort = nan ! + 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 + ! Number of members in the new patch, before we impose fire survivorship + nc%n = currentCohort%n * patch_site_areadis/currentPatch%area + + ! loss of individuals from source patch due to area shrinking currentCohort%n = currentCohort%n * (1._r8 - patch_site_areadis/currentPatch%area) + ! loss of individual from fire in new patch. + nc%n = nc%n * (1.0_r8 - currentCohort%fire_mort) + + nc%fmort = currentCohort%fire_mort/udata%deltat + nc%imort = 0.0_r8 + nc%cmort = currentCohort%cmort + nc%hmort = currentCohort%hmort + nc%bmort = currentCohort%bmort + endif if (nc%n > 0.0_r8) then @@ -465,12 +554,14 @@ subroutine fire_litter_fluxes(cp_target, new_patch_target, patch_site_areadis) 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 + currentSite%total_burn_flux_to_atm = currentSite%total_burn_flux_to_atm + burned_litter * new_patch%area !kG/site/day enddo do p = 1,numpft_ed 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 + currentSite%flux_out = currentSite%flux_out + burned_litter * new_patch%area !kG/site/day + currentSite%total_burn_flux_to_atm = currentSite%total_burn_flux_to_atm + burned_litter * new_patch%area !kG/site/day enddo !************************************/ @@ -532,6 +623,8 @@ subroutine fire_litter_fluxes(cp_target, new_patch_target, patch_site_areadis) 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 + currentSite%total_burn_flux_to_atm = currentSite%total_burn_flux_to_atm + dead_tree_density * & + AREA * SF_val_CWD_frac(c) * bstem * currentCohort%cfa enddo @@ -542,6 +635,8 @@ subroutine fire_litter_fluxes(cp_target, new_patch_target, patch_site_areadis) dead_tree_density * currentCohort%bl * currentCohort%cfa currentSite%flux_out = currentSite%flux_out + & dead_tree_density * AREA * currentCohort%bl * currentCohort%cfa + currentSite%total_burn_flux_to_atm = currentSite%total_burn_flux_to_atm + & + dead_tree_density * AREA * currentCohort%bl * currentCohort%cfa enddo @@ -572,6 +667,8 @@ subroutine fire_litter_fluxes(cp_target, new_patch_target, patch_site_areadis) !KgC/gridcell/day currentSite%flux_out = currentSite%flux_out + burned_leaves * currentCohort%n * & patch_site_areadis/currentPatch%area * AREA + currentSite%total_burn_flux_to_atm = currentSite%total_burn_flux_to_atm+ burned_leaves * currentCohort%n * & + patch_site_areadis/currentPatch%area * AREA endif currentCohort%cfa = 0.0_r8 @@ -702,7 +799,6 @@ subroutine create_patch(currentSite, new_patch, age, areap, spread_local,cwd_ag_ ! Set default values for creating a new patch ! ! !USES: - use clm_varpar , only : nlevgrnd ! ! !ARGUMENTS: type(ed_site_type) , intent(inout), target :: currentSite @@ -718,6 +814,17 @@ subroutine create_patch(currentSite, new_patch, age, areap, spread_local,cwd_ag_ ! ! !LOCAL VARIABLES: !--------------------------------------------------------------------- + + allocate(new_patch%tr_soil_dir(cp_numSWb)) + allocate(new_patch%tr_soil_dif(cp_numSWb)) + allocate(new_patch%tr_soil_dir_dif(cp_numSWb)) + allocate(new_patch%fab(cp_numSWb)) + allocate(new_patch%fabd(cp_numSWb)) + allocate(new_patch%fabi(cp_numSWb)) + allocate(new_patch%sabs_dir(cp_numSWb)) + allocate(new_patch%sabs_dif(cp_numSWb)) + allocate(new_patch%rootfr_ft(numpft_ed,cp_numlevgrnd)) + allocate(new_patch%rootr_ft(numpft_ed,cp_numlevgrnd)) call zero_patch(new_patch) !The nan value in here is not working?? @@ -743,6 +850,9 @@ subroutine create_patch(currentSite, new_patch, age, areap, spread_local,cwd_ag_ new_patch%cwd_ag_in(:) = 0._r8 new_patch%cwd_bg_in(:) = 0._r8 + new_patch%cwd_ag_out(:) = 0._r8 + new_patch%cwd_bg_out(:) = 0._r8 + new_patch%f_sun = 0._r8 new_patch%ed_laisun_z(:,:,:) = 0._r8 new_patch%ed_laisha_z(:,:,:) = 0._r8 @@ -761,8 +871,10 @@ subroutine create_patch(currentSite, new_patch, age, areap, spread_local,cwd_ag_ 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)) + new_patch%leaf_litter_in(:) = 0._r8 + new_patch%leaf_litter_out(:) = 0._r8 + + end subroutine create_patch @@ -802,7 +914,7 @@ subroutine zero_patch(cp_p) currentPatch%bare_frac_area = nan currentPatch%tlai_profile(:,:,:) = nan - currentPatch%elai_profile(:,:,:) = nan + currentPatch%elai_profile(:,:,:) = 0._r8 currentPatch%tsai_profile(:,:,:) = nan currentPatch%esai_profile(:,:,:) = nan currentPatch%canopy_area_profile(:,:,:) = nan @@ -816,13 +928,12 @@ subroutine zero_patch(cp_p) currentPatch%ed_laisha_z(:,:,:) = nan currentPatch%ed_parsun_z(:,:,:) = nan currentPatch%ed_parsha_z(:,:,:) = nan - currentPatch%psn_z(:,:,:) = nan + currentPatch%psn_z(:,:,:) = 0._r8 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 @@ -847,6 +958,9 @@ subroutine zero_patch(cp_p) currentPatch%root_litter(:) = 0.0_r8 currentPatch%leaf_litter(:) = 0.0_r8 + currentPatch%leaf_litter_in(:) = 0.0_r8 + currentPatch%leaf_litter_out(:) = 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) @@ -880,6 +994,7 @@ subroutine zero_patch(cp_p) 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 @@ -910,7 +1025,8 @@ subroutine fuse_patches( csite ) integer :: fuse_flag !do patches get fused (1) or not (0). !--------------------------------------------------------------------- - maxpatch = 4 + !maxpatch = 4 + maxpatch = numPatchesPerCol currentSite => csite @@ -1020,7 +1136,7 @@ subroutine fuse_patches( csite ) 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 ! !---------------------------------------------------------------------! @@ -1054,6 +1170,9 @@ subroutine fuse_2_patches(dp, rp) 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? + type(ed_patch_type), pointer :: youngerp ! pointer to the patch younger than donor + type(ed_patch_type), pointer :: olderp ! pointer to the patch older than donor + type(ed_site_type), pointer :: csite ! pointer to the donor patch's site !--------------------------------------------------------------------- !area weighted average of ages & litter & seed bank @@ -1096,7 +1215,11 @@ subroutine fuse_2_patches(dp, rp) 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%dleaf_litter_dt(:) = (dp%dleaf_litter_dt(:)*dp%area + rp%dleaf_litter_dt(:)*rp%area)/(dp%area+rp%area) + rp%leaf_litter_in(:) = (dp%leaf_litter_in(:)*dp%area + rp%leaf_litter_in(:)*rp%area)/(dp%area+rp%area) + rp%leaf_litter_out(:) = (dp%leaf_litter_out(:)*dp%area + rp%leaf_litter_out(:)*rp%area)/(dp%area+rp%area) + + rp%area = rp%area + dp%area !THIS MUST COME AT THE END! !insert donor cohorts into recipient patch @@ -1145,25 +1268,48 @@ subroutine fuse_2_patches(dp, rp) 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 + ! Define some aliases for the donor patches younger and older neighbors + ! which may or may not exist. After we set them, we will remove the donor + ! And then we will go about re-setting the map. + csite => dp%siteptr + if(associated(dp%older))then + olderp => dp%older + else + olderp => null() + end if + if(associated(dp%younger))then + youngerp => dp%younger + else + youngerp => null() + end if + ! We have no need for the dp pointer anymore, we have passed on it's legacy + call dealloc_patch(dp) deallocate(dp) + + if(associated(youngerp))then + ! Update the younger patch's new older patch (because it isn't dp anymore) + youngerp%older => olderp + else + ! There was no younger patch than dp, so the head of the young order needs + ! to be set, and it is set as the patch older than dp. That patch + ! already knows it's older patch (so no need to set or change it) + csite%youngest_patch => olderp + end if + + + if(associated(olderp))then + ! Update the older patch's new younger patch (becuase it isn't dp anymore) + olderp%younger => youngerp + else + ! There was no patch older than dp, so the head of the old patch order needs + ! to be set, and it is set as the patch younger than dp. That patch already + ! knows it's younger patch, no need to set + csite%oldest_patch => youngerp + end if + + end subroutine fuse_2_patches ! ============================================================================ @@ -1179,7 +1325,7 @@ subroutine terminate_patches(cs_pnt) ! ! !LOCAL VARIABLES: type(ed_site_type), pointer :: currentSite - type(ed_patch_type), pointer :: currentPatch + type(ed_patch_type), pointer :: currentPatch, tmpptr real(r8) areatot ! variable for checking whether the total patch area is wrong. !--------------------------------------------------------------------- @@ -1190,16 +1336,23 @@ subroutine terminate_patches(cs_pnt) !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 + if(currentPatch%area <= min_patch_area)then + if ( 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 + if(associated(currentPatch%older) )then + write(iulog,*) 'fusing to older patch because this 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) + write(iulog,*) 'after fusion to older patch',currentPatch%area,currentPatch%seed_bank(1) + else + write(iulog,*) 'fusing to younger patch because oldest one is too small',currentPatch%area, currentPatch%lai + tmpptr => currentPatch%younger + call fuse_2_patches(currentPatch, currentPatch%younger) + write(iulog,*) 'after fusion to younger patch' + currentPatch => tmpptr + endif + endif endif currentPatch => currentPatch%older @@ -1213,12 +1366,52 @@ subroutine terminate_patches(cs_pnt) 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 + write(iulog,*) 'ED: areatot too large. end terminate', areatot endif enddo end subroutine terminate_patches + ! ===================================================================================== + + subroutine dealloc_patch(cpatch) + + ! This Subroutine is intended to de-allocate the allocatable memory that is pointed + ! to via the patch structure. This subroutine DOES NOT deallocate the patch + ! structure itself. + + type(ed_patch_type), target :: cpatch + type(ed_cohort_type), pointer :: ccohort ! current + type(ed_cohort_type), pointer :: ncohort ! next + + ! First Deallocate the cohort space + ! ----------------------------------------------------------------------------------- + ccohort => cpatch%shortest + do while(associated(ccohort)) + + ncohort => ccohort%taller + deallocate(ccohort) + ccohort => ncohort + + end do + + ! Secondly, and lastly, deallocate the allocatable vector spaces in the patch + if(allocated(cpatch%tr_soil_dir))then + deallocate(cpatch%tr_soil_dir) + deallocate(cpatch%tr_soil_dif) + deallocate(cpatch%tr_soil_dir_dif) + deallocate(cpatch%fab) + deallocate(cpatch%fabd) + deallocate(cpatch%fabi) + deallocate(cpatch%sabs_dir) + deallocate(cpatch%sabs_dif) + deallocate(cpatch%rootfr_ft) + deallocate(cpatch%rootr_ft) + end if + + return + end subroutine dealloc_patch + ! ============================================================================ subroutine patch_pft_size_profile(cp_pnt) ! @@ -1287,7 +1480,7 @@ subroutine patch_pft_size_profile(cp_pnt) end subroutine patch_pft_size_profile ! ============================================================================ - function countPatches( bounds, ed_allsites_inst ) result ( totNumPatches ) + function countPatches( bounds, nsites, sites ) result ( totNumPatches ) ! ! !DESCRIPTION: ! Loop over all Patches to count how many there are @@ -1299,24 +1492,23 @@ function countPatches( bounds, ed_allsites_inst ) result ( totNumPatches ) ! ! !ARGUMENTS: type(bounds_type) , intent(in) :: bounds - type(ed_site_type) , intent(inout), target :: ed_allsites_inst( bounds%begg: ) + integer, intent(in) :: nsites + type(ed_site_type) , intent(inout), target :: sites(nsites) ! ! !LOCAL VARIABLES: type (ed_patch_type), pointer :: currentPatch - integer :: g ! gridcell integer :: totNumPatches ! total number of patches. + integer :: s !--------------------------------------------------------------------- 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 + do s = 1,nsites + currentPatch => sites(s)%oldest_patch + do while(associated(currentPatch)) + totNumPatches = totNumPatches + 1 + currentPatch => currentPatch%younger + enddo enddo end function countPatches diff --git a/biogeochem/EDPhenologyType.F90 b/biogeochem/EDPhenologyType.F90 deleted file mode 100644 index f948fc70..00000000 --- a/biogeochem/EDPhenologyType.F90 +++ /dev/null @@ -1,277 +0,0 @@ -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 index ab543045..4bdbef36 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -8,15 +8,16 @@ module EDPhysiologyMod use shr_kind_mod , only : r8 => shr_kind_r8 use clm_varctl , only : iulog + use spmdMod , only : masterproc 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 EDCohortDynamicsMod , only : allocate_live_biomass, zero_cohort + use EDCohortDynamicsMod , only : create_cohort, fuse_cohorts, sort_cohorts use EDTypesMod , only : dg_sf, dinc_ed, external_recruitment - use EDTypesMod , only : ncwd, nlevcan_ed, n_sub, numpft_ed, senes + use EDTypesMod , only : ncwd, cp_nlevcan, numpft_ed, senes use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type implicit none @@ -35,6 +36,10 @@ module EDPhysiologyMod public :: seeds_in public :: seed_decay public :: seed_germination + public :: flux_into_litter_pools + + logical, parameter :: DEBUG = .false. ! local debug flag + ! ============================================================================ contains @@ -66,7 +71,7 @@ subroutine canopy_derivs( currentPatch ) end subroutine canopy_derivs ! ============================================================================ - subroutine non_canopy_derivs( currentPatch, temperature_inst, soilstate_inst, waterstate_inst) + subroutine non_canopy_derivs( currentPatch, temperature_inst ) ! ! !DESCRIPTION: ! Returns time differentials of the state vector @@ -76,8 +81,6 @@ subroutine non_canopy_derivs( currentPatch, temperature_inst, soilstate_inst, wa ! !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 @@ -85,6 +88,8 @@ subroutine non_canopy_derivs( currentPatch, temperature_inst, soilstate_inst, wa currentPatch%leaf_litter_in(:) = 0.0_r8 currentPatch%root_litter_in(:) = 0.0_r8 + currentPatch%dleaf_litter_dt(:) = 0.0_r8 + currentPatch%droot_litter_dt(:) = 0.0_r8 currentPatch%leaf_litter_out(:) = 0.0_r8 currentPatch%root_litter_out(:) = 0.0_r8 currentPatch%cwd_AG_in(:) = 0.0_r8 @@ -102,7 +107,7 @@ subroutine non_canopy_derivs( currentPatch, temperature_inst, soilstate_inst, wa ! update fragmenting pool fluxes call cwd_input(currentPatch) - call cwd_out( currentPatch, temperature_inst, soilstate_inst, waterstate_inst) + call cwd_out( currentPatch, temperature_inst) do p = 1,numpft_ed currentPatch%dseed_dt(p) = currentPatch%seeds_in(p) - currentPatch%seed_decay(p) - currentPatch%seed_germination(p) @@ -118,14 +123,14 @@ subroutine non_canopy_derivs( currentPatch, temperature_inst, soilstate_inst, wa 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 + ! 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 @@ -166,13 +171,13 @@ subroutine trim_canopy( currentSite ) 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, & + if (currentCohort%nv > cp_nlevcan)then + write(iulog,*) 'nv > cp_nlevcan',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 + do z = 1,cp_nlevcan 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. @@ -180,17 +185,21 @@ subroutine trim_canopy( currentSite ) 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) + currentCohort%leaf_cost = currentCohort%leaf_cost * (ED_val_grperc(currentCohort%pft) + 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 + 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) + currentCohort%leaf_cost = currentCohort%leaf_cost * (ED_val_grperc(currentCohort%pft) + 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 + + if ( DEBUG ) then + write(iulog,*) 'trimming leaves',currentCohort%canopy_trim,currentCohort%leaf_cost + endif + ! 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 @@ -204,15 +213,19 @@ subroutine trim_canopy( currentSite ) 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 + ! leaf_cost may be uninitialized, removing its diagnostic from the log + ! to allow checking with fpe_traps (RGK) + write(iulog,*) 'nv>4',currentCohort%year_net_uptake(1:6),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 + + if ( DEBUG ) then + write(iulog,*) 'trimming',currentCohort%canopy_trim + endif ! currentCohort%canopy_trim = 1.0_r8 !FIX(RF,032414) this turns off ctrim for now. currentCohort => currentCohort%shorter @@ -223,45 +236,70 @@ subroutine trim_canopy( currentSite ) end subroutine trim_canopy ! ============================================================================ - subroutine phenology( currentSite, ed_phenology_inst, temperature_inst, waterstate_inst) + subroutine phenology( currentSite, temperature_inst, waterstate_inst) ! ! !DESCRIPTION: ! Phenology. ! ! !USES: use clm_varcon, only : tfrz + use clm_time_manager, only : get_curr_date + use clm_time_manager, only : get_ref_date, timemgr_datediff use EDTypesMod, only : udata + use PatchType , only : patch ! ! !ARGUMENTS: - type(ed_site_type) , intent(inout), pointer:: currentSite - type(ed_phenology_type) , intent(in) :: ed_phenology_inst + type(ed_site_type) , intent(inout), target :: currentSite 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 + integer :: refdate + integer :: curdate + + integer :: yr ! year (0, ...) + integer :: mon ! month (1, ..., 12) + integer :: day ! day of month (1, ..., 31) + integer :: sec ! seconds of the day + integer :: patchi ! the first CLM/ALM patch index of the associated column + integer :: coli ! the CLM/ALM column index of the associated site + 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. + integer :: ncdstart ! beginning of counting period for chilling degree days. + integer :: gddstart ! 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 + real(r8) :: modelday + !------------------------------------------------------------------------ + ! INTERF-TODO: THIS IS A BAND-AID, AS I WAS HOPING TO REMOVE CLM_PNO + ! ALREADY REMOVED currentSite%clmcolumn, hence the need for these + + patchi = currentSite%oldest_patch%clm_pno-1 + coli = patch%column(patchi) + 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 + call get_curr_date(yr, mon, day, sec) + curdate = yr*10000 + mon*100 + day + + call get_ref_date(yr, mon, day, sec) + refdate = yr*10000 + mon*100 + day + + call timemgr_datediff(refdate, 0, curdate, sec, modelday) + if ( masterproc ) write(iulog,*) 'modelday',modelday ! Parameter of drought decid leaf loss in mm in top layer...FIX(RF,032414) ! - this is arbitrary and poorly understood. Needs work. ED_ @@ -272,24 +310,26 @@ subroutine phenology( currentSite, ed_phenology_inst, temperature_inst, watersta a = -68.0_r8 b = 638.0_r8 c = -0.001_r8 - coldday = 5.0_r8 + coldday = 5.0_r8 !ed_ph_chiltemp mindayson = 30 !Parameters from SDGVM model of senesence ncolddayslim = 5 - cold_t = 7.5_r8 + cold_t = 7.5_r8 ! ed_ph_coldtemp t = udata%time_period - temp_in_C = t_veg24(currentSite%oldest_patch%clm_pno-1) - tfrz + temp_in_C = t_veg24(patchi) - tfrz !-----------------Cold Phenology--------------------! !Zero growing degree and chilling day counters if (currentSite%lat > 0)then - ncdstart = 270._r8; !Northern Hemisphere begining November + ncdstart = 270 !Northern Hemisphere begining November + gddstart = 1 !Northern Hemisphere begining January else - ncdstart = 120._r8; !Southern Hemisphere beginning May + ncdstart = 120 !Southern Hemisphere beginning May + gddstart = 181 !Northern Hemisphere begining July endif ! FIX(SPM,032414) - this will only work for the first year, no? @@ -315,29 +355,37 @@ subroutine phenology( currentSite, ed_phenology_inst, temperature_inst, watersta endif enddo - timesinceleafoff = t - currentSite%leafoffdate - if (t < currentSite%leafoffdate)then - timesinceleafoff = t +(365-currentSite%leafoffdate) + ! Here is where we do the GDD accumulation calculation + ! + ! reset GDD on set dates + if (t == gddstart)then + currentSite%ED_GDD_site = 0._r8 endif + ! + ! accumulate the GDD using daily mean temperatures + if (t_veg24(patchi) .gt. tfrz) then + currentSite%ED_GDD_site = currentSite%ED_GDD_site + t_veg24(currentSite%oldest_patch%clm_pno-1) - tfrz + endif + + timesinceleafoff = modelday - currentSite%leafoffdate !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 + if (currentSite%ED_GDD_site > gdd_threshold)then + if (currentSite%status == 1) then + if (currentSite%ncd >= 1) then + currentSite%status = 2 !alter status of site to 'leaves on' + ! NOTE(bja, 2015-01) should leafondate = modelday to be consistent with leaf off? + currentSite%leafondate = t !record leaf on date + if ( DEBUG ) 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 + timesinceleafon = modelday - currentSite%leafondate + !LEAF OFF: COLD THRESHOLD !Needs to: @@ -350,18 +398,18 @@ subroutine phenology( currentSite, ed_phenology_inst, temperature_inst, watersta 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' + currentSite%leafoffdate = modelday !record leaf off date + if ( DEBUG ) 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 + if(timesinceleafoff > 400)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' + currentSite%leafoffdate = modelday !record leaf off date + if ( DEBUG ) write(iulog,*) 'leaves off' endif endif @@ -393,7 +441,7 @@ subroutine phenology( currentSite, ed_phenology_inst, temperature_inst, watersta ! distinction actually matter??).... !Accumulate surface water memory of last 10 days. - currentSite%water_memory(1) = waterstate_inst%h2osoi_vol_col(currentSite%clmcolumn,1) + currentSite%water_memory(1) = waterstate_inst%h2osoi_vol_col(coli,1) do i = 1,9 !shift memory along one currentSite%water_memory(11-i) = currentSite%water_memory(10-i) enddo @@ -471,15 +519,20 @@ subroutine phenology_leafonoff(currentSite) ! !USES: ! ! !ARGUMENTS: - type(ed_site_type), intent(inout), pointer:: currentSite + type(ed_site_type), intent(inout), target :: currentSite ! ! !LOCAL VARIABLES: type(ed_patch_type) , pointer :: currentPatch type(ed_cohort_type), pointer :: currentCohort + + real(r8) :: store_output ! the amount of the store to put into leaves - is a barrier against negative storage and C starvation. + !------------------------------------------------------------------------ currentPatch => CurrentSite%oldest_patch + store_output = 0.5_r8 + do while(associated(currentPatch)) currentCohort => currentPatch%tallest do while(associated(currentCohort)) @@ -492,12 +545,23 @@ subroutine phenology_leafonoff(currentSite) 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 + ! 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 + currentCohort%bl = currentCohort%bstore * store_output endif - currentCohort%balive = currentCohort%balive + currentCohort%bl ! Add deployed carbon to alive biomass pool + + ! Add deployed carbon to alive biomass pool + currentCohort%balive = currentCohort%balive + currentCohort%bl + + if ( DEBUG ) write(iulog,*) 'EDPhysMod 1 ',currentCohort%bstore + currentCohort%bstore = currentCohort%bstore - currentCohort%bl ! Drain store + + if ( DEBUG ) write(iulog,*) 'EDPhysMod 2 ',currentCohort%bstore + currentCohort%laimemory = 0.0_r8 + endif !pft phenology endif ! growing season @@ -525,11 +589,18 @@ subroutine phenology_leafonoff(currentSite) 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%bl = currentCohort%bstore * store_output !we can only put on as much carbon as there is in the store... + endif currentCohort%balive = currentCohort%balive + currentCohort%bl + + if ( DEBUG ) write(iulog,*) 'EDPhysMod 3 ',currentCohort%bstore + currentCohort%bstore = currentCohort%bstore - currentCohort%bl ! empty store + + if ( DEBUG ) write(iulog,*) 'EDPhysMod 4 ',currentCohort%bstore + currentCohort%laimemory = 0.0_r8 + endif !currentCohort status again? endif !currentSite status @@ -580,6 +651,8 @@ subroutine seeds_in( cp_pnt ) currentSite => currentPatch%siteptr currentPatch%seeds_in(:) = 0.0_r8 + currentPatch%seed_rain_flux(:) = 0.0_r8 + currentCohort => currentPatch%tallest do while (associated(currentCohort)) p = currentCohort%pft @@ -593,6 +666,7 @@ subroutine seeds_in( cp_pnt ) 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 + currentPatch%seed_rain_flux(p) = currentPatch%seed_rain_flux(p) + EDecophyscon%seed_rain(p) !KgC/m2/year enddo endif currentPatch => currentPatch%younger @@ -677,6 +751,9 @@ subroutine Growth_Derivatives( currentCohort) 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) :: cmort ! starvation mortality rate (fraction per year) + real(r8) :: bmort ! background mortality rate (fraction per year) + real(r8) :: hmort ! hydraulic failure mortality rate (fraction per year) real(r8) :: balive_loss !---------------------------------------------------------------------- @@ -685,7 +762,8 @@ subroutine Growth_Derivatives( currentCohort) ! 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 + call mortality_rates(currentCohort,cmort,hmort,bmort) + currentCohort%dndt = -1.0_r8 * (cmort+hmort+bmort) * currentCohort%n else currentCohort%dndt = 0._r8 endif @@ -694,7 +772,7 @@ subroutine Growth_Derivatives( currentCohort) currentCohort%hite = Hite(currentCohort) h = currentCohort%hite - call allocate_live_biomass(currentCohort) + call allocate_live_biomass(currentCohort,0) ! calculate target size of living biomass compartment for a given dbh. target_balive = Bleaf(currentCohort) * (1.0_r8 + pftcon%froot_leaf(currentCohort%pft) + & @@ -706,9 +784,11 @@ subroutine Growth_Derivatives( currentCohort) 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 + if ( DEBUG ) write(iulog,*) 'EDphys 716 ',currentCohort%npp_acc + + currentCohort%npp = currentCohort%npp_acc * udata%n_sub !Link to CLM. convert from kgC/indiv/day into kgC/indiv/year + currentCohort%gpp = currentCohort%gpp_acc * udata%n_sub !Link to CLM. convert from kgC/indiv/day into kgC/indiv/year + currentCohort%resp = currentCohort%resp_acc * udata%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 @@ -750,10 +830,23 @@ subroutine Growth_Derivatives( currentCohort) ! Calculate carbon balance ! this is the fraction of maintenance demand we -have- to do... + if ( DEBUG ) write(iulog,*) 'EDphys 760 ',currentCohort%npp, currentCohort%md, & + EDecophyscon%leaf_stor_priority(currentCohort%pft) + currentCohort%carbon_balance = currentCohort%npp - currentCohort%md * EDecophyscon%leaf_stor_priority(currentCohort%pft) + ! Allowing only carbon from NPP pool to account for npp flux into the maintenance pools + ! ie this does not include any use of storage carbon or balive to make up for missing carbon balance in the transfer + currentCohort%npp_leaf = min(currentCohort%npp*currentCohort%leaf_md/currentCohort%md, & + currentCohort%leaf_md*EDecophyscon%leaf_stor_priority(currentCohort%pft)) + currentCohort%npp_froot = min(currentCohort%npp*currentCohort%root_md/currentCohort%md, & + currentCohort%root_md*EDecophyscon%leaf_stor_priority(currentCohort%pft)) + + if (Bleaf(currentCohort) > 0._r8)then + if ( DEBUG ) write(iulog,*) 'EDphys A ',currentCohort%carbon_balance + if (currentCohort%carbon_balance > 0._r8)then !spend C on growing and storing !what fraction of the target storage do we have? @@ -763,6 +856,9 @@ subroutine Growth_Derivatives( currentCohort) !what fraction of allocation do we divert to storage? !what is the flux into the store? currentCohort%storage_flux = currentCohort%carbon_balance * f_store + + if ( DEBUG ) write(iulog,*) 'EDphys B ',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. @@ -784,7 +880,19 @@ subroutine Growth_Derivatives( currentCohort) 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)) + + currentCohort%npp_leaf = currentCohort%npp_leaf + & + currentCohort%leaf_md * (1.0_r8-EDecophyscon%leaf_stor_priority(currentCohort%pft)) + currentCohort%npp_froot = currentCohort%npp_froot + & + currentCohort%root_md * (1.0_r8-EDecophyscon%leaf_stor_priority(currentCohort%pft)) + else ! we can't maintain constant leaf area and root area. Balive is reduced + + currentCohort%npp_leaf = currentCohort%npp_leaf + & + max(0.0_r8,currentCohort%carbon_balance*(currentCohort%leaf_md/currentCohort%md)) + currentCohort%npp_froot = currentCohort%npp_froot + & + max(0.0_r8,currentCohort%carbon_balance*(currentCohort%root_md/currentCohort%md)) + balive_loss = currentCohort%md *(1.0_r8- EDecophyscon%leaf_stor_priority(currentCohort%pft))- currentCohort%carbon_balance currentCohort%carbon_balance = 0._r8 endif @@ -829,6 +937,9 @@ subroutine Growth_Derivatives( currentCohort) currentCohort%dbalivedt = gr_fract * va * currentCohort%carbon_balance - balive_loss currentCohort%dbdeaddt = gr_fract * vs * currentCohort%carbon_balance currentCohort%dbstoredt = currentCohort%storage_flux + + if ( DEBUG ) write(iulog,*) 'EDPhys dbstoredt I ',currentCohort%dbstoredt + 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 @@ -847,13 +958,22 @@ subroutine Growth_Derivatives( currentCohort) write(iulog,*) 'using non-neg leaf mass cap',currentCohort%balive , currentCohort%dbalivedt,currentCohort%dbstoredt, & currentCohort%carbon_balance currentCohort%dbstoredt = currentCohort%dbstoredt + currentCohort%dbalivedt + + if ( DEBUG ) write(iulog,*) 'EDPhys dbstoredt II ',currentCohort%dbstoredt + currentCohort%dbalivedt = 0._r8 endif + currentCohort%npp_bseed = currentCohort%seed_prod + currentCohort%npp_store = max(0.0_r8,currentCohort%storage_flux) + ! calculate change in diameter and height currentCohort%ddbhdt = currentCohort%dbdeaddt * dDbhdBd(currentCohort) currentCohort%dhdt = currentCohort%dbdeaddt * dHdBd(currentCohort) + ! If the cohort has grown, it is not new + currentCohort%isnew=.false. + end subroutine Growth_Derivatives ! ============================================================================ @@ -915,18 +1035,17 @@ subroutine recruitment( t, currentPatch ) 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) + if (temp_cohort%n > 0.0_r8 )then + if ( DEBUG ) write(iulog,*) 'EDPhysiologyMod.F90 call create_cohort ' + 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 ! ============================================================================ @@ -1025,6 +1144,7 @@ subroutine fragmentation_scaler( currentPatch, temperature_inst ) ! !USES: use shr_const_mod , only : SHR_CONST_PI, SHR_CONST_TKFRZ use EDSharedParamsMod , only : EDParamsShareInst + ! ! !ARGUMENTS type(ed_patch_type) , intent(inout) :: currentPatch @@ -1033,7 +1153,7 @@ subroutine fragmentation_scaler( currentPatch, temperature_inst ) ! !LOCAL VARIABLES: logical :: use_century_tfunc = .false. type(ed_site_type), pointer :: currentSite - integer :: c,p,j + integer :: p,j real(r8) :: t_scalar real(r8) :: w_scalar real(r8) :: catanf ! hyperbolic temperature function from CENTURY @@ -1050,7 +1170,7 @@ subroutine fragmentation_scaler( currentPatch, temperature_inst ) catanf_30 = catanf(30._r8) - c = currentPatch%siteptr%clmcolumn +! c = currentPatch%siteptr%clmcolumn p = currentPatch%clm_pno ! set "froz_q10" parameter @@ -1082,7 +1202,7 @@ subroutine fragmentation_scaler( currentPatch, temperature_inst ) end subroutine fragmentation_scaler ! ============================================================================ - subroutine cwd_out( currentPatch, temperature_inst, soilstate_inst, waterstate_inst) + subroutine cwd_out( currentPatch, temperature_inst ) ! ! !DESCRIPTION: ! Simple CWD fragmentation Model @@ -1095,8 +1215,6 @@ subroutine cwd_out( currentPatch, temperature_inst, soilstate_inst, waterstate_i ! !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 @@ -1104,8 +1222,8 @@ subroutine cwd_out( currentPatch, temperature_inst, soilstate_inst, waterstate_i !---------------------------------------------------------------------- currentSite => currentPatch%siteptr - currentPatch%root_litter_out = 0.0_r8 - currentPatch%leaf_litter_out = 0.0_r8 + currentPatch%root_litter_out(:) = 0.0_r8 + currentPatch%leaf_litter_out(:) = 0.0_r8 call fragmentation_scaler(currentPatch, temperature_inst) @@ -1150,4 +1268,384 @@ subroutine cwd_out( currentPatch, temperature_inst, soilstate_inst, waterstate_i end subroutine cwd_out + + + subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) + ! Created by Charlie Koven and Rosie Fisher, 2014-2015 + ! take the flux out of the fragmenting litter pools and port into the decomposing litter pools. + ! in this implementation, decomposing pools are assumed to be humus and non-flammable, whereas fragmenting pools + ! are assumed to be physically fragmenting but not respiring. This is a simplification, but allows us to + ! a) reconcile the need to track both chemical fractions (lignin, cellulose, labile) and size fractions (trunk, branch, etc.) + ! b) to impose a realistic delay on the surge of nutrients into the litter pools when large CWD is added to the system via mortality + + ! because of the different subgrid structure, this subroutine includes the functionality that in the big-leaf BGC model, is calculated in SoilBiogeochemVerticalProfileMod + + ! The ED code is resolved at a daily timestep, but all of the CN-BGC fluxes are passed in as derivatives per second, + ! and then accumulated in the CNStateUpdate routines. One way of doing this is to pass back the CN fluxes per second, + ! and keep them constant for the whole day (making sure they are not overwritten. + ! This means that the carbon gets passed back and forth between the photosynthesis code (fast timestepping) to the ED code (slow timestepping), back to the BGC code (fast timestepping). + ! This means that the state update for the litter pools and for the CWD pools occurs at different timescales. + + + use EDTypesMod, only : AREA, numpft_ed, cp_numlevdecomp_full, cp_numlevdecomp + use SoilBiogeochemVerticalProfileMod, only: surfprof_exp + use EDCLMLinkMod, only: cwd_fcel_ed, cwd_flig_ed + use pftconMod, only : pftcon + use shr_const_mod, only: SHR_CONST_CDAY + use clm_varcon, only : zisoi, dzsoi_decomp, zsoi + use EDParamsMod, only : ED_val_ag_biomass + use FatesInterfaceMod, only : bc_in_type, bc_out_type + use clm_varctl, only : use_vertsoilc + use abortutils , only : endrun + + ! INTERF-TODO: remove the control parameters: exponential_rooting_profile, pftspecific_rootingprofile, rootprof_exp, surfprof_exp, zisoi, dzsoi_decomp, zsoi + ! + implicit none + ! + ! !ARGUMENTS + integer , intent(in) :: nsites + type(ed_site_type) , intent(inout), target :: sites(nsites) + type(bc_in_type) , intent(in) :: bc_in(:) + type(bc_out_type) , intent(inout) :: bc_out(:) + ! + ! !LOCAL VARIABLES: + type (ed_patch_type) , pointer :: currentPatch + type (ed_cohort_type) , pointer :: currentCohort + type(ed_site_type), pointer :: cs + integer p,ci,j,s + real(r8) time_convert ! from year to seconds + real(r8) mass_convert ! ED uses kg, CLM uses g + integer :: begp,endp + integer :: begc,endc !bounds + !------------------------------------------------------------------------ + real(r8) :: cinput_rootfr(1:numpft_ed, 1:cp_numlevdecomp_full) ! column by pft root fraction used for calculating inputs + real(r8) :: croot_prof_perpatch(1:cp_numlevdecomp_full) + real(r8) :: surface_prof(1:cp_numlevdecomp_full) + integer :: ft + real(r8) :: rootfr_tot(1:numpft_ed), biomass_bg_ft(1:numpft_ed) + real(r8) :: surface_prof_tot, leaf_prof_sum, stem_prof_sum, froot_prof_sum, biomass_bg_tot + real(r8) :: delta + + ! NOTE(bja, 201608) these were removed from clm in clm4_5_10_r187 + logical, parameter :: exponential_rooting_profile = .true. + logical, parameter :: pftspecific_rootingprofile = .true. + + ! NOTE(bja, 201608) as of clm4_5_10_r187 rootprof_exp is now a + ! private function level parameter in RootBiophysMod.F90::exponential_rootfr() + real(r8), parameter :: rootprof_exp = 3. ! how steep profile is + ! for root C inputs (1/ e-folding depth) (1/m) + + ! NOTE(bja, 201608) as of clm4_5_10_r187 rootprof_beta is now a + ! two dimensional array with the second dimension being water,1, + ! or carbon,2,. These are currently hard coded, but may be + ! overwritten by the namelist. + + ! Note cdk 2016/08 we actually want to use the carbon index here rather than the water index. + ! Doing so will be answer changing though so perhaps easiest to do this in steps. + integer, parameter :: rooting_profile_varindex_water = 1 + + real(r8) :: leaf_prof(1:nsites, 1:cp_numlevdecomp) + real(r8) :: froot_prof(1:nsites, 1:numpft_ed, 1:cp_numlevdecomp) + real(r8) :: croot_prof(1:nsites, 1:cp_numlevdecomp) + real(r8) :: stem_prof(1:nsites, 1:cp_numlevdecomp) + + + delta = 0.001_r8 + !no of seconds in a year. + time_convert = 365.0_r8*SHR_CONST_CDAY + + ! number of grams in a kilogram + mass_convert = 1000._r8 + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! first calculate vertical profiles + ! define two types of profiles: + ! (1) a surface profile, for leaves and stem inputs, which is the same for each pft but differs from one site to the next to avoid inputting any C into permafrost or bedrock + ! (2) a fine root profile, which is indexed by both site and pft, differs for each pft and also from one site to the next to avoid inputting any C into permafrost or bedrock + ! (3) a coarse root profile, which is the root-biomass=weighted average of the fine root profiles + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + if (use_vertsoilc) then + + ! define a single shallow surface profile for surface additions (leaves, stems, and N deposition) + surface_prof(:) = 0._r8 + do j = 1, cp_numlevdecomp + surface_prof(j) = exp(-surfprof_exp * zsoi(j)) / dzsoi_decomp(j) + end do + + ! initialize profiles to zero + leaf_prof(1:nsites, :) = 0._r8 + froot_prof(1:nsites, 1:numpft_ed, :) = 0._r8 + croot_prof(1:nsites, :) = 0._r8 + stem_prof(1:nsites, :) = 0._r8 + + cinput_rootfr(1:numpft_ed, :) = 0._r8 + + ! calculate pft-specific rooting profiles in the absence of permafrost or bedrock limitations + if ( exponential_rooting_profile ) then + if ( .not. pftspecific_rootingprofile ) then + ! define rooting profile from exponential parameters + do ft = 1, numpft_ed + do j = 1, cp_numlevdecomp + cinput_rootfr(ft,j) = exp(-rootprof_exp * zsoi(j)) / dzsoi_decomp(j) + end do + end do + else + ! use beta distribution parameter from Jackson et al., 1996 + do ft = 1, numpft_ed + do j = 1, cp_numlevdecomp + cinput_rootfr(ft,j) = ( pftcon%rootprof_beta(ft, rooting_profile_varindex_water) ** (zisoi(j-1)*100._r8) - & + pftcon%rootprof_beta(ft, rooting_profile_varindex_water) ** (zisoi(j)*100._r8) ) & + / dzsoi_decomp(j) + end do + end do + endif + else + do ft = 1,numpft_ed + do j = 1, cp_numlevdecomp + ! use standard CLM root fraction profiles; + cinput_rootfr(ft,j) = ( .5_r8*( & + exp(-pftcon%roota_par(ft) * zisoi(j-1)) & + + exp(-pftcon%rootb_par(ft) * zisoi(j-1)) & + - exp(-pftcon%roota_par(ft) * zisoi(j)) & + - exp(-pftcon%rootb_par(ft) * zisoi(j)))) / dzsoi_decomp(j) + end do + end do + endif + ! + + do s = 1,nsites + ! + ! now add permafrost constraint: integrate rootfr over active layer of soil site, + ! truncate below permafrost or bedrock table where present, and rescale so that integral = 1 + do ft = 1,numpft_ed + rootfr_tot(ft) = 0._r8 + end do + surface_prof_tot = 0._r8 + ! + do j = 1, min(max(bc_in(s)%max_rooting_depth_index_col, 1), cp_numlevdecomp) + surface_prof_tot = surface_prof_tot + surface_prof(j) * dzsoi_decomp(j) + end do + do ft = 1,numpft_ed + do j = 1, min(max(bc_in(s)%max_rooting_depth_index_col, 1), cp_numlevdecomp) + rootfr_tot(ft) = rootfr_tot(ft) + cinput_rootfr(ft,j) * dzsoi_decomp(j) + end do + end do + ! + ! rescale the fine root profile + do ft = 1,numpft_ed + if ( (bc_in(s)%max_rooting_depth_index_col > 0) .and. (rootfr_tot(ft) > 0._r8) ) then + ! where there is not permafrost extending to the surface, integrate the profiles over the active layer + ! this is equivalent to integrating over all soil layers outside of permafrost regions + do j = 1, min(max(bc_in(s)%max_rooting_depth_index_col, 1), cp_numlevdecomp) + froot_prof(s,ft,j) = cinput_rootfr(ft,j) / rootfr_tot(ft) + end do + else + ! if fully frozen, or no roots, put everything in the top layer + froot_prof(s,ft,1) = 1._r8/dzsoi_decomp(1) + endif + end do + ! + ! rescale the shallow profiles + if ( (bc_in(s)%max_rooting_depth_index_col > 0) .and. (surface_prof_tot > 0._r8) ) then + ! where there is not permafrost extending to the surface, integrate the profiles over the active layer + ! this is equivalent to integrating over all soil layers outside of permafrost regions + do j = 1, min(max(bc_in(s)%max_rooting_depth_index_col, 1), cp_numlevdecomp) + ! set all surface processes to shallower profile + leaf_prof(s,j) = surface_prof(j)/ surface_prof_tot + stem_prof(s,j) = surface_prof(j)/ surface_prof_tot + end do + else + ! if fully frozen, or no roots, put everything in the top layer + leaf_prof(s,1) = 1._r8/dzsoi_decomp(1) + stem_prof(s,1) = 1._r8/dzsoi_decomp(1) + do j = 2, cp_numlevdecomp + leaf_prof(s,j) = 0._r8 + stem_prof(s,j) = 0._r8 + end do + endif + end do + + else + + ! for one layer decomposition model, set profiles to unity + leaf_prof(1:nsites, :) = 1._r8 + froot_prof(1:nsites, 1:numpft_ed, :) = 1._r8 + stem_prof(1:nsites, :) = 1._r8 + + end if + + ! sanity check to ensure they integrate to 1 + do s = 1, nsites + ! check the leaf and stem profiles + leaf_prof_sum = 0._r8 + stem_prof_sum = 0._r8 + do j = 1, cp_numlevdecomp + leaf_prof_sum = leaf_prof_sum + leaf_prof(s,j) * dzsoi_decomp(j) + stem_prof_sum = stem_prof_sum + stem_prof(s,j) * dzsoi_decomp(j) + end do + if ( ( abs(stem_prof_sum - 1._r8) > delta ) .or. ( abs(leaf_prof_sum - 1._r8) > delta ) ) then + write(iulog, *) 'profile sums: ', leaf_prof_sum, stem_prof_sum + write(iulog, *) 'surface_prof: ', surface_prof + write(iulog, *) 'surface_prof_tot: ', surface_prof_tot + write(iulog, *) 'leaf_prof: ', leaf_prof(s,:) + write(iulog, *) 'stem_prof: ', stem_prof(s,:) + write(iulog, *) 'max_rooting_depth_index_col: ', bc_in(s)%max_rooting_depth_index_col + write(iulog, *) 'dzsoi_decomp: ', dzsoi_decomp + call endrun() + endif + ! now check each fine root profile + do ft = 1,numpft_ed + froot_prof_sum = 0._r8 + do j = 1, cp_numlevdecomp + froot_prof_sum = froot_prof_sum + froot_prof(s,ft,j) * dzsoi_decomp(j) + end do + if ( ( abs(froot_prof_sum - 1._r8) > delta ) ) then + write(iulog, *) 'profile sums: ', froot_prof_sum + call endrun() + endif + end do + end do + + ! zero the site-level C input variables + do s = 1, nsites + do j = 1, cp_numlevdecomp + bc_out(s)%FATES_c_to_litr_lab_c_col(j) = 0._r8 + bc_out(s)%FATES_c_to_litr_cel_c_col(j) = 0._r8 + bc_out(s)%FATES_c_to_litr_lig_c_col(j) = 0._r8 + croot_prof(s,j) = 0._r8 + end do + end do + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! now disaggregate the inputs vertically, using the vertical profiles + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + do s = 1,nsites + + ! do g = bounds%begg,bounds%endg + ! if (firstsoilpatch(g) >= 0 .and. ed_allsites_inst(g)%istheresoil) then + currentPatch => sites(s)%oldest_patch + + do while(associated(currentPatch)) + + ! the CWD pools lose information about which PFT they came from; for the stems this doesn't matter as they all have the same profile, + ! however for the coarse roots they may have different profiles. to approximately recover this information, loop over all cohorts in patch + ! to calculate the total root biomass in that patch of each pft, and then rescale the croot_prof as the weighted average of the froot_prof + biomass_bg_ft(1:numpft_ed) = 0._r8 + currentCohort => currentPatch%tallest + do while(associated(currentCohort)) + biomass_bg_ft(currentCohort%pft) = biomass_bg_ft(currentCohort%pft) + & + currentCohort%b * (currentCohort%n / currentPatch%area) * (1.0_r8-ED_val_ag_biomass) + currentCohort => currentCohort%shorter + enddo !currentCohort + ! + biomass_bg_tot = 0._r8 + do ft = 1,numpft_ed + biomass_bg_tot = biomass_bg_tot + biomass_bg_ft(ft) + end do + ! + do j = 1, cp_numlevdecomp + ! zero this for each patch + croot_prof_perpatch(j) = 0._r8 + end do + ! + if ( biomass_bg_tot .gt. 0._r8) then + do ft = 1,numpft_ed + do j = 1, cp_numlevdecomp + croot_prof_perpatch(j) = croot_prof_perpatch(j) + froot_prof(s,ft,j) * biomass_bg_ft(ft) / biomass_bg_tot + end do + end do + else ! no biomass + croot_prof_perpatch(1) = 1./dzsoi_decomp(1) + end if + + ! + ! add croot_prof as weighted average (weighted by patch area) of croot_prof_perpatch + do j = 1, cp_numlevdecomp + croot_prof(s, j) = croot_prof(s, j) + croot_prof_perpatch(j) * currentPatch%area / AREA + end do + ! + ! now disaggregate, vertically and by decomposition substrate type, the actual fluxes from CWD and litter pools + ! + ! do c = 1, ncwd + ! write(iulog,*)'cdk CWD_AG_out', c, currentpatch%CWD_AG_out(c), cwd_fcel_ed, currentpatch%area/AREA + ! write(iulog,*)'cdk CWD_BG_out', c, currentpatch%CWD_BG_out(c), cwd_fcel_ed, currentpatch%area/AREA + ! end do + ! do ft = 1,numpft_ed + ! write(iulog,*)'cdk leaf_litter_out', ft, currentpatch%leaf_litter_out(ft), cwd_fcel_ed, currentpatch%area/AREA + ! write(iulog,*)'cdk root_litter_out', ft, currentpatch%root_litter_out(ft), cwd_fcel_ed, currentpatch%area/AREA + ! end do + ! ! + ! CWD pools fragmenting into decomposing litter pools. + do ci = 1, ncwd + do j = 1, cp_numlevdecomp + bc_out(s)%FATES_c_to_litr_cel_c_col(j) = bc_out(s)%FATES_c_to_litr_cel_c_col(j) + & + currentpatch%CWD_AG_out(ci) * cwd_fcel_ed * currentpatch%area/AREA * stem_prof(s,j) + bc_out(s)%FATES_c_to_litr_lig_c_col(j) = bc_out(s)%FATES_c_to_litr_lig_c_col(j) + & + currentpatch%CWD_AG_out(ci) * cwd_flig_ed * currentpatch%area/AREA * stem_prof(s,j) + ! + bc_out(s)%FATES_c_to_litr_cel_c_col(j) = bc_out(s)%FATES_c_to_litr_cel_c_col(j) + & + currentpatch%CWD_BG_out(ci) * cwd_fcel_ed * currentpatch%area/AREA * croot_prof_perpatch(j) + bc_out(s)%FATES_c_to_litr_lig_c_col(j) = bc_out(s)%FATES_c_to_litr_lig_c_col(j) + & + currentpatch%CWD_BG_out(ci) * cwd_flig_ed * currentpatch%area/AREA * croot_prof_perpatch(j) + end do + end do + + ! leaf and fine root pools. + do ft = 1,numpft_ed + do j = 1, cp_numlevdecomp + bc_out(s)%FATES_c_to_litr_lab_c_col(j) = bc_out(s)%FATES_c_to_litr_lab_c_col(j) + & + currentpatch%leaf_litter_out(ft) * pftcon%lf_flab(ft) * currentpatch%area/AREA * leaf_prof(s,j) + bc_out(s)%FATES_c_to_litr_cel_c_col(j) = bc_out(s)%FATES_c_to_litr_cel_c_col(j) + & + currentpatch%leaf_litter_out(ft) * pftcon%lf_fcel(ft) * currentpatch%area/AREA * leaf_prof(s,j) + bc_out(s)%FATES_c_to_litr_lig_c_col(j) = bc_out(s)%FATES_c_to_litr_lig_c_col(j) + & + currentpatch%leaf_litter_out(ft) * pftcon%lf_flig(ft) * currentpatch%area/AREA * leaf_prof(s,j) + ! + bc_out(s)%FATES_c_to_litr_lab_c_col(j) = bc_out(s)%FATES_c_to_litr_lab_c_col(j) + & + currentpatch%root_litter_out(ft) * pftcon%fr_flab(ft) * currentpatch%area/AREA * froot_prof(s,ft,j) + bc_out(s)%FATES_c_to_litr_cel_c_col(j) = bc_out(s)%FATES_c_to_litr_cel_c_col(j) + & + currentpatch%root_litter_out(ft) * pftcon%fr_fcel(ft) * currentpatch%area/AREA * froot_prof(s,ft,j) + bc_out(s)%FATES_c_to_litr_lig_c_col(j) = bc_out(s)%FATES_c_to_litr_lig_c_col(j) + & + currentpatch%root_litter_out(ft) * pftcon%fr_flig(ft) * currentpatch%area/AREA * froot_prof(s,ft,j) + ! + !! and seed_decay too. for now, use the same lability fractions as for leaf litter + bc_out(s)%FATES_c_to_litr_lab_c_col(j) = bc_out(s)%FATES_c_to_litr_lab_c_col(j) + & + currentpatch%seed_decay(ft) * pftcon%lf_flab(ft) * currentpatch%area/AREA * leaf_prof(s,j) + bc_out(s)%FATES_c_to_litr_cel_c_col(j) = bc_out(s)%FATES_c_to_litr_cel_c_col(j) + & + currentpatch%seed_decay(ft) * pftcon%lf_fcel(ft) * currentpatch%area/AREA * leaf_prof(s,j) + bc_out(s)%FATES_c_to_litr_lig_c_col(j) = bc_out(s)%FATES_c_to_litr_lig_c_col(j) + & + currentpatch%seed_decay(ft) * pftcon%lf_flig(ft) * currentpatch%area/AREA * leaf_prof(s,j) + ! + enddo + end do + + currentPatch => currentPatch%younger + end do !currentPatch + + end do ! do sites(s) + + do s = 1, nsites + do j = 1, cp_numlevdecomp + ! time unit conversion + bc_out(s)%FATES_c_to_litr_lab_c_col(j)=bc_out(s)%FATES_c_to_litr_lab_c_col(j) * mass_convert / time_convert + bc_out(s)%FATES_c_to_litr_cel_c_col(j)=bc_out(s)%FATES_c_to_litr_cel_c_col(j) * mass_convert / time_convert + bc_out(s)%FATES_c_to_litr_lig_c_col(j)=bc_out(s)%FATES_c_to_litr_lig_c_col(j) * mass_convert / time_convert + + end do + end do + + ! write(iulog,*)'cdk FATES_c_to_litr_lab_c: ', FATES_c_to_litr_lab_c + ! write_col(iulog,*)'cdk FATES_c_to_litr_cel_c: ', FATES_c_to_litr_cel_c + ! write_col(iulog,*)'cdk FATES_c_to_litr_lig_c: ', FATES_c_to_litr_lig_c + ! write_col(iulog,*)'cdk cp_numlevdecomp_full, bounds%begc, bounds%endc: ', cp_numlevdecomp_full, bounds%begc, bounds%endc + ! write(iulog,*)'cdk leaf_prof: ', leaf_prof + ! write(iulog,*)'cdk stem_prof: ', stem_prof + ! write(iulog,*)'cdk froot_prof: ', froot_prof + ! write(iulog,*)'cdk croot_prof_perpatch: ', croot_prof_perpatch + ! write(iulog,*)'cdk croot_prof: ', croot_prof + + end subroutine flux_into_litter_pools + end module EDPhysiologyMod diff --git a/biogeophys/EDAccumulateFluxesMod.F90 b/biogeophys/EDAccumulateFluxesMod.F90 index 29312bb3..f44a2029 100644 --- a/biogeophys/EDAccumulateFluxesMod.F90 +++ b/biogeophys/EDAccumulateFluxesMod.F90 @@ -3,81 +3,90 @@ 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 + ! The fluxes are stored per cohort, and the npp_tstep (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 + private ! public :: AccumulateFluxes_ED + + logical :: DEBUG = .false. ! for debugging this module !------------------------------------------------------------------------------ contains !------------------------------------------------------------------------------ - subroutine AccumulateFluxes_ED(bounds, p, ed_allsites_inst, photosyns_inst) + subroutine AccumulateFluxes_ED(nsites, sites, bc_in, bc_out) ! ! !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 + use clm_varctl , only : iulog + use EDTypesMod , only : ed_patch_type, ed_cohort_type, ed_site_type + use FatesInterfaceMod , only : bc_in_type,bc_out_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 + integer, intent(in) :: nsites + type(ed_site_type), intent(inout), target :: sites(nsites) + type(bc_in_type), intent(in) :: bc_in(nsites) + type(bc_out_type), intent(inout) :: bc_out(nsites) ! ! !LOCAL VARIABLES: - type(ed_cohort_type), pointer :: currentCohort ! current cohort - type(ed_patch_type) , pointer :: currentPatch ! current patch + type(ed_cohort_type), pointer :: ccohort ! current cohort + type(ed_patch_type) , pointer :: cpatch ! current patch integer :: iv !leaf layer - integer :: g !gridcell + integer :: c ! clm/alm column + integer :: s ! ed site + integer :: ifp ! index fates patch !---------------------------------------------------------------------- - - 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 + + do s = 1, nsites + + ifp = 0 + cpatch => sites(s)%oldest_patch + do while (associated(cpatch)) + ifp = ifp+1 + + if( bc_in(s)%filter_photo_pa(ifp) == 3 ) then + ccohort => cpatch%shortest + do while(associated(ccohort)) + + ! Accumulate fluxes from hourly to daily values. + ! _tstep fluxes are KgC/indiv/timestep _acc are KgC/indiv/day + + if ( DEBUG ) then + write(iulog,*) 'EDAccumFlux 64 ',ccohort%npp_acc, & + ccohort%npp_tstep + write(iulog,*) 'EDAccumFlux 66 ',ccohort%gpp_tstep + write(iulog,*) 'EDAccumFlux 67 ',ccohort%resp_tstep + endif + + ccohort%npp_acc = ccohort%npp_acc + ccohort%npp_tstep + ccohort%gpp_acc = ccohort%gpp_acc + ccohort%gpp_tstep + ccohort%resp_acc = ccohort%resp_acc + ccohort%resp_tstep + + do iv=1,ccohort%nv + if(ccohort%year_net_uptake(iv) == 999._r8)then ! note that there were leaves in this layer this year. + ccohort%year_net_uptake(iv) = 0._r8 + end if + ccohort%year_net_uptake(iv) = ccohort%year_net_uptake(iv) + ccohort%ts_net_uptake(iv) + enddo + + ccohort => ccohort%taller + enddo ! while(associated(ccohort)) + end if + cpatch => cpatch%younger + end do ! while(associated(cpatch)) + end do + return + + end subroutine AccumulateFluxes_ED end module EDAccumulateFluxesMod + diff --git a/biogeophys/EDBtranMod.F90 b/biogeophys/EDBtranMod.F90 index 5cfb93c7..8ac4a51b 100644 --- a/biogeophys/EDBtranMod.F90 +++ b/biogeophys/EDBtranMod.F90 @@ -1,349 +1,338 @@ 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 - !------------------------------------------------------------------------------ + + !------------------------------------------------------------------------------------- + ! Description: + ! + ! ------------------------------------------------------------------------------------ + + use pftconMod , only : pftcon + use clm_varcon , only : tfrz + use EDTypesMod , only : ed_site_type, & + ed_patch_type, & + ed_cohort_type, & + numpft_ed, & + cp_numlevgrnd + use shr_kind_mod , only : r8 => shr_kind_r8 + use FatesInterfaceMod , only : bc_in_type, & + bc_out_type + use clm_varctl , only : iulog !INTERF-TODO: THIS SHOULD BE MOVED + + ! + implicit none + private + + public :: btran_ed + public :: get_active_suction_layers 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 - ! + + ! ==================================================================================== + + logical function check_layer_water(h2o_liq_vol, tempk) + + implicit none + ! Arguments + real(r8),intent(in) :: h2o_liq_vol + real(r8),intent(in) :: tempk + + check_layer_water = .false. + + if ( h2o_liq_vol .gt. 0._r8 ) then + if ( tempk .gt. tfrz-2._r8) then + check_layer_water = .true. + end if + end if + return + end function check_layer_water + + ! ===================================================================================== + + subroutine get_active_suction_layers(nsites, sites, bc_in, bc_out) + + ! Arguments + + integer,intent(in) :: nsites + type(ed_site_type),intent(inout),target :: sites(nsites) + type(bc_in_type),intent(in) :: bc_in(nsites) + type(bc_out_type),intent(inout) :: bc_out(nsites) + ! !LOCAL VARIABLES: - integer :: 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 + integer :: s ! site + integer :: j ! soil layer !------------------------------------------------------------------------------ - - 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 + + do s = 1,nsites + if (bc_in(s)%filter_btran) then + do j = 1,cp_numlevgrnd + bc_out(s)%active_suction_gl(j) = check_layer_water( bc_in(s)%h2o_liqvol_gl(j),bc_in(s)%tempk_gl(j) ) 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 - + else + bc_out(s)%active_suction_gl(:) = .false. + end if + end do + + end subroutine get_active_suction_layers + + ! ===================================================================================== + + subroutine btran_ed( nsites, sites, bc_in, bc_out) + + ! --------------------------------------------------------------------------------- + ! Calculate the transpiration wetness function (BTRAN) and the root uptake + ! distribution (ROOTR). + ! Boundary conditions in: bc_in(s)%eff_porosity_gl(j) unfrozen porosity + ! bc_in(s)%watsat_gl(j) porosity + ! bc_in(s)%active_uptake_gl(j) frozen/not frozen + ! bc_in(s)%smp_gl(j) suction + ! Boundary conditions out: bc_out(s)%rootr_pagl root uptake distribution + ! bc_out(s)%btran_pa wetness factor + ! --------------------------------------------------------------------------------- + + ! Arguments + + integer,intent(in) :: nsites + type(ed_site_type),intent(inout),target :: sites(nsites) + type(bc_in_type),intent(in) :: bc_in(nsites) + type(bc_out_type),intent(inout) :: bc_out(nsites) + + ! + ! !LOCAL VARIABLES: + type(ed_patch_type),pointer :: cpatch ! Current Patch Pointer + type(ed_cohort_type),pointer :: ccohort ! Current cohort pointer + integer :: s ! site + integer :: j ! soil layer + integer :: ifp ! patch vector index for the site + integer :: ft ! plant functional type index + real(r8) :: smp_node ! matrix potential + real(r8) :: rresis ! suction limitation to transpiration independent + ! of root density + real(r8) :: pftgs(numpft_ed) ! pft weighted stomatal conductance s/m + real(r8) :: temprootr + !------------------------------------------------------------------------------ + + associate( & + smpsc => pftcon%smpsc , & ! INTERF-TODO: THESE SHOULD BE FATES PARAMETERS + smpso => pftcon%smpso & ! INTERF-TODO: THESE SHOULD BE FATES PARAMETERS + ) + + do s = 1,nsites + + bc_out(s)%rootr_pagl(:,:) = 0._r8 + + ifp = 0 + cpatch => sites(s)%oldest_patch + do while (associated(cpatch)) + ifp=ifp+1 + + ! THIS SHOULD REALLY BE A COHORT LOOP ONCE WE HAVE rootfr_ft FOR COHORTS (RGK) + + do ft = 1,numpft_ed + cpatch%btran_ft(ft) = 0.0_r8 + do j = 1,cp_numlevgrnd + + ! Calculations are only relevant where liquid water exists + ! see clm_fates%wrap_btran for calculation with CLM/ALM + + if ( check_layer_water(bc_in(s)%h2o_liqvol_gl(j),bc_in(s)%tempk_gl(j)) ) then + + smp_node = max(smpsc(ft), bc_in(s)%smp_gl(j)) + + rresis = min( (bc_in(s)%eff_porosity_gl(j)/bc_in(s)%watsat_gl(j))* & + (smp_node - smpsc(ft)) / (smpso(ft) - smpsc(ft)), 1._r8) + + cpatch%rootr_ft(ft,j) = cpatch%rootfr_ft(ft,j)*rresis + + ! root water uptake is not linearly proportional to root density, + ! to allow proper deep root funciton. Replace with equations from SPA/Newman. FIX(RF,032414) + ! cpatch%rootr_ft(ft,j) = cpatch%rootfr_ft(ft,j)**0.3*rresis_ft(ft,j)/ & + ! sum(cpatch%rootfr_ft(ft,1:nlevgrnd)**0.3) + cpatch%btran_ft(ft) = cpatch%btran_ft(ft) + cpatch%rootr_ft(ft,j) + + else + cpatch%rootr_ft(ft,j) = 0._r8 + end if + + end do !j + + ! Normalize root resistances to get layer contribution to ET + do j = 1,cp_numlevgrnd + if (cpatch%btran_ft(ft) > 0.0_r8) then + cpatch%rootr_ft(ft,j) = cpatch%rootr_ft(ft,j)/cpatch%btran_ft(ft) + else + cpatch%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 + ccohort => cpatch%tallest + do while(associated(ccohort)) + pftgs(ccohort%pft) = pftgs(ccohort%pft) + ccohort%gscan * ccohort%n + ccohort => ccohort%shorter + enddo + + ! Process the boundary output, this is necessary for calculating the soil-moisture + ! sink term across the different layers in driver/host. Photosynthesis will + ! pass the host a total transpiration for the patch. This needs rootr to be + ! distributed over the soil layers. + + do j = 1,cp_numlevgrnd + bc_out(s)%rootr_pagl(ifp,j) = 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) + bc_out(s)%rootr_pagl(ifp,j) = bc_out(s)%rootr_pagl(ifp,j) + & + cpatch%rootr_ft(ft,j) * pftgs(ft)/sum(pftgs) + else + bc_out(s)%rootr_pagl(ifp,j) = bc_out(s)%rootr_pagl(ifp,j) + & + cpatch%rootr_ft(ft,j) * 1./numpft_ed + end if + enddo + enddo + + !weight patch level output BTRAN for the + bc_out(s)%btran_pa(ifp) = 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) + bc_out(s)%btran_pa(ifp) = bc_out(s)%btran_pa(ifp) + cpatch%btran_ft(ft) * pftgs(ft)/sum(pftgs) + else + bc_out(s)%btran_pa(ifp) = bc_out(s)%btran_pa(ifp) + cpatch%btran_ft(ft) * 1./numpft_ed + end if + enddo + + temprootr = sum(bc_out(s)%rootr_pagl(ifp,:)) + if(abs(1.0_r8-temprootr) > 1.0e-10_r8 .and. temprootr > 1.0e-10_r8)then + write(iulog,*) 'error with rootr in canopy fluxes',temprootr,sum(pftgs),sum(cpatch%rootr_ft(1:2,:),dim=2) + do j = 1,cp_numlevgrnd + bc_out(s)%rootr_pagl(ifp,j) = bc_out(s)%rootr_pagl(ifp,j)/temprootr + enddo + end if + + cpatch => cpatch%younger + end do + + + end do + + end associate + + end subroutine btran_ed + + ! ========================================================================================= !--------------------------------------------------------------------------------------- ! 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 +! 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) * cpatch%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.cpatch%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 +! 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) +! 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 +! 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 ! +! 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 +! +! cpatch%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 index 889c9054..4d2e924c 100644 --- a/biogeophys/EDPhotosynthesisMod.F90 +++ b/biogeophys/EDPhotosynthesisMod.F90 @@ -9,9 +9,16 @@ module EDPhotosynthesisMod ! ! !USES: ! + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_log_mod , only : errMsg => shr_log_errMsg + use abortutils , only : endrun + use clm_varctl , only : iulog implicit none private ! + + + ! PUBLIC MEMBER FUNCTIONS: public :: Photosynthesis_ED !ED specific photosynthesis routine !------------------------------------------------------------------------------ @@ -19,9 +26,9 @@ module EDPhotosynthesisMod 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) + subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) + + ! ! !DESCRIPTION: ! Leaf photosynthesis and stomatal conductance calculation as described by @@ -32,40 +39,28 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & 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_varpar , only : 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 EDTypesMod , only : numpft_ed, dinc_ed + use EDtypesMod , only : ed_patch_type, ed_cohort_type, ed_site_type, numpft_ed use EDEcophysContype , only : EDecophyscon + use FatesInterfaceMod , only : bc_in_type,bc_out_type + use EDtypesMod , only : numpatchespercol, cp_nlevcan, cp_nclmax + use EDCanopyStructureMod,only: calc_areaindex + + ! ! !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 + integer,intent(in) :: nsites + type(ed_site_type),intent(inout),target :: sites(nsites) + type(bc_in_type),intent(in) :: bc_in(nsites) + type(bc_out_type),intent(inout) :: bc_out(nsites) + real(r8),intent(in) :: dtime + ! ! !CALLED FROM: ! subroutine CanopyFluxes @@ -75,25 +70,31 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & type (ed_cohort_type), pointer :: currentCohort ! integer , parameter :: psn_type = 2 !c3 or c4. + + logical :: DEBUG = .false. + ! ! 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) :: vcmax_z(cp_nclmax,mxpft,cp_nlevcan) ! maximum rate of carboxylation (umol co2/m**2/s) + real(r8) :: jmax_z(cp_nclmax,mxpft,cp_nlevcan) ! maximum electron transport rate (umol electrons/m**2/s) + real(r8) :: tpu_z(cp_nclmax,mxpft,cp_nlevcan) ! triose phosphate utilization rate (umol CO2/m**2/s) + real(r8) :: kp_z(cp_nclmax,mxpft,cp_nlevcan) ! initial slope of CO2 response curve (C4 plants) + real(r8) :: lmr_z(cp_nclmax,mxpft,cp_nlevcan) ! initial slope of CO2 response curve (C4 plants) + real(r8) :: rs_z(cp_nclmax,mxpft,cp_nlevcan) ! stomatal resistance s/m + real(r8) :: gs_z(cp_nclmax,mxpft,cp_nlevcan) ! stomatal conductance m/s + + real(r8) :: ci(cp_nclmax,mxpft,cp_nlevcan) ! 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) :: kc( numpatchespercol ) ! Michaelis-Menten constant for CO2 (Pa) + real(r8) :: ko( numpatchespercol ) ! Michaelis-Menten constant for O2 (Pa) + real(r8) :: co2_cp( numpatchespercol ) ! CO2 compensation point (Pa) + + ! --------------------------------------------------------------- + ! TO-DO: bbbopt is slated to be transferred to the parameter file + ! ---------------------------------------------------------------- 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) @@ -142,7 +143,7 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & 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 :: c,CL,f,s,iv,j,ps,ft,ifp ! 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] @@ -173,9 +174,9 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & 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) :: ag(cp_nclmax,mxpft,cp_nlevcan) ! co-limited gross leaf photosynthesis (umol CO2/m**2/s) + real(r8) :: an(cp_nclmax,mxpft,cp_nlevcan) ! net leaf photosynthesis (umol CO2/m**2/s) + real(r8) :: an_av(cp_nclmax,mxpft,cp_nlevcan) ! 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 @@ -192,24 +193,8 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & 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] + real(r8) :: rscanopy + real(r8) :: elai associate( & c3psn => pftcon%c3psn , & ! photosynthetic pathway: 0. = c4, 1. = c3 @@ -218,26 +203,7 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & 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() + bb_slope => EDecophyscon%BB_slope ) ! slope of BB relationship ! Assign local pointers to derived type members (gridcell-level) dr(1) = 0.025_r8; dr(2) = 0.015_r8 @@ -287,10 +253,10 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & tpuse = 490._r8 lmrse = 490._r8 - vcmaxc = fth25(vcmaxhd, vcmaxse) - jmaxc = fth25(jmaxhd, jmaxse) - tpuc = fth25(tpuhd, tpuse) - lmrc = fth25(lmrhd, lmrse) + vcmaxc = fth25_f(vcmaxhd, vcmaxse) + jmaxc = fth25_f(jmaxhd, jmaxse) + tpuc = fth25_f(tpuhd, tpuse) + lmrc = fth25_f(lmrhd, lmrse) ! Miscellaneous parameters, from Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 @@ -301,248 +267,240 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & 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 + do s = 1,nsites + + ifp = 0 + currentpatch => sites(s)%oldest_patch + do while (associated(currentpatch)) + ifp = ifp+1 + + bc_out(s)%psncanopy_pa(ifp) = 0._r8 + bc_out(s)%lmrcanopy_pa(ifp) = 0._r8 + bc_out(s)%rssun_pa(ifp) = 0._r8 + bc_out(s)%rssha_pa(ifp) = 0._r8 + bc_out(s)%gccanopy_pa(ifp) = 0._r8 + + ! Patch level filter flag for photosynthesis calculations + ! has a short memory, flags: + ! 1 = patch has not been called + ! 2 = patch is currently marked for photosynthesis + ! 3 = patch has been called for photosynthesis at least once + if(bc_in(s)%filter_photo_pa(ifp)==2)then + + 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,cp_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 + - ! Leaf maintenance respiration to match the base rate used in CN - ! but with the new temperature functions for C3 and C4 plants. + ! kc, ko, currentPatch, from: Bernacchi et al (2001) Plant, Cell and Environment 24:253-259 ! - ! 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) + ! kc25 = 404.9 umol/mol + ! ko25 = 278.4 mmol/mol + ! cp25 = 42.75 umol/mol ! - ! Base rate is at 20C. Adjust to 25C using the CN Q10 = 1.5 + ! 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 ! - ! 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 + kc25 = (404.9_r8 / 1.e06_r8) * bc_in(s)%forc_pbot + ko25 = (278.4_r8 / 1.e03_r8) * bc_in(s)%forc_pbot + sco = 0.5_r8 * 0.209_r8 / (42.75_r8 / 1.e06_r8) + cp25 = 0.5_r8 * bc_in(s)%oair_pa(ifp) / sco + + if(bc_in(s)%t_veg_pa(ifp).gt.150_r8.and.bc_in(s)%t_veg_pa(ifp).lt.350_r8)then + kc(ifp) = kc25 * ft1_f(bc_in(s)%t_veg_pa(ifp), kcha) + ko(ifp) = ko25 * ft1_f(bc_in(s)%t_veg_pa(ifp), koha) + co2_cp(ifp) = cp25 * ft1_f(bc_in(s)%t_veg_pa(ifp), cpha) + else + kc(ifp) = 1 + ko(ifp) = 1 + co2_cp(ifp) = 1 + end if - !==============================================================================! - ! Calculate Nitrogen scaling factors and photosynthetic parameters. - !==============================================================================! - do CL = 1, NCL_p - do FT = 1,numpft_ed + end if + + currentpatch => currentpatch%younger + 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 + + ifp = 0 + currentpatch => sites(s)%oldest_patch + do while (associated(currentpatch)) + ifp = ifp+1 + + if(bc_in(s)%filter_photo_pa(ifp)==2)then + + NCL_p = currentPatch%NCL_p + + do FT = 1,numpft_ed !calculate patch and pft specific propserties at canopy top. + + if (nint(c3psn(FT)) == 1)then + ps = 1 + else + ps = 2 + end if + bbb(FT) = max (bbbopt(ps)*currentPatch%btran_ft(FT), 1._r8) - 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 + ! THIS CALL APPEARS TO BE REDUNDANT WITH LINE 650 (RGK) + if (nint(c3psn(FT)) == 1)then + ci(:,FT,:) = 0.7_r8 * bc_in(s)%cair_pa(ifp) + else + ci(:,FT,:) = 0.4_r8 * bc_in(s)%cair_pa(ifp) + end if - 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 + ! 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) = 1.67_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 (bc_in(s)%dayl_factor_pa(ifp) == 0._r8) then + kn(FT) = 0._r8 + else + kn(FT) = exp(0.00963_r8 * vcmax25top(FT) - 2.43_r8) + end if - ! Loop through canopy layers (above snow). Respiration needs to be - ! calculated every timestep. Others are calculated only if daytime + ! 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) - 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 + 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,cp_nclmax + currentPatch%present(CL,FT) = 1 end if + enddo - ! Scale for leaf nitrogen profile - nscaler = exp(-kn(FT) * laican) - - - ! Maintenance respiration: umol CO2 / m**2 [leaf] / s - lmr25 = lmr25top(FT) * nscaler + if(currentPatch%present(CL,FT) == 1)then ! are there any leaves of this pft in this layer? - if (nint(c3psn(FT)) == 1)then - lmr_z(CL,FT,iv) = lmr25 * ft1(t_veg(p), lmrha) * fth(t_veg(p), lmrhd, lmrse, lmrc) + if(CL==NCL_p)then !are we in the top canopy layer or a shaded layer? + laican = 0._r8 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)) )) + 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) - 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)) )) + + ! 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_f(bc_in(s)%t_veg_pa(ifp), lmrha) * & + fth_f(bc_in(s)%t_veg_pa(ifp), lmrhd, lmrse, lmrc) + else + lmr_z(CL,FT,iv) = lmr25 * 2._r8**((bc_in(s)%t_veg_pa(ifp)-(tfrz+25._r8))/10._r8) + lmr_z(CL,FT,iv) = lmr_z(CL,FT,iv) / (1._r8 + exp( 1.3_r8*(bc_in(s)%t_veg_pa(ifp)-(tfrz+55._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. + + 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_f(bc_in(s)%t_veg_pa(ifp), vcmaxha) * & + fth_f(bc_in(s)%t_veg_pa(ifp), vcmaxhd, vcmaxse, vcmaxc) + jmax_z(CL,FT,iv) = jmax25 * ft1_f(bc_in(s)%t_veg_pa(ifp), jmaxha) * & + fth_f(bc_in(s)%t_veg_pa(ifp), jmaxhd, jmaxse, jmaxc) + tpu_z(CL,FT,iv) = tpu25 * ft1_f(bc_in(s)%t_veg_pa(ifp), tpuha) * & + fth_f(bc_in(s)%t_veg_pa(ifp), tpuhd, tpuse, tpuc) + + if (nint(c3psn(FT)) /= 1) then + vcmax_z(CL,FT,iv) = vcmax25 * 2._r8**((bc_in(s)%t_veg_pa(ifp)-(tfrz+25._r8))/10._r8) + vcmax_z(CL,FT,iv) = vcmax_z(CL,FT,iv) / (1._r8 + & + exp( 0.2_r8*((tfrz+15._r8)-bc_in(s)%t_veg_pa(ifp)) )) + vcmax_z(CL,FT,iv) = vcmax_z(CL,FT,iv) / (1._r8 + & + exp( 0.3_r8*(bc_in(s)%t_veg_pa(ifp)-(tfrz+40._r8)) )) + end if + kp_z(CL,FT,iv) = kp25 * 2._r8**((bc_in(s)%t_veg_pa(ifp)-(tfrz+25._r8))/10._r8) !q10 response of product limited psn. end if ! Adjust for soil water:(umol co2/m**2/s) @@ -564,13 +522,14 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & ! 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) + cf = bc_in(s)%forc_pbot/(rgas*1.e-3_r8*bc_in(s)%tgcm_pa(ifp))*1.e06_r8 + gb = 1._r8/bc_in(s)%rb_pa(ifp) 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(bc_in(s)%eair_pa(ifp), 0.05_r8*bc_in(s)%esat_tv_pa(ifp)), bc_in(s)%esat_tv_pa(ifp) ) - 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 @@ -581,7 +540,9 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & 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 ( DEBUG ) write(iulog,*) 'EDphoto 581 ',currentPatch%ed_parsun_z(CL,ft,iv) if (currentPatch%ed_parsun_z(CL,FT,iv) <= 0._r8) then ! night time + ac = 0._r8 aj = 0._r8 ap = 0._r8 @@ -591,10 +552,16 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & 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 ( DEBUG ) write(iulog,*) 'EDphot 594 ',currentPatch%ed_laisun_z(CL,ft,iv) + if ( DEBUG ) write(iulog,*) 'EDphot 595 ',currentPatch%ed_laisha_z(CL,ft,iv) + if(currentPatch%ed_laisun_z(CL,ft,iv)+currentPatch%ed_laisha_z(cl,ft,iv) > 0._r8)then + + if ( DEBUG ) write(iulog,*) '600 in laisun, laisha loop ' + !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. @@ -629,14 +596,16 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & aquad = theta_psii bquad = -(qabs + jmax_z(cl,ft,iv)) cquad = qabs * jmax_z(cl,ft,iv) - call quadratic (aquad, bquad, cquad, r1, r2) + call quadratic_f (aquad, bquad, cquad, r1, r2) je = min(r1,r2) ! Iterative loop for ci beginning with initial guess + ! THIS CALL APPEARS TO BE REDUNDANT WITH LINE 423 (RGK) + if (nint(c3psn(FT)) == 1)then - ci(cl,ft,iv) = 0.7_r8 * cair(p) + ci(cl,ft,iv) = 0.7_r8 * bc_in(s)%cair_pa(ifp) else - ci(cl,ft,iv) = 0.4_r8 * cair(p) + ci(cl,ft,iv) = 0.4_r8 * bc_in(s)%cair_pa(ifp) end if niter = 0 @@ -651,10 +620,10 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & ! 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))) + ac = vcmax_z(cl,ft,iv) * max(ci(cl,ft,iv)-co2_cp(ifp), 0._r8) / (ci(cl,ft,iv)+kc(ifp)* & + (1._r8+bc_in(s)%oair_pa(ifp)/ko(ifp))) ! 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)) + aj = je * max(ci(cl,ft,iv)-co2_cp(ifp), 0._r8) / (4._r8*ci(cl,ft,iv)+8._r8*co2_cp(ifp)) ! C3: Product-limited photosynthesis ap = 3._r8 * tpu_z(cl,ft,iv) else @@ -678,19 +647,19 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & end if ! C4: PEP carboxylase-limited (CO2-limited) - ap = kp_z(cl,ft,iv) * max(ci(cl,ft,iv), 0._r8) / forc_pbot(c) + ap = kp_z(cl,ft,iv) * max(ci(cl,ft,iv), 0._r8) / bc_in(s)%forc_pbot 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) + call quadratic_f (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) + call quadratic_f (aquad, bquad, cquad, r1, r2) ag(cl,ft,iv) = min(r1,r2) ! Net carbon assimilation. Exit iteration if an < 0 @@ -702,23 +671,24 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & ! 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 = bc_in(s)%cair_pa(ifp) - 1.4_r8/gb_mol * an(cl,ft,iv) * bc_in(s)%forc_pbot 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) + bquad = cs*(gb_mol - bbb(FT)) - bb_slope(ft)*an(cl,ft,iv)*bc_in(s)%forc_pbot + cquad = -gb_mol*(cs*bbb(FT) + & + bb_slope(ft)*an(cl,ft,iv)*bc_in(s)%forc_pbot*ceair/bc_in(s)%esat_tv_pa(ifp)) + call quadratic_f (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) * & + ci(cl,ft,iv) = bc_in(s)%cair_pa(ifp) - an(cl,ft,iv) * bc_in(s)%forc_pbot * & (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 + if ((abs(ci(cl,ft,iv)-ciold)/bc_in(s)%forc_pbot*1.e06_r8 <= 2.e-06_r8) .or. niter == 5) then exitloop = 1 end if end do !iteration loop @@ -729,13 +699,17 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & 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 = bc_in(s)%cair_pa(ifp) - 1.4_r8/gb_mol * an(cl,ft,iv) * bc_in(s)%forc_pbot 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) + ci(cl,ft,iv) = bc_in(s)%cair_pa(ifp) - & + an(cl,ft,iv) * bc_in(s)%forc_pbot * (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 + if ( DEBUG ) write(iulog,*) 'EDPhoto 737 ', currentPatch%psn_z(cl,ft,iv) + if ( DEBUG ) write(iulog,*) 'EDPhoto 738 ', ag(cl,ft,iv) + if ( DEBUG ) write(iulog,*) 'EDPhoto 739 ', currentPatch%f_sun(cl,ft,iv) + !accumulate total photosynthesis umol/m2 ground/s-1. weight per unit sun and sha leaves. if(sunsha == 1)then !sunlit @@ -757,16 +731,20 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & end if + if ( DEBUG ) write(iulog,*) 'EDPhoto 758 ', currentPatch%psn_z(cl,ft,iv) + if ( DEBUG ) write(iulog,*) 'EDPhoto 759 ', ag(cl,ft,iv) + if ( DEBUG ) write(iulog,*) 'EDPhoto 760 ', currentPatch%f_sun(cl,ft,iv) + ! 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__)) + write (iulog,*)'ifp,iv,gs_mol= ',ifp,iv,gs_mol + call endrun(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) + hs = (gb_mol*ceair + gs_mol*bc_in(s)%esat_tv_pa(ifp)) / ((gb_mol+gs_mol)*bc_in(s)%esat_tv_pa(ifp)) + gs_mol_err = bb_slope(ft)*max(an(cl,ft,iv), 0._r8)*hs/cs*bc_in(s)%forc_pbot + bbb(FT) if (abs(gs_mol-gs_mol_err) > 1.e-01_r8) then write (iulog,*) 'CF: Ball-Berry error check - stomatal conductance error:' @@ -776,16 +754,19 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & 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) + else !No leaf area. This layer is present only because of stems. (leaves are off, or have reduced to 0 + currentPatch%psn_z(cl,ft,iv) = 0._r8 + rs_z(CL,FT,iv) = min(rsmax0, 1._r8/bbb(FT) * cf) + 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 !==============================================================================! @@ -797,11 +778,15 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & 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 + currentCohort%npp_tstep = 0.0_r8 + currentCohort%resp_tstep = 0.0_r8 + currentCohort%gpp_tstep = 0.0_r8 + currentCohort%rd = 0.0_r8 + currentCohort%resp_m = 0.0_r8 ! Select canopy layer and PFT. FT = currentCohort%pft !are we going to have ftindex? @@ -811,38 +796,57 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & !------------------------------------------------------------------------------ ! 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 + if ( DEBUG ) write(iulog,*) 'EDPhoto 816 ', currentCohort%gpp_tstep + if ( DEBUG ) write(iulog,*) 'EDPhoto 817 ', currentPatch%psn_z(cl,ft,1:currentCohort%nv-1) + if ( DEBUG ) write(iulog,*) 'EDPhoto 818 ', cl + if ( DEBUG ) write(iulog,*) 'EDPhoto 819 ', ft + if ( DEBUG ) write(iulog,*) 'EDPhoto 820 ', currentCohort%nv + if ( DEBUG ) write(iulog,*) 'EDPhoto 821 ', currentPatch%elai_profile(cl,ft,1:currentCohort%nv-1) + + if (currentCohort%nv > 1) then !is there canopy, and are the leaves on? - currentCohort%gpp_clm = sum(currentPatch%psn_z(cl,ft,1:currentCohort%nv-1) * & + currentCohort%gpp_tstep = 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%gscan = sum((1.0_r8/(rs_z(cl,ft,1:currentCohort%nv-1)+bc_in(s)%rb_pa(ifp)))) * 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 + currentCohort%gpp_tstep = 0.0_r8 + currentCohort%rd = 0.0_r8 + currentCohort%gscan = 0.0_r8 + currentCohort%ts_net_uptake(:) = 0.0_r8 end if + if ( DEBUG ) write(iulog,*) 'EDPhoto 832 ', currentCohort%gpp_tstep + 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 + gs_cohort = 1.0_r8/(rs_z(cl,ft,currentCohort%nv)+bc_in(s)%rb_pa(ifp))*laifrac*tree_area currentCohort%gscan = currentCohort%gscan+gs_cohort - currentCohort%gpp_clm = currentCohort%gpp_clm + currentPatch%psn_z(cl,ft,currentCohort%nv) * & + if ( DEBUG ) then + write(iulog,*) 'EDPhoto 868 ', currentCohort%gpp_tstep + write(iulog,*) 'EDPhoto 869 ', currentPatch%psn_z(cl,ft,currentCohort%nv) + write(iulog,*) 'EDPhoto 870 ', currentPatch%elai_profile(cl,ft,currentCohort%nv) + write(iulog,*) 'EDPhoto 871 ', laifrac + write(iulog,*) 'EDPhoto 872 ', tree_area + write(iulog,*) 'EDPhoto 873 ', currentCohort%nv, cl, ft + endif + + currentCohort%gpp_tstep = currentCohort%gpp_tstep + currentPatch%psn_z(cl,ft,currentCohort%nv) * & currentPatch%elai_profile(cl,ft,currentCohort%nv) * laifrac * tree_area + + if ( DEBUG ) write(iulog,*) 'EDPhoto 843 ', currentCohort%rd + 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. @@ -864,12 +868,17 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & currentCohort%livestem_mr = 0._r8 currentCohort%livecroot_mr = 0._r8 + + if ( DEBUG ) write(iulog,*) 'EDPhoto 874 ', currentCohort%livecroot_mr + if ( DEBUG ) write(iulog,*) 'EDPhoto 875 ', currentCohort%livecrootn + if (woody(FT) == 1) then - tc = q10**((t_veg(p)-tfrz - 20.0_r8)/10.0_r8) + tc = q10**((bc_in(s)%t_veg_pa(ifp)-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 + ! TODO: CHANGE THAT 1000 to 1000.0_r8 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! currentCohort%livestem_mr = currentCohort%livestem_mr /1000 currentCohort%livecroot_mr = currentCohort%livecroot_mr /1000 else @@ -888,7 +897,7 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & currentCohort%froot_mr = 0._r8 do j = 1,nlevsoi - tcsoi = q10**((t_soisno(c,j)-tfrz - 20.0_r8)/10.0_r8) + tcsoi = q10**((bc_in(s)%t_soisno_gl(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) @@ -896,11 +905,16 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & 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 + + if ( DEBUG ) write(iulog,*) 'EDPhoto 904 ', currentCohort%resp_m + if ( DEBUG ) write(iulog,*) 'EDPhoto 905 ', currentCohort%rd + if ( DEBUG ) write(iulog,*) 'EDPhoto 906 ', currentCohort%livestem_mr + if ( DEBUG ) write(iulog,*) 'EDPhoto 907 ', currentCohort%livecroot_mr + if ( DEBUG ) write(iulog,*) 'EDPhoto 908 ', currentCohort%froot_mr + + currentCohort%gpp_tstep = currentCohort%gpp_tstep * 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)) @@ -908,10 +922,15 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & ! 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 + currentCohort%gpp_tstep = currentCohort%gpp_tstep * dtime + + if ( DEBUG ) write(iulog,*) 'EDPhoto 911 ', currentCohort%gpp_tstep + if ( DEBUG ) write(iulog,*) 'EDPhoto 912 ', currentCohort%resp_tstep + if ( DEBUG ) write(iulog,*) 'EDPhoto 913 ', currentCohort%resp_m + + currentCohort%resp_g = ED_val_grperc(1) * (max(0._r8,currentCohort%gpp_tstep - currentCohort%resp_m)) + currentCohort%resp_tstep = currentCohort%resp_m + currentCohort%resp_g ! kgC/indiv/ts + currentCohort%npp_tstep = currentCohort%gpp_tstep - currentCohort%resp_tstep ! kgC/indiv/ts !------------------------------------------------------------------------------ ! Remove whole plant respiration from net uptake. (kgC/indiv/ts) @@ -923,50 +942,180 @@ subroutine Photosynthesis_ED (bounds, fn, filterp, esat_tv, eair, oair, cair, & ! + currentCohort%froot_mr))/(currentCohort%treelai*currentCohort%c_area/currentCohort%n) ! enddo else !lai<0 - currentCohort%gpp_clm = 0._r8 + currentCohort%gpp_tstep = 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%gpp_tstep = 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 + bc_out(s)%psncanopy_pa(ifp) = bc_out(s)%psncanopy_pa(ifp) + currentCohort%gpp_tstep + bc_out(s)%lmrcanopy_pa(ifp) = bc_out(s)%lmrcanopy_pa(ifp) + 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 + bc_out(s)%gccanopy_pa(ifp) = bc_out(s)%gccanopy_pa(ifp) + 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. + + + elai = calc_areaindex(currentPatch,'elai') + + bc_out(s)%psncanopy_pa(ifp) = bc_out(s)%psncanopy_pa(ifp) / currentPatch%area + bc_out(s)%lmrcanopy_pa(ifp) = bc_out(s)%lmrcanopy_pa(ifp) / currentPatch%area + if(bc_out(s)%gccanopy_pa(ifp) > 1._r8/rsmax0 .and. elai > 0.0_r8)then + rscanopy = (1.0_r8/bc_out(s)%gccanopy_pa(ifp))-bc_in(s)%rb_pa(ifp)/elai ! this needs to be resistance per unit leaf area. else - rscanopy(p) = rsmax0 + rscanopy = rsmax0 end if - gccanopy(p) = 1.0_r8/rscanopy(p) *cf /1000 !convert into umol m02 s-1 then mmol m-2 s-1. + bc_out(s)%rssun_pa(ifp) = rscanopy + bc_out(s)%rssha_pa(ifp) = rscanopy + bc_out(s)%gccanopy_pa(ifp) = 1.0_r8/rscanopy*cf/1000 !convert into umol m02 s-1 then mmol m-2 s-1. + end if + + currentPatch => currentPatch%younger + + end do + + end do !site loop + + end associate + +end subroutine Photosynthesis_ED + +! ======================================================================================= + +function ft1_f(tl, ha) result(ans) + ! + !!DESCRIPTION: + ! photosynthesis temperature response + ! + ! !REVISION HISTORY + ! Jinyun Tang separated it out from Photosynthesis, Feb. 07/2013 + ! 7/23/16: Copied over from CLM by Ryan Knox + ! + !!USES + use clm_varcon , only : rgas, tfrz + ! + ! !ARGUMENTS: + real(r8), intent(in) :: tl ! leaf temperature in photosynthesis temperature function (K) + real(r8), intent(in) :: ha ! activation energy in photosynthesis temperature function (J/mol) + ! + ! !LOCAL VARIABLES: + real(r8) :: ans + !------------------------------------------------------------------------------- - else !EDpatch + ans = exp( ha / (rgas*1.e-3_r8*(tfrz+25._r8)) * (1._r8 - (tfrz+25._r8)/tl) ) - rscanopy(p) = rsmax0 + return + end function ft1_f - end if !edpatch + ! ===================================================================================== + + function fth_f(tl,hd,se,scaleFactor) result(ans) + ! + !!DESCRIPTION: + !photosynthesis temperature inhibition + ! + ! !REVISION HISTORY + ! Jinyun Tang separated it out from Photosynthesis, Feb. 07/2013 + ! 7/23/16: Copied over from CLM by Ryan Knox + ! + use clm_varcon , only : rgas, tfrz + ! + ! !ARGUMENTS: + real(r8), intent(in) :: tl ! leaf temperature in photosynthesis temperature function (K) + real(r8), intent(in) :: hd ! deactivation energy in photosynthesis temperature function (J/mol) + real(r8), intent(in) :: se ! entropy term in photosynthesis temperature function (J/mol/K) + real(r8), intent(in) :: scaleFactor ! scaling factor for high temperature inhibition (25 C = 1.0) + ! + ! !LOCAL VARIABLES: + real(r8) :: ans + !------------------------------------------------------------------------------- - call t_stopf('edfluxunpack3') - call t_stopf('edunpack') + ans = scaleFactor / ( 1._r8 + exp( (-hd+se*tl) / (rgas*1.e-3_r8*tl) ) ) - end do !patch loop + return + end function fth_f - end associate + ! ===================================================================================== - end subroutine Photosynthesis_ED + function fth25_f(hd,se)result(ans) + ! + !!DESCRIPTION: + ! scaling factor for photosynthesis temperature inhibition + ! + ! !REVISION HISTORY: + ! Jinyun Tang separated it out from Photosynthesis, Feb. 07/2013 + ! 7/23/16: Copied over from CLM by Ryan Knox + ! + !!USES + use clm_varcon , only : rgas, tfrz + ! + ! !ARGUMENTS: + real(r8), intent(in) :: hd ! deactivation energy in photosynthesis temperature function (J/mol) + real(r8), intent(in) :: se ! entropy term in photosynthesis temperature function (J/mol/K) + ! + ! !LOCAL VARIABLES: + real(r8) :: ans + !------------------------------------------------------------------------------- + + ans = 1._r8 + exp( (-hd+se*(tfrz+25._r8)) / (rgas*1.e-3_r8*(tfrz+25._r8)) ) + + return + end function fth25_f + + ! ===================================================================================== + + subroutine quadratic_f (a, b, c, r1, r2) + ! + ! !DESCRIPTION: + !==============================================================================! + !----------------- Solve quadratic equation for its two roots -----------------! + !==============================================================================! + ! Solution from Press et al (1986) Numerical Recipes: The Art of Scientific + ! Computing (Cambridge University Press, Cambridge), pp. 145. + ! + ! !REVISION HISTORY: + ! 4/5/10: Adapted from /home/bonan/ecm/psn/An_gs_iterative.f90 by Keith Oleson + ! 7/23/16: Copied over from CLM by Ryan Knox + ! + ! !USES: + implicit none + ! + ! !ARGUMENTS: + real(r8), intent(in) :: a,b,c ! Terms for quadratic equation + real(r8), intent(out) :: r1,r2 ! Roots of quadratic equation + ! + ! !LOCAL VARIABLES: + real(r8) :: q ! Temporary term for quadratic solution + !------------------------------------------------------------------------------ + + if (a == 0._r8) then + write (iulog,*) 'Quadratic solution error: a = ',a + call endrun(msg=errmsg(__FILE__, __LINE__)) + end if + + if (b >= 0._r8) then + q = -0.5_r8 * (b + sqrt(b*b - 4._r8*a*c)) + else + q = -0.5_r8 * (b - sqrt(b*b - 4._r8*a*c)) + end if + + r1 = q / a + if (q /= 0._r8) then + r2 = c / q + else + r2 = 1.e36_r8 + end if + + end subroutine quadratic_f end module EDPhotosynthesisMod diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index 868bd984..c4bdd45d 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -1,940 +1,1097 @@ -module EDSurfaceAlbedoMod +module EDSurfaceRadiationMod + + !------------------------------------------------------------------------------------- + ! EDSurfaceRadiation + ! + ! This module contains function and type definitions for all things related + ! to radiative transfer in ED modules at the land surface. + ! + !------------------------------------------------------------------------------------- #include "shr_assert.h" - - !----------------------------------------------------------------------- - ! !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 - + + use EDtypesMod , only : ed_patch_type, ed_site_type + use EDtypesMod , only : numpft_ed + use EDtypesMod , only : numPatchesPerCol + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_log_mod , only : errMsg => shr_log_errMsg + use FatesInterfaceMod , only : bc_in_type, & + bc_out_type + use EDTypesMod , only : cp_numSWb, & ! Actual number of SW radiation bands + cp_maxSWb, & ! maximum number of SW bands (for scratch) + cp_nclmax ! control parameter, number of SW bands + use EDCanopyStructureMod, only: calc_areaindex + + 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: - !----------------------------------------------------------------------- + public :: ED_SunShadeFracs + + logical :: DEBUG = .false. ! for debugging this module + + real(r8), public :: albice(cp_maxSWb) = & ! albedo land ice by waveband (1=vis, 2=nir) + (/ 0.80_r8, 0.55_r8 /) + + ! INTERF-TODO: THIS NEEDS SOME CONSISTENCY AND SHOULD BE SET IN THE INTERFACE + ! WITH OTHER DIMENSIONS + integer, parameter :: ipar = 1 ! The band index for PAR contains + + subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) + ! - !----------------------------------------------------------------------- - 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 + ! + ! !USES: + use clm_varctl , only : iulog + use pftconMod , only : pftcon + use EDtypesMod , only : ed_patch_type, numpft_ed, cp_nlevcan + use EDTypesMod , only : ed_site_type + + + ! !ARGUMENTS: + + integer, intent(in) :: nsites + type(ed_site_type), intent(inout), target :: sites(nsites) ! FATES site vector + type(bc_in_type), intent(in) :: bc_in(nsites) + type(bc_out_type), intent(inout) :: bc_out(nsites) + + + ! !LOCAL VARIABLES: ! ============================================================================ - ! 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) + ! ED/NORMAN RADIATION DECS + ! ============================================================================ + type (ed_patch_type) , pointer :: currentPatch + integer :: radtype, L, ft, j, ifp + 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(cp_nclmax,numpft_ed,cp_nlevcan) + real(r8) :: k_dir(numpft_ed) ! Direct beam extinction coefficient + real(r8) :: tr_dir_z(cp_nclmax,numpft_ed,cp_nlevcan) ! Exponential transmittance of direct beam radiation through a single layer + real(r8) :: tr_dif_z(cp_nclmax,numpft_ed,cp_nlevcan) ! Exponential transmittance of diffuse radiation through a single layer + real(r8) :: forc_dir(numPatchesPerCol,cp_maxSWb) + real(r8) :: forc_dif(numPatchesPerCol,cp_maxSWb) + real(r8) :: weighted_dir_tr(cp_nclmax) + real(r8) :: weighted_fsun(cp_nclmax) + real(r8) :: weighted_dif_ratio(cp_nclmax,cp_maxSWb) + real(r8) :: weighted_dif_down(cp_nclmax) + real(r8) :: weighted_dif_up(cp_nclmax) + real(r8) :: refl_dif(cp_nclmax,numpft_ed,cp_nlevcan,cp_maxSWb) ! Term for diffuse radiation reflected by laye + real(r8) :: tran_dif(cp_nclmax,numpft_ed,cp_nlevcan,cp_maxSWb) ! Term for diffuse radiation transmitted by layer + real(r8) :: dif_ratio(cp_nclmax,numpft_ed,cp_nlevcan,cp_maxSWb) ! Ratio of upward to forward diffuse fluxes + real(r8) :: Dif_dn(cp_nclmax,numpft_ed,cp_nlevcan) ! Forward diffuse flux onto canopy layer J (W/m**2 ground area) + real(r8) :: Dif_up(cp_nclmax,numpft_ed,cp_nlevcan) ! Upward diffuse flux above canopy layer J (W/m**2 ground area) + real(r8) :: lai_change(cp_nclmax,numpft_ed,cp_nlevcan) ! Forward diffuse flux onto canopy layer J (W/m**2 ground area) + real(r8) :: f_not_abs(numpft_ed,cp_maxSWb) ! Fraction reflected + transmitted. 1-absorbtion. + real(r8) :: Abs_dir_z(numpft_ed,cp_nlevcan) + real(r8) :: Abs_dif_z(numpft_ed,cp_nlevcan) + real(r8) :: abs_rad(cp_maxSWb) !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(numPatchesPerCol,numpft_ed) ! Radiation transmitted to the soil surface. + real(r8) :: phi2b(numPatchesPerCol,numpft_ed) + real(r8) :: laisum ! cumulative lai+sai for canopy layer (at middle of layer) + real(r8) :: angle + + real(r8),parameter :: tolerance = 0.000000001_r8 + real(r8), parameter :: pi = 3.141592654 ! PI + + real(r8) :: denom + real(r8) :: lai_reduction(2) + + integer :: fp,iv,s ! array indices + integer :: ib ! waveband number + real(r8) :: cosz ! 0.001 <= coszen <= 1.000 + real(r8) :: chil(numPatchesPerCol) ! -0.4 <= xl <= 0.6 + real(r8) :: gdir(numPatchesPerCol) ! leaf projection in solar direction (0 to 1) + + !----------------------------------------------------------------------- + + 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 + +! albd => surfalb_inst%albd_patch , & ! Output: [real(r8) (:,:) ] surface albedo (direct) (USED IN LND2ATM,BALANCE_CHECK) +! albi => surfalb_inst%albi_patch , & ! Output: [real(r8) (:,:) ] surface albedo (diffuse) (LND2ATM,BALANCE_CHECK) +! fabd => surfalb_inst%fabd_patch , & ! Output: [real(r8) (:,:) ] flux absorbed by canopy per unit direct flux (BALANCE_CHECK) +! fabi => surfalb_inst%fabi_patch , & ! Output: [real(r8) (:,:) ] flux absorbed by canopy per unit diffuse flux (BALANCE_CHECK) +! ftdd => surfalb_inst%ftdd_patch , & ! Output: [real(r8) (:,:) ] down direct flux below canopy per unit direct flx (BALANCE_CHECK) +! ftid => surfalb_inst%ftid_patch , & ! Output: [real(r8) (:,:) ] down diffuse flux below canopy per unit direct flx (BALANCE_CHECK) +! ftii => surfalb_inst%ftii_patch , & ! Output: [real(r8) (:,:) ] down diffuse flux below canopy per unit diffuse flx (BALANCE_CHECK) + + ! ------------------------------------------------------------------------------- + ! TODO (mv, 2014-10-29) the filter here is different than below + ! this is needed to have the VOC's be bfb - this needs to be + ! re-examined int he future + ! RGK,2016-08-06: FATES is still incompatible with VOC emission module + ! ------------------------------------------------------------------------------- + + + do s = 1, nsites + + ifp = 0 + currentpatch => sites(s)%oldest_patch + do while (associated(currentpatch)) + ifp = ifp+1 + + currentPatch%f_sun (:,:,:) = 0._r8 + currentPatch%fabd_sun_z (:,:,:) = 0._r8 + currentPatch%fabd_sha_z (:,:,:) = 0._r8 + currentPatch%fabi_sun_z (:,:,:) = 0._r8 + currentPatch%fabi_sha_z (:,:,:) = 0._r8 + currentPatch%fabd (:) = 0._r8 + currentPatch%fabi (:) = 0._r8 + + if(bc_in(s)%filter_vegzen_pa(ifp))then + + weighted_dir_tr(:) = 0._r8 + weighted_dif_down(:) = 0._r8 + weighted_dif_up(:) = 0._r8 + bc_out(s)%albd_parb(ifp,:) = 0._r8 ! output HLM + bc_out(s)%albi_parb(ifp,:) = 0._r8 ! output HLM + bc_out(s)%fabi_parb(ifp,:) = 0._r8 ! output HLM + bc_out(s)%fabd_parb(ifp,:) = 0._r8 ! output HLM + 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 + bc_out(s)%ftdd_parb(ifp,:) = 1._r8 ! output HLM + bc_out(s)%ftid_parb(ifp,:) = 1._r8 ! output HLM + bc_out(s)%ftii_parb(ifp,:) = 1._r8 ! output HLM + + if (maxval(currentPatch%nrad(1,:))==0)then + !there are no leaf layers in this patch. it is effectively bare ground. + ! no radiation is absorbed + bc_out(s)%fabd_parb(ifp,:) = 0.0_r8 + bc_out(s)%fabi_parb(ifp,:) = 0.0_r8 + do ib = 1,cp_numSWb + bc_out(s)%albd_parb(ifp,ib) = bc_in(s)%albgr_dir_rb(ib) + bc_out(s)%albd_parb(ifp,ib) = bc_in(s)%albgr_dif_rb(ib) + bc_out(s)%ftdd_parb(ifp,ib)= 1.0_r8 + bc_out(s)%ftid_parb(ifp,ib)= 1.0_r8 + bc_out(s)%ftii_parb(ifp,ib)= 1.0_r8 + enddo + else + + ! Is this pft/canopy layer combination present in this patch? + do L = 1,cp_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 + + do radtype = 1,2 !do this once for one unit of diffuse, and once for one unit of direct radiation + do ib = 1,cp_numSWb + 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(ifp,ib) = 1.00_r8 + forc_dif(ifp,ib) = 0.00_r8 + else !dif + forc_dir(ifp,ib) = 0.00_r8 + forc_dif(ifp,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, bc_in(s)%coszen_pa(ifp)) !copied from previous radiation code... + do ft = 1,numpft_ed + sb = (90._r8 - (acos(cosz)*180/pi)) * (pi / 180._r8) + chil(ifp) = xl(ft) !min(max(xl(ft), -0.4_r8), 0.6_r8 ) + if (abs(chil(ifp)) <= 0.01_r8) then + chil(ifp) = 0.01_r8 + end if + phi1b(ifp,ft) = 0.5_r8 - 0.633_r8*chil(ifp) - 0.330_r8*chil(ifp)*chil(ifp) + phi2b(ifp,ft) = 0.877_r8 * (1._r8 - 2._r8*phi1b(ifp,ft)) !0 = horiz leaves, 1 - vert leaves. + gdir(ifp) = phi1b(ifp,ft) + phi2b(ifp,ft) * sin(sb) + !how much direct light penetrates a singleunit of lai? + k_dir(ft) = gdir(ifp) / 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:cp_numSWb) = 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(ifp) = phi1b(ifp,ft) + phi2b(ifp,ft) * sin(angle) !This line is redundant FIX(RF,032414). + tr_dif_z(L,ft,iv) = tr_dif_z(L,ft,iv) + exp(-gdir(ifp) / 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,cp_numSWb !vis, nir + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! Leaf scattering coefficient and terms do diffuse radiation reflected + ! and transmitted by a layer + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + f_not_abs(ft,ib) = rhol(ft,ib) + taul(ft,ib) !leaf level fraction NOT absorbed. + !tr_dif_z is a term that uses the LAI in each layer, whereas rhol and taul do not, + !because they are properties of leaf surfaces and not of the leaf matrix. + do iv = 1,currentPatch%nrad(L,ft) + !How much diffuse light is intercepted and then reflected? + refl_dif(L,ft,iv,ib) = (1._r8 - tr_dif_z(L,ft,iv)) * rhol(ft,ib) + !How much diffuse light in this layer is transmitted? + tran_dif(L,ft,iv,ib) = (1._r8 - tr_dif_z(L,ft,iv)) * taul(ft,ib) + tr_dif_z(L,ft,iv) + end do + + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! Ratio of upward to forward diffuse fluxes, dif_ratio + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! Soil diffuse reflectance (ratio of down to up radiation). + iv = currentPatch%nrad(L,ft) + 1 + if (L == currentPatch%NCL_p)then !nearest the soil + dif_ratio(L,ft,iv,ib) = bc_in(s)%albgr_dif_rb(ib) + else + dif_ratio(L,ft,iv,ib) = weighted_dif_ratio(L+1,ib) + end if + ! Canopy layers, working upwardfrom soil with dif_ratio(iv+1) known + ! FIX(RF,032414) ray tracing eqution - need to find derivation of this... + ! for each unit going down, there are x units going up. + do iv = currentPatch%nrad(L,ft),1, -1 + dif_ratio(L,ft,iv,ib) = dif_ratio(L,ft,iv+1,ib) * tran_dif(L,ft,iv,ib)*tran_dif(L,ft,iv,ib) / & + (1._r8 - dif_ratio(L,ft,iv+1,ib) * refl_dif(L,ft,iv,ib)) + refl_dif(L,ft,iv,ib) + dif_ratio(L,ft,iv,ib) = dif_ratio(L,ft,iv,ib) * ftweight(L,ft,iv)/ftweight(L,ft,1) + dif_ratio(L,ft,iv,ib) = dif_ratio(L,ft,iv,ib) + dif_ratio(L,ft,iv+1,ib)* & + (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) + end do + weighted_dif_ratio(L,ib) = weighted_dif_ratio(L,ib) + dif_ratio(L,ft,1,ib) * ftweight(L,ft,1) + !instance where the first layer ftweight is used a proxy for the whole column. FTWA + end do!cp_numSWb + endif ! currentPatch%present + end do!ft + end do!L + + do ib = 1,cp_numSWb + Dif_dn(:,:,:) = 0.00_r8 + Dif_up(:,:,:) = 0.00_r8 + do L = 1, currentPatch%NCL_p !work down from the top of the canopy. + weighted_dif_down(L) = 0._r8 + do ft = 1, numpft_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(ifp,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) =bc_in(s)%albgr_dif_rb(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) * bc_in(s)%albgr_dif_rb(ib) + !direct to diffuse + weighted_dif_up(L) = weighted_dif_up(L) + forc_dir(ifp,ib) * & + weighted_dir_tr(L-1) * (1.0-sum(ftweight(L,:,1)))*bc_in(s)%albgr_dir_rb(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(ifp,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(ifp,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 + 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) *bc_in(s)%albgr_dif_rb(ib) + & + forc_dir(ifp,ib) * tr_dir_z(L,ft,iv) *bc_in(s)%albgr_dir_rb(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(ifp,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) * bc_in(s)%albgr_dif_rb(ib) + weighted_dif_up(L) = weighted_dif_up(L) + forc_dir(ifp,ib) * & + weighted_dir_tr(L-1) * (1.0_r8-sum(ftweight(L,:,1)))*bc_in(s)%albgr_dir_rb(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(ifp,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 -bc_in(s)%albgr_dif_rb(ib)) + Abs_dir_z(ft,iv) = ftweight(L,ft,1)*forc_dir(ifp,ib) * & + tr_dir_z(L,ft,iv) * (1.0_r8 -bc_in(s)%albgr_dir_rb(ib)) + tr_soild = tr_soild + ftweight(L,ft,1)*forc_dir(ifp,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? + if (ib == 1) then ! only set the absorbed PAR for the visible light band. + do iv = 1, currentPatch%nrad(L,ft) + if (radtype==1) then + if ( DEBUG ) then + write(iulog,*) 'EDsurfAlb 730 ',Abs_dif_z(ft,iv),currentPatch%f_sun(L,ft,iv) + write(iulog,*) 'EDsurfAlb 731 ', currentPatch%fabd_sha_z(L,ft,iv), & + currentPatch%fabd_sun_z(L,ft,iv) + endif + currentPatch%fabd_sha_z(L,ft,iv) = Abs_dif_z(ft,iv) * & + (1._r8 - currentPatch%f_sun(L,ft,iv)) + currentPatch%fabd_sun_z(L,ft,iv) = Abs_dif_z(ft,iv) * & + currentPatch%f_sun(L,ft,iv) + & + Abs_dir_z(ft,iv) + else + currentPatch%fabi_sha_z(L,ft,iv) = Abs_dif_z(ft,iv) * & + (1._r8 - currentPatch%f_sun(L,ft,iv)) + currentPatch%fabi_sun_z(L,ft,iv) = Abs_dif_z(ft,iv) * & + currentPatch%f_sun(L,ft,iv) + endif + if ( DEBUG ) then + write(iulog,*) 'EDsurfAlb 740 ', currentPatch%fabd_sha_z(L,ft,iv), & + currentPatch%fabd_sun_z(L,ft,iv) + endif + end do + endif ! ib + + !==============================================================================! + ! Sum fluxes + !==============================================================================! + ! Solar radiation absorbed by ground + iv = currentPatch%nrad(L,ft) + 1 + if (L==currentPatch%NCL_p)then + abs_rad(ib) = abs_rad(ib) + (Abs_dir_z(ft,iv) + Abs_dif_z(ft,iv)) + end if + ! Solar radiation absorbed by vegetation and sunlit/shaded leaves + do iv = 1,currentPatch%nrad(L,ft) + if (radtype == 1)then + currentPatch%fabd(ib) = currentPatch%fabd(ib) + Abs_dir_z(ft,iv)+Abs_dif_z(ft,iv) + ! bc_out(s)%fabd_parb(ifp,ib) = currentPatch%fabd(ib) + else + currentPatch%fabi(ib) = currentPatch%fabi(ib) + Abs_dif_z(ft,iv) + ! bc_out(s)%fabi_parb(ifp,ib) = currentPatch%fabi(ib) + endif + end do + ! Albefor + if (L==1)then !top canopy layer. + if (radtype == 1)then + bc_out(s)%albd_parb(ifp,ib) = bc_out(s)%albd_parb(ifp,ib) + & + Dif_up(L,ft,1) * ftweight(L,ft,1) + else + bc_out(s)%albi_parb(ifp,ib) = bc_out(s)%albi_parb(ifp,ib) + & + Dif_up(L,ft,1) * ftweight(L,ft,1) + end if + end if + end if ! present + end do !ft + if (radtype == 1)then + bc_out(s)%fabd_parb(ifp,ib) = currentPatch%fabd(ib) + else + bc_out(s)%fabi_parb(ifp,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-bc_in(s)%albgr_dif_rb(ib)) + abs_rad(ib) = abs_rad(ib) + forc_dir(ifp,ib) * weighted_dir_tr(L-1) * & + (1.0_r8-sum(ftweight(L,:,1)))*(1.0_r8-bc_in(s)%albgr_dir_rb(ib)) + tr_soili = tr_soili + weighted_dif_down(L-1) * (1.0_r8-sum(ftweight(L,:,1))) + tr_soild = tr_soild + forc_dir(ifp,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) + bc_out(s)%ftdd_parb(ifp,ib) = tr_soild + bc_out(s)%ftid_parb(ifp,ib) = tr_soili + else + currentPatch%tr_soil_dif(ib) = tr_soili + currentPatch%sabs_dif(ib) = abs_rad(ib) + bc_out(s)%ftii_parb(ifp,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-bc_in(s)%albgr_dir_rb(ib)) + & + currentPatch%tr_soil_dir_dif(ib) * (1.0_r8-bc_in(s)%albgr_dif_rb(ib)))) + if ( abs(error) > 0.0001)then + write(iulog,*)'dir ground absorption error',ifp,s,error,currentPatch%sabs_dir(ib), & + currentPatch%tr_soil_dir(ib)* & + (1.0_r8-bc_in(s)%albgr_dir_rb(ib)),currentPatch%NCL_p,ib,sum(ftweight(1,:,1)) + write(iulog,*) 'albedos',currentPatch%sabs_dir(ib) ,currentPatch%tr_soil_dir(ib), & + (1.0_r8-bc_in(s)%albgr_dir_rb(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-bc_in(s)%albgr_dif_rb(ib)))) > 0.0001)then + write(iulog,*)'dif ground absorption error',ifp,s,currentPatch%sabs_dif(ib) , & + (currentPatch%tr_soil_dif(ib)* & + (1.0_r8-bc_in(s)%albgr_dif_rb(ib))),currentPatch%NCL_p,ib,sum(ftweight(1,:,1)) + endif + endif + + if (radtype == 1)then + error = (forc_dir(ifp,ib) + forc_dif(ifp,ib)) - & + (bc_out(s)%fabd_parb(ifp,ib) + bc_out(s)%albd_parb(ifp,ib) + currentPatch%sabs_dir(ib)) + else + error = (forc_dir(ifp,ib) + forc_dif(ifp,ib)) - & + (bc_out(s)%fabi_parb(ifp,ib) + bc_out(s)%albi_parb(ifp,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 + ! NO-OP + ! 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 + ! NO-OP + ! 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 + ! NO-OP + ! 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 + bc_out(s)%albd_parb(ifp,ib) = bc_out(s)%albd_parb(ifp,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 ,ifp,ib + write(iulog,*) 'diags', bc_out(s)%albd_parb(ifp,ib), bc_out(s)%ftdd_parb(ifp,ib), & + bc_out(s)%ftid_parb(ifp,ib), bc_out(s)%fabd_parb(ifp,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,*) 'bc_in(s)%albgr_dir_rb(ib)',bc_in(s)%albgr_dir_rb(ib) + + bc_out(s)%albd_parb(ifp,ib) = bc_out(s)%albd_parb(ifp,ib) + error + end if + else + + if (abs(error) > 1.e-9_r8 .and. abs(error) < 0.15_r8)then + bc_out(s)%albi_parb(ifp,ib) = bc_out(s)%albi_parb(ifp,ib) + error + end if + + if (abs(error) > 0.15_r8)then + write(iulog,*) '>5% Dif Radn consvn error',error ,ifp,ib + write(iulog,*) 'diags', bc_out(s)%albi_parb(ifp,ib), bc_out(s)%ftii_parb(ifp,ib), & + bc_out(s)%fabi_parb(ifp,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,*) 'bc_in(s)%albgr_dif_rb(ib)',bc_in(s)%albgr_dif_rb(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) + + bc_out(s)%albi_parb(ifp,ib) = bc_out(s)%albi_parb(ifp,ib) + error + end if + + if (radtype == 1)then + error = (forc_dir(ifp,ib) + forc_dif(ifp,ib)) - & + (bc_out(s)%fabd_parb(ifp,ib) + bc_out(s)%albd_parb(ifp,ib) + currentPatch%sabs_dir(ib)) + else + error = (forc_dir(ifp,ib) + forc_dif(ifp,ib)) - & + (bc_out(s)%fabi_parb(ifp,ib) + bc_out(s)%albi_parb(ifp,ib) + currentPatch%sabs_dif(ib)) + endif + + if (abs(error) > 0.00000001_r8)then + write(iulog,*) 'there is still error after correction',error ,ifp,ib + end if + + end if + + end do !cp_numSWb + + enddo ! rad-type + endif ! is there vegetation? + + end if ! if the vegetation and zenith filter is active + currentPatch => currentPatch%younger + end do ! Loop linked-list patches + enddo ! Loop Sites + + end associate + return + end subroutine ED_Norman_Radiation + + ! ====================================================================================== + + subroutine ED_SunShadeFracs(nsites, sites,bc_in,bc_out) + + use clm_varctl , only : iulog + + implicit none + + ! Arguments + integer,intent(in) :: nsites + type(ed_site_type),intent(inout),target :: sites(nsites) + type(bc_in_type),intent(in) :: bc_in(nsites) + type(bc_out_type),intent(inout) :: bc_out(nsites) + + + ! locals + type (ed_patch_type),pointer :: cpatch ! c"urrent" patch + real(r8) :: sunlai + real(r8) :: shalai + real(r8) :: elai + integer :: CL + integer :: FT + integer :: iv + integer :: s + integer :: ifp + + + do s = 1,nsites + + ifp = 0 + cpatch => sites(s)%oldest_patch + + do while (associated(cpatch)) + + ifp=ifp+1 + + if( DEBUG ) write(iulog,*) 'edsurfRad_5600',ifp,s,cpatch%NCL_p,numpft_ed + + ! zero out various datas + cpatch%ed_parsun_z(:,:,:) = 0._r8 + cpatch%ed_parsha_z(:,:,:) = 0._r8 + cpatch%ed_laisun_z(:,:,:) = 0._r8 + cpatch%ed_laisha_z(:,:,:) = 0._r8 + + bc_out(s)%fsun_pa(ifp) = 0._r8 + + sunlai = 0._r8 + shalai = 0._r8 + + ! Loop over patches to calculate laisun_z and laisha_z for each layer. + ! Derive canopy laisun, laisha, and fsun from layer sums. + ! If sun/shade big leaf code, nrad=1 and fsun_z(p,1) and tlai_z(p,1) from + ! SurfaceAlbedo is canopy integrated so that layer value equals canopy value. + + ! cpatch%f_sun is calculated in the surface_albedo routine... + + do CL = 1, cpatch%NCL_p + do FT = 1,numpft_ed + + if( DEBUG ) write(iulog,*) 'edsurfRad_5601',CL,FT,cpatch%nrad(CL,ft) + + do iv = 1, cpatch%nrad(CL,ft) !NORMAL CASE. + + ! FIX(SPM,040114) - existing comment + ! ** Should this be elai or tlai? Surely we only do radiation for elai? + + cpatch%ed_laisun_z(CL,ft,iv) = cpatch%elai_profile(CL,ft,iv) * & + cpatch%f_sun(CL,ft,iv) + + if ( DEBUG ) write(iulog,*) 'edsurfRad 570 ',cpatch%elai_profile(CL,ft,iv) + if ( DEBUG ) write(iulog,*) 'edsurfRad 571 ',cpatch%f_sun(CL,ft,iv) + + cpatch%ed_laisha_z(CL,ft,iv) = cpatch%elai_profile(CL,ft,iv) * & + (1._r8 - cpatch%f_sun(CL,ft,iv)) + + end do + + !needed for the VOC emissions, etc. + sunlai = sunlai + sum(cpatch%ed_laisun_z(CL,ft,1:cpatch%nrad(CL,ft))) + shalai = shalai + sum(cpatch%ed_laisha_z(CL,ft,1:cpatch%nrad(CL,ft))) + + end do + end do + + if(sunlai+shalai > 0._r8)then + bc_out(s)%fsun_pa(ifp) = sunlai / (sunlai+shalai) + else + bc_out(s)%fsun_pa(ifp) = 0._r8 + endif + + if(bc_out(s)%fsun_pa(ifp) > 1._r8)then + write(iulog,*) 'too much leaf area in profile', bc_out(s)%fsun_pa(ifp), & + cpatch%lai,sunlai,shalai + endif + + elai = calc_areaindex(cpatch,'elai') + + bc_out(s)%laisun_pa(ifp) = elai*bc_out(s)%fsun_pa(ifp) + bc_out(s)%laisha_pa(ifp) = elai*(1.0_r8-bc_out(s)%fsun_pa(ifp)) + + ! Absorbed PAR profile through canopy + ! If sun/shade big leaf code, nrad=1 and fluxes from SurfaceAlbedo + ! are canopy integrated so that layer values equal big leaf values. + + if ( DEBUG ) write(iulog,*) 'edsurfRad 645 ',cpatch%NCL_p,numpft_ed + + do CL = 1, cpatch%NCL_p + do FT = 1,numpft_ed + + if ( DEBUG ) write(iulog,*) 'edsurfRad 649 ',cpatch%nrad(CL,ft) + + do iv = 1, cpatch%nrad(CL,ft) + + if ( DEBUG ) then + write(iulog,*) 'edsurfRad 653 ', cpatch%ed_parsun_z(CL,ft,iv) + write(iulog,*) 'edsurfRad 654 ', bc_in(s)%solad_parb(ifp,ipar) + write(iulog,*) 'edsurfRad 655 ', bc_in(s)%solai_parb(ifp,ipar) + write(iulog,*) 'edsurfRad 656 ', cpatch%fabd_sun_z(CL,ft,iv) + write(iulog,*) 'edsurfRad 657 ', cpatch%fabi_sun_z(CL,ft,iv) + endif + + cpatch%ed_parsun_z(CL,ft,iv) = & + bc_in(s)%solad_parb(ifp,ipar)*cpatch%fabd_sun_z(CL,ft,iv) + & + bc_in(s)%solai_parb(ifp,ipar)*cpatch%fabi_sun_z(CL,ft,iv) + + if ( DEBUG )write(iulog,*) 'edsurfRad 663 ', cpatch%ed_parsun_z(CL,ft,iv) + + cpatch%ed_parsha_z(CL,ft,iv) = & + bc_in(s)%solad_parb(ifp,ipar)*cpatch%fabd_sha_z(CL,ft,iv) + & + bc_in(s)%solai_parb(ifp,ipar)*cpatch%fabi_sha_z(CL,ft,iv) + + if ( DEBUG ) write(iulog,*) 'edsurfRad 669 ', cpatch%ed_parsha_z(CL,ft,iv) + + end do !iv + end do !FT + end do !CL + + cpatch => cpatch%younger + enddo + + + enddo + return + +end subroutine ED_SunShadeFracs + + +! ! MOVE TO THE INTERFACE +! subroutine ED_CheckSolarBalance(g,filter_nourbanp,num_nourbanp,fsa,fsr,forc_solad,forc_solai) + + +! implicit none +! integer,intent(in),dimension(:) :: gridcell ! => gridcell index +! integer,intent(in),dimension(:) :: filter_nourbanp ! => patch filter for non-urban points +! integer, intent(in) :: num_nourbanp ! number of patches in non-urban points in patch filter +! real(r8),intent(in),dimension(:,:) :: forc_solad ! => atm2lnd_inst%forc_solad_grc, direct radiation (W/m**2 +! real(r8),intent(in),dimension(:,:) :: forc_solai ! => atm2lnd_inst%forc_solai_grc, diffuse radiation (W/m**2) +! real(r8),intent(in),dimension(:,:) :: fsa ! => solarabs_inst%fsa_patch, solar radiation absorbed (total) (W/m**2) +! real(r8),intent(in),dimension(:,:) :: fsr ! => solarabs_inst%fsr_patch, solar radiation reflected (W/m**2) + +! integer :: p +! integer :: fp +! integer :: g +! real(r8) :: errsol + +! do fp = 1,num_nourbanp +! p = filter_nourbanp(fp) +! g = gridcell(p) +! errsol = (fsa(p) + fsr(p) - (forc_solad(g,1) + forc_solad(g,2) + forc_solai(g,1) + forc_solai(g,2))) +! if(abs(errsol) > 0.1_r8)then +! write(iulog,*) 'sol error in surf rad',p,g, errsol +! endif +! end do +! return +! end subroutine ED_CheckSolarBalance + + +end module EDSurfaceRadiationMod diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index 29679323..075f797b 100755 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -640,6 +640,7 @@ subroutine area_burnt ( currentSite ) use domainMod, only : ldomain use EDParamsMod, only : ED_val_nfires + use PatchType, only : patch type(ed_site_type), intent(inout), target :: currentSite @@ -650,7 +651,7 @@ subroutine area_burnt ( currentSite ) real db !distance fire has travelled backward real(r8) gridarea real(r8) size_of_fire - integer g + integer g, p currentSite%frac_burnt = 0.0_r8 @@ -683,9 +684,17 @@ subroutine area_burnt ( currentSite ) ! --- calculate area burnt--- if(lb > 0.0_r8) then - g = currentSite%clmgcell + + p = currentPatch%clm_pno + g = patch%gridcell(p) + ! g = currentSite%clmgcell (DEPRECATED VARIABLE) + + ! INTERF-TODO: + ! THIS SHOULD HAVE THE COLUMN AND LU AREA WEIGHT ALSO, NO? + 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. diff --git a/main/CMakeLists.txt b/main/CMakeLists.txt index 28dbfa2d..5f8dbdcf 100644 --- a/main/CMakeLists.txt +++ b/main/CMakeLists.txt @@ -6,3 +6,4 @@ list(APPEND clm_sources ) sourcelist_to_parent(clm_sources) + diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 294198c4..517d1829 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -5,16 +5,34 @@ module EDCLMLinkMod ! diagnostics, or as input to the land surface components. ! ============================================================================ - use shr_kind_mod , only : r8 => shr_kind_r8; + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_infnan_mod, only : isnan => shr_infnan_isnan use decompMod , only : bounds_type - use clm_varpar , only : nclmax, nlevcan_ed, numpft, numcft + use clm_varpar , only : numpft, numcft, mxpft use clm_varctl , only : iulog - use EDtypesMod , only : ed_site_type, ed_cohort_type, ed_patch_type + use ColumnType , only : col + use EDtypesMod , only : ed_site_type, ed_cohort_type, ed_patch_type, ncwd + use EDtypesMod , only : sclass_ed, nlevsclass_ed, AREA, cp_nclmax, cp_nlevcan + use CanopyStateType , only : canopystate_type + use clm_varctl , only : use_vertsoilc + use EDParamsMod , only : ED_val_ag_biomass + use SoilBiogeochemCarbonFluxType , only : soilbiogeochem_carbonflux_type + use SoilBiogeochemCarbonStatetype , only : soilbiogeochem_carbonstate_type + use clm_time_manager , only : is_beg_curr_day, get_step_size, get_nstep + use shr_const_mod, only: SHR_CONST_CDAY + use abortutils , only : endrun + use shr_log_mod , only : errMsg => shr_log_errMsg + use EDCanopyStructureMod, only : calc_areaindex + ! implicit none private ! logical :: DEBUG = .false. ! for debugging this module (EDCLMLinkMod.F90) + + ! !PUBLIC DATA MEMBERS + real(r8), public :: cwd_fcel_ed + real(r8), public :: cwd_flig_ed type, public :: ed_clm_type @@ -62,14 +80,75 @@ module EDCLMLinkMod 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 + ! vegetation carbon fluxes at the patch scale 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 + real(r8), pointer, private :: ar_patch (:) ! (gC/m2/s) patch autotrophic respiration + real(r8), pointer, private :: maint_resp_patch (:) ! (gC/m2/s) patch maintenance respiration + real(r8), pointer, private :: growth_resp_patch (:) ! (gC/m2/s) patch growth respiration + + real(r8), pointer :: ed_gpp_col_scpf (:,:) ! [kg/m2/yr] gross primary production + real(r8), pointer :: ed_npp_totl_col_scpf (:,:) ! [kg/m2/yr] net primary production (npp) + real(r8), pointer :: ed_npp_leaf_col_scpf (:,:) ! [kg/m2/yr] npp flux into leaf pool + real(r8), pointer :: ed_npp_seed_col_scpf (:,:) ! [kg/m2/yr] npp flux into flower,fruit,nut,seed + real(r8), pointer :: ed_npp_fnrt_col_scpf (:,:) ! [kg/m2/yr] npp flux into fine roots + real(r8), pointer :: ed_npp_bgsw_col_scpf (:,:) ! [kg/m2/yr] npp flux into below ground sapwood + real(r8), pointer :: ed_npp_bgdw_col_scpf (:,:) ! [kg/m2/yr] npp flux into below ground structural (dead) wood + real(r8), pointer :: ed_npp_agsw_col_scpf (:,:) ! [kg/m2/yr] npp flux into above ground sapwood + real(r8), pointer :: ed_npp_agdw_col_scpf (:,:) ! [kg/m2/yr] npp flux into below ground structural (dead) wood + real(r8), pointer :: ed_npp_stor_col_scpf (:,:) ! [kg/m2/yr] npp flux through the storage pool + real(r8), pointer :: ed_litt_leaf_col_scpf (:,:) ! [kg/m2/yr] carbon flux of live leaves to litter + real(r8), pointer :: ed_litt_fnrt_col_scpf (:,:) ! [kg/m2/yr] carbon flux of fine roots to litter + real(r8), pointer :: ed_litt_sawd_col_scpf (:,:) ! [kg/m2/yr] carbon flux of sapwood to litter (above+below) + real(r8), pointer :: ed_litt_ddwd_col_scpf (:,:) ! [kg/m2/yr] carbon flux of dead wood (above+below) to litter + real(r8), pointer :: ed_r_leaf_col_scpf (:,:) ! [kg/m2/yr] total leaf respiration + real(r8), pointer :: ed_r_stem_col_scpf (:,:) ! [kg/m2/yr] total above ground live wood (stem) respiration + real(r8), pointer :: ed_r_root_col_scpf (:,:) ! [kg/m2/yr] total below ground live wood (root) respiration + real(r8), pointer :: ed_r_stor_col_scpf (:,:) ! [kg/m2/yr] total storage respiration + + ! Carbon State Variables for direct comparison to inventory - dimensions: (disturbance patch, pft x size) + + real(r8), pointer :: ed_ddbh_col_scpf (:,:) ! [cm/yr] diameter increment + real(r8), pointer :: ed_ba_col_scpf (:,:) ! [m2/ha] basal area + real(r8), pointer :: ed_np_col_scpf (:,:) ! [/m2] number of plants + real(r8), pointer :: ed_m1_col_scpf (:,:) ! [Stems/ha/yr] Mean Background Mortality + real(r8), pointer :: ed_m2_col_scpf (:,:) ! [Stems/ha/yr] Mean Hydraulic Mortaliry + real(r8), pointer :: ed_m3_col_scpf (:,:) ! [Stems/ha/yr] Mean Carbon Starvation Mortality + real(r8), pointer :: ed_m4_col_scpf (:,:) ! [Stems/ha/yr] Mean Impact Mortality + real(r8), pointer :: ed_m5_col_scpf (:,:) ! [Stems/ha/yr] Mean Fire Mortality + + ! summary carbon fluxes at the column level + real(r8), pointer, private :: nep_col(:) ! [gC/m2/s] Net ecosystem production, i.e. fast-timescale carbon balance that does not include disturbance + real(r8), pointer, private :: nep_timeintegrated_col(:) ! [gC/m2/s] Net ecosystem production, i.e. fast-timescale carbon balance that does not include disturbance + real(r8), pointer, private :: npp_timeintegrated_col(:) ! [gC/m2/s] Net primary production, time integrated at column level for carbon balance checking + real(r8), pointer, private :: hr_timeintegrated_col(:) ! [gC/m2/s] heterotrophic respiration, time integrated for carbon balance checking + real(r8), pointer, private :: nbp_col(:) ! [gC/m2/s] Net biosphere production, i.e. slow-timescale carbon balance that integrates to total carbon change + real(r8), pointer, private :: npp_col(:) ! [gC/m2/s] Net primary production at the fast timescale, aggregated to the column level + real(r8), pointer, private :: fire_c_to_atm_col(:) ! [gC/m2/s] total fire carbon loss to atmosphere + real(r8), pointer, private :: ed_to_bgc_this_edts_col(:) ! [gC/m2/s] total flux of carbon from ED to BGC models on current ED timestep + real(r8), pointer, private :: ed_to_bgc_last_edts_col(:) ! [gC/m2/s] total flux of carbon from ED to BGC models on prior ED timestep + real(r8), pointer, private :: seed_rain_flux_col(:) ! [gC/m2/s] total flux of carbon from seed rain + + ! summary carbon states at the column level + real(r8), pointer, private :: totecosysc_col(:) ! [gC/m2] Total ecosystem carbon at the column level, including vegetation, CWD, litter, and soil pools + real(r8), pointer, private :: totecosysc_old_col(:) ! [gC/m2] Total ecosystem C at the column level from last call to balance check + real(r8), pointer, private :: totedc_col(:) ! [gC/m2] Total ED carbon at the column level, including vegetation, CWD, seeds, and ED litter + real(r8), pointer, private :: totedc_old_col(:) ! [gC/m2] Total ED C at the column level from last call to balance check + real(r8), pointer, private :: totbgcc_col(:) ! [gC/m2] Total BGC carbon at the column level, including litter, and soil pools + real(r8), pointer, private :: totbgcc_old_col(:) ! [gC/m2] Total BGC C at the column level from last call to balance check + real(r8), pointer, private :: biomass_stock_col(:) ! [gC/m2] total biomass at the column level in gC / m2 + real(r8), pointer, private :: ed_litter_stock_col(:) ! [gC/m2] ED litter at the column level in gC / m2 + real(r8), pointer, private :: cwd_stock_col(:) ! [gC/m2] ED CWD at the column level in gC / m2 + real(r8), pointer, private :: seed_stock_col(:) ! [gC/m2] ED seed mass carbon at the column level in gC / m2 + + ! carbon balance errors. at some point we'll reduce these to close to zero and delete, but for now we'll just keep[ track of them + real(r8), pointer, private :: cbalance_error_ed_col(:) ! [gC/m2/s] total carbon balance error for the ED side + real(r8), pointer, private :: cbalance_error_bgc_col(:) ! [gC/m2/s] total carbon balance error for the BGC side + real(r8), pointer, private :: cbalance_error_total_col(:) ! [gC/m2/s] total carbon balance error for the whole thing + + ! ED patch/cohort data + real(r8), pointer, private :: ed_npatches_col(:) ! [#] the number of patches per ED site + real(r8), pointer, private :: ed_ncohorts_col(:) ! [#] the number of cohorts per ED site contains @@ -78,13 +157,16 @@ module EDCLMLinkMod procedure , public :: Restart procedure , public :: SetValues procedure , public :: ed_clm_link + procedure , public :: SummarizeNetFluxes + procedure , public :: SummarizeProductivityFluxes + procedure , public :: ED_BGC_Carbon_Balancecheck ! Private routines procedure , private :: ed_clm_leaf_area_profile procedure , private :: ed_update_history_variables procedure , private :: InitAllocate procedure , private :: InitHistory - procedure , private :: InitCold +! procedure , private :: InitCold end type ed_clm_type @@ -106,7 +188,7 @@ subroutine Init(this, bounds) call this%InitAllocate(bounds) call this%InitHistory(bounds) - call this%InitCold(bounds) + !call this%InitCold(bounds) end subroutine Init @@ -115,7 +197,8 @@ subroutine InitAllocate(this, bounds) ! ! !USES: use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) - use clm_varpar , only : nlevgrnd + use clm_varpar , only : nlevgrnd, nlevdecomp_full + use EDtypesMod , only : numpft_ed ! ! !ARGUMENTS: class (ed_clm_type) :: this @@ -123,9 +206,13 @@ subroutine InitAllocate(this, bounds) ! ! !LOCAL VARIABLES: integer :: begp,endp + integer :: begc,endc !bounds + integer :: begg,endg !------------------------------------------------------------------------ begp = bounds%begp; endp = bounds%endp + begc = bounds%begc; endc = bounds%endc + 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 @@ -161,15 +248,71 @@ subroutine InitAllocate(this, bounds) 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 + allocate(this%ar_patch (begp:endp)) ; this%ar_patch (:) = nan + allocate(this%maint_resp_patch (begp:endp)) ; this%maint_resp_patch (:) = nan + allocate(this%growth_resp_patch (begp:endp)) ; this%growth_resp_patch (:) = nan + + allocate(this%ed_to_bgc_this_edts_col (begc:endc)) ; this%ed_to_bgc_this_edts_col (:) = nan + allocate(this%ed_to_bgc_last_edts_col (begc:endc)) ; this%ed_to_bgc_last_edts_col (:) = nan + allocate(this%seed_rain_flux_col (begc:endc)) ; this%seed_rain_flux_col (:) = nan + + allocate(this%nep_col (begc:endc)) ; this%nep_col (:) = nan + allocate(this%nep_timeintegrated_col (begc:endc)) ; this%nep_timeintegrated_col (:) = nan + allocate(this%npp_timeintegrated_col (begc:endc)) ; this%npp_timeintegrated_col (:) = nan + allocate(this%hr_timeintegrated_col (begc:endc)) ; this%hr_timeintegrated_col (:) = nan + + allocate(this%nbp_col (begc:endc)) ; this%nbp_col (:) = nan + allocate(this%npp_col (begc:endc)) ; this%npp_col (:) = nan + allocate(this%fire_c_to_atm_col (begc:endc)) ; this%fire_c_to_atm_col (:) = nan + + allocate(this%totecosysc_col (begc:endc)) ; this%totecosysc_col (:) = nan + allocate(this%totecosysc_old_col (begc:endc)) ; this%totecosysc_old_col (:) = nan + allocate(this%totedc_col (begc:endc)) ; this%totedc_col (:) = nan + allocate(this%totedc_old_col (begc:endc)) ; this%totedc_old_col (:) = nan + allocate(this%totbgcc_col (begc:endc)) ; this%totbgcc_col (:) = nan + allocate(this%totbgcc_old_col (begc:endc)) ; this%totbgcc_old_col (:) = nan + allocate(this%biomass_stock_col (begc:endc)) ; this%biomass_stock_col (:) = nan + allocate(this%ed_litter_stock_col (begc:endc)) ; this%ed_litter_stock_col (:) = nan + allocate(this%cwd_stock_col (begc:endc)) ; this%cwd_stock_col (:) = nan + allocate(this%seed_stock_col (begc:endc)) ; this%seed_stock_col (:) = nan + + allocate(this%cbalance_error_ed_col (begc:endc)) ; this%cbalance_error_ed_col (:) = nan + allocate(this%cbalance_error_bgc_col (begc:endc)) ; this%cbalance_error_bgc_col (:) = nan + allocate(this%cbalance_error_total_col (begc:endc)) ; this%cbalance_error_total_col (:) = nan + + allocate(this%ed_npatches_col (begc:endc)) ; this%ed_npatches_col (:) = nan + allocate(this%ed_ncohorts_col (begc:endc)) ; this%ed_ncohorts_col (:) = nan + + allocate(this%ed_gpp_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_gpp_col_scpf (:,:) = 0.0_r8 + allocate(this%ed_npp_totl_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_npp_totl_col_scpf (:,:) = 0.0_r8 + allocate(this%ed_npp_leaf_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_npp_leaf_col_scpf (:,:) = 0.0_r8 + allocate(this%ed_npp_seed_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_npp_seed_col_scpf (:,:) = 0.0_r8 + allocate(this%ed_npp_fnrt_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_npp_fnrt_col_scpf (:,:) = 0.0_r8 + allocate(this%ed_npp_bgsw_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_npp_bgsw_col_scpf (:,:) = 0.0_r8 + allocate(this%ed_npp_bgdw_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_npp_bgdw_col_scpf (:,:) = 0.0_r8 + allocate(this%ed_npp_agsw_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_npp_agsw_col_scpf (:,:) = 0.0_r8 + allocate(this%ed_npp_agdw_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_npp_agdw_col_scpf (:,:) = 0.0_r8 + allocate(this%ed_npp_stor_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_npp_stor_col_scpf (:,:) = 0.0_r8 + allocate(this%ed_litt_leaf_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_litt_leaf_col_scpf (:,:) = 0.0_r8 + allocate(this%ed_litt_fnrt_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_litt_fnrt_col_scpf (:,:) = 0.0_r8 + allocate(this%ed_litt_sawd_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_litt_sawd_col_scpf (:,:) = 0.0_r8 + allocate(this%ed_litt_ddwd_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_litt_ddwd_col_scpf (:,:) = 0.0_r8 + allocate(this%ed_r_leaf_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_r_leaf_col_scpf (:,:) = 0.0_r8 + allocate(this%ed_r_stem_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_r_stem_col_scpf (:,:) = 0.0_r8 + allocate(this%ed_r_root_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_r_root_col_scpf (:,:) = 0.0_r8 + allocate(this%ed_r_stor_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)); this%ed_r_stor_col_scpf (:,:) = 0.0_r8 + + ! Carbon State Variables for direct comparison to inventory - dimensions: (disturbance patch, pft x size) + allocate(this%ed_ddbh_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)) ; this%ed_ddbh_col_scpf (:,:) = 0.0_r8 + allocate(this%ed_ba_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)) ; this%ed_ba_col_scpf (:,:) = 0.0_r8 + allocate(this%ed_np_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)) ; this%ed_np_col_scpf (:,:) = 0.0_r8 + allocate(this%ed_m1_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)) ; this%ed_m1_col_scpf (:,:) = 0.0_r8 + allocate(this%ed_m2_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)) ; this%ed_m2_col_scpf (:,:) = 0.0_r8 + allocate(this%ed_m3_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)) ; this%ed_m3_col_scpf (:,:) = 0.0_r8 + allocate(this%ed_m4_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)) ; this%ed_m4_col_scpf (:,:) = 0.0_r8 + allocate(this%ed_m5_col_scpf (begc:endc,1:nlevsclass_ed*mxpft)) ; this%ed_m5_col_scpf (:,:) = 0.0_r8 end subroutine InitAllocate @@ -219,20 +362,20 @@ subroutine InitHistory(this, bounds) 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', & + call hist_addfld2d (fname='PFTbiomass', units='gC/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', & + call hist_addfld2d (fname='PFTleafbiomass', units='gC/m2', type2d='levgrnd', & + avgflag='A', long_name='total PFT level leaf 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', & + call hist_addfld2d (fname='PFTstorebiomass', units='gC/m2', type2d='levgrnd', & + avgflag='A', long_name='total PFT level stored 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', & + call hist_addfld2d (fname='PFTnindivs', units='indiv / m2', type2d='levgrnd', & + avgflag='A', long_name='total PFT level number of individuals', & ptr_patch=this%PFTnindivs_patch, set_lake=0._r8, set_urb=0._r8) call hist_addfld1d (fname='FIRE_NESTEROV_INDEX', units='none', & @@ -279,59 +422,55 @@ subroutine InitHistory(this, bounds) 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', & + call hist_addfld1d (fname='SUM_FUEL', units='gC m-2', & + avgflag='A', long_name='total ground fuel related to ros (omits 1000hr fuels)', & 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', & + call hist_addfld1d (fname='LITTER_IN', units='gC m-2 s-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', & + call hist_addfld1d (fname='LITTER_OUT', units='gC m-2 s-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', & + call hist_addfld1d (fname='SEED_BANK', units='gC 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', & + call hist_addfld1d (fname='SEEDS_IN', units='gC m-2 s-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', & + call hist_addfld1d (fname='SEED_GERMINATION', units='gC m-2 s-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', & + call hist_addfld1d (fname='SEED_DECAY', units='gC m-2 s-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', & + call hist_addfld1d (fname='ED_bstore', units='gC 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', & + call hist_addfld1d (fname='ED_bdead', units='gC 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', & + call hist_addfld1d (fname='ED_balive', units='gC 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', & + call hist_addfld1d (fname='ED_bleaf', units='gC 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', & + call hist_addfld1d (fname='ED_biomass', units='gC 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', & + 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) @@ -339,36 +478,6 @@ subroutine InitHistory(this, bounds) 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', & @@ -379,29 +488,185 @@ subroutine InitHistory(this, bounds) avgflag='A', long_name='net primary production', & ptr_patch=this%npp_patch) + this%ar_patch(begp:endp) = spval + call hist_addfld1d (fname='AR', units='gC/m^2/s', & + avgflag='A', long_name='autotrophic respiration', & + ptr_patch=this%ar_patch) + + this%growth_resp_patch(begp:endp) = spval + call hist_addfld1d (fname='GROWTH_RESP', units='gC/m^2/s', & + avgflag='A', long_name='growth respiration', & + ptr_patch=this%growth_resp_patch) + + this%maint_resp_patch(begp:endp) = spval + call hist_addfld1d (fname='MAINT_RESP', units='gC/m^2/s', & + avgflag='A', long_name='maintenance respiration', & + ptr_patch=this%maint_resp_patch) + + this%nep_col(begc:endc) = spval + call hist_addfld1d (fname='NEP', units='gC/m^2/s', & + avgflag='A', long_name='net ecosystem production', & + ptr_col=this%nep_col) + + this%fire_c_to_atm_col(begc:endc) = spval + call hist_addfld1d (fname='Fire_Closs', units='gC/m^2/s', & + avgflag='A', long_name='ED/SPitfire Carbon loss to atmosphere', & + ptr_col=this%fire_c_to_atm_col) + + this%nbp_col(begc:endc) = spval + call hist_addfld1d (fname='NBP', units='gC/m^2/s', & + avgflag='A', long_name='net biosphere production', & + ptr_col=this%nbp_col) + + this%npp_col(begc:endc) = spval + call hist_addfld1d (fname='NPP_column', units='gC/m^2/s', & + avgflag='A', long_name='net primary production on column level', & + ptr_col=this%npp_col,default='inactive') + + this%totecosysc_col(begc:endc) = spval + call hist_addfld1d (fname='TOTECOSYSC', units='gC/m^2', & + avgflag='A', long_name='total ecosystem carbon', & + ptr_col=this%totecosysc_col) + + this%cbalance_error_ed_col(begc:endc) = spval + call hist_addfld1d (fname='CBALANCE_ERROR_ED', units='gC/m^2/s', & + avgflag='A', long_name='total carbon balance error on ED side', & + ptr_col=this%cbalance_error_ed_col) + + this%cbalance_error_bgc_col(begc:endc) = spval + call hist_addfld1d (fname='CBALANCE_ERROR_BGC', units='gC/m^2/s', & + avgflag='A', long_name='total carbon balance error on BGC side', & + ptr_col=this%cbalance_error_bgc_col) + + this%cbalance_error_total_col(begc:endc) = spval + call hist_addfld1d (fname='CBALANCE_ERROR_TOTAL', units='gC/m^2/s', & + avgflag='A', long_name='total carbon balance error total', & + ptr_col=this%cbalance_error_total_col) + + this%biomass_stock_col(begc:endc) = spval + call hist_addfld1d (fname='BIOMASS_STOCK_COL', units='gC/m^2', & + avgflag='A', long_name='total ED biomass carbon at the column level', & + ptr_col=this%biomass_stock_col) + + this%ed_litter_stock_col(begc:endc) = spval + call hist_addfld1d (fname='ED_LITTER_STOCK_COL', units='gC/m^2', & + avgflag='A', long_name='total ED litter carbon at the column level', & + ptr_col=this%ed_litter_stock_col) + + this%cwd_stock_col(begc:endc) = spval + call hist_addfld1d (fname='CWD_STOCK_COL', units='gC/m^2', & + avgflag='A', long_name='total CWD carbon at the column level', & + ptr_col=this%cwd_stock_col) + + this%seed_stock_col(begc:endc) = spval + call hist_addfld1d (fname='SEED_STOCK_COL', units='gC/m^2', & + avgflag='A', long_name='total seed carbon at the column level', & + ptr_col=this%seed_stock_col) + + + ! Carbon Flux (grid dimension x scpf) + ! ============================================================== + + call hist_addfld2d (fname='ED_GPP_COL_SCPF',units='kgC/m2/yr',type2d='levscpf',& + avgflag='A', long_name='gross primary production', & + ptr_gcell=this%ed_gpp_col_scpf,default='inactive') + + call hist_addfld2d (fname='ED_NPP_LEAF_COL_SCPF',units='kgC/m2/yr',type2d='levscpf',& + avgflag='A', long_name='NPP flux into leaves', & + ptr_gcell=this%ed_npp_leaf_col_scpf,default='inactive') + + call hist_addfld2d (fname='ED_NPP_SEED_COL_SCPF',units='kgC/m2/yr',type2d='levscpf',& + avgflag='A', long_name='NPP flux into seeds', & + ptr_gcell=this%ed_npp_seed_col_scpf,default='inactive') + + call hist_addfld2d (fname='ED_NPP_FNRT_COL_SCPF',units='kgC/m2/yr',type2d='levscpf',& + avgflag='A', long_name='NPP flux into fine roots', & + ptr_gcell=this%ed_npp_fnrt_col_scpf,default='inactive') + + call hist_addfld2d (fname='ED_NPP_BGSW_COL_SCPF',units='kgC/m2/yr',type2d='levscpf',& + avgflag='A', long_name='NPP flux into below-ground sapwood', & + ptr_gcell=this%ed_npp_bgsw_col_scpf,default='inactive') + + call hist_addfld2d (fname='ED_NPP_BGDW_COL_SCPF',units='kgC/m2/yr',type2d='levscpf',& + avgflag='A', long_name='NPP flux into below-ground deadwood', & + ptr_gcell=this%ed_npp_bgdw_col_scpf,default='inactive') + + call hist_addfld2d (fname='ED_NPP_AGSW_COL_SCPF',units='kgC/m2/yr',type2d='levscpf',& + avgflag='A', long_name='NPP flux into above-ground sapwood', & + ptr_gcell=this%ed_npp_agsw_col_scpf,default='inactive') + + call hist_addfld2d ( fname = 'ED_NPP_AGDW_COL_SCPF', units='kgC/m2/yr',type2d='levscpf',& + avgflag='A', long_name='NPP flux into above-ground deadwood', & + ptr_gcell=this%ed_npp_agdw_col_scpf,default='inactive') + + call hist_addfld2d ( fname = 'ED_NPP_STOR_COL_SCPF', units='kgC/m2/yr',type2d='levscpf',& + avgflag='A', long_name='NPP flux into storage', & + ptr_gcell=this%ed_npp_stor_col_scpf,default='inactive') + + call hist_addfld2d (fname='ED_DDBH_COL_SCPF', units = 'cm/yr/ha', type2d = 'levscpf', & + avgflag='A', long_name='diameter growth increment and pft/size', & + ptr_gcell=this%ed_ddbh_col_scpf, default='inactive') + + call hist_addfld2d (fname='ED_BA_COL_SCPF',units = 'm2/ha', type2d = 'levscpf', & + avgflag='A', long_name='basal area by patch and pft/size', & + ptr_gcell=this%ed_ba_col_scpf, default='inactive') + + call hist_addfld2d (fname='ED_NPLANT_COL_SCPF',units = 'N/ha', type2d = 'levscpf', & + avgflag='A', long_name='stem number density by patch and pft/size', & + ptr_gcell=this%ed_np_col_scpf, default='inactive') + + call hist_addfld2d (fname='ED_M1_COL_SCPF',units = 'N/ha/yr', type2d = 'levscpf', & + avgflag='A', long_name='background mortality count by patch and pft/size', & + ptr_gcell=this%ed_m1_col_scpf, default='inactive') + + call hist_addfld2d (fname='ED_M2_COL_SCPF',units = 'N/ha/yr', type2d = 'levscpf', & + avgflag='A', long_name='hydraulic mortality count by patch and pft/size', & + ptr_gcell=this%ed_m2_col_scpf, default='inactive') + + call hist_addfld2d (fname='ED_M3_COL_SCPF',units = 'N/ha/yr', type2d = 'levscpf', & + avgflag='A', long_name='carbon starvation mortality count by patch and pft/size', & + ptr_gcell=this%ed_m3_col_scpf, default='inactive') + + call hist_addfld2d (fname='ED_M4_COL_SCPF',units = 'N/ha/yr', type2d = 'levscpf', & + avgflag='A', long_name='impact mortality count by patch and pft/size', & + ptr_gcell=this%ed_m4_col_scpf, default='inactive') + + call hist_addfld2d (fname='ED_M5_COL_SCPF',units = 'N/ha/yr', type2d = 'levscpf', & + avgflag='A', long_name='fire mortality count by patch and pft/size', & + ptr_gcell=this%ed_m5_col_scpf, default='inactive') + + this%ed_npatches_col(begc:endc) = spval + call hist_addfld1d (fname='ED_NPATCHES', units='unitless', & + avgflag='A', long_name='ED total number of patches per site', & + ptr_col=this%ed_npatches_col) + + this%ed_ncohorts_col(begc:endc) = spval + call hist_addfld1d (fname='ED_NCOHORTS', units='unitless', & + avgflag='A', long_name='ED total number of cohorts per site', & + ptr_col=this%ed_ncohorts_col) + 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 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 ) ! @@ -411,6 +676,8 @@ subroutine Restart ( this, bounds, ncid, flag ) ! !USES: use restUtilMod use ncdio_pio + ! use EDtypesMod , only : numpft_ed + ! ! !ARGUMENTS: class (ed_clm_type) :: this @@ -420,23 +687,72 @@ subroutine Restart ( this, bounds, ncid, flag ) ! ! !LOCAL VARIABLES: logical :: readvar + real(r8), pointer :: ptr2d(:,:) ! temp. pointers for slicing larger arrays + real(r8), pointer :: ptr1d(:) ! temp. pointers for slicing larger arrays + ! character(LEN=3) :: istr1 + ! integer :: k !------------------------------------------------------------------------ - 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) + ptr1d => this%nep_timeintegrated_col(:) + call restartvar(ncid=ncid, flag=flag, varname='nep_timeintegrated_col', xtype=ncd_double, & + dim1name='column', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=ptr1d) + + ptr1d => this%npp_timeintegrated_col(:) + call restartvar(ncid=ncid, flag=flag, varname='npp_timeintegrated_col', xtype=ncd_double, & + dim1name='column', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=ptr1d) + + ptr1d => this%hr_timeintegrated_col(:) + call restartvar(ncid=ncid, flag=flag, varname='hr_timeintegrated_col', xtype=ncd_double, & + dim1name='column', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=ptr1d) + + ptr1d => this%totecosysc_old_col(:) + call restartvar(ncid=ncid, flag=flag, varname='totecosysc_old_col', xtype=ncd_double, & + dim1name='column', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=ptr1d) + + ptr1d => this%cbalance_error_ed_col(:) + call restartvar(ncid=ncid, flag=flag, varname='cbalance_error_ed_col', xtype=ncd_double, & + dim1name='column', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=ptr1d) + + ptr1d => this%cbalance_error_bgc_col(:) + call restartvar(ncid=ncid, flag=flag, varname='cbalance_error_bgc_col', xtype=ncd_double, & + dim1name='column', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=ptr1d) + + ptr1d => this%cbalance_error_total_col(:) + call restartvar(ncid=ncid, flag=flag, varname='cbalance_error_total_col', xtype=ncd_double, & + dim1name='column', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=ptr1d) + + ptr1d => this%totedc_old_col(:) + call restartvar(ncid=ncid, flag=flag, varname='totedc_old_col', xtype=ncd_double, & + dim1name='column', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=ptr1d) + + ptr1d => this%totbgcc_old_col(:) + call restartvar(ncid=ncid, flag=flag, varname='totbgcc_old_col', xtype=ncd_double, & + dim1name='column', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=ptr1d) + + ptr1d => this%ed_to_bgc_this_edts_col(:) + call restartvar(ncid=ncid, flag=flag, varname='ed_to_bgc_this_edts_col', xtype=ncd_double, & + dim1name='column', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=ptr1d) + + ptr1d => this%ed_to_bgc_last_edts_col(:) + call restartvar(ncid=ncid, flag=flag, varname='ed_to_bgc_last_edts_col', xtype=ncd_double, & + dim1name='column', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=ptr1d) + + ptr1d => this%seed_rain_flux_col(:) + call restartvar(ncid=ncid, flag=flag, varname='seed_rain_flux_col', xtype=ncd_double, & + dim1name='column', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=ptr1d) + end subroutine Restart @@ -468,46 +784,44 @@ subroutine SetValues( this, bounds, val) end subroutine SetValues !----------------------------------------------------------------------- - subroutine ed_clm_link( this, bounds, ed_allsites_inst, ed_phenology_inst, & - waterstate_inst, canopystate_inst) + + subroutine ed_clm_link( this, bounds, nsites, sites, fcolumn, 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 + integer , intent(in) :: nsites + type(ed_site_type) , intent(inout), target :: sites(nsites) + integer , intent(in) :: fcolumn(nsites) 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 :: g,l,p,c,s 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) + integer :: begp_fp, endp_fp ! Valid range of patch indices that are associated with + ! FATES (F) for each parent (P) iteration (grid/column) !---------------------------------------------------------------------- - if (DEBUG) then + if ( DEBUG ) then write(iulog,*) 'in ed_clm_link' endif @@ -526,223 +840,227 @@ subroutine ed_clm_link( this, bounds, ed_allsites_inst, ed_phenology_inst, & 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 + do s = 1,nsites - 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 + c = fcolumn(s) + + ! ============================================================================ + ! Zero the bare ground tile BGC variables. + ! Valid Range for zero'ing here is the soil_patch and non crop patches + ! If the crops are not turned on, don't worry, they were zero'd once and should + ! not change again (RGK). + ! col%patchi(c) + numpft - numcft + ! ============================================================================ + + begp_fp = col%patchi(c) + endp_fp = col%patchi(c) + numpft - numcft + + clmpatch%is_veg(begp_fp:endp_fp) = .false. + clmpatch%is_bareground(begp_fp:endp_fp) = .false. + + tlai(begp_fp:endp_fp) = 0.0_r8 + htop(begp_fp:endp_fp) = 0.0_r8 + hbot(begp_fp:endp_fp) = 0.0_r8 + elai(begp_fp:endp_fp) = 0.0_r8 + tsai(begp_fp:endp_fp) = 0.0_r8 + esai(begp_fp:endp_fp) = 0.0_r8 + + + patchn = 0 + total_bare_ground = 0.0_r8 + total_patch_area = 0._r8 - patchn = 0 - total_bare_ground = 0.0_r8 - total_patch_area = 0._r8 + currentPatch => sites(s)%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 = col%patchi(c) + patchn !the first 'soil' patch is unvegetated... + + ! INTERF-TODO: currentPatch%clm_pno should be removed (FATES internal variable with CLM iformation) + + p = col%patchi(c) + patchn + + if(c .ne. clmpatch%column(p))then + write(iulog,*) ' fcolumn(s) does not match clmpatch%column(p)' + call endrun(msg=errMsg(__FILE__, __LINE__)) + end if - currentPatch => ed_allsites_inst(g)%oldest_patch - do while(associated(currentPatch)) - patchn = patchn + 1 - currentPatch%patchno = patchn + clmpatch%is_veg(p) = .true. !this .is. a tile filled with vegetation... + + call currentPatch%set_root_fraction() - if (patchn <= numpft - numcft)then !don't expand into crop patches. + !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 - 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... + !update cohort quantitie s + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + + ft = currentCohort%pft + currentCohort%livestemn = currentCohort%bsw / pftcon%leafcn(currentCohort%pft) - call currentPatch%set_root_fraction() + currentCohort%livecrootn = 0.0_r8 - !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 + if (pftcon%woody(ft) == 1) then + coarse_wood_frac = 0.5_r8 + else + coarse_wood_frac = 0.0_r8 + end if + + if ( DEBUG ) then + write(iulog,*) 'EDCLMLink 618 ',currentCohort%livecrootn + write(iulog,*) 'EDCLMLink 619 ',currentCohort%br + write(iulog,*) 'EDCLMLink 620 ',coarse_wood_frac + write(iulog,*) 'EDCLMLink 621 ',pftcon%leafcn(ft) + endif - !update cohort quantitie s - currentCohort => currentPatch%shortest - do while(associated(currentCohort)) - ft = currentCohort%pft - currentCohort%livestemn = currentCohort%bsw / pftcon%leafcn(currentCohort%pft) + currentCohort%livecrootn = currentCohort%br * coarse_wood_frac / pftcon%leafcn(ft) - if (pftcon%woody(ft) == 1) then - coarse_wood_frac = 0.5_r8 - else - coarse_wood_frac = 0.0_r8 - end if + if ( DEBUG ) write(iulog,*) 'EDCLMLink 625 ',currentCohort%livecrootn - 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 + currentCohort%b = currentCohort%balive+currentCohort%bdead+currentCohort%bstore + currentCohort%treelai = tree_lai(currentCohort) - ! 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 + currentCohort%c_area = c_area(currentCohort) + canopy_leaf_area = canopy_leaf_area + currentCohort%treelai *currentCohort%c_area + + + if(currentCohort%canopy_layer==1)then + currentPatch%total_canopy_area = currentPatch%total_canopy_area + currentCohort%c_area + if(pftcon%woody(ft)==1)then + currentPatch%total_tree_area = currentPatch%total_tree_area + currentCohort%c_area 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 + ! 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 - - 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 + 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 - !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. + currentCohort => currentCohort%taller + + enddo ! ends 'do while(associated(currentCohort)) - 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 + if ( currentPatch%total_canopy_area-currentPatch%area > 0.000001_r8 ) then + write(iulog,*) 'ED: 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 - write(iulog,*) 'ED: too many patches' - end if ! patchn<15 + ! FIX(RF,040113) - should this be a parameter for the minimum possible vegetation height? + htop(p) = 0.1_r8 + endif - currentPatch => currentPatch%younger - end do !patch loop + hbot(p) = max(0._r8, min(0.2_r8, htop(p)- 1.0_r8)) - if((total_patch_area-1.0_r8)>1e-9)then - write(iulog,*) 'total area is wrong in CLMEDLINK',total_patch_area - endif + ! 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 - !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? + ! 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. - call this%ed_clm_leaf_area_profile(ed_allsites_inst(g), waterstate_inst, canopystate_inst ) - end do !grid loop + 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) + + if ( DEBUG ) then + write(iulog, *) 'EDCLMLinkMod bare frac', currentPatch%bare_frac_area + end if - call this%ed_update_history_variables( bounds, ed_allsites_inst(begg:endg), & - firstsoilpatch, ed_Phenology_inst, canopystate_inst) + total_patch_area = total_patch_area + clmpatch%wt_ed(p) + currentPatch%bare_frac_area + total_bare_ground = total_bare_ground + currentPatch%bare_frac_area + + 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 + ! while ED's domain of influence only extends to non-crop patches + ! wt_ed should not be non-zero anwhere but ED patches, so this loop is ok + do p = col%patchi(c)+patchn+1,col%patchi(c)+numpft + clmpatch%wt_ed(p) = 0.0_r8 + enddo + + !set the area of the bare ground patch. + p = col%patchi(c) + clmpatch%wt_ed(p) = total_bare_ground + clmpatch%is_bareground = .true. + + call this%ed_clm_leaf_area_profile(sites(s), c, waterstate_inst, canopystate_inst ) + + end do ! column loop + call this%ed_update_history_variables(bounds, nsites, sites(:), fcolumn(:), 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) + subroutine ed_update_history_variables( this, bounds, nsites, sites, fcolumn, canopystate_inst) ! ! !USES: - use EDPhenologyType , only : ed_phenology_type use CanopyStateType , only : canopystate_type use PatchType , only : clmpatch => patch + use pftconMod , only : pftcon + ! ! !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: ) + integer , intent(in) :: nsites + type(ed_site_type) , intent(inout), target :: sites(nsites) + integer , intent(in) :: fcolumn(nsites) 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) + integer :: p,ft,c,s +! integer :: firstsoilpatch(bounds%begg:bounds%endg) real(r8) :: n_density ! individual of cohort per m2. + real(r8) :: n_perm2 ! individuals per m2 for the whole column + real(r8) :: patch_scaling_scalar ! ratio of canopy to patch area for counteracting patch scaling + real(r8) :: dbh ! actual dbh used to identify relevant size class + integer :: scpf ! size class x pft index + integer :: sc !----------------------------------------------------------------------- associate( & @@ -779,11 +1097,29 @@ subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & 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: - + ed_gpp_scpf => this%ed_gpp_col_scpf , & + ed_npp_totl_scpf => this%ed_npp_totl_col_scpf , & + ed_npp_leaf_scpf => this%ed_npp_leaf_col_scpf , & + ed_npp_seed_scpf => this%ed_npp_seed_col_scpf , & + ed_npp_fnrt_scpf => this%ed_npp_fnrt_col_scpf , & + ed_npp_bgsw_scpf => this%ed_npp_bgsw_col_scpf , & + ed_npp_bgdw_scpf => this%ed_npp_bgdw_col_scpf , & + ed_npp_agsw_scpf => this%ed_npp_agsw_col_scpf , & + ed_npp_agdw_scpf => this%ed_npp_agdw_col_scpf , & + ed_npp_stor_scpf => this%ed_npp_stor_col_scpf , & + + ed_npatches => this%ed_npatches_col , & + ed_ncohorts => this%ed_ncohorts_col , & + + ed_ddbh_col_scpf => this%ed_ddbh_col_scpf , & + ed_ba_col_scpf => this%ed_ba_col_scpf , & + ed_np_col_scpf => this%ed_np_col_scpf , & + ed_m1_col_scpf => this%ed_m1_col_scpf , & + ed_m2_col_scpf => this%ed_m2_col_scpf , & + ed_m3_col_scpf => this%ed_m3_col_scpf , & + ed_m4_col_scpf => this%ed_m4_col_scpf , & + ed_m5_col_scpf => this%ed_m5_col_scpf , & + tlai => canopystate_inst%tlai_patch , & ! InOut: elai => canopystate_inst%elai_patch , & ! InOut: tsai => canopystate_inst%tsai_patch , & ! InOut: @@ -791,7 +1127,6 @@ subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & begp => bounds%begp , & endp => bounds%endp & - ) ! ============================================================================ @@ -804,8 +1139,6 @@ subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & 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 @@ -830,138 +1163,268 @@ subroutine ed_update_history_variables( this, bounds, ed_allsites_inst, & 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 + + ed_gpp_scpf(:,:) = 0.0_r8 + ed_npp_totl_scpf(:,:) = 0.0_r8 + ed_npp_leaf_scpf(:,:) = 0.0_r8 + ed_npp_seed_scpf(:,:) = 0.0_r8 + ed_npp_fnrt_scpf(:,:) = 0.0_r8 + ed_npp_bgsw_scpf(:,:) = 0.0_r8 + ed_npp_bgdw_scpf(:,:) = 0.0_r8 + ed_npp_agsw_scpf(:,:) = 0.0_r8 + ed_npp_agdw_scpf(:,:) = 0.0_r8 + ed_npp_stor_scpf(:,:) = 0.0_r8 + + ed_ddbh_col_scpf(:,:) = 0.0_r8 + ed_ba_col_scpf(:,:) = 0.0_r8 + ed_np_col_scpf(:,:) = 0.0_r8 + ed_m1_col_scpf(:,:) = 0.0_r8 + ed_m2_col_scpf(:,:) = 0.0_r8 + ed_m3_col_scpf(:,:) = 0.0_r8 + ed_m4_col_scpf(:,:) = 0.0_r8 + ed_m5_col_scpf(:,:) = 0.0_r8 + + ed_npatches(:) = 0._r8 + ed_ncohorts(:) = 0._r8 + + do s = 1,nsites + + c = fcolumn(s) + + ! ============================================================================ + ! Zero the bare ground tile BGC variables. + ! ============================================================================ + + p = col%patchi(c) + + ! INTERF-TODO: THIS ZERO'ING IS REDUNDANT, THE WHOLE PATCH CLUMP IS ALREADY ZERO'D + + trimming(p) = 1.0_r8 + canopy_spread(p) = 0.0_r8 + PFTbiomass(p,:) = 0.0_r8 + PFTleafbiomass(p,:) = 0.0_r8 + PFTstorebiomass(p,:) = 0.0_r8 + PFTnindivs(p,:) = 0.0_r8 + area_plant(p) = 0.0_r8 + area_trees(p) = 0.0_r8 + nesterov_fire_danger(p) = 0.0_r8 + spitfire_ROS(p) = 0.0_r8 + TFC_ROS(p) = 0.0_r8 + effect_wspeed(p) = 0.0_r8 + fire_intensity(p) = 0.0_r8 + fire_area(p) = 0.0_r8 + scorch_height(p) = 0.0_r8 + fire_fuel_bulkd(p) = 0.0_r8 + fire_fuel_eff_moist(p) = 0.0_r8 + fire_fuel_sav(p) = 0.0_r8 + fire_fuel_mef(p) = 0.0_r8 + litter_in(p) = 0.0_r8 + litter_out(p) = 0.0_r8 + seed_bank(p) = 0.0_r8 + seeds_in(p) = 0.0_r8 + seed_decay(p) = 0.0_r8 + seed_germination(p) = 0.0_r8 + ED_biomass(p) = 0.0_r8 + ED_balive(p) = 0.0_r8 + ED_bdead(p) = 0.0_r8 + ED_bstore(p) = 0.0_r8 + ED_bleaf(p) = 0.0_r8 + elai(p) = 0.0_r8 + tlai(p) = 0.0_r8 + tsai(p) = 0.0_r8 + esai(p) = 0.0_r8 + ED_bleaf(p) = 0.0_r8 + sum_fuel(p) = 0.0_r8 + + currentPatch => sites(s)%oldest_patch + do while(associated(currentPatch)) + + ! INTERF-TODO: THIS LOGIC SHOULDN'T BE NECESSARY, SHOULD BE CHECKED AT THE BEGINNING + ! OF LINKING, ONCE + ! %patchno is the local index of the ED/FATES patches, starting at 1 + if(currentPatch%patchno <= numpft - numcft)then !don't expand into crop patches. + + ! Increment CLM/ALM patch index, first was non-veg, these are veg + p = p + 1 + + ed_npatches(c) = ed_npatches(c) + 1._r8 + + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + !accumulate into history variables. + + ft = currentCohort%pft + + ed_ncohorts(c) = ed_ncohorts(c) + 1._r8 + + if ((currentPatch%area .gt. 0._r8) .and. (currentPatch%total_canopy_area .gt. 0._r8)) then + + ! for quantities that are at the CLM patch level, because of the way that CLM patches are weighted for radiative purposes + ! this # density needs to be over either ED patch canopy area or ED patch total area, whichever is less + n_density = currentCohort%n/min(currentPatch%area,currentPatch%total_canopy_area) + + ! for quantities that are natively at column level, calculate plant density using whole area + n_perm2 = currentCohort%n/AREA + else - trimming(p) = 0.0_r8 + n_density = 0.0_r8 + n_perm2 = 0.0_r8 + endif + + if ( DEBUG ) then + write(iulog,*) 'EDCLMLinkMod I ',currentCohort%bstore + write(iulog,*) 'EDCLMLinkMod II ',p,ED_bstore(p) endif + ED_bleaf(p) = ED_bleaf(p) + n_density * currentCohort%bl * 1.e3_r8 + ED_bstore(p) = ED_bstore(p) + n_density * currentCohort%bstore * 1.e3_r8 + ED_biomass(p) = ED_biomass(p) + n_density * currentCohort%b * 1.e3_r8 + ED_bdead(p) = ED_bdead(p) + n_density * currentCohort%bdead * 1.e3_r8 + ED_balive(p) = ED_balive(p) + n_density * currentCohort%balive * 1.e3_r8 + PFTbiomass(p,ft) = PFTbiomass(p,ft) + n_density * currentCohort%b * 1.e3_r8 + PFTleafbiomass(p,ft) = PFTleafbiomass(p,ft) + n_density * currentCohort%bl * 1.e3_r8 + PFTstorebiomass(p,ft) = PFTstorebiomass(p,ft) + n_density * currentCohort%bstore * 1.e3_r8 + PFTnindivs(p,ft) = PFTnindivs(p,ft) + currentCohort%n + + dbh = currentCohort%dbh !-0.5*(1./365.25)*currentCohort%ddbhdt + sc = count(dbh-sclass_ed.ge.0.0) + scpf = (ft-1)*nlevsclass_ed+sc + + ! Flux Variables (must pass a NaN check on growth increment and not be recruits) + if( .not.(currentCohort%isnew) ) then + ed_gpp_scpf(c,scpf) = ed_gpp_scpf(c,scpf) + n_perm2*currentCohort%gpp ! [kgC/m2/yr] + ed_npp_totl_scpf(c,scpf) = ed_npp_totl_scpf(c,scpf) + currentcohort%npp*n_perm2 + ed_npp_leaf_scpf(c,scpf) = ed_npp_leaf_scpf(c,scpf) + currentcohort%npp_leaf*n_perm2 + ed_npp_fnrt_scpf(c,scpf) = ed_npp_fnrt_scpf(c,scpf) + currentcohort%npp_froot*n_perm2 + ed_npp_bgsw_scpf(c,scpf) = ed_npp_bgsw_scpf(c,scpf) + currentcohort%npp_bsw*(1._r8-ED_val_ag_biomass)*n_perm2 + ed_npp_agsw_scpf(c,scpf) = ed_npp_agsw_scpf(c,scpf) + currentcohort%npp_bsw*ED_val_ag_biomass*n_perm2 + ed_npp_bgdw_scpf(c,scpf) = ed_npp_bgdw_scpf(c,scpf) + currentcohort%npp_bdead*(1._r8-ED_val_ag_biomass)*n_perm2 + ed_npp_agdw_scpf(c,scpf) = ed_npp_agdw_scpf(c,scpf) + currentcohort%npp_bdead*ED_val_ag_biomass*n_perm2 + ed_npp_seed_scpf(c,scpf) = ed_npp_seed_scpf(c,scpf) + currentcohort%npp_bseed*n_perm2 + ed_npp_stor_scpf(c,scpf) = ed_npp_stor_scpf(c,scpf) + currentcohort%npp_store*n_perm2 + if( abs(currentcohort%npp-(currentcohort%npp_leaf+currentcohort%npp_froot+ & + currentcohort%npp_bsw+currentcohort%npp_bdead+ & + currentcohort%npp_bseed+currentcohort%npp_store))>1.e-9) then + write(iulog,*) 'NPP Partitions are not balancing' + write(iulog,*) 'Fractional Error: ',abs(currentcohort%npp-(currentcohort%npp_leaf+currentcohort%npp_froot+ & + currentcohort%npp_bsw+currentcohort%npp_bdead+ & + currentcohort%npp_bseed+currentcohort%npp_store))/currentcohort%npp + write(iulog,*) 'Terms: ',currentcohort%npp,currentcohort%npp_leaf,currentcohort%npp_froot, & + currentcohort%npp_bsw,currentcohort%npp_bdead, & + currentcohort%npp_bseed,currentcohort%npp_store + write(iulog,*) ' NPP components during FATES-HLM linking does not balance ' + call endrun(msg=errMsg(__FILE__, __LINE__)) + end if + + ! Woody State Variables (basal area and number density and mortality) + if (pftcon%woody(ft) == 1) then + + ed_m1_col_scpf(c,scpf) = ed_m1_col_scpf(c,scpf) + currentcohort%bmort*n_perm2*AREA + ed_m2_col_scpf(c,scpf) = ed_m2_col_scpf(c,scpf) + currentcohort%hmort*n_perm2*AREA + ed_m3_col_scpf(c,scpf) = ed_m3_col_scpf(c,scpf) + currentcohort%cmort*n_perm2*AREA + ed_m4_col_scpf(c,scpf) = ed_m4_col_scpf(c,scpf) + currentcohort%imort*n_perm2*AREA + ed_m5_col_scpf(c,scpf) = ed_m5_col_scpf(c,scpf) + currentcohort%fmort*n_perm2*AREA + + ! basal area [m2/ha] + ed_ba_col_scpf(c,scpf) = ed_ba_col_scpf(c,scpf) + & + 0.25*3.14159*((dbh/100.0)**2.0)*n_perm2*AREA + + ! number density [/ha] + ed_np_col_scpf(c,scpf) = ed_np_col_scpf(c,scpf) + AREA*n_perm2 + + ! Growth Incrments must have NaN check and woody check + if(currentCohort%ddbhdt == currentCohort%ddbhdt) then + ed_ddbh_col_scpf(c,scpf) = ed_ddbh_col_scpf(c,scpf) + & + currentCohort%ddbhdt*n_perm2*AREA + else + ed_ddbh_col_scpf(c,scpf) = -999.9 + end if + end if + + end if + + 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? + ! define scalar to counteract the patch albedo scaling logic for conserved quantities + + if (currentPatch%area .gt. 0._r8 .and. currentPatch%total_canopy_area .gt.0 ) then + patch_scaling_scalar = min(1._r8, currentPatch%area / currentPatch%total_canopy_area) else - write(iulog,*) 'ED: too many patches' - end if ! patchn<15 + patch_scaling_scalar = 0._r8 + endif - currentPatch => currentPatch%younger - end do !patch loop + nesterov_fire_danger(p) = sites(s)%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 * 1.e3_r8 * patch_scaling_scalar + + litter_in(p) = (sum(currentPatch%CWD_AG_in) + sum(currentPatch%leaf_litter_in)) * & + 1.e3_r8 * 365.0_r8 * SHR_CONST_CDAY * patch_scaling_scalar + + litter_out(p) = (sum(currentPatch%CWD_AG_out) + sum(currentPatch%leaf_litter_out)) * & + 1.e3_r8 * 365.0_r8 * SHR_CONST_CDAY * patch_scaling_scalar + + seed_bank(p) = sum(currentPatch%seed_bank) * 1.e3_r8 * patch_scaling_scalar + + seeds_in(p) = sum(currentPatch%seeds_in) * 1.e3_r8 * 365.0_r8 * SHR_CONST_CDAY * patch_scaling_scalar + + seed_decay(p) = sum(currentPatch%seed_decay) * 1.e3_r8 * 365.0_r8 * SHR_CONST_CDAY * patch_scaling_scalar + + seed_germination(p) = sum(currentPatch%seed_germination) * & + 1.e3_r8 * 365.0_r8 * SHR_CONST_CDAY * patch_scaling_scalar + + canopy_spread(p) = currentPatch%spread(1) + area_plant(p) = 1._r8 + if (min(currentPatch%total_canopy_area,currentPatch%area)>0.0_r8) then + area_trees(p) = currentPatch%total_tree_area / min(currentPatch%total_canopy_area,currentPatch%area) + else + area_trees(p) = 0.0_r8 + end if + 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 + enddo ! site loop end associate - end subroutine ed_update_history_variables + end subroutine ed_update_history_variables !------------------------------------------------------------------------ - subroutine ed_clm_leaf_area_profile( this, currentSite, waterstate_inst, canopystate_inst ) + + ! INTERF-TODO: THIS ROUTINE COULD BE SPLIT. IT CALCULATES BOTH FATES/ED INTERNALS + ! AS WELL AS VARIABLES FOR CLM/ALM. + + + subroutine ed_clm_leaf_area_profile( this, currentSite, colindex, waterstate_inst, canopystate_inst ) ! ! !DESCRIPTION: ! Load LAI in each layer into array to send to CLM ! - ! !USES: + ! !USES: + use FatesGlobals, only : fates_log + 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 @@ -972,6 +1435,7 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, waterstate_inst, canopys ! !ARGUMENTS class(ed_clm_type) :: this type(ed_site_type) , intent(inout) :: currentSite + integer , intent(in) :: colindex ! ALM/CLM column index of this site type(waterstate_type) , intent(inout) :: waterstate_inst type(canopystate_type) , intent(inout) :: canopystate_inst ! @@ -983,8 +1447,8 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, waterstate_inst, canopys 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 + integer :: p ! clm patch 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 ! @@ -1000,7 +1464,9 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, waterstate_inst, canopys 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 + real(r8) :: snow_depth_col ! averaged snow over whole columb integer :: NC ! number of cohorts, for bug fixing. + !---------------------------------------------------------------------- smooth_leaf_distribution = 0 @@ -1022,57 +1488,57 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, waterstate_inst, canopys ! 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 = col%patchi(colindex) ! first patch of the column of interest, for vegetated + ! columns this is the non-veg patch + + do while(associated(currentPatch)) + p = p + 1 ! First CLM/ALM patch is non-veg, increment at loop start + + !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) - 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 + !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,cp_nclmax-1 + if(currentCohort%canopy_layer == L)then + currentPatch%canopy_layer_lai(L) = currentPatch%canopy_layer_lai(L) + currentCohort%lai + & + currentCohort%sai + endif 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 + + currentCohort => currentCohort%taller + + enddo !currentCohort + currentPatch%nrad = currentPatch%ncan - if(smooth_leaf_distribution == 1)then + 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 @@ -1091,7 +1557,9 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, waterstate_inst, canopys maxh(iv) = (iv)*dh endif enddo - c = clmpatch%column(currentPatch%clm_pno) + + !c = clmpatch%column(currentPatch%clm_pno) + currentCohort => currentPatch%shortest do while(associated(currentCohort)) ft = currentCohort%pft @@ -1119,23 +1587,27 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, waterstate_inst, canopys 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 +!write(fates_log(), *) 'calc snow' + snow_depth_col = snow_depth(colindex) * frac_sno_eff(colindex) + if(snow_depth_col > maxh(iv))then fraction_exposed = 0._r8 endif - if(snowdp(c) < minh(iv))then - fraction_exposed = 1._r8 + if(snow_depth_col < 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))) + if(snow_depth_col>= minh(iv).and.snow_depth_col <= maxh(iv))then !only partly hidden... + fraction_exposed = max(0._r8,(min(1.0_r8,(snow_depth_col-minh(iv))/dh))) endif - + fraction_exposed = 1.0_r8 ! no m2 of leaf per m2 of ground in each height class ! FIX(SPM,032414) these should be uncommented this and double check - !currentPatch%elai_profile(1,ft,iv) = currentPatch%tlai_profile(1,ft,iv) * fraction_exposed - !currentPatch%esai_profile(1,ft,iv) = currentPatch%tsai_profile(1,ft,iv) * fraction_exposed + + if ( DEBUG ) write(fates_log(), *) 'EDCLMLink 1154 ', currentPatch%elai_profile(1,ft,iv) + + currentPatch%elai_profile(1,ft,iv) = currentPatch%tlai_profile(1,ft,iv) * fraction_exposed + currentPatch%esai_profile(1,ft,iv) = currentPatch%tsai_profile(1,ft,iv) * fraction_exposed + + if ( DEBUG ) write(fates_log(), *) 'EDCLMLink 1159 ', currentPatch%elai_profile(1,ft,iv) enddo ! (iv) hite bins @@ -1156,7 +1628,7 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, waterstate_inst, canopys enddo if(lai > currentPatch%lai)then - write(iulog,*) 'problem with lai assignments' + write(fates_log(), *) 'ED: problem with lai assignments' endif @@ -1165,7 +1637,8 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, waterstate_inst, canopys currentPatch%tlai_profile = 0._r8 currentPatch%tsai_profile = 0._r8 currentPatch%elai_profile = 0._r8 - currentPatch%esai_profile = 0._r8 + currentPatch%esai_profile = 0._r8 + currentPatch%layer_height_profile = 0._r8 currentPatch%canopy_area_profile(:,:,:) = 0._r8 currentPatch%ncan(:,:) = 0 currentPatch%nrad(:,:) = 0 @@ -1181,52 +1654,73 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, waterstate_inst, canopys fleaf = currentCohort%lai / (currentCohort%lai + currentCohort%sai) else fleaf = 0._r8 - write(iulog,*) 'no stem or leaf area' ,currentCohort%pft,currentCohort%bl, & + write(fates_log(), *) 'ED: 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 + write(fates_log(), *) 'ED: issue with NV',currentCohort%NV,currentCohort%pft,currentCohort%canopy_layer endif - c = clmpatch%column(currentPatch%clm_pno) + + ! c = clmpatch%column(currentPatch%clm_pno) + ! INTERF-TODO: REMOVE THIS AT SOME POINT, THIS SANITY CHECK IS NOT NEEDED WHEN THE + ! COLUMNIZATION IS COMPLETE + if( clmpatch%column(currentPatch%clm_pno) .ne. colindex .or. currentPatch%clm_pno .ne. p )then + ! ERROR + write(fates_log(), *) ' clmpatch%column(currentPatch%clm_pno) .ne. colindex .or. currentPatch%clm_pno .ne. p ' + call endrun(msg=errMsg(__FILE__, __LINE__)) + end if + !Whole layers. Make a weighted average of the leaf area in each layer before dividing it by the total area. !fill up layer for whole layers. 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 + + write(fates_log(), *) 'calc snow 2', colindex, snow_depth(colindex) , frac_sno_eff(colindex) + ! fraction_exposed = 1.0_r8 !default. + + ! snow_depth_col = snow_depth(c) ! * frac_sno_eff(c) + ! if(snow_depth_col > layer_top_hite)then + ! fraction_exposed = 0._r8 + ! endif + ! if(snow_depth_col < layer_bottom_hite)then + ! fraction_exposed = 1._r8 + ! endif + ! if(snow_depth_col>= layer_bottom_hite.and.snow_depth_col <= layer_top_hite)then !only partly hidden... + ! fraction_exposed = max(0._r8,(min(1.0_r8,(snow_depth_col-layer_bottom_hite)/ & + ! (layer_top_hite-layer_bottom_hite )))) + ! endif +fraction_exposed =1.0_r8 - 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 + currentPatch%tlai_profile(L,ft,iv) = currentPatch%tlai_profile(L,ft,iv)+ dinc_ed * fleaf * & + currentCohort%c_area/currentPatch%total_canopy_area + currentPatch%elai_profile(L,ft,iv) = currentPatch%elai_profile(L,ft,iv)+ dinc_ed * fleaf * & + currentCohort%c_area/currentPatch%total_canopy_area * fraction_exposed + + 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%esai_profile(L,ft,iv) = currentPatch%esai_profile(L,ft,iv)+ dinc_ed * (1._r8 - fleaf) * & + currentCohort%c_area/currentPatch%total_canopy_area * 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) + currentPatch%layer_height_profile(L,ft,iv) = currentPatch%layer_height_profile(L,ft,iv) + (dinc_ed * fleaf * & + currentCohort%c_area/currentPatch%total_canopy_area *(layer_top_hite+layer_bottom_hite)/2.0_r8) !average height of layer. + + write(fates_log(), *) 'LHP', currentPatch%layer_height_profile(L,ft,iv) + if ( DEBUG ) write(fates_log(), *) 'EDCLMLink 1246 ', currentPatch%elai_profile(1,ft,iv) + 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. @@ -1235,47 +1729,55 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, waterstate_inst, canopys ! 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 +!write(fates_log(), *) 'calc snow 3', snow_depth(c) , frac_sno_eff(c) + fraction_exposed = 1.0_r8 !default. + snow_depth_col = snow_depth(colindex) * frac_sno_eff(colindex) + if(snow_depth_col > layer_top_hite)then + fraction_exposed = 0._r8 + endif + if(snow_depth_col < layer_bottom_hite)then + fraction_exposed = 1._r8 + + endif + if(snow_depth_col>= layer_bottom_hite.and.snow_depth_col <= layer_top_hite)then !only partly hidden... + fraction_exposed = max(0._r8,(min(1.0_r8,(snow_depth_col-layer_bottom_hite)/ & + (layer_top_hite-layer_bottom_hite )))) + endif +fraction_exposed= 1.0_r8 + 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, & + write(fates_log(), *)'ED: 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 - + currentPatch%elai_profile(L,ft,iv) = currentPatch%elai_profile(L,ft,iv) + remainder * fleaf * & + currentCohort%c_area/currentPatch%total_canopy_area * fraction_exposed !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%esai_profile(L,ft,iv) = currentPatch%esai_profile(L,ft,iv)+ remainder * & + (1.0_r8-fleaf) * currentCohort%c_area/currentPatch%total_canopy_area * 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) - + currentPatch%layer_height_profile(L,ft,iv) = currentPatch%layer_height_profile(L,ft,iv) + (remainder * fleaf * & + currentCohort%c_area/currentPatch%total_canopy_area*(layer_top_hite+layer_bottom_hite)/2.0_r8) + write(fates_log(), *) 'LHP', currentPatch%layer_height_profile(L,ft,iv) 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 + write(fates_log(), *) '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 + write(fates_log(), *) '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 + write(fates_log(), *) 'ED: balive is zero in clmedlink',currentCohort%balive,currentCohort%bl endif currentCohort => currentCohort%taller @@ -1290,62 +1792,66 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, waterstate_inst, canopys 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) + + if ( DEBUG ) write(fates_log(), *) 'EDCLMLink 1293 ', currentPatch%elai_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) + currentPatch%layer_height_profile(L,ft,iv) = currentPatch%layer_height_profile(L,ft,iv) & + /currentPatch%tlai_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 - + currentPatch%tlai_profile(L,ft,currentPatch%nrad(L,ft)+1: cp_nlevcan) = 0._r8 + currentPatch%tsai_profile(L,ft,currentPatch%nrad(L,ft)+1: cp_nlevcan) = 0._r8 + currentPatch%elai_profile(L,ft,currentPatch%nrad(L,ft)+1: cp_nlevcan) = 0._r8 + currentPatch%esai_profile(L,ft,currentPatch%nrad(L,ft)+1: cp_nlevcan) = 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 +! 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))) + ! 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 + ! This should not had changed +! 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) + write(fates_log(), *) 'ED: error with tlai calcs',& + NC,colindex, 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)) + write(fates_log(), *) 'ED: carea profile',L,currentPatch%canopy_area_profile(L,1,1:currentPatch%nrad(L,1)) + write(fates_log(), *) 'ED: 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,:,:) + elai(p) = calc_areaindex(currentPatch,'elai') + tlai(p) = calc_areaindex(currentPatch,'tlai') + esai(p) = calc_areaindex(currentPatch,'esai') + tsai(p) = calc_areaindex(currentPatch,'tsai') ! Fraction of vegetation free of snow. What does this do? Is it right? if ((elai(p) + esai(p)) > 0._r8) then @@ -1353,13 +1859,12 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, waterstate_inst, canopys 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' + write(fates_log(), *) 'ED: issue w/ nrad' endif currentPatch%present(L,ft) = 0 do iv = 1, currentPatch%nrad(L,ft); @@ -1371,30 +1876,32 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, waterstate_inst, canopys 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,:) + write(fates_log(), *) 'ED: canopy area too small',sum(currentPatch%canopy_area_profile(1,1:numpft_ed,1)) + write(fates_log(), *) 'ED: cohort areas', currentPatch%canopy_area_profile(1,1:numpft_ed,:) 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', & + write(fates_log(), *) 'ED: not enough area in the top canopy', & sum(currentPatch%canopy_area_profile(L,1:numpft_ed,1)), & currentPatch%canopy_area_profile(L,1:numpft_ed,1) 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 + write(fates_log(), *) 'ED: canopy-area-profile wrong', & + sum(currentPatch%canopy_area_profile(L,1:numpft_ed,1)), & + colindex, currentPatch%patchno, L + write(fates_log(), *) 'ED: 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, & + write(fates_log(), *) 'ED: 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 + write(fates_log(), *) 'ED: fracarea', currentCohort%pft, & + currentCohort%c_area/currentPatch%total_canopy_area endif currentCohort => currentCohort%taller @@ -1406,7 +1913,7 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, waterstate_inst, canopys 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) + write(fates_log(), *) 'ED: present issue',currentPatch%clm_pno,L,ft,currentPatch%present(L,FT) currentPatch%present(L,ft) = 1 endif enddo @@ -1418,10 +1925,444 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, waterstate_inst, canopys enddo !patch - endif !is there soil? - - end associate + end associate end subroutine ed_clm_leaf_area_profile + ! ===================================================================================== + + subroutine SummarizeProductivityFluxes(this, bounds, nsites, sites, fcolumn) + + ! Summarize the fast production inputs from fluxes per ED individual to fluxes per CLM patch and column + ! Must be called between calculation of productivity fluxes and daily ED calls + ! (since daily ED calls reorganize the patch / cohort structure) + + ! Written By Charlie Koven, April 2016 + ! + ! !USES: + use LandunitType , only : lun + use landunit_varcon , only : istsoil + !use subgridAveMod , only : p2c + ! + implicit none + ! + ! !ARGUMENTS + class(ed_clm_type) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: nsites + type(ed_site_type) , intent(in), target :: sites(nsites) + integer , intent(in) :: fcolumn(nsites) + ! + ! !LOCAL VARIABLES: + real(r8) :: dt ! radiation time step (seconds) + integer :: c, fc, l, p, s + type (ed_patch_type) , pointer :: currentPatch + type (ed_cohort_type) , pointer :: currentCohort + integer :: firstsoilpatch(bounds%begg:bounds%endg) ! the first patch in this gridcell that is soil and thus bare... + real(r8) :: n_density ! individual of cohort per m2. + real(r8) :: n_perm2 ! individuals per m2 of the whole column + + associate(& + npp_col => this%npp_col, & + npp => this%npp_patch, & + gpp => this%gpp_patch, & + ar => this%ar_patch, & + growth_resp => this%growth_resp_patch, & + maint_resp => this%maint_resp_patch & + ) + + ! set time steps + dt = real( get_step_size(), r8 ) + + ! zero variables first + ! column variables + do c = bounds%begc,bounds%endc + ! summary flux variables + npp_col(c) = 0._r8 + end do + + ! patch variables + do p = bounds%begp,bounds%endp + npp(p) = 0._r8 + gpp(p) = 0._r8 + ar(p) = 0._r8 + growth_resp(p) = 0._r8 + maint_resp(p) = 0._r8 + end do + + ! retrieve the first soil patch associated with each gridcell. + ! make sure we only get the first patch value for places which have soil. + + do s = 1,nsites + + c = fcolumn(s) + p = col%patchi(c) + + currentPatch => sites(s)%oldest_patch + do while(associated(currentPatch)) + + p = p + 1 + + currentCohort => currentPatch%tallest + do while(associated(currentCohort)) + + if ((currentPatch%area .gt. 0._r8) .and. (currentPatch%total_canopy_area .gt. 0._r8)) then + + ! for quantities that are at the CLM patch level, because of the way that CLM patches are weighted for radiative purposes + ! this # density needs to be over either ED patch canopy area or ED patch total area, whichever is less + n_density = currentCohort%n/min(currentPatch%area,currentPatch%total_canopy_area) + + ! for quantities that are natively at column level or higher, calculate plant density using whole area (for grid cell averages) + n_perm2 = currentCohort%n/AREA + + else + n_density = 0.0_r8 + n_perm2 = 0.0_r8 + endif + + if ( .not. currentCohort%isnew ) then + + ! map ed cohort-level fluxes to clm patch fluxes + npp(p) = npp(p) + currentCohort%npp_tstep * 1.e3_r8 * n_density / dt + gpp(p) = gpp(p) + currentCohort%gpp_tstep * 1.e3_r8 * n_density / dt + ar(p) = ar(p) + currentCohort%resp_tstep * 1.e3_r8 * n_density / dt + growth_resp(p) = growth_resp(p) + currentCohort%resp_g * 1.e3_r8 * n_density / dt + maint_resp(p) = maint_resp(p) + currentCohort%resp_m * 1.e3_r8 * n_density / dt + + ! map ed cohort-level npp fluxes to clm column fluxes + npp_col(c) = npp_col(c) + currentCohort%npp_tstep * n_perm2 * 1.e3_r8 /dt + + endif + + currentCohort => currentCohort%shorter + enddo !currentCohort + currentPatch => currentPatch%younger + end do !currentPatch + + end do ! site loop + + ! leaving this as a comment here. it should produce same answer for npp_col as above, + ! so it may be useful to try as a check to make sure machinery is working proerly + !call p2c(bounds,num_soilc, filter_soilc, npp(bounds%begp:bounds%endp), npp_col(bounds%begc:bounds%endc)) + + end associate +end subroutine SummarizeProductivityFluxes + + !------------------------------------------------------------------------ + subroutine SummarizeNetFluxes(this, bounds, num_soilc, filter_soilc, & + nsites, sites, fcolumn, soilbiogeochem_carbonflux_inst, & + soilbiogeochem_carbonstate_inst) + + ! Summarize the combined production and decomposition fluxes into net fluxes + ! This is done on the fast timestep, and to be called after both daily ED calls and fast BGC calls + ! Does not include summarization of fast-timestsp productivity calls because these must be summarized prior to daily ED calls + ! + ! Written by Charlie Koven, Feb 2016 + ! + ! !USES: + use LandunitType , only : lun + use landunit_varcon , only : istsoil + ! + implicit none + ! + ! !ARGUMENTS + class(ed_clm_type) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + integer , intent(in) :: nsites + type(ed_site_type) , intent(in), target :: sites(nsites) + integer , intent(in) :: fcolumn(nsites) + type(soilbiogeochem_carbonflux_type) , intent(inout) :: soilbiogeochem_carbonflux_inst + type(soilbiogeochem_carbonstate_type) , intent(inout) :: soilbiogeochem_carbonstate_inst + ! + ! !LOCAL VARIABLES: + real(r8) :: dt ! radiation time step (seconds) + integer :: c, s, cc, fc, l, p, pp + type(ed_site_type), pointer :: cs + type (ed_patch_type) , pointer :: currentPatch + type (ed_cohort_type) , pointer :: currentCohort +! integer :: firstsoilpatch(bounds%begg:bounds%endg) ! the first patch in this gridcell that is soil and thus bare... + real(r8) :: n_perm2 ! individuals per m2 of the whole column + + associate(& + hr => soilbiogeochem_carbonflux_inst%hr_col, & ! (gC/m2/s) total heterotrophic respiration + totsomc => soilbiogeochem_carbonstate_inst%totsomc_col, & ! (gC/m2) total soil organic matter carbon + totlitc => soilbiogeochem_carbonstate_inst%totlitc_col, & ! (gC/m2) total litter carbon in BGC pools + npp_col => this%npp_col, & + nep => this%nep_col, & + fire_c_to_atm => this%fire_c_to_atm_col, & + nbp => this%nbp_col, & + totecosysc => this%totecosysc_col, & + totedc => this%totedc_col, & + totbgcc => this%totbgcc_col, & + biomass_stock => this%biomass_stock_col, & ! total biomass in gC / m2 + ed_litter_stock => this%ed_litter_stock_col, & ! ED litter in gC / m2 + cwd_stock => this%cwd_stock_col, & ! total CWD in gC / m2 + seed_stock => this%seed_stock_col, & ! total seed mass in gC / m2 + ed_to_bgc_this_edts => this%ed_to_bgc_this_edts_col, & + ed_to_bgc_last_edts => this%ed_to_bgc_last_edts_col, & + seed_rain_flux => this%seed_rain_flux_col & + ) + + ! set time steps + dt = real( get_step_size(), r8 ) + + ! zero variables first + ! column variables + do c = bounds%begc,bounds%endc + ! summary flux variables + fire_c_to_atm(c) = 0._r8 + + ! summary stock variables + ed_litter_stock(c) = 0._r8 + cwd_stock(c) = 0._r8 + seed_stock(c) = 0._r8 + biomass_stock(c) = 0._r8 + end do + + do s = 1, nsites + + c = fcolumn(s) + p = col%patchi(c) + + ! map ed site-level fire fluxes to clm column fluxes + fire_c_to_atm(c) = sites(s)%total_burn_flux_to_atm / ( AREA * SHR_CONST_CDAY * 1.e3_r8) + + currentPatch => sites(s)%oldest_patch + do while(associated(currentPatch)) + + p = p + 1 + + ! map litter, CWD, and seed pools to column level + cwd_stock(c) = cwd_stock(c) + (currentPatch%area / AREA) * (sum(currentPatch%cwd_ag)+ & + sum(currentPatch%cwd_bg)) * 1.e3_r8 + ed_litter_stock(c) = ed_litter_stock(c) + (currentPatch%area / AREA) * & + (sum(currentPatch%leaf_litter)+sum(currentPatch%root_litter)) * 1.e3_r8 + seed_stock(c) = seed_stock(c) + (currentPatch%area / AREA) * sum(currentPatch%seed_bank) * 1.e3_r8 + + currentCohort => currentPatch%tallest + do while(associated(currentCohort)) + + ! for quantities that are natively at column level or higher, calculate plant density using whole area (for grid cell averages) + n_perm2 = currentCohort%n/AREA + + ! map biomass pools to column level + biomass_stock(c) = biomass_stock(c) + (currentCohort%bdead + currentCohort%balive + & + currentCohort%bstore) * n_perm2 * 1.e3_r8 + + currentCohort => currentCohort%shorter + enddo !currentCohort + currentPatch => currentPatch%younger + end do ! patch loop + end do ! site loop + + ! calculate NEP and NBP fluxes. ????? + do fc = 1,num_soilc + c = filter_soilc(fc) + nep(c) = npp_col(c) - hr(c) + nbp(c) = npp_col(c) - ( hr(c) + fire_c_to_atm(c) ) + end do + + ! calculate total stocks + do fc = 1,num_soilc + c = filter_soilc(fc) + + totedc(c) = ed_litter_stock(c) + cwd_stock(c) + seed_stock(c) + biomass_stock(c) ! ED stocks + totbgcc(c) = totsomc(c) + totlitc(c) ! BGC stocks + totecosysc(c) = totedc(c) + totbgcc(c) + + end do + + ! in ED timesteps, because of offset between when ED and BGC reconcile the gain and loss of litterfall carbon, + ! (i.e. ED reconciles it instantly, while BGC reconciles it incrementally over the subsequent day) + ! calculate the total ED -> BGC flux and keep track of the last day's info for balance checking purposes + if ( is_beg_curr_day() ) then + ! + do s = 1,nsites + c = fcolumn(s) + ed_to_bgc_last_edts(c) = ed_to_bgc_this_edts(c) + end do + ! + do s = 1,nsites + c = fcolumn(s) + ed_to_bgc_this_edts(c) = 0._r8 + seed_rain_flux(c) = 0._r8 + end do + ! + do s = 1,nsites + c = fcolumn(s) + + currentPatch => sites(s)%oldest_patch + do while(associated(currentPatch)) + ! + ed_to_bgc_this_edts(c) = ed_to_bgc_this_edts(c) + & + (sum(currentPatch%CWD_AG_out) + sum(currentPatch%CWD_BG_out) + & + sum(currentPatch%seed_decay) + sum(currentPatch%leaf_litter_out) + & + sum(currentPatch%root_litter_out)) * & + ( currentPatch%area/AREA ) * 1.e3_r8 / ( 365.0_r8*SHR_CONST_CDAY ) + ! + seed_rain_flux(c) = seed_rain_flux(c) + sum(currentPatch%seed_rain_flux) * 1.e3_r8 / ( 365.0_r8*SHR_CONST_CDAY ) + ! + currentPatch => currentPatch%younger + end do !currentPatch + end do + endif + + end associate + + end subroutine SummarizeNetFluxes + + + subroutine ED_BGC_Carbon_Balancecheck(this, bounds, num_soilc, filter_soilc, soilbiogeochem_carbonflux_inst) + + ! Integrate in time the fluxes into and out of the ecosystem, and compare these on a daily timestep + ! to the chagne in carbon stocks of the ecosystem + ! + ! Written by Charlie Koven, Feb 2016 + ! + ! !USES: + ! + implicit none + ! + ! !ARGUMENTS + class(ed_clm_type) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + type(soilbiogeochem_carbonflux_type) , intent(inout) :: soilbiogeochem_carbonflux_inst + ! + ! !LOCAL VARIABLES: + real(r8) :: dtime ! land model time step (sec) + integer :: nstep ! model timestep + real(r8) :: nbp_integrated(bounds%begc:bounds%endc) ! total net biome production integrated + real(r8) :: error_total(bounds%begc:bounds%endc) + real(r8) :: error_ed(bounds%begc:bounds%endc) + real(r8) :: error_bgc(bounds%begc:bounds%endc) + real(r8) :: error_tolerance = 1.e-6_r8 + real(r8) :: max_error_ed + real(r8) :: max_error_bgc + real(r8) :: max_error_total + integer :: fc,c + + associate(& + nep => this%nep_col, & + nep_timeintegrated => this%nep_timeintegrated_col, & + hr => soilbiogeochem_carbonflux_inst%hr_col, & + hr_timeintegrated => this%hr_timeintegrated_col, & + npp_col => this%npp_col, & + npp_timeintegrated => this%npp_timeintegrated_col, & + fire_c_to_atm => this%fire_c_to_atm_col, & + totecosysc_old => this%totecosysc_old_col, & + totecosysc => this%totecosysc_col, & + totedc_old => this%totedc_old_col, & + totedc => this%totedc_col, & + totbgcc_old => this%totbgcc_old_col, & + totbgcc => this%totbgcc_col, & + ed_to_bgc_this_edts => this%ed_to_bgc_this_edts_col, & + ed_to_bgc_last_edts => this%ed_to_bgc_last_edts_col, & + seed_rain_flux => this%seed_rain_flux_col, & + cbalance_error_ed => this%cbalance_error_ed_col, & + cbalance_error_bgc => this%cbalance_error_bgc_col, & + cbalance_error_total=> this%cbalance_error_total_col & + ) + + dtime = get_step_size() + nstep = get_nstep() + + if (nstep .le. 1) then + ! when starting up the model, initialize the integrator variables + do fc = 1,num_soilc + c = filter_soilc(fc) + totecosysc_old(c) = totecosysc(c) + totedc_old(c) = totedc(c) + totbgcc_old(c) = totbgcc(c) + nep_timeintegrated(c) = 0._r8 + hr_timeintegrated(c) = 0._r8 + npp_timeintegrated(c) = 0._r8 + ! + ! also initialize the ed-BGC flux variables + ed_to_bgc_this_edts(c) = 0._r8 + ed_to_bgc_last_edts(c) = 0._r8 + ! + cbalance_error_ed(c) = 0._r8 + cbalance_error_bgc(c) = 0._r8 + cbalance_error_total(c) = 0._r8 + end do + endif + + if ( .not. is_beg_curr_day() ) then + ! on CLM (half-hourly) timesteps, integrate the NEP fluxes + do fc = 1,num_soilc + c = filter_soilc(fc) + nep_timeintegrated(c) = nep_timeintegrated(c) + nep(c) * dtime + hr_timeintegrated(c) = hr_timeintegrated(c) + hr(c) * dtime + npp_timeintegrated(c) = npp_timeintegrated(c) + npp_col(c) * dtime + end do + else + ! on ED (daily) timesteps, first integrate the NEP fluxes and add in the daily disturbance flux + do fc = 1,num_soilc + c = filter_soilc(fc) + nep_timeintegrated(c) = nep_timeintegrated(c) + nep(c) * dtime + hr_timeintegrated(c) = hr_timeintegrated(c) + hr(c) * dtime + npp_timeintegrated(c) = npp_timeintegrated(c) + npp_col(c) * dtime + nbp_integrated(c) = nep_timeintegrated(c) - fire_c_to_atm(c) * SHR_CONST_CDAY + seed_rain_flux(c)* SHR_CONST_CDAY + end do + + ! next compare the change in carbon and calculate the error + do fc = 1,num_soilc + c = filter_soilc(fc) + error_ed(c) = totedc(c) - totedc_old(c) - & + (npp_timeintegrated(c) + seed_rain_flux(c) * SHR_CONST_CDAY - & + ed_to_bgc_this_edts(c) * SHR_CONST_CDAY - & + fire_c_to_atm(c) * SHR_CONST_CDAY) + + error_bgc(c) = totbgcc(c) - totbgcc_old(c) - & + (ed_to_bgc_last_edts(c) * SHR_CONST_CDAY - hr_timeintegrated(c)) + + error_total(c) = totecosysc(c) - totecosysc_old(c) - & + (nbp_integrated(c) + ed_to_bgc_last_edts(c) * SHR_CONST_CDAY - & + ed_to_bgc_this_edts(c)* SHR_CONST_CDAY) + end do + ! + ! put in consistent flux units and send to history so we can keep track of the errors + do fc = 1,num_soilc + c = filter_soilc(fc) + cbalance_error_ed(c) = error_ed(c) / SHR_CONST_CDAY + cbalance_error_bgc(c) = error_bgc(c) / SHR_CONST_CDAY + cbalance_error_total(c) = error_total(c) / SHR_CONST_CDAY + end do + + ! for now, rather than crashing the model, lets just report the largest error to see what we're up against + ! + ! RETURN TO THIS LATER AND ADD A CRASHER IF BALANCE EXCEEDS THRESHOLD + ! + ! max_error_total = 0._r8 + ! do fc = 1,num_soilc + ! c = filter_soilc(fc) + ! if (abs(error_total(c)) .gt. max_error_total) then + ! max_error_ed = abs(error_ed(c)) + ! max_error_bgc = abs(error_bgc(c)) + ! max_error_total = abs(error_total(c)) + ! endif + ! end do + ! write(iulog,*) 'ED_BGC_Carbon_Balancecheck: max_error_ed, max_error_bgc, max_error_total (gC / m2 / day): ', max_error_ed, max_error_bgc, max_error_total + + ! reset the C stock and flux integrators + do fc = 1,num_soilc + c = filter_soilc(fc) + totecosysc_old(c) = totecosysc(c) + totedc_old(c) = totedc(c) + totbgcc_old(c) = totbgcc(c) + nep_timeintegrated(c) = 0._r8 + npp_timeintegrated(c) = 0._r8 + hr_timeintegrated(c) = 0._r8 + end do + + endif + + end associate + + end subroutine ED_BGC_Carbon_Balancecheck + end module EDCLMLinkMod diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 3390053c..dd263295 100755 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -8,131 +8,37 @@ module EDInitMod use spmdMod , only : masterproc use decompMod , only : bounds_type use abortutils , only : endrun - use clm_varpar , only : nclmax + use EDTypesMod , only : cp_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 EDTypesMod , only : cohorts_per_col, ncwd, numpft_ed, udata use EDCLMLinkMod , only : ed_clm_type implicit none private - public :: ed_init - public :: ed_init_sites - public :: zero_site + logical :: DEBUG = .false. - private :: set_site_properties - private :: init_patches + public :: zero_site + public :: init_patches + public :: set_site_properties + 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: @@ -152,9 +58,6 @@ subroutine zero_site( site_in ) ! 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. @@ -163,7 +66,7 @@ subroutine zero_site( site_in ) ! 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%ED_GDD_site = 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 @@ -179,84 +82,85 @@ subroutine zero_site( site_in ) end subroutine zero_site ! ============================================================================ - subroutine set_site_properties( bounds, ed_allsites_inst ) + subroutine set_site_properties( nsites, sites) ! ! !DESCRIPTION: ! ! !USES: ! ! !ARGUMENTS - type(bounds_type) , intent(in) :: bounds - type(ed_site_type) , intent(inout), target :: ed_allsites_inst( bounds%begg: ) + + integer, intent(in) :: nsites + type(ed_site_type) , intent(inout), target :: sites(nsites) ! ! !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) + integer :: s + real(r8) :: leafon + real(r8) :: leafoff + real(r8) :: stat + real(r8) :: NCD + real(r8) :: GDD + real(r8) :: dstat + real(r8) :: acc_NI + real(r8) :: watermem + integer :: dleafoff + integer :: dleafon !---------------------------------------------------------------------- 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 + NCD = 0.0_r8 + GDD = 30.0_r8 + leafon = 100.0_r8 + leafoff = 300.0_r8 + stat = 2 + acc_NI = 0.0_r8 + dstat = 2 + dleafoff = 300 + dleafon = 100 + watermem = 0.5_r8 + 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 + + NCD = 1.0_r8 ! NCD should be 1 on restart + GDD = 0.0_r8 + leafon = 0.0_r8 + leafoff = 0.0_r8 + stat = 1 + acc_NI = 0.0_r8 + dstat = 2 + dleafoff = 300 + dleafon = 100 + watermem = 0.5_r8 + 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) + do s = 1,nsites + sites(s)%ncd = NCD + sites(s)%leafondate = leafon + sites(s)%leafoffdate = leafoff + sites(s)%dleafoffdate = dleafoff + sites(s)%dleafondate = dleafon + sites(s)%ED_GDD_site = GDD if ( .not. is_restart() ) then - ed_allsites_inst(g)%water_memory(1:10) = watermem(g) + sites(s)%water_memory(1:10) = watermem end if - ed_allsites_inst(g)%status = stat(g) + sites(s)%status = stat !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 - + sites(s)%dstatus= dstat + + sites(s)%acc_NI = acc_NI + sites(s)%frac_burnt = 0.0_r8 + sites(s)%old_stock = 0.0_r8 + end do + + return end subroutine set_site_properties ! ============================================================================ - subroutine init_patches( bounds, ed_allsites_inst ) + subroutine init_patches( nsites, sites) ! ! !DESCRIPTION: !initialize patches on new ground @@ -265,14 +169,14 @@ subroutine init_patches( bounds, ed_allsites_inst ) 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: ) + integer, intent(in) :: nsites + type(ed_site_type) , intent(inout), target :: sites(nsites) ! ! !LOCAL VARIABLES: - integer :: g + integer :: s real(r8) :: cwd_ag_local(ncwd) real(r8) :: cwd_bg_local(ncwd) - real(r8) :: spread_local(nclmax) + real(r8) :: spread_local(cp_nclmax) real(r8) :: leaf_litter_local(numpft_ed) real(r8) :: root_litter_local(numpft_ed) real(r8) :: seed_bank_local(numpft_ed) @@ -289,27 +193,26 @@ subroutine init_patches( bounds, ed_allsites_inst ) age = 0.0_r8 !FIX(SPM,032414) clean this up...inits out of this loop - do g = bounds%begg,bounds%endg + do s = 1, nsites 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 + sites(s)%youngest_patch => newp + sites(s)%youngest_patch => newp + sites(s)%oldest_patch => newp ! make new patch... - call create_patch(ed_allsites_inst(g), newp, age, AREA, & + call create_patch(sites(s), 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 + enddo end subroutine init_patches @@ -335,6 +238,8 @@ subroutine init_cohorts( patch_in ) do pft = 1,numpft_ed !FIX(RF,032414) - turning off veg dynamics + if(EDecophyscon%initd(pft)>1.0E-7) then + allocate(temp_cohort) ! temporary cohort temp_cohort%pft = pft @@ -372,12 +277,16 @@ subroutine init_cohorts( patch_in ) cstatus = patch_in%siteptr%dstatus endif + if ( DEBUG ) write(iulog,*) 'EDInitMod.F90 call create_cohort ' + 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 + endif + enddo !numpft call fuse_cohorts(patch_in) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index ccabb1ba..f920f397 100755 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -5,7 +5,7 @@ module EDMainMod ! ============================================================================ 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 @@ -15,9 +15,8 @@ module EDMainMod 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 : ncwd, 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 @@ -25,109 +24,31 @@ module EDMainMod ! ! !PUBLIC MEMBER FUNCTIONS: - public :: ed_driver + public :: ed_ecosystem_dynamics 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. + logical :: DEBUG = .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, & + ed_clm_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_site_type) , intent(inout), target :: currentSite type(ed_clm_type) , intent(in) :: ed_clm_inst type(atm2lnd_type) , intent(in) :: atm2lnd_inst type(soilstate_type) , intent(in) :: soilstate_inst @@ -147,7 +68,7 @@ subroutine ed_ecosystem_dynamics(currentSite, & call ed_total_balance_check(currentSite, 0) - call phenology(currentSite, ed_phenology_inst, temperature_inst, waterstate_inst) + call phenology(currentSite, temperature_inst, waterstate_inst) call fire_model(currentSite, atm2lnd_inst, temperature_inst) @@ -155,7 +76,7 @@ subroutine ed_ecosystem_dynamics(currentSite, & 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) + call ed_integrate_state_variables(currentSite, temperature_inst ) !****************************************************************************** ! Reproduction, Recruitment and Cohort Dynamics : controls cohort organisation @@ -175,15 +96,16 @@ subroutine ed_ecosystem_dynamics(currentSite, & 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) + ! kills cohorts that are too small + call terminate_cohorts(currentPatch) + + currentPatch => currentPatch%younger enddo @@ -211,7 +133,7 @@ subroutine ed_ecosystem_dynamics(currentSite, & end subroutine ed_ecosystem_dynamics !-------------------------------------------------------------------------------! - subroutine ed_integrate_state_variables(currentSite, soilstate_inst, temperature_inst, waterstate_inst) + subroutine ed_integrate_state_variables(currentSite, temperature_inst ) ! ! !DESCRIPTION: ! FIX(SPM,032414) refactor so everything goes through interface @@ -219,10 +141,8 @@ subroutine ed_integrate_state_variables(currentSite, soilstate_inst, temperature ! !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 + type(ed_site_type) , intent(in) :: currentSite + type(temperature_type) , intent(in) :: temperature_inst ! ! !LOCAL VARIABLES: type(ed_patch_type) , pointer :: currentPatch @@ -243,7 +163,7 @@ subroutine ed_integrate_state_variables(currentSite, soilstate_inst, temperature 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, & + write(iulog,*) 'negative patch age?',currentPatch%age, & currentPatch%patchno,currentPatch%area endif @@ -258,7 +178,15 @@ subroutine ed_integrate_state_variables(currentSite, soilstate_inst, temperature 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 ) + if ( DEBUG ) then + write(iulog,*) 'EDMainMod dbstoredt I ',currentCohort%bstore, & + currentCohort%dbstoredt,udata%deltat + end if currentCohort%bstore = currentCohort%bstore + currentCohort%dbstoredt * udata%deltat + if ( DEBUG ) then + write(iulog,*) 'EDMainMod dbstoredt II ',currentCohort%bstore, & + currentCohort%dbstoredt,udata%deltat + end if if( (currentCohort%balive+currentCohort%bdead+currentCohort%bstore)*currentCohort%n<0._r8)then write(iulog,*) 'biomass is negative', currentCohort%n,currentCohort%balive, & @@ -276,14 +204,17 @@ subroutine ed_integrate_state_variables(currentSite, soilstate_inst, temperature currentCohort%gpp_acc = 0.0_r8 currentCohort%resp_acc = 0.0_r8 - call allocate_live_biomass(currentCohort) + call allocate_live_biomass(currentCohort,1) 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 ) + if ( DEBUG ) then + write(6,*)'DEBUG18: calling non_canopy_derivs with pno= ',currentPatch%clm_pno + endif + + call non_canopy_derivs( currentPatch, temperature_inst ) !update state variables simultaneously according to derivatives for this time period. do p = 1,numpft_ed @@ -321,11 +252,12 @@ subroutine ed_integrate_state_variables(currentSite, soilstate_inst, temperature do p = 1,numpft_ed if(currentPatch%leaf_litter(p) 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 => currentSite%oldest_patch + do while(associated(currentPatch)) - currentPatch => currentPatch%younger + 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 - enddo !end patch loop + currentPatch => currentPatch%younger - endif + enddo !end patch loop total_stock = biomass_stock + seed_stock +litter_stock change_in_stock = total_stock - currentSite%old_stock @@ -477,8 +407,12 @@ subroutine ed_total_balance_check (currentSite, call_index ) 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,*) 'total error: call index: ',call_index, & + 'in: ',currentSite%flux_in, & + 'out: ',currentSite%flux_out, & + 'net: ',net_flux, & + 'dstock: ',change_in_stock, & + 'error=net_flux-dstock:', error write(iulog,*) 'biomass,litter,seeds', biomass_stock,litter_stock,seed_stock write(iulog,*) 'lat lon',currentSite%lat,currentSite%lon endif @@ -487,6 +421,6 @@ subroutine ed_total_balance_check (currentSite, call_index ) currentSite%flux_out = 0.0_r8 currentSite%old_stock = total_stock - end subroutine ed_total_balance_check + end subroutine ed_total_balance_check end module EDMainMod diff --git a/main/EDParamsMod.F90 b/main/EDParamsMod.F90 index cf851430..16e2f2f5 100644 --- a/main/EDParamsMod.F90 +++ b/main/EDParamsMod.F90 @@ -3,6 +3,7 @@ module EDParamsMod ! module that deals with reading the ED parameter file ! use shr_kind_mod , only: r8 => shr_kind_r8 + use EDtypesMod , only: maxPft implicit none save @@ -16,7 +17,7 @@ module EDParamsMod 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_grperc(maxPft) real(r8),protected :: ED_val_maxspread real(r8),protected :: ED_val_minspread real(r8),protected :: ED_val_init_litter diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index 421828a6..475ee7b1 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -38,6 +38,7 @@ module EDPftvarcon 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 + real(r8) :: dbh2h_m (0:mxpft) ! allocation parameter m from dbh to height end type EDPftvarcon_type type(EDPftvarcon_type), public :: EDPftvarcon_inst @@ -131,6 +132,10 @@ subroutine EDpftconrd( ncid ) 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') + +! HOLDING ON SEW ENSITIVITY-ANALYSIS PARAMETERS UNTIL MACHINE CONFIGS SET RGK/CX +! call ncd_io('dbh2h_m',EDPftvarcon_inst%dbh2h_m, 'read', ncid, readvar=readv) +! if ( .not. readv) call endrun(trim(subname)// ' ERROR : error in reading in pft data') end subroutine EDpftconrd diff --git a/main/EDRestVectorMod.F90 b/main/EDRestVectorMod.F90 index 4481e42e..89d485be 100755 --- a/main/EDRestVectorMod.F90 +++ b/main/EDRestVectorMod.F90 @@ -6,18 +6,22 @@ module EDRestVectorMod 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 spmdMod , only : masterproc + use decompMod , only : bounds_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 : area, cohorts_per_col, numpft_ed, numWaterMem, cp_nclmax, numCohortsPerPatch + use EDTypesMod , only : ncwd, invalidValue, cp_nlevcan use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type - use EDPhenologyType , only : ed_phenology_type + use abortutils , only : endrun + ! implicit none private ! + ! integer constants for storing logical data + integer, parameter :: old_cohort = 0 + integer, parameter :: new_cohort = 1 + ! ! ED cohort data as a type of vectors ! type, public :: EDRestartVectorClass @@ -34,8 +38,7 @@ module EDRestVectorMod ! required to map cohorts and patches to/fro ! vectors/LinkedLists - integer, pointer :: cellWithPatch(:) - integer, pointer :: numPatchesPerCell(:) + integer, pointer :: numPatchesPerCol(:) integer, pointer :: cohortsPerPatch(:) ! ! cohort data @@ -55,9 +58,24 @@ module EDRestVectorMod real(r8), pointer :: n(:) real(r8), pointer :: gpp_acc(:) real(r8), pointer :: npp_acc(:) - real(r8), pointer :: resp_clm(:) + real(r8), pointer :: gpp(:) + real(r8), pointer :: npp(:) + real(r8), pointer :: npp_leaf(:) + real(r8), pointer :: npp_froot(:) + real(r8), pointer :: npp_bsw(:) + real(r8), pointer :: npp_bdead(:) + real(r8), pointer :: npp_bseed(:) + real(r8), pointer :: npp_store(:) + real(r8), pointer :: bmort(:) + real(r8), pointer :: hmort(:) + real(r8), pointer :: cmort(:) + real(r8), pointer :: imort(:) + real(r8), pointer :: fmort(:) + real(r8), pointer :: ddbhdt(:) + real(r8), pointer :: resp_tstep(:) integer, pointer :: pft(:) integer, pointer :: status_coh(:) + integer, pointer :: isnew(:) ! ! patch level restart vars ! indexed by ncwd @@ -82,11 +100,27 @@ module EDRestVectorMod real(r8), pointer :: livegrass(:) ! this can probably be removed real(r8), pointer :: age(:) real(r8), pointer :: areaRestart(:) + real(r8), pointer :: f_sun(:) + real(r8), pointer :: fabd_sun_z(:) + real(r8), pointer :: fabi_sun_z(:) + real(r8), pointer :: fabd_sha_z(:) + real(r8), pointer :: fabi_sha_z(:) ! ! site level restart vars ! real(r8), pointer :: water_memory(:) real(r8), pointer :: old_stock(:) + real(r8), pointer :: cd_status(:) + real(r8), pointer :: dd_status(:) + real(r8), pointer :: ED_GDD_site(:) + real(r8), pointer :: ncd(:) + real(r8), pointer :: leafondate(:) + real(r8), pointer :: leafoffdate(:) + real(r8), pointer :: dleafondate(:) + real(r8), pointer :: dleafoffdate(:) + real(r8), pointer :: acc_NI(:) + + contains ! ! implement getVector and setVector @@ -142,8 +176,7 @@ subroutine deleteEDRestartVectorClass( this ) class(EDRestartVectorClass), intent(inout) :: this ! ! !LOCAL VARIABLES: - deallocate(this%cellWithPatch ) - deallocate(this%numPatchesPerCell ) + deallocate(this%numPatchesPerCol ) deallocate(this%cohortsPerPatch ) deallocate(this%balive ) deallocate(this%bdead ) @@ -160,9 +193,24 @@ subroutine deleteEDRestartVectorClass( this ) deallocate(this%n ) deallocate(this%gpp_acc ) deallocate(this%npp_acc ) - deallocate(this%resp_clm ) + deallocate(this%gpp ) + deallocate(this%npp ) + deallocate(this%npp_leaf ) + deallocate(this%npp_froot ) + deallocate(this%npp_bsw ) + deallocate(this%npp_bdead ) + deallocate(this%npp_bseed ) + deallocate(this%npp_store ) + deallocate(this%bmort ) + deallocate(this%hmort ) + deallocate(this%cmort ) + deallocate(this%imort ) + deallocate(this%fmort ) + deallocate(this%ddbhdt ) + deallocate(this%resp_tstep ) deallocate(this%pft ) deallocate(this%status_coh ) + deallocate(this%isnew ) deallocate(this%cwd_ag ) deallocate(this%cwd_bg ) deallocate(this%leaf_litter ) @@ -174,8 +222,22 @@ subroutine deleteEDRestartVectorClass( this ) deallocate(this%livegrass ) deallocate(this%age ) deallocate(this%areaRestart ) + deallocate(this%f_sun ) + deallocate(this%fabd_sun_z ) + deallocate(this%fabi_sun_z ) + deallocate(this%fabd_sha_z ) + deallocate(this%fabi_sha_z ) deallocate(this%water_memory ) deallocate(this%old_stock ) + deallocate(this%cd_status ) + deallocate(this%dd_status ) + deallocate(this%ED_GDD_site ) + deallocate(this%ncd ) + deallocate(this%leafondate ) + deallocate(this%leafoffdate ) + deallocate(this%dleafondate ) + deallocate(this%dleafoffdate ) + deallocate(this%acc_NI ) end subroutine deleteEDRestartVectorClass @@ -203,19 +265,68 @@ function newEDRestartVectorClass( bounds ) new%vectorLengthStart = bounds%begCohort new%vectorLengthStop = bounds%endCohort - ! - ! cohort level variables that are required on restart - ! + ! Column level variables + + allocate(new%numPatchesPerCol & + (bounds%begc:bounds%endc), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%numPatchesPerCol(:) = invalidValue + + allocate(new%old_stock & + (bounds%begc:bounds%endc), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%old_stock(:) = 0.0_r8 - allocate(new%cellWithPatch & - (bounds%begg:bounds%endg), stat=retVal) + allocate(new%cd_status & + (bounds%begc:bounds%endc), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%cd_status(:) = 0_r8 + + allocate(new%dd_status & + (bounds%begc:bounds%endc), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%dd_status(:) = 0_r8 + + allocate(new%ncd & + (bounds%begc:bounds%endc), stat=retVal) SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) - new%cellWithPatch(:) = 0 + new%ncd(:) = 0_r8 + - allocate(new%numPatchesPerCell & - (bounds%begg:bounds%endg), stat=retVal) + allocate(new%leafondate & + (bounds%begc:bounds%endc), stat=retVal) SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) - new%numPatchesPerCell(:) = invalidValue + new%leafondate(:) = 0_r8 + + allocate(new%leafoffdate & + (bounds%begc:bounds%endc), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%leafoffdate(:) = 0_r8 + + allocate(new%dleafondate & + (bounds%begc:bounds%endc), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%dleafondate(:) = 0_r8 + + allocate(new%dleafoffdate & + (bounds%begc:bounds%endc), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%dleafoffdate(:) = 0_r8 + + allocate(new%acc_NI & + (bounds%begc:bounds%endc), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%acc_NI(:) = 0_r8 + + allocate(new%ED_GDD_site & + (bounds%begc:bounds%endc), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%ED_GDD_site(:) = 0_r8 + + + ! cohort level variables + + allocate(new%cohortsPerPatch & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) @@ -297,10 +408,80 @@ function newEDRestartVectorClass( bounds ) SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) new%npp_acc(:) = 0.0_r8 - allocate(new%resp_clm & + allocate(new%gpp & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%gpp(:) = 0.0_r8 + + allocate(new%npp & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%npp(:) = 0.0_r8 + + allocate(new%npp_leaf & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%npp_leaf(:) = 0.0_r8 + + allocate(new%npp_froot & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%npp_froot(:) = 0.0_r8 + + allocate(new%npp_bsw & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%npp_bsw(:) = 0.0_r8 + + allocate(new%npp_bdead & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%npp_bdead(:) = 0.0_r8 + + allocate(new%npp_bseed & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%npp_bseed(:) = 0.0_r8 + + allocate(new%npp_store & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%npp_store(:) = 0.0_r8 + + allocate(new%bmort & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%bmort(:) = 0.0_r8 + + allocate(new%hmort & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%hmort(:) = 0.0_r8 + + allocate(new%cmort & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%cmort(:) = 0.0_r8 + + allocate(new%imort & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%imort(:) = 0.0_r8 + + allocate(new%fmort & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) - new%resp_clm(:) = 0.0_r8 + new%fmort(:) = 0.0_r8 + + allocate(new%ddbhdt & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%ddbhdt(:) = 0.0_r8 + + allocate(new%resp_tstep & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%resp_tstep(:) = 0.0_r8 allocate(new%pft & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) @@ -312,6 +493,11 @@ function newEDRestartVectorClass( bounds ) SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) new%status_coh(:) = 0 + allocate(new%isnew & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%isnew(:) = new_cohort + ! ! some patch level variables that are required on restart ! @@ -370,26 +556,48 @@ function newEDRestartVectorClass( bounds ) SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) new%areaRestart(:) = 0.0_r8 + allocate(new%f_sun & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%f_sun(:) = 0.0_r8 + + allocate(new%fabd_sun_z & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%fabd_sun_z(:) = 0.0_r8 + + allocate(new%fabi_sun_z & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%fabi_sun_z(:) = 0.0_r8 + + allocate(new%fabd_sha_z & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%fabd_sha_z(:) = 0.0_r8 + + allocate(new%fabi_sha_z & + (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%fabi_sha_z(:) = 0.0_r8 + ! - ! site level variable + ! Site level variable stored with cohort indexing + ! (to accomodate the second dimension) ! 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 ) + subroutine setVectors( this, bounds, nsites, sites, fcolumn ) ! ! !DESCRIPTION: ! implement setVectors @@ -400,29 +608,35 @@ subroutine setVectors( this, bounds, ed_allsites_inst ) ! !ARGUMENTS: class(EDRestartVectorClass) , intent(inout) :: this type(bounds_type) , intent(in) :: bounds - type(ed_site_type) , intent(in), target :: ed_allsites_inst( bounds%begg: ) + integer , intent(in) :: nsites + type(ed_site_type) , intent(in), target :: sites(nsites) + integer , intent(in) :: fcolumn(nsites) ! ! !LOCAL VARIABLES: !----------------------------------------------------------------------- - write(iulog,*) 'edtime setVectors ',get_nstep() + if ( masterproc ) 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 + !if (this%DEBUG) then + ! call this%printIoInfoLL ( bounds, sites, nsites ) + ! call this%printDataInfoLL ( bounds, sites, nsites ) + !end if - call this%convertCohortListToVector ( bounds, ed_allsites_inst(bounds%begg:bounds%endg) ) + call this%convertCohortListToVector ( bounds, nsites, sites, fcolumn ) if (this%DEBUG) then - call this%printDataInfoVector ( ) + call this%printIoInfoLL ( bounds, nsites, sites, fcolumn ) + call this%printDataInfoLL ( bounds, nsites, sites ) + + ! RGK: Commenting this out because it is calling several + ! variables over the wrong indices +! 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) + subroutine getVectors( this, bounds, nsites, sites, fcolumn) ! ! !DESCRIPTION: ! implement getVectors @@ -430,43 +644,35 @@ subroutine getVectors( this, bounds, ed_allsites_inst, ed_clm_inst, & ! !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 + integer , intent(in) :: nsites + type(ed_site_type) , intent(inout), target :: sites(nsites) + integer , intent(in) :: fcolumn(nsites) ! ! !LOCAL VARIABLES: - integer :: g + integer :: s !----------------------------------------------------------------------- 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%createPatchCohortStructure ( bounds, nsites, sites, fcolumn ) - call this%convertCohortVectorToList ( bounds, ed_allsites_inst(bounds%begg:bounds%endg) ) + call this%convertCohortVectorToList ( bounds, nsites , sites, fcolumn) - do g = bounds%begg,bounds%endg - if (ed_allsites_inst(g)%istheresoil) then - call ed_update_site( ed_allsites_inst(g) ) - end if + do s = 1,nsites + call ed_update_site( sites(s) ) 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) ) + call this%printIoInfoLL ( bounds, nsites, sites, fcolumn ) + call this%printDataInfoLL ( bounds, nsites, sites ) + call this%printDataInfoVector ( ) end if end subroutine getVectors @@ -480,9 +686,8 @@ subroutine doVectorIO( this, ncid, flag ) ! !USES: use ncdio_pio , only : file_desc_t, ncd_int, ncd_double use restUtilMod, only : restartvar - use clm_varcon, only : nameg, nameCohort + use clm_varcon, only : namec, nameCohort use spmdMod, only : iam - use mct_mod, only : mct_gsMap, mct_gsmap_OP ! ! !ARGUMENTS: class(EDRestartVectorClass), intent(inout) :: this @@ -491,233 +696,409 @@ subroutine doVectorIO( this, ncid, flag ) ! ! !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 + character(len=16) :: coh_dimName = trim(nameCohort) + character(len=16) :: col_dimName = trim(namec) !----------------------------------------------------------------------- - ! 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, & + if(this%DEBUG) then + write(iulog,*) 'flag:',flag + write(iulog,*) 'dimname:',col_dimName + write(iulog,*) 'readvar:',readvar + write(iulog,*) 'associated?',associated(this%numPatchesPerCol) + write(iulog,*) '' + write(iulog,*) 'col size:',size(this%numPatchesPerCol) + write(iulog,*) 'col lbound:',lbound(this%numPatchesPerCol) + write(iulog,*) 'col ubound:',ubound(this%numPatchesPerCol) + + write(iulog,*) 'coh size:',size(this%cohortsPerPatch) + write(iulog,*) 'coh lbound:',lbound(this%cohortsPerPatch) + write(iulog,*) 'coh ubound:',ubound(this%cohortsPerPatch) + write(iulog,*) '' + end if + + call restartvar(ncid=ncid, flag=flag, varname='ed_io_numPatchesPerCol', xtype=ncd_int, & + dim1name=col_dimName, & + long_name='Num patches per column', units='unitless', & + interpinic_flag='interp', data=this%numPatchesPerCol, & 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, & + + call restartvar(ncid=ncid, flag=flag, varname='ed_old_stock', xtype=ncd_double, & + dim1name=col_dimName, & + long_name='ed cohort - old_stock', units='unitless', & + interpinic_flag='interp', data=this%old_stock, & 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, & + call restartvar(ncid=ncid, flag=flag, varname='ed_cd_status', xtype=ncd_double, & + dim1name=col_dimName, & + long_name='ed cold dec status', units='unitless', & + interpinic_flag='interp', data=this%cd_status, & readvar=readvar) + call restartvar(ncid=ncid, flag=flag, varname='ed_dd_status', xtype=ncd_double, & + dim1name=col_dimName, & + long_name='ed drought dec status', units='unitless', & + interpinic_flag='interp', data=this%dd_status, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_chilling_days', xtype=ncd_double, & + dim1name=col_dimName, & + long_name='ed chilling day counter', units='unitless', & + interpinic_flag='interp', data=this%ncd, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_leafondate', xtype=ncd_double, & + dim1name=col_dimName, & + long_name='ed leafondate', units='unitless', & + interpinic_flag='interp', data=this%leafondate, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_leafoffdate', xtype=ncd_double, & + dim1name=col_dimName, & + long_name='ed leafoffdate', units='unitless', & + interpinic_flag='interp', data=this%leafoffdate, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_dleafondate', xtype=ncd_double, & + dim1name=col_dimName, & + long_name='ed dleafondate', units='unitless', & + interpinic_flag='interp', data=this%dleafondate, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_dleafoffdate', xtype=ncd_double, & + dim1name=col_dimName, & + long_name='ed dleafoffdate', units='unitless', & + interpinic_flag='interp', data=this%dleafoffdate, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_acc_NI', xtype=ncd_double, & + dim1name=col_dimName, & + long_name='ed nesterov index', units='unitless', & + interpinic_flag='interp', data=this%acc_NI, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_gdd_site', xtype=ncd_double, & + dim1name=col_dimName, & + long_name='ed GDD site', units='unitless', & + interpinic_flag='interp', data=this%ED_GDD_site, & + readvar=readvar) + call restartvar(ncid=ncid, flag=flag, varname='ed_balive', xtype=ncd_double, & - dim1name=dimName, & + dim1name=coh_dimName, & long_name='ed cohort ed_balive', units='unitless', & interpinic_flag='interp', data=this%balive, & readvar=readvar) + ! + ! cohort level vars + ! + call restartvar(ncid=ncid, flag=flag, varname='ed_io_cohortsPerPatch', xtype=ncd_int, & + dim1name=coh_dimName, & + long_name='cohorts per patch, indexed by numPatchesPerCol', units='unitless', & + interpinic_flag='interp', data=this%cohortsPerPatch, & + readvar=readvar) + call restartvar(ncid=ncid, flag=flag, varname='ed_bdead', xtype=ncd_double, & - dim1name=dimName, & + dim1name=coh_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, & + dim1name=coh_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, & + dim1name=coh_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, & + dim1name=coh_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, & + dim1name=coh_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, & + dim1name=coh_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, & + dim1name=coh_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, & + dim1name=coh_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, & + dim1name=coh_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, & + dim1name=coh_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, & + dim1name=coh_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, & + dim1name=coh_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, & + dim1name=coh_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, & + dim1name=coh_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, & + call restartvar(ncid=ncid, flag=flag, varname='ed_gpp', xtype=ncd_double, & + dim1name=coh_dimName, & + long_name='ed cohort - gpp', units='unitless', & + interpinic_flag='interp', data=this%gpp, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_npp', xtype=ncd_double, & + dim1name=coh_dimName, & + long_name='ed cohort - npp', units='unitless', & + interpinic_flag='interp', data=this%npp, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_npp_leaf', xtype=ncd_double, & + dim1name=coh_dimName, & + long_name='ed cohort - npp_leaf', units='unitless', & + interpinic_flag='interp', data=this%npp_leaf, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_npp_froot', xtype=ncd_double, & + dim1name=coh_dimName, & + long_name='ed cohort - npp_froot', units='unitless', & + interpinic_flag='interp', data=this%npp_froot, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_npp_bsw', xtype=ncd_double, & + dim1name=coh_dimName, & + long_name='ed cohort - npp_bsw', units='unitless', & + interpinic_flag='interp', data=this%npp_bsw, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_npp_bdead', xtype=ncd_double, & + dim1name=coh_dimName, & + long_name='ed cohort - npp_bdead', units='unitless', & + interpinic_flag='interp', data=this%npp_bdead, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_npp_bseed', xtype=ncd_double, & + dim1name=coh_dimName, & + long_name='ed cohort - npp_bseed', units='unitless', & + interpinic_flag='interp', data=this%npp_bseed, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_npp_store', xtype=ncd_double, & + dim1name=coh_dimName, & + long_name='ed cohort - npp_store', units='unitless', & + interpinic_flag='interp', data=this%npp_store, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_bmort', xtype=ncd_double, & + dim1name=coh_dimName, & + long_name='ed cohort - bmort', units='unitless', & + interpinic_flag='interp', data=this%bmort, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_hmort', xtype=ncd_double, & + dim1name=coh_dimName, & + long_name='ed cohort - hmort', units='unitless', & + interpinic_flag='interp', data=this%hmort, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_cmort', xtype=ncd_double, & + dim1name=coh_dimName, & + long_name='ed cohort - cmort', units='unitless', & + interpinic_flag='interp', data=this%cmort, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_imort', xtype=ncd_double, & + dim1name=coh_dimName, & + long_name='ed cohort - imort', units='unitless', & + interpinic_flag='interp', data=this%imort, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_fmort', xtype=ncd_double, & + dim1name=coh_dimName, & + long_name='ed cohort - fmort', units='unitless', & + interpinic_flag='interp', data=this%fmort, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_ddbhdt', xtype=ncd_double, & + dim1name=coh_dimName, & + long_name='ed cohort - ddbhdt', units='unitless', & + interpinic_flag='interp', data=this%ddbhdt, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_resp_tstep', xtype=ncd_double, & + dim1name=coh_dimName, & + long_name='ed cohort - resp_tstep', units='unitless', & + interpinic_flag='interp', data=this%resp_tstep, & readvar=readvar) call restartvar(ncid=ncid, flag=flag, varname='ed_pft', xtype=ncd_int, & - dim1name=dimName, & + dim1name=coh_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, & + dim1name=coh_dimName, & long_name='ed cohort - status_coh', units='unitless', & interpinic_flag='interp', data=this%status_coh, & readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_isnew', xtype=ncd_int, & + dim1name=coh_dimName, & + long_name='ed cohort - isnew', units='unitless', & + interpinic_flag='interp', data=this%isnew, & + 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', & + dim1name=coh_dimName, & + long_name='ed patch - 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', & + dim1name=coh_dimName, & + long_name='ed patch - 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', & + dim1name=coh_dimName, & + long_name='ed patch - 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', & + dim1name=coh_dimName, & + long_name='ed patch - 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', & + dim1name=coh_dimName, & + long_name='ed patch - 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', & + dim1name=coh_dimName, & + long_name='ed patch - 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', & + dim1name=coh_dimName, & + long_name='ed patch - 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', & + dim1name=coh_dimName, & + long_name='ed patch - 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', & + dim1name=coh_dimName, & + long_name='ed patch - 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', & + dim1name=coh_dimName, & + long_name='ed patch - 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', & + dim1name=coh_dimName, & + long_name='ed patch - area', units='unitless', & interpinic_flag='interp', data=this%areaRestart, & readvar=readvar) + call restartvar(ncid=ncid, flag=flag, varname='ed_f_sun', xtype=ncd_double, & + dim1name=coh_dimName, & + long_name='ed patch - f_sun', units='unitless', & + interpinic_flag='interp', data=this%f_sun, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_fabd_sun_z', xtype=ncd_double, & + dim1name=coh_dimName, & + long_name='ed patch - fabd_sun_z', units='unitless', & + interpinic_flag='interp', data=this%fabd_sun_z, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_fabi_sun_z', xtype=ncd_double, & + dim1name=coh_dimName, & + long_name='ed patch - fabi_sun_z', units='unitless', & + interpinic_flag='interp', data=this%fabi_sun_z, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_fabd_sha_z', xtype=ncd_double, & + dim1name=coh_dimName, & + long_name='ed patch - fabd_sha_z', units='unitless', & + interpinic_flag='interp', data=this%fabd_sha_z, & + readvar=readvar) + + call restartvar(ncid=ncid, flag=flag, varname='ed_fabi_sha_z', xtype=ncd_double, & + dim1name=coh_dimName, & + long_name='ed patch - fabi_sha_z', units='unitless', & + interpinic_flag='interp', data=this%fabi_sha_z, & + readvar=readvar) ! ! site level vars ! call restartvar(ncid=ncid, flag=flag, varname='ed_water_memory', xtype=ncd_double, & - dim1name=dimName, & + dim1name=coh_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 !-------------------------------------------------------------------------------! @@ -735,6 +1116,9 @@ subroutine printDataInfoVector( this ) integer :: iSta, iSto !----------------------------------------------------------------------- + ! RGK: changed the vector end-point on column variables to match the start point + ! this avoids exceeding bounds on the last column of the dataset + iSta = this%vectorLengthStart iSto = iSta + 1 @@ -776,13 +1160,43 @@ subroutine printDataInfoVector( this ) 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)//' :: gpp ', & + this%gpp(iSta:iSto) + write(iulog,*) trim(methodName)//' :: npp ', & + this%npp(iSta:iSto) + write(iulog,*) trim(methodName)//' :: npp_leaf ', & + this%npp_leaf(iSta:iSto) + write(iulog,*) trim(methodName)//' :: npp_froot ', & + this%npp_froot(iSta:iSto) + write(iulog,*) trim(methodName)//' :: npp_bsw ', & + this%npp_bsw(iSta:iSto) + write(iulog,*) trim(methodName)//' :: npp_bdead ', & + this%npp_bdead(iSta:iSto) + write(iulog,*) trim(methodName)//' :: npp_bseed ', & + this%npp_bseed(iSta:iSto) + write(iulog,*) trim(methodName)//' :: npp_store ', & + this%npp_store(iSta:iSto) + write(iulog,*) trim(methodName)//' :: bmort ', & + this%bmort(iSta:iSto) + write(iulog,*) trim(methodName)//' :: hmort ', & + this%hmort(iSta:iSto) + write(iulog,*) trim(methodName)//' :: cmort ', & + this%cmort(iSta:iSto) + write(iulog,*) trim(methodName)//' :: imort ', & + this%imort(iSta:iSto) + write(iulog,*) trim(methodName)//' :: fmort ', & + this%fmort(iSta:iSto) + write(iulog,*) trim(methodName)//' :: ddbhdt ', & + this%ddbhdt(iSta:iSto) + write(iulog,*) trim(methodName)//' :: resp_tstep ', & + this%resp_tstep(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)//' :: isnew ', & + this%isnew(iSta:iSto) write(iulog,*) trim(methodName)//' :: cwd_ag ', & this%cwd_ag(iSta:iSto) @@ -806,15 +1220,44 @@ subroutine printDataInfoVector( this ) this%age(iSta:iSto) write(iulog,*) trim(methodName)//' :: area ', & this%areaRestart(iSta:iSto) + write(iulog,*) trim(methodName)//' :: f_sun ', & + this%f_sun(iSta:iSto) + write(iulog,*) trim(methodName)//' :: fabd_sun_z ', & + this%fabd_sun_z(iSta:iSto) + write(iulog,*) trim(methodName)//' :: fabi_sun_z ', & + this%fabi_sun_z(iSta:iSto) + write(iulog,*) trim(methodName)//' :: fabd_sha_z ', & + this%fabd_sha_z(iSta:iSto) + write(iulog,*) trim(methodName)//' :: fabi_sha_z ', & + this%fabi_sha_z(iSta:iSto) write(iulog,*) trim(methodName)//' :: water_memory ', & this%water_memory(iSta:iSto) + write(iulog,*) trim(methodName)//' :: old_stock ', & - this%old_stock(iSta:iSto) - + this%old_stock(iSta:iSta) + write(iulog,*) trim(methodName)//' :: cd_status', & + this%cd_status(iSta:iSta) + write(iulog,*) trim(methodName)//' :: dd_status', & + this%cd_status(iSta:iSto) + write(iulog,*) trim(methodName)//' :: ED_GDD_site', & + this%ED_GDD_site(iSta:iSto) + write(iulog,*) trim(methodName)//' :: ncd', & + this%ncd(iSta:iSta) + write(iulog,*) trim(methodName)//' :: leafondate', & + this%leafondate(iSta:iSta) + write(iulog,*) trim(methodName)//' :: leafoffdate', & + this%leafoffdate(iSta:iSta) + write(iulog,*) trim(methodName)//' :: dleafondate', & + this%dleafondate(iSta:iSta) + write(iulog,*) trim(methodName)//' :: dleafoffdate', & + this%dleafoffdate(iSta:iSta) + write(iulog,*) trim(methodName)//' :: acc_NI', & + this%acc_NI(iSta:iSta) + end subroutine printDataInfoVector !-------------------------------------------------------------------------------! - subroutine printDataInfoLL( this, bounds, ed_allsites_inst ) + subroutine printDataInfoLL( this, bounds, nsites, sites ) ! ! !DESCRIPTION: ! counts the total number of cohorts over all p levels (ed_patch_type) so we @@ -825,12 +1268,13 @@ subroutine printDataInfoLL( this, bounds, ed_allsites_inst ) ! !ARGUMENTS: class(EDRestartVectorClass) , intent(inout) :: this type(bounds_type) , intent(in) :: bounds - type(ed_site_type) , intent(in), target :: ed_allsites_inst( bounds%begg: ) + integer , intent(in) :: nsites + type(ed_site_type) , intent(in), target :: sites(nsites) ! ! !LOCAL VARIABLES: type (ed_patch_type), pointer :: currentPatch type (ed_cohort_type), pointer :: currentCohort - integer :: g + integer :: s integer :: totalCohorts integer :: numCohort integer :: numPatches,totPatchCount @@ -842,19 +1286,15 @@ subroutine printDataInfoLL( this, bounds, ed_allsites_inst ) write(iulog,*) 'vecLenStart ',this%vectorLengthStart - g = bounds%begg - do while(g <= bounds%endg) + do s = 1,nsites - if (ed_allsites_inst(g)%istheresoil) then - currentPatch => ed_allsites_inst(g)%oldest_patch + currentPatch => sites(s)%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)) @@ -876,17 +1316,32 @@ subroutine printDataInfoLL( this, bounds, ed_allsites_inst ) 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)//' gpp ' ,totalCohorts,currentCohort%gpp + write(iulog,*) trim(methodName)//' npp ' ,totalCohorts,currentCohort%npp + write(iulog,*) trim(methodName)//' npp_leaf ' ,totalCohorts,currentCohort%npp_leaf + write(iulog,*) trim(methodName)//' npp_froot ' ,totalCohorts,currentCohort%npp_froot + write(iulog,*) trim(methodName)//' npp_bsw ' ,totalCohorts,currentCohort%npp_bsw + write(iulog,*) trim(methodName)//' npp_bdead ' ,totalCohorts,currentCohort%npp_bdead + write(iulog,*) trim(methodName)//' npp_bseed ' ,totalCohorts,currentCohort%npp_bseed + write(iulog,*) trim(methodName)//' npp_store ' ,totalCohorts,currentCohort%npp_store + write(iulog,*) trim(methodName)//' bmort ' ,totalCohorts,currentCohort%bmort + write(iulog,*) trim(methodName)//' hmort ' ,totalCohorts,currentCohort%hmort + write(iulog,*) trim(methodName)//' cmort ' ,totalCohorts,currentCohort%cmort + write(iulog,*) trim(methodName)//' imort ' ,totalCohorts,currentCohort%imort + write(iulog,*) trim(methodName)//' fmort ' ,totalCohorts,currentCohort%fmort + write(iulog,*) trim(methodName)//' ddbhdt ' ,totalCohorts,currentCohort%ddbhdt + write(iulog,*) trim(methodName)//' resp_tstep ' ,totalCohorts,currentCohort%resp_tstep write(iulog,*) trim(methodName)//' pft ' ,totalCohorts,currentCohort%pft write(iulog,*) trim(methodName)//' status_coh ' ,totalCohorts,currentCohort%status_coh + write(iulog,*) trim(methodName)//' isnew ' ,totalCohorts,currentCohort%isnew 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)//': numpatches for col ',& + numPatches write(iulog,*) trim(methodName)//': patches and cohorts ',& totPatchCount,numCohort @@ -902,17 +1357,30 @@ subroutine printDataInfoLL( this, bounds, ed_allsites_inst ) 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 + write(iulog,*) trim(methodName)//' f_sun (sum) ' ,sum(currentPatch%f_sun) + write(iulog,*) trim(methodName)//' fabd_sun_z (sum) ' ,sum(currentPatch%fabd_sun_z) + write(iulog,*) trim(methodName)//' fabi_sun_z (sum) ' ,sum(currentPatch%fabi_sun_z) + write(iulog,*) trim(methodName)//' fabd_sha_z (sum) ' ,sum(currentPatch%fabd_sha_z) + write(iulog,*) trim(methodName)//' fabi_sha_z (sum) ' ,sum(currentPatch%fabi_sha_z) + + write(iulog,*) trim(methodName)//' old_stock ' ,sites(s)%old_stock + write(iulog,*) trim(methodName)//' cd_status ' ,sites(s)%status + write(iulog,*) trim(methodName)//' dd_status ' ,sites(s)%dstatus + write(iulog,*) trim(methodName)//' ncd ' ,sites(s)%ncd + write(iulog,*) trim(methodName)//' leafondate ' ,sites(s)%leafondate + write(iulog,*) trim(methodName)//' leafoffdate ' ,sites(s)%leafoffdate + write(iulog,*) trim(methodName)//' dleafondate ' ,sites(s)%dleafondate + write(iulog,*) trim(methodName)//' dleafoffdate ' ,sites(s)%dleafoffdate + write(iulog,*) trim(methodName)//' acc_NI' ,sites(s)%acc_NI + write(iulog,*) trim(methodName)//' ED_GDD_site ' ,sites(s)%ED_GDD_site 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) + write(iulog,*) trim(methodName)//' water_memory ',sites(s)%water_memory(1) enddo @@ -921,8 +1389,8 @@ subroutine printDataInfoLL( this, bounds, ed_allsites_inst ) end subroutine printDataInfoLL !-------------------------------------------------------------------------------! - subroutine printIoInfoLL( this, bounds, ed_allsites_inst ) - ! + subroutine printIoInfoLL( this, bounds, nsites, sites, fcolumn ) + !! ! !DESCRIPTION: ! for debugging. prints some IO info regarding cohorts/patches ! currently prints cohort level variables @@ -932,12 +1400,14 @@ subroutine printIoInfoLL( this, bounds, ed_allsites_inst ) ! !ARGUMENTS: class(EDRestartVectorClass) , intent(inout) :: this type(bounds_type) , intent(in) :: bounds - type(ed_site_type) , intent(in), target :: ed_allsites_inst( bounds%begg: ) + integer , intent(in) :: nsites + type(ed_site_type) , intent(in), target :: sites(nsites) + integer , intent(in) :: fcolumn(nsites) ! ! !LOCAL VARIABLES: type (ed_patch_type), pointer :: currentPatch type (ed_cohort_type), pointer :: currentCohort - integer g + integer s integer totalCohorts integer numCohort integer numPatches,totPatchCount @@ -949,81 +1419,95 @@ subroutine printIoInfoLL( this, bounds, ed_allsites_inst ) 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 + do s = 1,nsites + + currentPatch => sites(s)%oldest_patch + + numPatches = 1 + + do while(associated(currentPatch)) + currentCohort => currentPatch%shortest + + write(iulog,*) trim(methodName)//': found column with patch(s) ',fcolumn(s) + + 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)//' gpp ',currentCohort%gpp + write(iulog,*) trim(methodName)//' npp ',currentCohort%npp + write(iulog,*) trim(methodName)//' npp_leaf ',currentCohort%npp_leaf + write(iulog,*) trim(methodName)//' npp_froot ',currentCohort%npp_froot + write(iulog,*) trim(methodName)//' npp_bsw ',currentCohort%npp_bsw + write(iulog,*) trim(methodName)//' npp_bdead ',currentCohort%npp_bdead + write(iulog,*) trim(methodName)//' npp_bseed ',currentCohort%npp_bseed + write(iulog,*) trim(methodName)//' npp_store ',currentCohort%npp_store + write(iulog,*) trim(methodName)//' bmort ',currentCohort%bmort + write(iulog,*) trim(methodName)//' hmort ',currentCohort%hmort + write(iulog,*) trim(methodName)//' cmort ',currentCohort%cmort + write(iulog,*) trim(methodName)//' imort ',currentCohort%imort + write(iulog,*) trim(methodName)//' fmort ',currentCohort%fmort + write(iulog,*) trim(methodName)//' ddbhdt ',currentCohort%ddbhdt + write(iulog,*) trim(methodName)//' resp_tstep ',currentCohort%resp_tstep + write(iulog,*) trim(methodName)//' pft ',currentCohort%pft + write(iulog,*) trim(methodName)//' status_coh ',currentCohort%status_coh + write(iulog,*) trim(methodName)//' isnew ',currentCohort%isnew + + currentCohort => currentCohort%taller + enddo ! currentCohort do while + + write(iulog,*) trim(methodName)//': numpatches for column ',numPatches + write(iulog,*) trim(methodName)//': patches and cohorts ',totPatchCount,numCohort + + currentPatch => currentPatch%younger + + totPatchCount = totPatchCount + 1 + numPatches = numPatches + 1 + enddo ! currentPatch do while enddo - + + return end subroutine printIoInfoLL !-------------------------------------------------------------------------------! - subroutine convertCohortListToVector( this, bounds, ed_allsites_inst ) + subroutine convertCohortListToVector( this, bounds, nsites, sites, fcolumn ) ! ! !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 + use EDTypesMod, only : cp_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: ) + integer , intent(in) :: nsites + type(ed_site_type) , intent(in), target :: sites(nsites) + integer , intent(in) :: fcolumn(nsites) ! ! !LOCAL VARIABLES: type (ed_patch_type), pointer :: currentPatch type (ed_cohort_type), pointer :: currentCohort - integer :: g + integer :: s, c integer :: totalCohorts ! number of cohorts starting from 1 integer :: countCohort ! number of cohorts starting from ! vectorLengthStart @@ -1034,175 +1518,232 @@ subroutine convertCohortListToVector( this, bounds, ed_allsites_inst ) integer :: countNcwd integer :: countWaterMem integer :: countNclmax - integer :: i, incrementOffset + integer :: countSunZ + integer :: i,j,k + integer :: 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__)) +! if(fcolumn(1).eq.bounds%begc .and. & +! (fcolumn(1)-1)*cohorts_per_col+1.ne.bounds%begCohort) then +! write(iulog,*) 'fcolumn(1) in this clump, points to the first column of the clump' +! write(iulog,*) 'but the assumption on first cohort index does not jive' +! call endrun(msg=errMsg(__FILE__, __LINE__)) +! end if + + + do s = 1,nsites + + ! Calculate the offsets + ! fcolumn is the global column index of the current site. + ! For the first site, if that site aligns with the first column index + ! in the clump, than the offset should be be equal to begCohort + + c = fcolumn(s) + +! incrementOffset = (c-1)*cohorts_per_col + 1 +! countCohort = (c-1)*cohorts_per_col + 1 +! countPft = (c-1)*cohorts_per_col + 1 +! countNcwd = (c-1)*cohorts_per_col + 1 +! countNclmax = (c-1)*cohorts_per_col + 1 +! countWaterMem = (c-1)*cohorts_per_col + 1 +! countSunZ = (c-1)*cohorts_per_col + 1 + + incrementOffset = bounds%begCohort+(c-bounds%begc)*cohorts_per_col + 1 + countCohort = bounds%begCohort+(c-bounds%begc)*cohorts_per_col + 1 + countPft = bounds%begCohort+(c-bounds%begc)*cohorts_per_col + 1 + countNcwd = bounds%begCohort+(c-bounds%begc)*cohorts_per_col + 1 + countNclmax = bounds%begCohort+(c-bounds%begc)*cohorts_per_col + 1 + countWaterMem = bounds%begCohort+(c-bounds%begc)*cohorts_per_col + 1 + countSunZ = bounds%begCohort+(c-bounds%begc)*cohorts_per_col + 1 + + currentPatch => sites(s)%oldest_patch + + ! new column, 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,*) 'CLTV countCohort ', countCohort + write(iulog,*) 'CLTV vecLenStart ', this%vectorLengthStart + write(iulog,*) 'CLTV vecLenStop ', this%vectorLengthStop 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 - + + 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%gpp(countCohort) = currentCohort%gpp + this%npp(countCohort) = currentCohort%npp + this%npp_leaf(countCohort) = currentCohort%npp_leaf + this%npp_froot(countCohort) = currentCohort%npp_froot + this%npp_bsw(countCohort) = currentCohort%npp_bsw + this%npp_bdead(countCohort) = currentCohort%npp_bdead + this%npp_bseed(countCohort) = currentCohort%npp_bseed + this%npp_store(countCohort) = currentCohort%npp_store + this%bmort(countCohort) = currentCohort%bmort + this%hmort(countCohort) = currentCohort%hmort + this%cmort(countCohort) = currentCohort%cmort + this%imort(countCohort) = currentCohort%imort + this%fmort(countCohort) = currentCohort%fmort + this%ddbhdt(countCohort) = currentCohort%ddbhdt + this%resp_tstep(countCohort) = currentCohort%resp_tstep + this%pft(countCohort) = currentCohort%pft + this%status_coh(countCohort) = currentCohort%status_coh + if ( currentCohort%isnew ) then + this%isnew(countCohort) = new_cohort + else + this%isnew(countCohort) = old_cohort + endif + if (this%DEBUG) then - write(iulog,*) 'offsetNumCohorts III ' & - ,countCohort,cohorts_per_gcell, numCohort + write(iulog,*) 'CLTV offsetNumCohorts II ',countCohort, & + 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 + + countCohort = countCohort + 1 + + currentCohort => currentCohort%taller + + enddo ! currentCohort do while - 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 + ! + ! deal with patch level fields here + ! + this%livegrass(incrementOffset) = currentPatch%livegrass + this%age(incrementOffset) = currentPatch%age + this%areaRestart(incrementOffset) = currentPatch%area + + ! set cohorts per patch for IO + this%cohortsPerPatch( incrementOffset ) = numCohort + + if (this%DEBUG) then + write(iulog,*) 'offsetNumCohorts III ' & + ,countCohort,cohorts_per_col, 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 + 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,cp_nclmax ! cp_nclmax currently 2 + this%spread(countNclmax) = currentPatch%spread(i) + countNclmax = countNclmax + 1 + end do + + if (this%DEBUG) write(iulog,*) 'CLTV countSunZ 1 ',countSunZ + + if (this%DEBUG) write(iulog,*) 'CLTV 1186 ',cp_nlevcan,numpft_ed,cp_nclmax + + do k = 1,cp_nlevcan ! cp_nlevcan currently 40 + do j = 1,numpft_ed ! numpft_ed currently 2 + do i = 1,cp_nclmax ! cp_nclmax currently 2 + this%f_sun(countSunZ) = currentPatch%f_sun(i,j,k) + this%fabd_sun_z(countSunZ) = currentPatch%fabd_sun_z(i,j,k) + this%fabi_sun_z(countSunZ) = currentPatch%fabi_sun_z(i,j,k) + this%fabd_sha_z(countSunZ) = currentPatch%fabd_sha_z(i,j,k) + this%fabi_sha_z(countSunZ) = currentPatch%fabi_sha_z(i,j,k) + countSunZ = countSunZ + 1 + end do 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 - + + if (this%DEBUG) write(iulog,*) 'CLTV countSunZ 2 ',countSunZ + + incrementOffset = incrementOffset + numCohortsPerPatch + + ! reset counters so that they are all advanced evenly. Currently + ! the offset is 10, the max of numpft_ed, ncwd, cp_nclmax, + ! countWaterMem and the number of allowed cohorts per patch + countPft = incrementOffset + countNcwd = incrementOffset + countNclmax = incrementOffset + countCohort = incrementOffset + countSunZ = incrementOffset + + if (this%DEBUG) then + write(iulog,*) 'CLTV incrementOffset ', incrementOffset + write(iulog,*) 'CLTV cohorts_per_col ', cohorts_per_col + write(iulog,*) 'CLTV numCohort ', numCohort + write(iulog,*) 'CLTV totalCohorts ', totalCohorts + end if + + currentPatch => currentPatch%younger + + enddo ! currentPatch do while + + this%old_stock(c) = sites(s)%old_stock + this%cd_status(c) = sites(s)%status + this%dd_status(c) = sites(s)%dstatus + this%ncd(c) = sites(s)%ncd + this%leafondate(c) = sites(s)%leafondate + this%leafoffdate(c) = sites(s)%leafoffdate + this%dleafondate(c) = sites(s)%dleafondate + this%dleafoffdate(c) = sites(s)%dleafoffdate + this%acc_NI(c) = sites(s)%acc_NI + this%ED_GDD_site(c) = sites(s)%ED_GDD_site + + ! set numpatches for this column + this%numPatchesPerCol(c) = numPatches + + do i = 1,numWaterMem ! numWaterMem currently 10 + this%water_memory( countWaterMem ) = sites(s)%water_memory(i) + countWaterMem = countWaterMem + 1 + end do + enddo - + if (this%DEBUG) then - write(iulog,*) 'total cohorts ',totalCohorts + write(iulog,*) 'CLTV total cohorts ',totalCohorts end if - - end subroutine convertCohortListToVector + + return + end subroutine convertCohortListToVector !-------------------------------------------------------------------------------! - subroutine createPatchCohortStructure( this, bounds, ed_allsites_inst ) + subroutine createPatchCohortStructure( this, bounds, nsites, sites, fcolumn ) ! ! !DESCRIPTION: ! counts the total number of cohorts over all p levels (ed_patch_type) so we @@ -1216,24 +1757,30 @@ subroutine createPatchCohortStructure( this, bounds, ed_allsites_inst ) use EDParamsMod , only : ED_val_maxspread use EDPatchDynamicsMod , only : create_patch use GridcellType , only : grc + use ColumnType , only : col ! ! !ARGUMENTS: class(EDRestartVectorClass) , intent(inout) :: this type(bounds_type) , intent(in) :: bounds - type(ed_site_type) , intent(inout), target :: ed_allsites_inst( bounds%begg: ) + integer , intent(in) :: nsites + type(ed_site_type) , intent(inout), target :: sites(nsites) + integer , intent(in) :: fcolumn(nsites) ! ! !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) :: cwd_ag_local(ncwd),cwd_bg_local(ncwd),spread_local(cp_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 + integer :: s ! site index + integer :: c ! column index + integer :: g ! grid index + integer :: 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 @@ -1246,25 +1793,40 @@ subroutine createPatchCohortStructure( this, bounds, ed_allsites_inst ) ! loop over model grid cells and create patch/cohort structure based on ! restart data ! - do g = bounds%begg, bounds%endg + do s = 1,nsites - if (this%DEBUG) then - write(iulog,*) 'cellWithPatch ',this%cellWithPatch(g),this%numPatchesPerCell(g) + c = fcolumn(s) + if( (s-1) .ne. (c-bounds%begc) ) then + write(iulog,*) 'NAT COLUMNS REALLY ARENT MONOTONICALLY INCREASING' + write(iulog,*) s,c,bounds%begc,s-1,c-bounds%begc end if - call zero_site( ed_allsites_inst(g) ) - ! + g = col%gridcell(c) + + currIdx = bounds%begCohort + (c-bounds%begc)*cohorts_per_col + 1 +! currIdx = (c-1)*cohorts_per_col + 1 ! global cohort index at the head of the column + + call zero_site( sites(s) ) + ! ! 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) + sites(s)%lat = grc%latdeg(g) + sites(s)%lon = grc%londeg(g) + sites(s)%ncd = 0.0_r8 + + if (this%numPatchesPerCol(c)<0 .or. this%numPatchesPerCol(c)>10000) then + write(iulog,*) 'a column was expected to contain a valid number of patches' + write(iulog,*) '0 is a valid number, but this column seems uninitialized',this%numPatchesPerCol(c) + call endrun(msg=errMsg(__FILE__, __LINE__)) + end if + + ! Initialize the site pointers to null + sites(s)%youngest_patch => null() + sites(s)%oldest_patch => null() + + do patchIdx = 1,this%numPatchesPerCol(c) if (this%DEBUG) then write(iulog,*) 'create patch ',patchIdx @@ -1273,14 +1835,13 @@ subroutine createPatchCohortStructure( this, bounds, ed_allsites_inst ) ! create patch allocate(newp) - call zero_patch(newp) ! make new patch - call create_patch(ed_allsites_inst(g), newp, age, AREA, & + call create_patch(sites(s), 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) + newp%siteptr => sites(s) ! give this patch a unique patch number newp%patchno = patchIdx @@ -1315,6 +1876,8 @@ subroutine createPatchCohortStructure( this, bounds, ed_allsites_inst ) ! item it needs, not the entire cohort...refactor temp_cohort%dbh = Dbh(temp_cohort) + 0.0001_r8*ft + write(iulog,*) 'EDRestVectorMod.F90::createPatchCohortStructure call create_cohort ' + 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) @@ -1329,33 +1892,33 @@ subroutine createPatchCohortStructure( this, bounds, ed_allsites_inst ) ! if (patchIdx == 1) then ! nothing associated yet. first patch is pointed to by youngest and oldest - if (this%DEBUG) write(iulog,*) 'patchIdx ',patchIdx + if (this%DEBUG) write(iulog,*) 'patchIdx = 1 ',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() + sites(s)%youngest_patch => newp + sites(s)%oldest_patch => newp + sites(s)%youngest_patch%younger => null() + sites(s)%youngest_patch%older => null() + sites(s)%oldest_patch%younger => null() + sites(s)%oldest_patch%older => null() else if (patchIdx == 2) then ! add second patch to list - if (this%DEBUG) write(iulog,*) 'patchIdx ',patchIdx + if (this%DEBUG) write(iulog,*) 'patchIdx = 2 ',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() + sites(s)%youngest_patch => newp + sites(s)%youngest_patch%younger => null() + sites(s)%youngest_patch%older => sites(s)%oldest_patch + sites(s)%oldest_patch%younger => sites(s)%youngest_patch + sites(s)%oldest_patch%older => null() else ! more than 2 patches, insert patch into youngest slot - if (this%DEBUG) write(iulog,*) 'patchIdx ',patchIdx + if (this%DEBUG) write(iulog,*) 'patchIdx > 2 ',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 + newp%older => sites(s)%youngest_patch + sites(s)%youngest_patch%younger => newp + newp%younger => null() + sites(s)%youngest_patch => newp endif @@ -1363,29 +1926,31 @@ subroutine createPatchCohortStructure( this, bounds, ed_allsites_inst ) enddo ! ends loop over patchIdx - enddo ! ends loop over g + enddo ! ends loop over s - end subroutine createPatchCohortStructure + end subroutine createPatchCohortStructure !-------------------------------------------------------------------------------! - subroutine convertCohortVectorToList( this, bounds, ed_allsites_inst ) + subroutine convertCohortVectorToList( this, bounds, nsites, sites, fcolumn ) ! ! !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: ) + integer , intent(in) :: nsites + type(ed_site_type) , intent(inout), target :: sites(nsites) + integer , intent(in) :: fcolumn(nsites) + ! ! !LOCAL VARIABLES: type (ed_patch_type), pointer :: currentPatch type (ed_cohort_type),pointer :: currentCohort - integer :: g + integer :: c, s integer :: totalCohorts ! number of cohorts starting from 0 integer :: countCohort ! number of cohorts starting from ! vectorLengthStart @@ -1395,169 +1960,198 @@ subroutine convertCohortVectorToList( this, bounds, ed_allsites_inst ) integer :: countNcwd integer :: countWaterMem integer :: countNclmax - integer :: i, incrementOffset + integer :: countSunZ + integer :: i,j,k + integer :: 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 - + + do s = 1,nsites + + c = fcolumn(s) + + incrementOffset = bounds%begCohort+(c-bounds%begc)*cohorts_per_col + 1 + + countCohort = bounds%begCohort+(c-bounds%begc)*cohorts_per_col + 1 + countPft = bounds%begCohort+(c-bounds%begc)*cohorts_per_col + 1 + countNcwd = bounds%begCohort+(c-bounds%begc)*cohorts_per_col + 1 + countNclmax = bounds%begCohort+(c-bounds%begc)*cohorts_per_col + 1 + countWaterMem = bounds%begCohort+(c-bounds%begc)*cohorts_per_col + 1 + countSunZ = bounds%begCohort+(c-bounds%begc)*cohorts_per_col + 1 + + currentPatch => sites(s)%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,*) 'CVTL III ' & - ,countCohort,cohorts_per_gcell, numCohort + write(iulog,*) 'CVTL countCohort ',countCohort, this%vectorLengthStart, this%vectorLengthStop 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 - + + 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%gpp = this%gpp(countCohort) + currentCohort%npp = this%npp(countCohort) + currentCohort%npp_leaf = this%npp_leaf(countCohort) + currentCohort%npp_froot = this%npp_froot(countCohort) + currentCohort%npp_bsw = this%npp_bsw(countCohort) + currentCohort%npp_bdead = this%npp_bdead(countCohort) + currentCohort%npp_bseed = this%npp_bseed(countCohort) + currentCohort%npp_store = this%npp_store(countCohort) + currentCohort%bmort = this%bmort(countCohort) + currentCohort%hmort = this%hmort(countCohort) + currentCohort%cmort = this%cmort(countCohort) + currentCohort%imort = this%imort(countCohort) + currentCohort%fmort = this%fmort(countCohort) + currentCohort%ddbhdt = this%ddbhdt(countCohort) + currentCohort%resp_tstep = this%resp_tstep(countCohort) + currentCohort%pft = this%pft(countCohort) + currentCohort%status_coh = this%status_coh(countCohort) + currentCohort%isnew = ( this%isnew(countCohort) .eq. new_cohort ) + if (this%DEBUG) then - write(iulog,*) 'CVTL incrementOffset, cohorts_per_gcell, numCohort, totalCohorts ', & - incrementOffset, cohorts_per_gcell, numCohort, totalCohorts + write(iulog,*) 'CVTL II ',countCohort, & + numCohort 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__)) + + countCohort = countCohort + 1 + + currentCohort => currentCohort%taller + + enddo ! current cohort do while + + + ! 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) + + + + ! set cohorts per patch for IO + + if (this%DEBUG) then + write(iulog,*) 'CVTL III ' & + ,countCohort,cohorts_per_col, numCohort endif - - countWaterMem = incrementOffset - - endif ! is there soil check - - g = g + 1 - + ! + ! 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,cp_nclmax ! cp_nclmax currently 2 + currentPatch%spread(i) = this%spread(countNclmax) + countNclmax = countNclmax + 1 + end do + + if (this%DEBUG) write(iulog,*) 'CVTL countSunZ 1 ',countSunZ + + do k = 1,cp_nlevcan ! cp_nlevcan currently 40 + do j = 1,numpft_ed ! numpft_ed currently 2 + do i = 1,cp_nclmax ! cp_nclmax currently 2 + currentPatch%f_sun(i,j,k) = this%f_sun(countSunZ) + currentPatch%fabd_sun_z(i,j,k) = this%fabd_sun_z(countSunZ) + currentPatch%fabi_sun_z(i,j,k) = this%fabi_sun_z(countSunZ) + currentPatch%fabd_sha_z(i,j,k) = this%fabd_sha_z(countSunZ) + currentPatch%fabi_sha_z(i,j,k) = this%fabi_sha_z(countSunZ) + countSunZ = countSunZ + 1 + end do + end do + end do + + if (this%DEBUG) write(iulog,*) 'CVTL countSunZ 2 ',countSunZ + + incrementOffset = incrementOffset + numCohortsPerPatch + + ! and the number of allowed cohorts per patch (currently 200) + countPft = incrementOffset + countNcwd = incrementOffset + countNclmax = incrementOffset + countCohort = incrementOffset + countSunZ = incrementOffset + + if (this%DEBUG) then + write(iulog,*) 'CVTL incrementOffset ', incrementOffset + write(iulog,*) 'CVTL cohorts_per_col ', cohorts_per_col + write(iulog,*) 'CVTL numCohort ', numCohort + write(iulog,*) 'CVTL totalCohorts ', totalCohorts + end if + + currentPatch => currentPatch%younger + + enddo ! currentPatch do while + + do i = 1,numWaterMem + sites(s)%water_memory(i) = this%water_memory( countWaterMem ) + countWaterMem = countWaterMem + 1 + end do + + sites(s)%old_stock = this%old_stock(c) + sites(s)%status = this%cd_status(c) + sites(s)%dstatus = this%dd_status(c) + sites(s)%ncd = this%ncd(c) + sites(s)%leafondate = this%leafondate(c) + sites(s)%leafoffdate = this%leafoffdate(c) + sites(s)%dleafondate = this%dleafondate(c) + sites(s)%dleafoffdate = this%dleafoffdate(c) + sites(s)%acc_NI = this%acc_NI(c) + sites(s)%ED_GDD_site = this%ED_GDD_site(c) + enddo if (this%DEBUG) then @@ -1571,44 +2165,47 @@ end subroutine convertCohortVectorToList !--------------------------------------------! !-------------------------------------------------------------------------------! - subroutine EDRest ( bounds, ncid, flag, ed_allsites_inst, ed_clm_inst, ed_phenology_inst, & - waterstate_inst, canopystate_inst ) + subroutine EDRest ( bounds, nsites, sites, fcolumn, ncid, flag ) ! ! !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 + integer , intent(in) :: nsites + type(ed_site_type) , intent(inout), target :: sites(nsites) ! The site vector + integer , intent(in) :: fcolumn(nsites) 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 (ervc%DEBUG) then + write(iulog,*) 'EDRestVectorMod:EDRest flag ',flag + end if + if ( flag == 'write' ) then - call ervc%setVectors( bounds, ed_allsites_inst(bounds%begg:bounds%endg) ) + call ervc%setVectors( bounds, nsites, sites, fcolumn ) 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) + call ervc%getVectors( bounds, nsites, sites, fcolumn ) endif call ervc%deleteEDRestartVectorClass () diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 1362b048..ca11fa8a 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -2,7 +2,7 @@ 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 clm_varpar , only : nlevgrnd, mxpft use domainMod , only : domain_type use shr_sys_mod , only : shr_sys_flush @@ -14,7 +14,7 @@ module EDTypesMod ! 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 @@ -23,9 +23,15 @@ module EDTypesMod ! 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 :: numPatchesPerCol = 10 ! + integer, parameter :: numCohortsPerPatch = 160 ! + integer, parameter :: cohorts_per_col = 1600 ! This is the max number of individual items one can store per + + ! each grid cell and effects the striding in the ED restart + ! data as some fields are arrays where each array is + ! associated with one cohort + integer, parameter :: numWaterMem = 10 ! watermemory saved as site level var ! BIOLOGY/BIOGEOCHEMISTRY @@ -35,9 +41,11 @@ module EDTypesMod 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. + integer , parameter :: maxPft = 79 ! max number of PFTs potentially used by CLM + ! SPITFIRE - integer , parameter :: NLSC = 5 ! number carbon compartments in above ground litter array + integer , parameter :: NLSC = 6 ! 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 @@ -57,7 +65,79 @@ module EDTypesMod 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 + + real(r8), parameter :: min_npm2 = 1.0d-5 ! minimum cohort number density per m2 before termination + real(r8), parameter :: min_patch_area = 0.001_r8 ! smallest allowable patch area before termination + real(r8), parameter :: min_nppatch = 1.0d-8 ! minimum number of cohorts per patch (min_npm2*min_patch_area) + real(r8), parameter :: min_n_safemath = 1.0d-15 ! in some cases, we want to immediately remove super small + ! number densities of cohorts to prevent FPEs, this is usually + ! just relevant in the first day after recruitment + + character*4 yearchar + + !the lower limit of the size classes of ED cohorts + !0-10,10-20... + integer, parameter :: nlevsclass_ed = 13 ! Number of dbh size classes for size structure analysis + ! |0-1,1-2,2-3,3-4,4-5,5-10,10-20,20-30,30-40,40-50,50-60,60-70,70-80,80-90,90-100,100+| +! real(r8), parameter, dimension(16) :: sclass_ed = (/0.0_r8,1.0_r8,2.0_r8,3.0_r8,4.0_r8,5.0_r8,10.0_r8,20.0_r8,30.0_r8,40.0_r8, & +! 50.0_r8,60.0_r8,70.0_r8,80.0_r8,90.0_r8,100.0_r8/) + + real(r8), parameter, dimension(13) :: sclass_ed = (/0.0_r8,5.0_r8,10.0_r8,15.0_r8,20.0_r8,30.0_r8,40.0_r8, & + 50.0_r8,60.0_r8,70.0_r8,80.0_r8,90.0_r8,100.0_r8/) + + + ! integer, parameter :: nlevsclass_ed = 17 + ! real(r8), parameter, dimension(17) :: sclass_ed = (/0.1_r8, 5.0_r8,10.0_r8,15.0_r8,20.0_r8,25.0_r8, & + ! 30.0_r8,35.0_r8,40.0_r8,45.0_r8,50.0_r8,55.0_r8, & + ! 60.0_r8,65.0_r8,70.0_r8,75.0_r8,80.0_r8/) + + integer, parameter :: nlevmclass_ed = 5 ! nlev "mortality" classes in ED + ! Number of ways to die + ! (background,hydraulic,carbon,impact,fire) + + character(len = 10), parameter,dimension(5) :: char_list = (/"background","hydraulic ","carbon ","impact ","fire "/) + + + ! These three vectors are used for history output mapping + real(r8) ,allocatable :: levsclass_ed(:) ! The lower bound on size classes for ED trees. This + ! is used really for IO into the + ! history tapes. It gets copied from + ! the parameter array sclass_ed. + integer , allocatable :: pft_levscpf_ed(:) + integer , allocatable :: scls_levscpf_ed(:) + + + ! Control Parameters (cp_) + ! ------------------------------------------------------------------------------------- + + ! These parameters are dictated by FATES internals + + integer, parameter :: cp_nclmax = 2 ! Maximum number of canopy layers + + integer, parameter :: cp_nlevcan = 40 ! number of leaf layers in canopy layer + + integer, parameter :: cp_maxSWb = 2 ! maximum number of broad-bands in the + ! shortwave spectrum cp_numSWb <= cp_maxSWb + ! this is just for scratch-array purposes + ! if cp_numSWb is larger than this value + ! simply bump this number up as needed + ! These parameters are dictated by the host model or driver + + integer :: cp_numSWb ! Number of broad-bands in the short-wave radiation + ! specturm to track + ! (typically 2 as a default, VIS/NIR, in ED variants <2016) + + + integer :: cp_numlevgrnd ! Number of soil layers + + ! Number of GROUND layers for the purposes of biogeochemistry; can be either 1 + ! or the total number of soil layers (includes bedrock) + integer :: cp_numlevdecomp_full + + ! Number of SOIL layers for the purposes of biogeochemistry; can be either 1 + ! or the total number of soil layers + integer :: cp_numlevdecomp + !************************************ !** COHORT type structure ** @@ -97,20 +177,29 @@ module EDTypesMod 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) + logical :: isnew ! flag to signify a new cohort, new cohorts have not experienced + ! npp or mortality and should therefore not be fused or averaged ! 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) :: gpp_tstep ! 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) :: npp_tstep ! 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) :: resp_tstep ! 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 + real(r8) :: npp_leaf ! NPP into leaves (includes replacement of turnover): KgC/indiv/day + real(r8) :: npp_froot ! NPP into fine roots (includes replacement of turnover): KgC/indiv/day + real(r8) :: npp_bsw ! NPP into sapwood: KgC/indiv/day + real(r8) :: npp_bdead ! NPP into deadwood (structure): KgC/indiv/day + real(r8) :: npp_bseed ! NPP into seeds: KgC/indiv/day + real(r8) :: npp_store ! NPP into storage: KgC/indiv/day + + real(r8) :: ts_net_uptake(cp_nlevcan) ! Net uptake of leaf layers: kgC/m2/s + real(r8) :: year_net_uptake(cp_nlevcan) ! Net uptake of leaf layers: kgC/m2/year ! RESPIRATION COMPONENTS real(r8) :: rd ! Dark respiration: umol/indiv/s @@ -132,6 +221,13 @@ module EDTypesMod !MORTALITY real(r8) :: dmort ! proportional mortality rate. (year-1) + ! Mortality Rate Partitions + real(r8) :: bmort ! background mortality rate n/year + real(r8) :: cmort ! carbon starvation mortality rate n/year + real(r8) :: hmort ! hydraulic failure mortality rate n/year + real(r8) :: imort ! mortality from impacts by others n/year + real(r8) :: fmort ! fire mortality n/year + ! NITROGEN POOLS real(r8) :: livestemn ! live stem nitrogen : KgN/invid real(r8) :: livecrootn ! live coarse root nitrogen: KgN/invid @@ -169,6 +265,8 @@ module EDTypesMod !INDICES integer :: patchno ! unique number given to each new patch created for tracking + + ! INTERF-TODO: THIS VARIABLE SHOULD BE REMOVED integer :: clm_pno ! clm patch number (index of p vector) ! PATCH INFO @@ -178,54 +276,55 @@ module EDTypesMod 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) :: spread(cp_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) :: canopy_layer_lai(cp_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 + real(r8) :: tlai_profile(cp_nclmax,numpft_ed,cp_nlevcan) ! total leaf area in each canopy layer, pft, and leaf layer. m2/m2 + real(r8) :: elai_profile(cp_nclmax,numpft_ed,cp_nlevcan) ! exposed leaf area in each canopy layer, pft, and leaf layer. m2/m2 + real(r8) :: tsai_profile(cp_nclmax,numpft_ed,cp_nlevcan) ! total stem area in each canopy layer, pft, and leaf layer. m2/m2 + real(r8) :: esai_profile(cp_nclmax,numpft_ed,cp_nlevcan) ! exposed stem area in each canopy layer, pft, and leaf layer. m2/m2 + real(r8) :: layer_height_profile(cp_nclmax,numpft_ed,cp_nlevcan) + real(r8) :: canopy_area_profile(cp_nclmax,numpft_ed,cp_nlevcan) ! 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 + integer :: present(cp_nclmax,numpft_ed) ! is there any of this pft in this canopy layer? + integer :: nrad(cp_nclmax,numpft_ed) ! number of exposed leaf layers for each canopy layer and pft + integer :: ncan(cp_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 + real(r8) :: fabd_sun_z(cp_nclmax,numpft_ed,cp_nlevcan) ! 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 + real(r8) :: fabd_sha_z(cp_nclmax,numpft_ed,cp_nlevcan) ! 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 + real(r8) :: fabi_sun_z(cp_nclmax,numpft_ed,cp_nlevcan) ! 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 + real(r8) :: fabi_sha_z(cp_nclmax,numpft_ed,cp_nlevcan) ! 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, + real(r8) :: ed_laisun_z(cp_nclmax,numpft_ed,cp_nlevcan) ! 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, + real(r8) :: ed_laisha_z(cp_nclmax,numpft_ed,cp_nlevcan) ! amount of LAI in the shade in each canopy layer, + real(r8) :: ed_parsun_z(cp_nclmax,numpft_ed,cp_nlevcan) ! PAR absorbed in the sun in each canopy layer, + real(r8) :: ed_parsha_z(cp_nclmax,numpft_ed,cp_nlevcan) ! PAR absorbed in the shade in each canopy layer, + real(r8) :: f_sun(cp_nclmax,numpft_ed,cp_nlevcan) ! 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 + real(r8),allocatable :: tr_soil_dir(:) ! fraction of incoming direct radiation that (cm_numSWb) ! is transmitted to the soil as direct - real(r8) :: tr_soil_dif(numrad) ! fraction of incoming diffuse radiation that + real(r8),allocatable :: tr_soil_dif(:) ! 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 + real(r8),allocatable :: tr_soil_dir_dif(:) ! 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 + real(r8),allocatable :: fab(:) ! fraction of incoming total radiation that is absorbed by the canopy + real(r8),allocatable :: fabd(:) ! fraction of incoming direct radiation that is absorbed by the canopy + real(r8),allocatable :: fabi(:) ! fraction of incoming diffuse radiation that is absorbed by the canopy + real(r8),allocatable :: sabs_dir(:) ! fraction of incoming direct radiation that is absorbed by the canopy + real(r8),allocatable :: sabs_dif(:) ! fraction of incoming diffuse radiation that is absorbed by the canopy !SEED BANK @@ -234,9 +333,10 @@ module EDTypesMod 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) + real(r8) :: seed_rain_flux(numpft_ed) ! flux of seeds from exterior KgC/m2/year (needed for C balance purposes) ! 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) :: psn_z(cp_nclmax,numpft_ed,cp_nlevcan) ! 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 @@ -331,9 +431,6 @@ module EDTypesMod ! 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 @@ -347,9 +444,9 @@ module EDTypesMod real(r8) :: disturbance_rate ! site total dist rate ! PHENOLOGY + real(r8) :: ED_GDD_site ! ED Phenology growing degree days. 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:- @@ -357,13 +454,14 @@ module EDTypesMod 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. + real(r8) :: total_burn_flux_to_atm ! total carbon burnt to the atmosphere in this day. KgC/site + real(r8) :: cwd_ag_burned(ncwd) + real(r8) :: leaf_litter_burned(numpft_ed) end type ed_site_type @@ -372,17 +470,53 @@ module EDTypesMod !************************************ type userdata - integer :: cohort_number ! Counts up the number of cohorts which have been made. + integer :: cohort_number ! Counts up the number of cohorts which have been made. + integer :: n_sub ! num of substeps in year 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 + + type(userdata), public, target :: udata ! THIS WAS NOT THREADSAFE !-------------------------------------------------------------------------------------! + public :: ed_hist_scpfmaps + contains + !-------------------------------------------------------------------------------------! + subroutine ed_hist_scpfmaps + ! This subroutine allocates and populates the variables + ! that define the mapping of variables in history files in the "scpf" format + ! back to + ! its respective size-class "sc" and pft "pf" + + integer :: i + integer :: isc + integer :: ipft + + allocate( levsclass_ed(1:nlevsclass_ed )) + allocate( pft_levscpf_ed(1:nlevsclass_ed*mxpft)) + allocate(scls_levscpf_ed(1:nlevsclass_ed*mxpft)) + + ! Fill the IO array of plant size classes + ! For some reason the history files did not like + ! a hard allocation of sclass_ed + levsclass_ed(:) = sclass_ed(:) + + ! Fill the IO arrays that match pft and size class to their combined array + i=0 + do ipft=1,mxpft + do isc=1,nlevsclass_ed + i=i+1 + pft_levscpf_ed(i) = ipft + scls_levscpf_ed(i) = isc + end do + end do + + end subroutine ed_hist_scpfmaps + !-------------------------------------------------------------------------------------! function map_clmpatch_to_edpatch(site, clmpatch_number) result(edpatch_pointer) ! diff --git a/main/EDVecCohortType.F90 b/main/EDVecCohortType.F90 index 96dc04e9..feefd135 100644 --- a/main/EDVecCohortType.F90 +++ b/main/EDVecCohortType.F90 @@ -12,8 +12,8 @@ module EDVecCohortType public ! type, public :: ed_vec_cohort_type - integer :: cohorts_per_gridcell - integer , pointer :: gridcell(:) !index into gridcell level quantities + integer :: cohorts_per_column + integer , pointer :: column(:) !index into column level quantities contains procedure, public :: Init end type ed_vec_cohort_type @@ -35,7 +35,7 @@ subroutine Init(this, beg, end) ! FIX(SPM,032414) pull this out and put in own ED source - allocate(this%gridcell(beg:end)) + allocate(this%column(beg:end)) end subroutine Init diff --git a/main/FatesGlobals.F90 b/main/FatesGlobals.F90 new file mode 100644 index 00000000..9ae06e20 --- /dev/null +++ b/main/FatesGlobals.F90 @@ -0,0 +1,38 @@ +module FatesGlobals + ! NOTE(bja, 201608) This is a temporary hack module to store global + ! data used inside fates. It's main use it to explicitly call out + ! global data that needs to be dealt with, but doesn't have an + ! immediately obvious home. + + implicit none + + integer, private :: fates_log_ + logical, private :: fates_global_verbose_ + + public :: FatesGlobalsInit + public :: fates_log + public :: fates_global_verbose + +contains + + subroutine FatesGlobalsInit(log_unit, global_verbose) + + implicit none + + integer, intent(in) :: log_unit + logical, intent(in) :: global_verbose + + fates_log_ = log_unit + fates_global_verbose_ = global_verbose + + end subroutine FatesGlobalsInit + + integer function fates_log() + fates_log = fates_log_ + end function fates_log + + logical function fates_global_verbose() + fates_global_verbose = fates_global_verbose_ + end function fates_global_verbose + +end module FatesGlobals diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 new file mode 100644 index 00000000..776e4cdc --- /dev/null +++ b/main/FatesInterfaceMod.F90 @@ -0,0 +1,593 @@ +module FatesInterfaceMod + + ! ------------------------------------------------------------------------------------ + ! This is the FATES public API + ! A host land model has defined and allocated a structure "fates" as + ! defined by fates_interface_type + ! + ! It is also likely/possible that this type is defined as a vector + ! which is allocated by thread + ! ------------------------------------------------------------------------------------ + + ! ------------------------------------------------------------------------------------ + ! Used CLM Modules + ! INTERF-TODO: NO CLM MODULES SHOULD BE ACCESSIBLE BY THE FATES + ! PUBLIC API!!!! + ! ------------------------------------------------------------------------------------ + + use EDtypesMod , only : ed_site_type, & + numPatchesPerCol, & + cp_nclmax, & + cp_numSWb, & + cp_numlevgrnd, & + cp_maxSWb, & + cp_numlevdecomp, & + cp_numlevdecomp_full + + use shr_kind_mod , only : r8 => shr_kind_r8 ! INTERF-TODO: REMOVE THIS + + + + ! ------------------------------------------------------------------------------------ + ! Notes on types + ! For floating point arrays, it is sometimes the convention to define the arrays as + ! POINTER instead of ALLOCATABLE. This usually achieves the same result with subtle + ! differences. POINTER arrays can point to scalar values, discontinuous array slices + ! or alias other variables, ALLOCATABLES cannnot. According to S. Lionel + ! (Intel-Forum Post), ALLOCATABLES are better perfomance wise as long as they point + ! to contiguous memory spaces and do not alias other variables, the case here. + ! Naming conventions: _gl means ground layer dimensions + ! _pa means patch dimensions + ! _rb means radiation band + ! ------------------------------------------------------------------------------------ + + type, public :: bc_in_type + + ! The actual number of FATES' ED patches + integer :: npatches + + ! Radiation variables for calculating sun/shade fractions + ! --------------------------------------------------------------------------------- + + ! Downwelling direct beam radiation (patch,radiation-band) [W/m2] + real(r8), allocatable :: solad_parb(:,:) + + ! Downwelling diffuse (I-ndirect) radiation (patch,radiation-band) [W/m2] + real(r8), allocatable :: solai_parb(:,:) + + ! Hydrology variables for BTRAN + ! --------------------------------------------------------------------------------- + + ! Soil suction potential of layers in each site, negative, [mm] + real(r8), allocatable :: smp_gl(:) + + ! Effective porosity = porosity - vol_ic, of layers in each site [-] + real(r8), allocatable :: eff_porosity_gl(:) + + ! volumetric soil water at saturation (porosity) + real(r8), allocatable :: watsat_gl(:) + + ! Temperature of ground layers [K] + real(r8), allocatable :: tempk_gl(:) + + ! Liquid volume in ground layer + real(r8), allocatable :: h2o_liqvol_gl(:) + + ! Site level filter for uptake response functions + logical :: filter_btran + + ! Photosynthesis variables + ! --------------------------------------------------------------------------------- + + ! Patch level filter flag for photosynthesis calculations + ! has a short memory, flags: + ! 1 = patch has not been called + ! 2 = patch is currently marked for photosynthesis + ! 3 = patch has been called for photosynthesis at least once + integer, allocatable :: filter_photo_pa(:) + + ! atmospheric pressure (Pa) + real(r8) :: forc_pbot + + ! daylength scaling factor (0-1) + real(r8), allocatable :: dayl_factor_pa(:) + + ! saturation vapor pressure at t_veg (Pa) + real(r8), allocatable :: esat_tv_pa(:) + + ! vapor pressure of canopy air (Pa) + real(r8), allocatable :: eair_pa(:) + + ! Atmospheric O2 partial pressure (Pa) + real(r8), allocatable :: oair_pa(:) + + ! Atmospheric CO2 partial pressure (Pa) + real(r8), allocatable :: cair_pa(:) + + ! boundary layer resistance (s/m) + real(r8), allocatable :: rb_pa(:) + + ! vegetation temperature (Kelvin) + real(r8), allocatable :: t_veg_pa(:) + + ! air temperature at agcm reference height (kelvin) + real(r8), allocatable :: tgcm_pa(:) + + ! soil temperature (Kelvin) + real(r8), allocatable :: t_soisno_gl(:) + + ! Canopy Radiation Boundaries + ! --------------------------------------------------------------------------------- + + ! Filter for vegetation patches with a positive zenith angle (daylight) + logical, allocatable :: filter_vegzen_pa(:) + + ! Cosine of the zenith angle (0-1), by patch + ! Note RGK: It does not seem like the code would currently generate + ! different zenith angles for different patches (nor should it) + ! I am leaving it at this scale for simplicity. Patches should + ! have no spacially variable information + real(r8), allocatable :: coszen_pa(:) + + ! Abledo of the ground for direct radiation, by site broadband (0-1) + real(r8), allocatable :: albgr_dir_rb(:) + + ! Albedo of the ground for diffuse radiation, by site broadband (0-1) + real(r8), allocatable :: albgr_dif_rb(:) + + ! LitterFlux Boundaries + ! the index of the deepest model soil level where roots may be + ! due to permafrost or bedrock constraints + integer :: max_rooting_depth_index_col + + + end type bc_in_type + + + type, public :: bc_out_type + + ! Sunlit fraction of the canopy for this patch [0-1] + real(r8),allocatable :: fsun_pa(:) + + ! Sunlit canopy LAI + real(r8),allocatable :: laisun_pa(:) + + ! Shaded canopy LAI + real(r8),allocatable :: laisha_pa(:) + + ! Logical stating whether a ground layer can have water uptake by plants + ! The only condition right now is that liquid water exists + ! The name (suction) is used to indicate that soil suction should be calculated + logical, allocatable :: active_suction_gl(:) + + ! Effective fraction of roots in each soil layer + real(r8), allocatable :: rootr_pagl(:,:) + + ! Integrated (vertically) transpiration wetness factor (0 to 1) + ! (diagnostic, should not be used by HLM) + real(r8), allocatable :: btran_pa(:) + + ! Sunlit canopy resistance [s/m] + real(r8), allocatable :: rssun_pa(:) + + ! Shaded canopy resistance [s/m] + real(r8), allocatable :: rssha_pa(:) + + ! Canopy conductance [mmol m-2 s-1] + real(r8), allocatable :: gccanopy_pa(:) + + ! patch sunlit leaf photosynthesis (umol CO2 /m**2/ s) + real(r8), allocatable :: psncanopy_pa(:) + + ! patch sunlit leaf maintenance respiration rate (umol CO2/m**2/s) + real(r8), allocatable :: lmrcanopy_pa(:) + + ! Canopy Radiation Boundaries + ! --------------------------------------------------------------------------------- + + ! Surface albedo (direct) (HLMs use this for atm coupling and balance checks) + real(r8), allocatable :: albd_parb(:,:) + + ! Surface albedo (diffuse) (HLMs use this for atm coupling and balance checks) + real(r8), allocatable :: albi_parb(:,:) + + ! Flux absorbed by canopy per unit direct flux (HLMs use this for balance checks) + real(r8), allocatable :: fabd_parb(:,:) + + ! Flux absorbed by canopy per unit diffuse flux (HLMs use this for balance checks) + real(r8), allocatable :: fabi_parb(:,:) + + ! Down direct flux below canopy per unit direct flx (HLMs use this for balance checks) + real(r8), allocatable :: ftdd_parb(:,:) + + ! Down diffuse flux below canopy per unit direct flx (HLMs use this for balance checks) + real(r8), allocatable :: ftid_parb(:,:) + + ! Down diffuse flux below canopy per unit diffuse flx (HLMs use this for balance checks) + real(r8), allocatable :: ftii_parb(:,:) + + + ! litterfall fluxes of C from FATES patches to BGC columns + + ! total labile litter coming from ED. gC/m3/s + real(r8), allocatable :: FATES_c_to_litr_lab_c_col(:) + + !total cellulose litter coming from ED. gC/m3/s + real(r8), allocatable :: FATES_c_to_litr_cel_c_col(:) + + !total lignin litter coming from ED. gC/m3/s + real(r8), allocatable :: FATES_c_to_litr_lig_c_col(:) + + + end type bc_out_type + + + type, public :: fates_interface_type + + ! This is the root of the ED/FATES hierarchy of instantaneous state variables + ! ie the root of the linked lists. Each path list is currently associated with a + ! grid-cell, this is intended to be migrated to columns + + integer :: nsites + + type(ed_site_type), pointer :: sites(:) + + ! These are boundary conditions that the FATES models are required to be filled. + ! These values are filled by the driver or HLM. Once filled, these have an + ! intent(in) status. Each site has a derived type structure, which may include + ! a scalar for site level data, a patch vector, potentially cohort vectors (but + ! not yet atm) and other dimensions such as soil-depth or pft. These vectors + ! are initialized by maximums, and the allocations are static in time to avoid + ! having to allocate/de-allocate memory + + type(bc_in_type), allocatable :: bc_in(:) + + ! These are the boundary conditions that the FATES model returns to its HLM or + ! driver. It has the same allocation strategy and similar vector types. + + type(bc_out_type), allocatable :: bc_out(:) + + contains + + procedure, public :: zero_bcs + + end type fates_interface_type + + public :: FatesInterfaceInit + public :: set_fates_ctrlparms + + +contains + + ! ==================================================================================== + subroutine FatesInterfaceInit(log_unit, global_verbose) + + use FatesGlobals, only : FatesGlobalsInit + + implicit none + + integer, intent(in) :: log_unit + logical, intent(in) :: global_verbose + + call FatesGlobalsInit(log_unit, global_verbose) + + end subroutine FatesInterfaceInit + + ! ==================================================================================== + + ! INTERF-TODO: THIS IS A PLACE-HOLDER ROUTINE, NOT CALLED YET... + subroutine fates_clean(this) + + implicit none + + ! Input Arguments + class(fates_interface_type), intent(inout) :: this + + ! Incrementally walk through linked list and deallocate + + + + ! Deallocate the site list + deallocate (this%sites) + + return + end subroutine fates_clean + + + ! ==================================================================================== + + + subroutine allocate_bcin(bc_in) + + ! --------------------------------------------------------------------------------- + ! Allocate and Initialze the FATES boundary condition vectors + ! --------------------------------------------------------------------------------- + + implicit none + type(bc_in_type), intent(inout) :: bc_in + + ! Allocate input boundaries + + ! Radiation + allocate(bc_in%solad_parb(numPatchesPerCol,cp_numSWb)) + allocate(bc_in%solai_parb(numPatchesPerCol,cp_numSWb)) + + ! Hydrology + allocate(bc_in%smp_gl(cp_numlevgrnd)) + allocate(bc_in%eff_porosity_gl(cp_numlevgrnd)) + allocate(bc_in%watsat_gl(cp_numlevgrnd)) + allocate(bc_in%tempk_gl(cp_numlevgrnd)) + allocate(bc_in%h2o_liqvol_gl(cp_numlevgrnd)) + + ! Photosynthesis + allocate(bc_in%filter_photo_pa(numPatchesPerCol)) + allocate(bc_in%dayl_factor_pa(numPatchesPerCol)) + allocate(bc_in%esat_tv_pa(numPatchesPerCol)) + allocate(bc_in%eair_pa(numPatchesPerCol)) + allocate(bc_in%oair_pa(numPatchesPerCol)) + allocate(bc_in%cair_pa(numPatchesPerCol)) + allocate(bc_in%rb_pa(numPatchesPerCol)) + allocate(bc_in%t_veg_pa(numPatchesPerCol)) + allocate(bc_in%tgcm_pa(numPatchesPerCol)) + allocate(bc_in%t_soisno_gl(cp_numlevgrnd)) + + ! Canopy Radiation + allocate(bc_in%filter_vegzen_pa(numPatchesPerCol)) + allocate(bc_in%coszen_pa(numPatchesPerCol)) + allocate(bc_in%albgr_dir_rb(cp_numSWb)) + allocate(bc_in%albgr_dif_rb(cp_numSWb)) + + return + end subroutine allocate_bcin + + subroutine allocate_bcout(bc_out) + + ! --------------------------------------------------------------------------------- + ! Allocate and Initialze the FATES boundary condition vectors + ! --------------------------------------------------------------------------------- + + implicit none + type(bc_out_type), intent(inout) :: bc_out + + + ! Radiation + allocate(bc_out%fsun_pa(numPatchesPerCol)) + allocate(bc_out%laisun_pa(numPatchesPerCol)) + allocate(bc_out%laisha_pa(numPatchesPerCol)) + + ! Hydrology + allocate(bc_out%active_suction_gl(cp_numlevgrnd)) + allocate(bc_out%rootr_pagl(numPatchesPerCol,cp_numlevgrnd)) + allocate(bc_out%btran_pa(numPatchesPerCol)) + + ! Photosynthesis + allocate(bc_out%rssun_pa(numPatchesPerCol)) + allocate(bc_out%rssha_pa(numPatchesPerCol)) + allocate(bc_out%gccanopy_pa(numPatchesPerCol)) + allocate(bc_out%lmrcanopy_pa(numPatchesPerCol)) + allocate(bc_out%psncanopy_pa(numPatchesPerCol)) + + ! Canopy Radiation + allocate(bc_out%albd_parb(numPatchesPerCol,cp_numSWb)) + allocate(bc_out%albi_parb(numPatchesPerCol,cp_numSWb)) + allocate(bc_out%fabd_parb(numPatchesPerCol,cp_numSWb)) + allocate(bc_out%fabi_parb(numPatchesPerCol,cp_numSWb)) + allocate(bc_out%ftdd_parb(numPatchesPerCol,cp_numSWb)) + allocate(bc_out%ftid_parb(numPatchesPerCol,cp_numSWb)) + allocate(bc_out%ftii_parb(numPatchesPerCol,cp_numSWb)) + + ! biogeochemistry + allocate(bc_out%FATES_c_to_litr_lab_c_col(cp_numlevdecomp_full)) + allocate(bc_out%FATES_c_to_litr_cel_c_col(cp_numlevdecomp_full)) + allocate(bc_out%FATES_c_to_litr_lig_c_col(cp_numlevdecomp_full)) + + return + end subroutine allocate_bcout + + ! ==================================================================================== + + subroutine zero_bcs(this,s) + + implicit none + class(fates_interface_type), intent(inout) :: this + integer, intent(in) :: s + + ! Input boundaries + + this%bc_in(s)%solad_parb(:,:) = 0.0_r8 + this%bc_in(s)%solai_parb(:,:) = 0.0_r8 + this%bc_in(s)%smp_gl(:) = 0.0_r8 + this%bc_in(s)%eff_porosity_gl(:) = 0.0_r8 + this%bc_in(s)%watsat_gl(:) = 0.0_r8 + this%bc_in(s)%tempk_gl(:) = 0.0_r8 + this%bc_in(s)%h2o_liqvol_gl(:) = 0.0_r8 + this%bc_in(s)%filter_vegzen_pa(:) = .false. + this%bc_in(s)%coszen_pa(:) = 0.0_r8 + this%bc_in(s)%albgr_dir_rb(:) = 0.0_r8 + this%bc_in(s)%albgr_dif_rb(:) = 0.0_r8 + this%bc_in(s)%max_rooting_depth_index_col = 0 + + + ! Output boundaries + this%bc_out(s)%active_suction_gl(:) = .false. + this%bc_out(s)%fsun_pa(:) = 0.0_r8 + this%bc_out(s)%laisun_pa(:) = 0.0_r8 + this%bc_out(s)%laisha_pa(:) = 0.0_r8 + this%bc_out(s)%rootr_pagl(:,:) = 0.0_r8 + this%bc_out(s)%btran_pa(:) = 0.0_r8 + + this%bc_out(s)%FATES_c_to_litr_lab_c_col(:) = 0.0_r8 + this%bc_out(s)%FATES_c_to_litr_cel_c_col(:) = 0.0_r8 + this%bc_out(s)%FATES_c_to_litr_lig_c_col(:) = 0.0_r8 + + this%bc_out(s)%rssun_pa(:) = 0.0_r8 + this%bc_out(s)%rssha_pa(:) = 0.0_r8 + this%bc_out(s)%gccanopy_pa(:) = 0.0_r8 + this%bc_out(s)%psncanopy_pa(:) = 0.0_r8 + this%bc_out(s)%lmrcanopy_pa(:) = 0.0_r8 + + this%bc_out(s)%albd_parb(:,:) = 0.0_r8 + this%bc_out(s)%albi_parb(:,:) = 0.0_r8 + this%bc_out(s)%fabd_parb(:,:) = 0.0_r8 + this%bc_out(s)%fabi_parb(:,:) = 0.0_r8 + this%bc_out(s)%ftdd_parb(:,:) = 0.0_r8 + this%bc_out(s)%ftid_parb(:,:) = 0.0_r8 + this%bc_out(s)%ftii_parb(:,:) = 0.0_r8 + + return + end subroutine zero_bcs + + ! ==================================================================================== + + subroutine set_fates_ctrlparms(tag,dimval) + + ! --------------------------------------------------------------------------------- + ! INTERF-TODO: NEED ALLOWANCES FOR REAL AND CHARACTER ARGS.. + ! Certain model control parameters and dimensions used by FATES are dictated by + ! the the driver or the host mode. To see which parameters should be filled here + ! please also look at the ctrl_parms_type in FATESTYpeMod, in the section listing + ! components dictated by the host model. + ! + ! Some important points: + ! 1. Calls to this function are likely from the clm_fates module in the HLM. + ! 2. The calls should be preceeded by a flush function. + ! 3. All values in ctrl_parm (FATESTypesMod.F90) that are classified as + ! 'dictated by the HLM' must be listed in this subroutine + ! 4. Should look like this: + ! + ! call set_fates_ctrlparms('flush_to_unset') + ! call set_fates_ctrlparms('num_sw_bbands',numrad) ! or other variable + ! ... + ! call set_fates_ctrlparms('num_lev_ground',nlevgrnd) ! or other variable + ! call set_fates_ctrlparms('check_allset') + ! + ! RGK-2016 + ! --------------------------------------------------------------------------------- + use FatesGlobals, only : fates_log, fates_global_verbose + + ! Arguments + integer, optional, intent(in) :: dimval + character(len=*),intent(in) :: tag + + ! local variables + logical :: all_set + integer, parameter :: unset_int = -999 + real(r8), parameter :: unset_double = -999.9 + + select case (trim(tag)) + case('flush_to_unset') + if (fates_global_verbose()) then + write(fates_log(), *) 'Flushing FATES control parameters prior to transfer from host' + end if + cp_numSwb = unset_int + cp_numlevgrnd = unset_int + cp_numlevdecomp_full = unset_int + cp_numlevdecomp = unset_int + + + case('check_allset') + + if(cp_numSWb .eq. unset_int) then + if (fates_global_verbose()) then + write(fates_log(), *) 'FATES dimension/parameter unset: num_sw_rad_bbands' + end if + ! INTERF-TODO: FATES NEEDS INTERNAL end_run + ! end_run('MESSAGE') + end if + + if(cp_numSWb > cp_maxSWb) then + if (fates_global_verbose()) then + write(fates_log(), *) 'FATES sets a maximum number of shortwave bands' + write(fates_log(), *) 'for some scratch-space, cp_maxSWb' + write(fates_log(), *) 'it defaults to 2, but can be increased as needed' + write(fates_log(), *) 'your driver or host model is intending to drive' + write(fates_log(), *) 'FATES with:',cp_numSWb,' bands.' + write(fates_log(), *) 'please increase cp_maxSWb in EDTypes to match' + write(fates_log(), *) 'or exceed this value' + end if + ! end_run('MESSAGE') + end if + + if(cp_numlevgrnd .eq. unset_int) then + if (fates_global_verbose()) then + write(fates_log(), *) 'FATES dimension/parameter unset: numlevground' + end if + ! INTERF-TODO: FATES NEEDS INTERNAL end_run + ! end_run('MESSAGE') + end if + + if(cp_numlevdecomp_full .eq. unset_int) then + if (fates_global_verbose()) then + write(fates_log(), *) 'FATES dimension/parameter unset: numlevdecomp_full' + end if + ! INTERF-TODO: FATES NEEDS INTERNAL end_run + ! end_run('MESSAGE') + end if + + if(cp_numlevdecomp .eq. unset_int) then + if (fates_global_verbose()) then + write(fates_log(), *) 'FATES dimension/parameter unset: numlevdecomp' + end if + ! INTERF-TODO: FATES NEEDS INTERNAL end_run + ! end_run('MESSAGE') + end if + + if (fates_global_verbose()) then + write(fates_log(), *) 'Checked. All control parameters sent to FATES.' + end if + + case default + + if(present(dimval))then + select case (trim(tag)) + + case('num_sw_bbands') + + cp_numSwb = dimval + if (fates_global_verbose()) then + write(fates_log(), *) 'Transfering num_sw_bbands = ',dimval,' to FATES' + end if + + case('num_lev_ground') + + cp_numlevgrnd = dimval + if (fates_global_verbose()) then + + write(fates_log(), *) 'Transfering num_lev_ground = ',dimval,' to FATES' + end if + + case('num_levdecomp_full') + + cp_numlevdecomp_full = dimval + if (fates_global_verbose()) then + write(fates_log(), *) 'Transfering num_levdecomp_full = ',dimval,' to FATES' + end if + + case('num_levdecomp') + + cp_numlevdecomp = dimval + if (fates_global_verbose()) then + write(fates_log(), *) 'Transfering num_levdecomp = ',dimval,' to FATES' + end if + + case default + if (fates_global_verbose()) then + write(fates_log(), *) 'tag not recognized:',trim(tag) + end if + ! end_run + end select + else + if (fates_global_verbose()) then + write(fates_log(), *) 'no value was provided for the tag' + end if + end if + + end select + + + return + end subroutine set_fates_ctrlparms + + + +end module FatesInterfaceMod From b19c113a600b7770f23fd62463a0cf1f62da0039 Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Wed, 31 Aug 2016 13:38:17 -0700 Subject: [PATCH 181/437] first attempt to move seed_bank from patch to site level --- biogeochem/EDPatchDynamicsMod.F90 | 30 +++++---------------------- biogeochem/EDPhysiologyMod.F90 | 11 +++++----- main/EDCLMLinkMod.F90 | 33 ++++++++++-------------------- main/EDInitMod.F90 | 4 +--- main/EDMainMod.F90 | 34 ++++++++++++++++++------------- main/EDRestVectorMod.F90 | 29 +++++++++++++++++--------- main/EDTypesMod.F90 | 8 +++++--- 7 files changed, 67 insertions(+), 82 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index d38e868d..3ae1337d 100755 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -191,7 +191,6 @@ subroutine spawn_patches( currentSite ) 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(cp_nclmax) ! initial value of canopy spread parameter.no units !--------------------------------------------------------------------- @@ -222,7 +221,6 @@ subroutine spawn_patches( currentSite ) root_litter_local = 0.0_r8 spread_local(1:cp_nclmax) = ED_val_maxspread age = 0.0_r8 - seed_bank_local = 0.0_r8 allocate(new_patch) @@ -233,7 +231,7 @@ subroutine spawn_patches( currentSite ) 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) + root_litter_local) new_patch%tallest => null() new_patch%shortest => null() @@ -488,10 +486,6 @@ subroutine average_patch_properties( currentPatch, newPatch, patch_site_areadis 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 @@ -793,7 +787,7 @@ 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) + leaf_litter_local,root_litter_local) ! ! !DESCRIPTION: ! Set default values for creating a new patch @@ -810,7 +804,6 @@ subroutine create_patch(currentSite, new_patch, age, areap, spread_local,cwd_ag_ 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: !--------------------------------------------------------------------- @@ -844,7 +837,6 @@ subroutine create_patch(currentSite, new_patch, age, areap, spread_local,cwd_ag_ 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 @@ -945,8 +937,6 @@ subroutine zero_patch(cp_p) 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 @@ -991,9 +981,6 @@ subroutine zero_patch(cp_p) 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 @@ -1175,16 +1162,9 @@ subroutine fuse_2_patches(dp, rp) type(ed_site_type), pointer :: csite ! pointer to the donor patch's site !--------------------------------------------------------------------- - !area weighted average of ages & litter & seed bank + !area weighted average of ages & litter 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) @@ -1342,9 +1322,9 @@ subroutine terminate_patches(cs_pnt) ! This is only really meant for very old patches. if(associated(currentPatch%older) )then write(iulog,*) 'fusing to older patch because this one is too small',currentPatch%area, currentPatch%lai, & - currentPatch%older%area,currentPatch%older%lai,currentPatch%seed_bank(1) + currentPatch%older%area,currentPatch%older%lai call fuse_2_patches(currentPatch%older, currentPatch) - write(iulog,*) 'after fusion to older patch',currentPatch%area,currentPatch%seed_bank(1) + write(iulog,*) 'after fusion to older patch',currentPatch%area else write(iulog,*) 'fusing to younger patch because oldest one is too small',currentPatch%area, currentPatch%lai tmpptr => currentPatch%younger diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 1dff2f2e..fde0d85b 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -71,7 +71,7 @@ subroutine canopy_derivs( currentPatch ) end subroutine canopy_derivs ! ============================================================================ - subroutine non_canopy_derivs( currentPatch, temperature_inst ) + subroutine non_canopy_derivs( currentSite, currentPatch, temperature_inst ) ! ! !DESCRIPTION: ! Returns time differentials of the state vector @@ -79,6 +79,7 @@ subroutine non_canopy_derivs( currentPatch, temperature_inst ) ! !USES: ! ! !ARGUMENTS + type(ed_site_type), intent(inout), target :: currentSite type(ed_patch_type) , intent(inout) :: currentPatch type(temperature_type) , intent(in) :: temperature_inst ! @@ -110,7 +111,7 @@ subroutine non_canopy_derivs( currentPatch, temperature_inst ) call cwd_out( currentPatch, temperature_inst) do p = 1,numpft_ed - currentPatch%dseed_dt(p) = currentPatch%seeds_in(p) - currentPatch%seed_decay(p) - currentPatch%seed_germination(p) + currentSite%dseed_dt(p) = currentSite%dseed_dt(p) + (currentPatch%seeds_in(p) - currentPatch%seed_decay(p) - currentPatch%seed_germination(p)) * currentPatch%area/AREA enddo do c = 1,ncwd @@ -666,7 +667,7 @@ subroutine seeds_in( cp_pnt ) 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 - currentPatch%seed_rain_flux(p) = currentPatch%seed_rain_flux(p) + EDecophyscon%seed_rain(p) !KgC/m2/year + currentPatch%siteptr%seed_rain_flux(p) = currentPatch%siteptr%seed_rain_flux(p) + EDecophyscon%seed_rain(p) * currentPatch%area/AREA !KgC/m2/year enddo endif currentPatch => currentPatch%younger @@ -694,7 +695,7 @@ subroutine seed_decay( currentPatch ) ! 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 + currentPatch%seed_decay(p) = currentPatch%siteptr%seed_bank(p) * seed_turnover enddo end subroutine seed_decay @@ -720,7 +721,7 @@ subroutine seed_germination( currentPatch ) 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) + currentPatch%seed_germination(p) = min(currentPatch%siteptr%seed_bank(p) * germination_timescale,max_germination) enddo end subroutine seed_germination diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 3b839cbc..5de6ab39 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -67,9 +67,8 @@ module EDCLMLinkMod 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_col (:) ! kGC/m2 Mass of seeds. - 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. @@ -139,7 +138,6 @@ module EDCLMLinkMod real(r8), pointer, private :: biomass_stock_col(:) ! [gC/m2] total biomass at the column level in gC / m2 real(r8), pointer, private :: ed_litter_stock_col(:) ! [gC/m2] ED litter at the column level in gC / m2 real(r8), pointer, private :: cwd_stock_col(:) ! [gC/m2] ED CWD at the column level in gC / m2 - real(r8), pointer, private :: seed_stock_col(:) ! [gC/m2] ED seed mass carbon at the column level in gC / m2 ! carbon balance errors. at some point we'll reduce these to close to zero and delete, but for now we'll just keep[ track of them real(r8), pointer, private :: cbalance_error_ed_col(:) ! [gC/m2/s] total carbon balance error for the ED side @@ -238,7 +236,6 @@ subroutine InitAllocate(this, bounds) 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 @@ -254,6 +251,7 @@ subroutine InitAllocate(this, bounds) allocate(this%maint_resp_patch (begp:endp)) ; this%maint_resp_patch (:) = nan allocate(this%growth_resp_patch (begp:endp)) ; this%growth_resp_patch (:) = nan + allocate(this%seed_bank_col (begc:endc)) ; this%seed_bank_col (:) = 0.0_r8 allocate(this%ed_to_bgc_this_edts_col (begc:endc)) ; this%ed_to_bgc_this_edts_col (:) = nan allocate(this%ed_to_bgc_last_edts_col (begc:endc)) ; this%ed_to_bgc_last_edts_col (:) = nan allocate(this%seed_rain_flux_col (begc:endc)) ; this%seed_rain_flux_col (:) = nan @@ -276,7 +274,6 @@ subroutine InitAllocate(this, bounds) allocate(this%biomass_stock_col (begc:endc)) ; this%biomass_stock_col (:) = nan allocate(this%ed_litter_stock_col (begc:endc)) ; this%ed_litter_stock_col (:) = nan allocate(this%cwd_stock_col (begc:endc)) ; this%cwd_stock_col (:) = nan - allocate(this%seed_stock_col (begc:endc)) ; this%seed_stock_col (:) = nan allocate(this%cbalance_error_ed_col (begc:endc)) ; this%cbalance_error_ed_col (:) = nan allocate(this%cbalance_error_bgc_col (begc:endc)) ; this%cbalance_error_bgc_col (:) = nan @@ -436,7 +433,7 @@ subroutine InitHistory(this, bounds) call hist_addfld1d (fname='SEED_BANK', units='gC 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) + ptr_col=this%seed_bank_col, set_lake=0._r8, set_urb=0._r8) call hist_addfld1d (fname='SEEDS_IN', units='gC m-2 s-1', & avgflag='A', long_name='Seed Production Rate', & @@ -558,11 +555,6 @@ subroutine InitHistory(this, bounds) avgflag='A', long_name='total CWD carbon at the column level', & ptr_col=this%cwd_stock_col) - this%seed_stock_col(begc:endc) = spval - call hist_addfld1d (fname='SEED_STOCK_COL', units='gC/m^2', & - avgflag='A', long_name='total seed carbon at the column level', & - ptr_col=this%seed_stock_col) - ! Carbon Flux (grid dimension x scpf) ! ============================================================== @@ -1086,11 +1078,12 @@ subroutine ed_update_history_variables( this, bounds, sites, nsites, fcolumn, ca 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: + seed_bank => this%seed_bank_col , & ! Output: + ED_biomass => this%ED_biomass_patch , & ! InOut: ED_bdead => this%ED_bdead_patch , & ! InOut: ED_bleaf => this%ED_bleaf_patch , & ! InOut: @@ -1154,7 +1147,6 @@ subroutine ed_update_history_variables( this, bounds, sites, nsites, fcolumn, ca 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 @@ -1220,7 +1212,6 @@ subroutine ed_update_history_variables( this, bounds, sites, nsites, fcolumn, ca fire_fuel_mef(p) = 0.0_r8 litter_in(p) = 0.0_r8 litter_out(p) = 0.0_r8 - seed_bank(p) = 0.0_r8 seeds_in(p) = 0.0_r8 seed_decay(p) = 0.0_r8 seed_germination(p) = 0.0_r8 @@ -1236,6 +1227,8 @@ subroutine ed_update_history_variables( this, bounds, sites, nsites, fcolumn, ca ED_bleaf(p) = 0.0_r8 sum_fuel(p) = 0.0_r8 + seed_bank(c) = sum(sites(s)%seed_bank) * 1.e3_r8 + currentPatch => sites(s)%oldest_patch do while(associated(currentPatch)) @@ -1371,7 +1364,6 @@ subroutine ed_update_history_variables( this, bounds, sites, nsites, fcolumn, ca sum_fuel(p) = currentPatch%sum_fuel * 1.e3_r8 * patch_scaling_scalar litter_in(p) = (sum(currentPatch%CWD_AG_in) +sum(currentPatch%leaf_litter_in)) * 1.e3_r8 * 365.0_r8 * SHR_CONST_CDAY * patch_scaling_scalar litter_out(p) = (sum(currentPatch%CWD_AG_out)+sum(currentPatch%leaf_litter_out)) * 1.e3_r8 * 365.0_r8 * SHR_CONST_CDAY * patch_scaling_scalar - seed_bank(p) = sum(currentPatch%seed_bank) * 1.e3_r8 * patch_scaling_scalar seeds_in(p) = sum(currentPatch%seeds_in) * 1.e3_r8 * 365.0_r8 * SHR_CONST_CDAY * patch_scaling_scalar seed_decay(p) = sum(currentPatch%seed_decay) * 1.e3_r8 * 365.0_r8 * SHR_CONST_CDAY * patch_scaling_scalar seed_germination(p) = sum(currentPatch%seed_germination) * 1.e3_r8 * 365.0_r8 * SHR_CONST_CDAY * patch_scaling_scalar @@ -2085,7 +2077,7 @@ subroutine SummarizeNetFluxes(this, bounds, num_soilc, filter_soilc, & biomass_stock => this%biomass_stock_col, & ! total biomass in gC / m2 ed_litter_stock => this%ed_litter_stock_col, & ! ED litter in gC / m2 cwd_stock => this%cwd_stock_col, & ! total CWD in gC / m2 - seed_stock => this%seed_stock_col, & ! total seed mass in gC / m2 + seed_bank => this%seed_bank_col, & ! total seed mass in gC / m2 ed_to_bgc_this_edts => this%ed_to_bgc_this_edts_col, & ed_to_bgc_last_edts => this%ed_to_bgc_last_edts_col, & seed_rain_flux => this%seed_rain_flux_col & @@ -2103,7 +2095,6 @@ subroutine SummarizeNetFluxes(this, bounds, num_soilc, filter_soilc, & ! summary stock variables ed_litter_stock(c) = 0._r8 cwd_stock(c) = 0._r8 - seed_stock(c) = 0._r8 biomass_stock(c) = 0._r8 end do @@ -2125,7 +2116,6 @@ subroutine SummarizeNetFluxes(this, bounds, num_soilc, filter_soilc, & sum(currentPatch%cwd_bg)) * 1.e3_r8 ed_litter_stock(c) = ed_litter_stock(c) + (currentPatch%area / AREA) * & (sum(currentPatch%leaf_litter)+sum(currentPatch%root_litter)) * 1.e3_r8 - seed_stock(c) = seed_stock(c) + (currentPatch%area / AREA) * sum(currentPatch%seed_bank) * 1.e3_r8 currentCohort => currentPatch%tallest do while(associated(currentCohort)) @@ -2154,7 +2144,7 @@ subroutine SummarizeNetFluxes(this, bounds, num_soilc, filter_soilc, & do fc = 1,num_soilc c = filter_soilc(fc) - totedc(c) = ed_litter_stock(c) + cwd_stock(c) + seed_stock(c) + biomass_stock(c) ! ED stocks + totedc(c) = ed_litter_stock(c) + cwd_stock(c) + seed_bank(c) + biomass_stock(c) ! ED stocks totbgcc(c) = totsomc(c) + totlitc(c) ! BGC stocks totecosysc(c) = totedc(c) + totbgcc(c) @@ -2173,12 +2163,13 @@ subroutine SummarizeNetFluxes(this, bounds, num_soilc, filter_soilc, & do s = 1,nsites c = fcolumn(s) ed_to_bgc_this_edts(c) = 0._r8 - seed_rain_flux(c) = 0._r8 end do ! do s = 1,nsites c = fcolumn(s) + seed_rain_flux(c) = sum(sites(s)%seed_rain_flux) * 1.e3_r8 / ( 365.0_r8*SHR_CONST_CDAY ) + ! currentPatch => sites(s)%oldest_patch do while(associated(currentPatch)) ! @@ -2186,8 +2177,6 @@ subroutine SummarizeNetFluxes(this, bounds, num_soilc, filter_soilc, & + sum(currentPatch%seed_decay) + sum(currentPatch%leaf_litter_out) + sum(currentPatch%root_litter_out)) & * ( currentPatch%area/AREA ) * 1.e3_r8 / ( 365.0_r8*SHR_CONST_CDAY ) ! - seed_rain_flux(c) = seed_rain_flux(c) + sum(currentPatch%seed_rain_flux) * 1.e3_r8 / ( 365.0_r8*SHR_CONST_CDAY ) - ! currentPatch => currentPatch%younger end do !currentPatch end do diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 29a370c0..6739fce5 100755 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -179,7 +179,6 @@ subroutine init_patches( sites, nsites) real(r8) :: spread_local(cp_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 !---------------------------------------------------------------------- @@ -189,7 +188,6 @@ subroutine init_patches( sites, nsites) 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 @@ -208,7 +206,7 @@ subroutine init_patches( sites, nsites) ! make new patch... call create_patch(sites(s), newp, age, AREA, & spread_local, cwd_ag_local, cwd_bg_local, leaf_litter_local, & - root_litter_local, seed_bank_local) + root_litter_local) call init_cohorts(newp) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index f920f397..42d14905 100755 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -156,6 +156,8 @@ subroutine ed_integrate_state_variables(currentSite, temperature_inst ) small_no = 0.0000000000_r8 ! Obviously, this is arbitrary. RF - changed to zero + currentSite%dseed_dt(p) = 0._r8 ! zero the dseed_dt at the site level before looping through patches and adding the fluxes from each patch + currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) @@ -214,13 +216,11 @@ subroutine ed_integrate_state_variables(currentSite, temperature_inst ) write(6,*)'DEBUG18: calling non_canopy_derivs with pno= ',currentPatch%clm_pno endif - call non_canopy_derivs( currentPatch, temperature_inst ) + call non_canopy_derivs( currentSite, currentPatch, temperature_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 + ! first update the litter variables that are tracked at the patch level 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 @@ -231,14 +231,6 @@ subroutine ed_integrate_state_variables(currentSite, temperature_inst ) 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) 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)) diff --git a/main/EDRestVectorMod.F90 b/main/EDRestVectorMod.F90 index 3f37c521..bd7cf93e 100755 --- a/main/EDRestVectorMod.F90 +++ b/main/EDRestVectorMod.F90 @@ -89,7 +89,6 @@ module EDRestVectorMod 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 ! @@ -119,6 +118,10 @@ module EDRestVectorMod real(r8), pointer :: dleafondate(:) real(r8), pointer :: dleafoffdate(:) real(r8), pointer :: acc_NI(:) + ! + ! site x pft + real(r8), pointer :: seed_bank(:) + contains @@ -1032,7 +1035,7 @@ subroutine doVectorIO( this, ncid, flag ) call restartvar(ncid=ncid, flag=flag, varname='ed_seed_bank', xtype=ncd_double, & dim1name=coh_dimName, & - long_name='ed patch - seed_bank', units='unitless', & + long_name='ed site - seed_bank', units='unitless', & interpinic_flag='interp', data=this%seed_bank, & readvar=readvar) @@ -1352,7 +1355,6 @@ subroutine printDataInfoLL( this, bounds, sites, nsites ) 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 @@ -1373,6 +1375,7 @@ subroutine printDataInfoLL( this, bounds, sites, nsites ) write(iulog,*) trim(methodName)//' dleafoffdate ' ,sites(s)%dleafoffdate write(iulog,*) trim(methodName)//' acc_NI' ,sites(s)%acc_NI write(iulog,*) trim(methodName)//' ED_GDD_site ' ,sites(s)%ED_GDD_site + write(iulog,*) trim(methodName)//' seed_bank ' ,sites(s)%seed_bank currentPatch => currentPatch%younger @@ -1558,6 +1561,11 @@ subroutine convertCohortListToVector( this, bounds, sites, nsites, fcolumn ) countWaterMem = bounds%begCohort+(c-bounds%begc)*cohorts_per_col + 1 countSunZ = bounds%begCohort+(c-bounds%begc)*cohorts_per_col + 1 + ! write seed_bank info(site-level, but PFT-resolved) + do i = 1,numpft_ed + this%seed_bank(incrementOffset+i-1) = sites(s)%seed_bank(i) + end do + currentPatch => sites(s)%oldest_patch ! new column, reset num patches @@ -1658,7 +1666,6 @@ subroutine convertCohortListToVector( this, bounds, sites, nsites, fcolumn ) 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 @@ -1723,8 +1730,8 @@ subroutine convertCohortListToVector( this, bounds, sites, nsites, fcolumn ) this%dleafondate(c) = sites(s)%dleafondate this%dleafoffdate(c) = sites(s)%dleafoffdate this%acc_NI(c) = sites(s)%acc_NI - this%ED_GDD_site(c) = sites(s)%ED_GDD_site - + this%ED_GDD_site(c) = sites(s)%ED_GDD_site + ! set numpatches for this column this%numPatchesPerCol(c) = numPatches @@ -1771,7 +1778,6 @@ subroutine createPatchCohortStructure( this, bounds, sites, nsites, fcolumn ) type(ed_cohort_type), allocatable :: temp_cohort real(r8) :: cwd_ag_local(ncwd),cwd_bg_local(ncwd),spread_local(cp_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 :: s ! site index @@ -1839,7 +1845,7 @@ subroutine createPatchCohortStructure( this, bounds, sites, nsites, fcolumn ) ! make new patch call create_patch(sites(s), newp, age, area, & spread_local, cwd_ag_local, cwd_bg_local, & - leaf_litter_local, root_litter_local, seed_bank_local) + leaf_litter_local, root_litter_local) newp%siteptr => sites(s) @@ -1980,6 +1986,11 @@ subroutine convertCohortVectorToList( this, bounds, sites, nsites, fcolumn ) countWaterMem = bounds%begCohort+(c-bounds%begc)*cohorts_per_col + 1 countSunZ = bounds%begCohort+(c-bounds%begc)*cohorts_per_col + 1 + ! read seed_bank info(site-level, but PFT-resolved) + do i = 1,numpft_ed + sites(s)%seed_bank(i) = this%seed_bank(incrementOffset+i-1) + end do + currentPatch => sites(s)%oldest_patch ! new grid cell, reset num patches @@ -2056,7 +2067,6 @@ subroutine convertCohortVectorToList( this, bounds, sites, nsites, fcolumn ) 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 ! @@ -2084,7 +2094,6 @@ subroutine convertCohortVectorToList( this, bounds, sites, nsites, fcolumn ) 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 diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index ca11fa8a..bbf86899 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -328,12 +328,9 @@ module EDTypesMod !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) - real(r8) :: seed_rain_flux(numpft_ed) ! flux of seeds from exterior KgC/m2/year (needed for C balance purposes) ! PHOTOSYNTHESIS real(r8) :: psn_z(cp_nclmax,numpft_ed,cp_nlevcan) ! carbon assimilation in each canopy layer, pft, and leaf layer. umolC/m2/s @@ -455,6 +452,11 @@ module EDTypesMod integer :: dleafoffdate ! doy of leaf on drought:- real(r8) :: water_memory(10) ! last 10 days of soil moisture memory... + !SEED BANK + real(r8) :: seed_bank(numpft_ed) ! seed pool in KgC/m2/year + real(r8) :: dseed_dt(numpft_ed) + real(r8) :: seed_rain_flux(numpft_ed) ! flux of seeds from exterior KgC/m2/year (needed for C balance purposes) + ! FIRE real(r8) :: acc_ni ! daily nesterov index accumulating over time. real(r8) :: ab ! daily burnt area: m2 From c1d442f6a165327414e9cfdbb0ddd6ce1b160e48 Mon Sep 17 00:00:00 2001 From: ckoven Date: Wed, 31 Aug 2016 14:19:08 -0700 Subject: [PATCH 182/437] compile-time bugfixes --- biogeochem/EDPhysiologyMod.F90 | 3 ++- main/EDMainMod.F90 | 3 ++- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index fde0d85b..cf680c68 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -77,6 +77,7 @@ subroutine non_canopy_derivs( currentSite, currentPatch, temperature_inst ) ! Returns time differentials of the state vector ! ! !USES: + use EDTypesMod, only : AREA ! ! !ARGUMENTS type(ed_site_type), intent(inout), target :: currentSite @@ -637,6 +638,7 @@ subroutine seeds_in( cp_pnt ) ! Flux from plants into seed pool. ! ! !USES: + use EDTypesMod, only : AREA ! ! !ARGUMENTS type(ed_patch_type), intent(inout), target :: cp_pnt ! seeds go to these patches. @@ -652,7 +654,6 @@ subroutine seeds_in( cp_pnt ) currentSite => currentPatch%siteptr currentPatch%seeds_in(:) = 0.0_r8 - currentPatch%seed_rain_flux(:) = 0.0_r8 currentCohort => currentPatch%tallest do while (associated(currentCohort)) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 42d14905..68e0f7c4 100755 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -141,7 +141,7 @@ subroutine ed_integrate_state_variables(currentSite, temperature_inst ) ! !USES: ! ! !ARGUMENTS: - type(ed_site_type) , intent(in) :: currentSite + type(ed_site_type) , intent(inout) :: currentSite type(temperature_type) , intent(in) :: temperature_inst ! ! !LOCAL VARIABLES: @@ -157,6 +157,7 @@ subroutine ed_integrate_state_variables(currentSite, temperature_inst ) small_no = 0.0000000000_r8 ! Obviously, this is arbitrary. RF - changed to zero currentSite%dseed_dt(p) = 0._r8 ! zero the dseed_dt at the site level before looping through patches and adding the fluxes from each patch + currentSite%seed_rain_flux = 0._r8 currentPatch => currentSite%youngest_patch From be9d73f6dd49c76a0a6efebb79ab6d2982b1edd3 Mon Sep 17 00:00:00 2001 From: ckoven Date: Wed, 31 Aug 2016 15:15:53 -0700 Subject: [PATCH 183/437] runtime bugfix --- main/EDMainMod.F90 | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 68e0f7c4..02662b50 100755 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -156,7 +156,9 @@ subroutine ed_integrate_state_variables(currentSite, temperature_inst ) small_no = 0.0000000000_r8 ! Obviously, this is arbitrary. RF - changed to zero - currentSite%dseed_dt(p) = 0._r8 ! zero the dseed_dt at the site level before looping through patches and adding the fluxes from each patch + do p = 1,numpft_ed + currentSite%dseed_dt(p) = 0._r8 ! zero the dseed_dt at the site level before looping through patches and adding the fluxes from each patch + end do currentSite%seed_rain_flux = 0._r8 currentPatch => currentSite%youngest_patch From 420c52a3f49f4d8eb6d055c1f0685ca0b24ef90f Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 31 Aug 2016 17:53:17 -0700 Subject: [PATCH 184/437] bgc summary and bgc carbon balance check have been converted to the site system. First pass, no cleaning or compilations have been attempted yet. --- main/EDCLMLinkMod.F90 | 420 ++++++++++++++----------------------- main/EDTypesMod.F90 | 40 +++- main/FatesInterfaceMod.F90 | 12 +- main/HistoryIOMod.F90 | 137 +++++++++++- 4 files changed, 328 insertions(+), 281 deletions(-) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 177eb948..7c9e4d33 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -62,33 +62,33 @@ module EDCLMLinkMod ! real(r8), pointer, private :: growth_resp_patch (:) ! (gC/m2/s) patch growth respiration ! summary carbon fluxes at the column level - real(r8), pointer, private :: nep_col(:) ! [gC/m2/s] Net ecosystem production, i.e. fast-timescale carbon balance that does not include disturbance - real(r8), pointer, private :: nep_timeintegrated_col(:) ! [gC/m2/s] Net ecosystem production, i.e. fast-timescale carbon balance that does not include disturbance - real(r8), pointer, private :: npp_timeintegrated_col(:) ! [gC/m2/s] Net primary production, time integrated at column level for carbon balance checking - real(r8), pointer, private :: hr_timeintegrated_col(:) ! [gC/m2/s] heterotrophic respiration, time integrated for carbon balance checking - real(r8), pointer, private :: nbp_col(:) ! [gC/m2/s] Net biosphere production, i.e. slow-timescale carbon balance that integrates to total carbon change - real(r8), pointer, private :: npp_col(:) ! [gC/m2/s] Net primary production at the fast timescale, aggregated to the column level - real(r8), pointer, private :: fire_c_to_atm_col(:) ! [gC/m2/s] total fire carbon loss to atmosphere - real(r8), pointer, private :: ed_to_bgc_this_edts_col(:) ! [gC/m2/s] total flux of carbon from ED to BGC models on current ED timestep - real(r8), pointer, private :: ed_to_bgc_last_edts_col(:) ! [gC/m2/s] total flux of carbon from ED to BGC models on prior ED timestep - real(r8), pointer, private :: seed_rain_flux_col(:) ! [gC/m2/s] total flux of carbon from seed rain +! real(r8), pointer, private :: nep_col(:) ! [gC/m2/s] Net ecosystem production, i.e. fast-timescale carbon balance that does not include disturbance +! real(r8), pointer, private :: nep_timeintegrated_col(:) ! [gC/m2/s] Net ecosystem production, i.e. fast-timescale carbon balance that does not include disturbance +! real(r8), pointer, private :: npp_timeintegrated_col(:) ! [gC/m2/s] Net primary production, time integrated at column level for carbon balance checking +! real(r8), pointer, private :: hr_timeintegrated_col(:) ! [gC/m2/s] heterotrophic respiration, time integrated for carbon balance checking +! real(r8), pointer, private :: nbp_col(:) ! [gC/m2/s] Net biosphere production, i.e. slow-timescale carbon balance that integrates to total carbon change +! real(r8), pointer, private :: npp_col(:) ! [gC/m2/s] Net primary production at the fast timescale, aggregated to the column level +! real(r8), pointer, private :: fire_c_to_atm_col(:) ! [gC/m2/s] total fire carbon loss to atmosphere +! real(r8), pointer, private :: ed_to_bgc_this_edts_col(:) ! [gC/m2/s] total flux of carbon from ED to BGC models on current ED timestep +! real(r8), pointer, private :: ed_to_bgc_last_edts_col(:) ! [gC/m2/s] total flux of carbon from ED to BGC models on prior ED timestep +! real(r8), pointer, private :: seed_rain_flux_col(:) ! [gC/m2/s] total flux of carbon from seed rain ! summary carbon states at the column level - real(r8), pointer, private :: totecosysc_col(:) ! [gC/m2] Total ecosystem carbon at the column level, including vegetation, CWD, litter, and soil pools - real(r8), pointer, private :: totecosysc_old_col(:) ! [gC/m2] Total ecosystem C at the column level from last call to balance check - real(r8), pointer, private :: totedc_col(:) ! [gC/m2] Total ED carbon at the column level, including vegetation, CWD, seeds, and ED litter - real(r8), pointer, private :: totedc_old_col(:) ! [gC/m2] Total ED C at the column level from last call to balance check - real(r8), pointer, private :: totbgcc_col(:) ! [gC/m2] Total BGC carbon at the column level, including litter, and soil pools - real(r8), pointer, private :: totbgcc_old_col(:) ! [gC/m2] Total BGC C at the column level from last call to balance check - real(r8), pointer, private :: biomass_stock_col(:) ! [gC/m2] total biomass at the column level in gC / m2 - real(r8), pointer, private :: ed_litter_stock_col(:) ! [gC/m2] ED litter at the column level in gC / m2 - real(r8), pointer, private :: cwd_stock_col(:) ! [gC/m2] ED CWD at the column level in gC / m2 - real(r8), pointer, private :: seed_stock_col(:) ! [gC/m2] ED seed mass carbon at the column level in gC / m2 +! real(r8), pointer, private :: totecosysc_col(:) ! [gC/m2] Total ecosystem carbon at the column level, including vegetation, CWD, litter, and soil pools +! real(r8), pointer, private :: totecosysc_old_col(:) ! [gC/m2] Total ecosystem C at the column level from last call to balance check +! real(r8), pointer, private :: totedc_col(:) ! [gC/m2] Total ED carbon at the column level, including vegetation, CWD, seeds, and ED litter +! real(r8), pointer, private :: totedc_old_col(:) ! [gC/m2] Total ED C at the column level from last call to balance check +! real(r8), pointer, private :: totbgcc_col(:) ! [gC/m2] Total BGC carbon at the column level, including litter, and soil pools +! real(r8), pointer, private :: totbgcc_old_col(:) ! [gC/m2] Total BGC C at the column level from last call to balance check +! real(r8), pointer, private :: biomass_stock_col(:) ! [gC/m2] total biomass at the column level in gC / m2 +! real(r8), pointer, private :: ed_litter_stock_col(:) ! [gC/m2] ED litter at the column level in gC / m2 +! real(r8), pointer, private :: cwd_stock_col(:) ! [gC/m2] ED CWD at the column level in gC / m2 +! real(r8), pointer, private :: seed_stock_col(:) ! [gC/m2] ED seed mass carbon at the column level in gC / m2 ! carbon balance errors. at some point we'll reduce these to close to zero and delete, but for now we'll just keep[ track of them - real(r8), pointer, private :: cbalance_error_ed_col(:) ! [gC/m2/s] total carbon balance error for the ED side - real(r8), pointer, private :: cbalance_error_bgc_col(:) ! [gC/m2/s] total carbon balance error for the BGC side - real(r8), pointer, private :: cbalance_error_total_col(:) ! [gC/m2/s] total carbon balance error for the whole thing +! real(r8), pointer, private :: cbalance_error_ed_col(:) ! [gC/m2/s] total carbon balance error for the ED side +! real(r8), pointer, private :: cbalance_error_bgc_col(:) ! [gC/m2/s] total carbon balance error for the BGC side +! real(r8), pointer, private :: cbalance_error_total_col(:) ! [gC/m2/s] total carbon balance error for the whole thing ! ED patch/cohort data real(r8), pointer, private :: ed_npatches_col(:) ! [#] the number of patches per ED site @@ -100,9 +100,9 @@ module EDCLMLinkMod procedure , public :: Init procedure , public :: Restart procedure , public :: ed_clm_link - procedure , public :: SummarizeNetFluxes +! procedure , public :: SummarizeNetFluxes ! procedure , public :: SummarizeProductivityFluxes - procedure , public :: ED_BGC_Carbon_Balancecheck +! procedure , public :: ED_BGC_Carbon_Balancecheck ! Private routines procedure , private :: ed_clm_leaf_area_profile @@ -1149,9 +1149,7 @@ end subroutine ed_clm_leaf_area_profile !------------------------------------------------------------------------ - subroutine SummarizeNetFluxes(this, bounds, num_soilc, filter_soilc, & - sites, nsites, fcolumn, soilbiogeochem_carbonflux_inst, & - soilbiogeochem_carbonstate_inst) + subroutine SummarizeNetFluxes( sites, nsites, bc_in, is_beg_day ) ! Summarize the combined production and decomposition fluxes into net fluxes ! This is done on the fast timestep, and to be called after both daily ED calls and fast BGC calls @@ -1160,90 +1158,46 @@ subroutine SummarizeNetFluxes(this, bounds, num_soilc, filter_soilc, & ! Written by Charlie Koven, Feb 2016 ! ! !USES: - use LandunitType , only : lun - use landunit_varcon , only : istsoil + use FatesInterfaceMod , only : bc_in_type ! implicit none ! ! !ARGUMENTS - class(ed_clm_type) :: this - type(bounds_type) , intent(in) :: bounds - integer , intent(in) :: num_soilc ! number of soil columns in filter - integer , intent(in) :: filter_soilc(:) ! filter for soil columns type(ed_site_type) , intent(in), target :: sites(nsites) integer , intent(in) :: nsites - integer , intent(in) :: fcolumn(nsites) - type(soilbiogeochem_carbonflux_type) , intent(inout) :: soilbiogeochem_carbonflux_inst - type(soilbiogeochem_carbonstate_type) , intent(inout) :: soilbiogeochem_carbonstate_inst + type(bc_in_type) , intent(in) :: bc_in + logical , intent(in) :: is_beg_day + ! ! !LOCAL VARIABLES: - real(r8) :: dt ! radiation time step (seconds) - integer :: c, s, cc, fc, l, p, pp - type(ed_site_type), pointer :: cs + integer :: s + type (ed_patch_type) , pointer :: currentPatch type (ed_cohort_type) , pointer :: currentCohort -! integer :: firstsoilpatch(bounds%begg:bounds%endg) ! the first patch in this gridcell that is soil and thus bare... real(r8) :: n_perm2 ! individuals per m2 of the whole column - - associate(& - hr => soilbiogeochem_carbonflux_inst%hr_col, & ! (gC/m2/s) total heterotrophic respiration - totsomc => soilbiogeochem_carbonstate_inst%totsomc_col, & ! (gC/m2) total soil organic matter carbon - totlitc => soilbiogeochem_carbonstate_inst%totlitc_col, & ! (gC/m2) total litter carbon in BGC pools - npp_col => this%npp_col, & - nep => this%nep_col, & - fire_c_to_atm => this%fire_c_to_atm_col, & - nbp => this%nbp_col, & - totecosysc => this%totecosysc_col, & - totedc => this%totedc_col, & - totbgcc => this%totbgcc_col, & - biomass_stock => this%biomass_stock_col, & ! total biomass in gC / m2 - ed_litter_stock => this%ed_litter_stock_col, & ! ED litter in gC / m2 - cwd_stock => this%cwd_stock_col, & ! total CWD in gC / m2 - seed_stock => this%seed_stock_col, & ! total seed mass in gC / m2 - ed_to_bgc_this_edts => this%ed_to_bgc_this_edts_col, & - ed_to_bgc_last_edts => this%ed_to_bgc_last_edts_col, & - seed_rain_flux => this%seed_rain_flux_col & - ) - - ! set time steps - dt = real( get_step_size(), r8 ) - - ! zero variables first - ! column variables - do c = bounds%begc,bounds%endc - ! summary flux variables - fire_c_to_atm(c) = 0._r8 - - ! summary stock variables - ed_litter_stock(c) = 0._r8 - cwd_stock(c) = 0._r8 - seed_stock(c) = 0._r8 - biomass_stock(c) = 0._r8 - npp_col(c) = 0.0_r8 - end do - do s = 1, nsites + do s = 1,nsites - c = fcolumn(s) - p = col%patchi(c) - - ! Temporary - npp_col(c) = sites(s)%npp + sites(s)%fire_c_to_atm = 0._r8 ! REMOVE THIS VARIABLE? + sites(s)%ed_litter_stock = 0._r8 + sites(s)%cwd_stock = 0._r8 + sites(s)%seed_stock = 0._r8 + sites(s)%biomass_stock = 0._r8 ! map ed site-level fire fluxes to clm column fluxes - fire_c_to_atm(c) = sites(s)%total_burn_flux_to_atm / ( AREA * SHR_CONST_CDAY * 1.e3_r8) - + sites(s)%fire_c_to_atm = sites(s)%total_burn_flux_to_atm / ( AREA * SHR_CONST_CDAY * 1.e3_r8) + currentPatch => sites(s)%oldest_patch do while(associated(currentPatch)) - p = p + 1 - ! map litter, CWD, and seed pools to column level - cwd_stock(c) = cwd_stock(c) + (currentPatch%area / AREA) * (sum(currentPatch%cwd_ag)+ & - sum(currentPatch%cwd_bg)) * 1.e3_r8 - ed_litter_stock(c) = ed_litter_stock(c) + (currentPatch%area / AREA) * & + sites(s)%cwd_stock = sites(s)%cwd_stock + (currentPatch%area / AREA) * & + (sum(currentPatch%cwd_ag) + sum(currentPatch%cwd_bg)) * 1.e3_r8 + + sites(s)%ed_litter_stock = sites(s)%ed_litter_stock + (currentPatch%area / AREA) * & (sum(currentPatch%leaf_litter)+sum(currentPatch%root_litter)) * 1.e3_r8 - seed_stock(c) = seed_stock(c) + (currentPatch%area / AREA) * sum(currentPatch%seed_bank) * 1.e3_r8 + + sites(s)%seed_stock = sites(s)%seed_stock + (currentPatch%area / AREA) * sum(currentPatch%seed_bank) * 1.e3_r8 currentCohort => currentPatch%tallest do while(associated(currentCohort)) @@ -1251,85 +1205,61 @@ subroutine SummarizeNetFluxes(this, bounds, num_soilc, filter_soilc, & n_perm2 = currentCohort%n/AREA ! map biomass pools to column level - biomass_stock(c) = biomass_stock(c) + (currentCohort%bdead + currentCohort%balive + & - currentCohort%bstore) * n_perm2 * 1.e3_r8 - - ! if ( .not. currentCohort%isnew ) then - ! - ! The following implementation to calculation n_perm2 is necessary for b4b reproducibility - ! while restructuring a large amount of code. This should be re-visited and we should be - ! more consistent in how n_perm2 is calculated for different cases - ! if ((currentPatch%area .gt. 0._r8) .and. (currentPatch%total_canopy_area .gt. 0._r8)) then - ! n_perm2 = currentCohort%n/AREA - ! else - ! n_perm2 = 0.0_r8 - ! endif - - ! npp_col(c) = npp_col(c) + currentCohort%npp_tstep * n_perm2 * 1.e3_r8 /dt - ! end if + sites(s)%biomass_stock = sites(s)%biomass_stock + (currentCohort%bdead + currentCohort%balive + & + currentCohort%bstore) * n_perm2 * 1.e3_r8 currentCohort => currentCohort%shorter enddo !currentCohort currentPatch => currentPatch%younger end do ! patch loop - end do ! site loop - - ! calculate NEP and NBP fluxes. ????? - do fc = 1,num_soilc - c = filter_soilc(fc) - nep(c) = npp_col(c) - hr(c) - nbp(c) = npp_col(c) - ( hr(c) + fire_c_to_atm(c) ) - end do - - ! calculate total stocks - do fc = 1,num_soilc - c = filter_soilc(fc) - totedc(c) = ed_litter_stock(c) + cwd_stock(c) + seed_stock(c) + biomass_stock(c) ! ED stocks - totbgcc(c) = totsomc(c) + totlitc(c) ! BGC stocks - totecosysc(c) = totedc(c) + totbgcc(c) + ! calculate NEP and NBP fluxes + sites(s)%nep = sites(s)%npp - bc_in(s)%tot_het_resp + sites(s)%nbp = sites(s)%npp - ( bc_in(s)%tot_het_resp + sites(s)%fire_c_to_atm ) - end do + ! FATES stocks + sites(s)%totfatesc = sites(s)%ed_litter_stock + sites(s)%cwd_stock + sites(s)%seed_stock + sites(s)%biomass_stock + + ! BGC stocks (used for error checking, totlitc should be zero?) + sites(s)%totbgcc = bc_in(s)%tot_somc + bc_in(s)%tot_litc - ! in ED timesteps, because of offset between when ED and BGC reconcile the gain and loss of litterfall carbon, - ! (i.e. ED reconciles it instantly, while BGC reconciles it incrementally over the subsequent day) + ! Total Ecosystem Carbon Stocks + sites(s)%totecosysc = sites(s)%totfatesc + sites(s)%totbgcc + + end do + + ! in FATES timesteps, because of offset between when ED and BGC reconcile the gain and loss of litterfall carbon, + ! (i.e. FATES reconciles it instantly, while BGC reconciles it incrementally over the subsequent day) ! calculate the total ED -> BGC flux and keep track of the last day's info for balance checking purposes - if ( is_beg_curr_day() ) then - ! - do s = 1,nsites - c = fcolumn(s) - ed_to_bgc_last_edts(c) = ed_to_bgc_this_edts(c) - end do - ! - do s = 1,nsites - c = fcolumn(s) - ed_to_bgc_this_edts(c) = 0._r8 - seed_rain_flux(c) = 0._r8 - end do + if ( is_beg_day ) then ! do s = 1,nsites - c = fcolumn(s) + ! order of operations in the next to lines is quite important ;) + sites(s)%fates_to_bgc_last_ts = sites(s)%fates_to_bgc_this_ts + sites(s)%fates_to_bgc_this_ts = 0._r8 + sites(s)%seed_rain_flux = 0._r8 currentPatch => sites(s)%oldest_patch do while(associated(currentPatch)) ! - ed_to_bgc_this_edts(c) = ed_to_bgc_this_edts(c) + (sum(currentPatch%CWD_AG_out) + sum(currentPatch%CWD_BG_out) & - + sum(currentPatch%seed_decay) + sum(currentPatch%leaf_litter_out) + sum(currentPatch%root_litter_out)) & - * ( currentPatch%area/AREA ) * 1.e3_r8 / ( 365.0_r8*SHR_CONST_CDAY ) + sites(s)%fates_to_bgc_this_ts = sites(s)%fates_to_bgc_this_ts + (sum(currentPatch%CWD_AG_out) + sum(currentPatch%CWD_BG_out) & + + sum(currentPatch%seed_decay) + sum(currentPatch%leaf_litter_out) + sum(currentPatch%root_litter_out)) & + * ( currentPatch%area/AREA ) * 1.e3_r8 / ( 365.0_r8*SHR_CONST_CDAY ) ! - seed_rain_flux(c) = seed_rain_flux(c) + sum(currentPatch%seed_rain_flux) * 1.e3_r8 / ( 365.0_r8*SHR_CONST_CDAY ) + sites(s)%seed_rain_flux = sites(s)%seed_rain_flux + sum(currentPatch%seed_rain_flux) * 1.e3_r8 / ( 365.0_r8*SHR_CONST_CDAY ) ! currentPatch => currentPatch%younger end do !currentPatch end do endif + end associate end subroutine SummarizeNetFluxes - subroutine ED_BGC_Carbon_Balancecheck(this, bounds, num_soilc, filter_soilc, soilbiogeochem_carbonflux_inst) + subroutine ED_BGC_Carbon_Balancecheck(sites, nsites, bc_in, is_beg_day, dtime, nstep) ! Integrate in time the fluxes into and out of the ecosystem, and compare these on a daily timestep ! to the chagne in carbon stocks of the ecosystem @@ -1341,135 +1271,91 @@ subroutine ED_BGC_Carbon_Balancecheck(this, bounds, num_soilc, filter_soilc, soi implicit none ! ! !ARGUMENTS - class(ed_clm_type) :: this - type(bounds_type) , intent(in) :: bounds - integer , intent(in) :: num_soilc ! number of soil columns in filter - integer , intent(in) :: filter_soilc(:) ! filter for soil columns - type(soilbiogeochem_carbonflux_type) , intent(inout) :: soilbiogeochem_carbonflux_inst - ! + type(ed_site_type) , intent(in), target :: sites(nsites) + integer , intent(in) :: nsites + type(bc_in_type) , intent(in) :: bc_in + logical , intent(in) :: is_beg_day + real(r8) , intent(in) :: dtime ! time-step length (s) + integer , intent(in) :: nstep ! time-step index + ! !LOCAL VARIABLES: - real(r8) :: dtime ! land model time step (sec) - integer :: nstep ! model timestep - real(r8) :: nbp_integrated(bounds%begc:bounds%endc) ! total net biome production integrated - real(r8) :: error_total(bounds%begc:bounds%endc) - real(r8) :: error_ed(bounds%begc:bounds%endc) - real(r8) :: error_bgc(bounds%begc:bounds%endc) real(r8) :: error_tolerance = 1.e-6_r8 - real(r8) :: max_error_ed - real(r8) :: max_error_bgc - real(r8) :: max_error_total - integer :: fc,c - - associate(& - nep => this%nep_col, & - nep_timeintegrated => this%nep_timeintegrated_col, & - hr => soilbiogeochem_carbonflux_inst%hr_col, & - hr_timeintegrated => this%hr_timeintegrated_col, & - npp_col => this%npp_col, & - npp_timeintegrated => this%npp_timeintegrated_col, & - fire_c_to_atm => this%fire_c_to_atm_col, & - totecosysc_old => this%totecosysc_old_col, & - totecosysc => this%totecosysc_col, & - totedc_old => this%totedc_old_col, & - totedc => this%totedc_col, & - totbgcc_old => this%totbgcc_old_col, & - totbgcc => this%totbgcc_col, & - ed_to_bgc_this_edts => this%ed_to_bgc_this_edts_col, & - ed_to_bgc_last_edts => this%ed_to_bgc_last_edts_col, & - seed_rain_flux => this%seed_rain_flux_col, & - cbalance_error_ed => this%cbalance_error_ed_col, & - cbalance_error_bgc => this%cbalance_error_bgc_col, & - cbalance_error_total=> this%cbalance_error_total_col & - ) - - dtime = get_step_size() - nstep = get_nstep() - - if (nstep .le. 1) then - ! when starting up the model, initialize the integrator variables - do fc = 1,num_soilc - c = filter_soilc(fc) - totecosysc_old(c) = totecosysc(c) - totedc_old(c) = totedc(c) - totbgcc_old(c) = totbgcc(c) - nep_timeintegrated(c) = 0._r8 - hr_timeintegrated(c) = 0._r8 - npp_timeintegrated(c) = 0._r8 - ! - ! also initialize the ed-BGC flux variables - ed_to_bgc_this_edts(c) = 0._r8 - ed_to_bgc_last_edts(c) = 0._r8 - ! - cbalance_error_ed(c) = 0._r8 - cbalance_error_bgc(c) = 0._r8 - cbalance_error_total(c) = 0._r8 - end do - endif + integer :: s - if ( .not. is_beg_curr_day() ) then - ! on CLM (half-hourly) timesteps, integrate the NEP fluxes - do fc = 1,num_soilc - c = filter_soilc(fc) - nep_timeintegrated(c) = nep_timeintegrated(c) + nep(c) * dtime - hr_timeintegrated(c) = hr_timeintegrated(c) + hr(c) * dtime - npp_timeintegrated(c) = npp_timeintegrated(c) + npp_col(c) * dtime - end do - else - ! on ED (daily) timesteps, first integrate the NEP fluxes and add in the daily disturbance flux - do fc = 1,num_soilc - c = filter_soilc(fc) - nep_timeintegrated(c) = nep_timeintegrated(c) + nep(c) * dtime - hr_timeintegrated(c) = hr_timeintegrated(c) + hr(c) * dtime - npp_timeintegrated(c) = npp_timeintegrated(c) + npp_col(c) * dtime - nbp_integrated(c) = nep_timeintegrated(c) - fire_c_to_atm(c) * SHR_CONST_CDAY + seed_rain_flux(c)* SHR_CONST_CDAY - end do + if (nstep .le. 1) then + ! when starting up the model, initialize the integrator variables + do s = 1,nsites + sites(s)%totecosysc_old = sites(s)%totecosysc + sites(s)%totfatesc_old = sites(s)%totfatesc + sites(s)%totbgcc_old = sites(s)%totbgcc + sites(s)%nep_timeintegrated = 0._r8 + sites(s)%hr_timeintegrated = 0._r8 + sites(s)%npp_timeintegrated = 0._r8 + ! + ! also initialize the ed-BGC flux variables + sites(s)%fates_to_bgc_this_ts = 0._r8 + sites(s)%fates_to_bgc_last_ts = 0._r8 + ! + sites(s)%cbal_err_fates = 0._r8 + sites(s)%cbal_err_bgc = 0._r8 + sites(s)%cbal_err_tot = 0._r8 + end do + endif + + do s = 1,nsites + sites(s)%nep_timeintegrated = sites(s)%nep_timeintegrated + sites(s)%nep * dtime + sites(s)%hr_timeintegrated = sites(s)%hr_timeintegrated + bc_in(s)%tot_het_resp * dtime + sites(s)%npp_timeintegrated = sites(s)%npp_timeintegrated + sites(s)%npp * dtime + end do + + ! If this is on the dynamics time-step, then we calculate the balance checks - ! next compare the change in carbon and calculate the error - do fc = 1,num_soilc - c = filter_soilc(fc) - error_ed(c) = totedc(c) - totedc_old(c) - (npp_timeintegrated(c) + seed_rain_flux(c)* SHR_CONST_CDAY - ed_to_bgc_this_edts(c)* SHR_CONST_CDAY - fire_c_to_atm(c) * SHR_CONST_CDAY) - error_bgc(c) = totbgcc(c) - totbgcc_old(c) - (ed_to_bgc_last_edts(c)* SHR_CONST_CDAY - hr_timeintegrated(c)) - error_total(c) = totecosysc(c) - totecosysc_old(c) - (nbp_integrated(c) + ed_to_bgc_last_edts(c)* SHR_CONST_CDAY - ed_to_bgc_this_edts(c)* SHR_CONST_CDAY) - end do - ! - ! put in consistent flux units and send to history so we can keep track of the errors - do fc = 1,num_soilc - c = filter_soilc(fc) - cbalance_error_ed(c) = error_ed(c) / SHR_CONST_CDAY - cbalance_error_bgc(c) = error_bgc(c) / SHR_CONST_CDAY - cbalance_error_total(c) = error_total(c) / SHR_CONST_CDAY - end do - - ! for now, rather than crashing the model, lets just report the largest error to see what we're up against - ! - ! RETURN TO THIS LATER AND ADD A CRASHER IF BALANCE EXCEEDS THRESHOLD - ! - ! max_error_total = 0._r8 - ! do fc = 1,num_soilc - ! c = filter_soilc(fc) - ! if (abs(error_total(c)) .gt. max_error_total) then - ! max_error_ed = abs(error_ed(c)) - ! max_error_bgc = abs(error_bgc(c)) - ! max_error_total = abs(error_total(c)) - ! endif - ! end do - ! write(iulog,*) 'ED_BGC_Carbon_Balancecheck: max_error_ed, max_error_bgc, max_error_total (gC / m2 / day): ', max_error_ed, max_error_bgc, max_error_total - - ! reset the C stock and flux integrators - do fc = 1,num_soilc - c = filter_soilc(fc) - totecosysc_old(c) = totecosysc(c) - totedc_old(c) = totedc(c) - totbgcc_old(c) = totbgcc(c) - nep_timeintegrated(c) = 0._r8 - npp_timeintegrated(c) = 0._r8 - hr_timeintegrated(c) = 0._r8 - end do + if ( is_beg_day ) then - endif + do s = 1,nsites + + ! NBP can only be updated when dynamics level information is available + sites(s)%nbp_integrated = sites(s)%nep_timeintegrated - & + sites(s)%fire_c_to_atm * SHR_CONST_CDAY + & + sites(s)%seed_rain_flux * SHR_CONST_CDAY + + + sites(s)%cbal_err_fates = sites(s)%totfatesc(c) - & + sites(s)%totfatesc_old(c) - & + (sites(s)%npp_timeintegrated + & + sites(s)%seed_rain_flux*SHR_CONST_CDAY - & + sites(s)%fates_to_bgc_this_ts*SHR_CONST_CDAY - & + this(s)%fire_c_to_atm*SHR_CONST_CDAY) + sites(s)%cbal_err_fates = sites(s)%cbal_err_fates / SHR_CONST_CDAY + + + sites(s)%cbal_err_bgc = this(s)%totbgcc - & + this(s)%totbgcc_old - & + (this(s)%fates_to_bgc_last_ts*SHR_CONST_CDAY - & + this(s)%hr_timeintegrated) + sites(s)%cbal_err_bgc = sites(s)%cbal_err_bgc / SHR_CONST_CDAY + + sites(s)%cbal_err_tot = sites(s)%totecosysc - & + sites(s)%totecosysc_old - & + (sites(s)%nbp_integrated + & + sites(s)%fates_to_bgc_last_ts*SHR_CONST_CDAY - & + sites(s)%fates_to_bgc_this_ts*SHR_CONST_CDAY) + sites(s)%cbal_err_tot = sites(s)%cbal_err_tot / SHR_CONST_CDAY + + ! Send the current to the previous/last + sites(s)%totecosysc_old = sites(s)%totecosysc + sites(s)%totfatesc_old = sites(s)%totfatesc + sites(s)%totbgcc_old = sites(s)%totbgcc + sites(s)%nep_timeintegrated = 0._r8 + sites(s)%npp_timeintegrated = 0._r8 + sites(s)%hr_timeintegrated = 0._r8 + + end do + + endif - end associate + end associate - end subroutine ED_BGC_Carbon_Balancecheck +end subroutine ED_BGC_Carbon_Balancecheck end module EDCLMLinkMod diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 4398c264..2525d383 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -442,10 +442,42 @@ module EDTypesMod real(r8) :: lon ! longitude: degrees ! 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 - real(r8) :: npp ! used for calculating NEP and NBP during BGC summarization phase + 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 + real(r8) :: npp ! used for calculating NEP and NBP during BGC summarization phase + real(r8) :: nep ! Net ecosystem production, i.e. fast-timescale carbon balance that + ! does not include disturbance [gC/m2/s] + real(r8) :: nbp ! Net biosphere production, i.e. slow-timescale carbon balance that + ! integrates to total carbon change [gC/m2/s] + real(r8) :: seed_rain_flux ! [gC/m2/s] total flux of carbon from seed rain + real(r8) :: fire_c_to_atm ! total fire carbon loss to atmosphere [gC/m2/s] + real(r8) :: ed_litter_stock ! litter in [gC/m2] + real(r8) :: cwd_stock ! coarse woody debris [gC/m2] + real(r8) :: seed_stock ! seed mass [gc/m2] + real(r8) :: biomass_stock ! total biomass at the column level in [gC / m2] + real(r8) :: totfatesc ! Total FATES carbon at the site, including vegetation, CWD, seeds, + ! and FATES portion of litter [gC/m2] + real(r8) :: totbgcc ! Total BGC carbon at the site, including litter, and soil pools [gC/m2] + real(r8) :: totecosysc ! Total ecosystem C at the site, including vegetation, + ! CWD, litter (from HLM and FATES), and soil pools [gC/m2] + + real(r8) :: totfatesc_old ! Total FATES C at the site from last call to balance check [gC/m2] + real(r8) :: totbgcc_old ! Total BGC C at the site from last call to balance check [gC/m2] + real(r8) :: totecosysc_old ! Total ecosystem C at the site from last call to balance check [gC/m2] + + real(r8) :: fates_to_bgc_this_ts ! total flux of carbon from FATES to BGC models on current timestep [gC/m2/s] + real(r8) :: fates_to_bgc_last_ts ! total flux of carbon from FATES to BGC models on previous timestep [gC/m2/s] + + real(r8) :: cbal_err_fates ! [gC/m2/s] total carbon balance error for FATES processes + real(r8) :: cbal_err_bgc ! [gC/m2/s] total carbon balance error for BGC (HLM) processes + real(r8) :: cbal_err_tot ! [gC/m2/s] total carbon balance error for all land processes + + real(r8) :: nep_timeintegrated ! Net ecosystem production accumulated over model time-steps [gC/m2] + real(r8) :: hr_timeintegrated ! Heterotrophic respiration accumulated over model time-steps [gC/m2] + real(r8) :: npp_timeintegrated ! Net primary production accumulated over model time-steps [gC/m2] + real(r8) :: nbp_integrated ! Net biosphere production accumulated over model time-steps [gC/m2] + ! DISTURBANCE real(r8) :: disturbance_mortality ! site level disturbance rates from mortality. diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 0c3333d4..e82c822e 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -141,6 +141,11 @@ module FatesInterfaceMod ! due to permafrost or bedrock constraints integer :: max_rooting_depth_index_col + ! BGC Accounting + + real(r8) :: tot_het_resp ! total heterotrophic respiration (gC/m2/s) + real(r8) :: tot_somc ! total soil organic matter carbon (gc/m2) + real(r8) :: tot_litc ! total litter carbon tracked in the HLM (gc/m2) end type bc_in_type @@ -324,6 +329,9 @@ subroutine allocate_bcin(bc_in) allocate(bc_in%albgr_dir_rb(cp_numSWb)) allocate(bc_in%albgr_dif_rb(cp_numSWb)) + + + return end subroutine allocate_bcin @@ -393,7 +401,9 @@ subroutine zero_bcs(this,s) this%bc_in(s)%albgr_dir_rb(:) = 0.0_r8 this%bc_in(s)%albgr_dif_rb(:) = 0.0_r8 this%bc_in(s)%max_rooting_depth_index_col = 0 - + this%bc_in(s)%tot_het_resp = 0.0_r8 + this%bc_in(s)%tot_somc = 0.0_r8 + this%bc_in(s)%tot_litc = 0.0_r8 ! Output boundaries this%bc_out(s)%active_suction_gl(:) = .false. diff --git a/main/HistoryIOMod.F90 b/main/HistoryIOMod.F90 index c0ef7c0f..15ffaee1 100644 --- a/main/HistoryIOMod.F90 +++ b/main/HistoryIOMod.F90 @@ -65,6 +65,7 @@ Module HistoryIOMod ! Indices to (site) variables + integer, private :: ih_nep_si integer, private :: ih_nep_timeintegrated_si integer, private :: ih_npp_timeintegrated_si @@ -82,12 +83,12 @@ Module HistoryIOMod integer, private :: ih_totbgcc_si integer, private :: ih_totbgcc_old_si integer, private :: ih_biomass_stock_si - integer, private :: ih_ed_litter_stock_si + integer, private :: ih_litter_stock_si integer, private :: ih_cwd_stock_si integer, private :: ih_seed_stock_si - integer, private :: ih_cbalance_error_ed_si - integer, private :: ih_cbalance_error_bgc_si - integer, private :: ih_cbalance_error_total_si + integer, private :: ih_cbal_err_fates_si + integer, private :: ih_cbal_err_bgc_si + integer, private :: ih_cbal_err_total_si integer, private :: ih_npatches_si integer, private :: ih_ncohorts_si @@ -237,11 +238,72 @@ Module HistoryIOMod contains + + ! =================================================================================== - + subroutine update_history_cbal(this,nc,sites,nsites) + !ptr_col=this%seed_stock_col) + !ptr_col=this%cwd_stock_col) + !ptr_col=this%ed_litter_stock_col) + !ptr_col=this%biomass_stock_col) + !ptr_col=this%cbalance_error_total_col) + !ptr_col=this%cbalance_error_bgc_col) + !ptr_col=this%cbalance_error_ed_col) + ! ptr_col=this%totecosysc_col) + ! ptr_col=this%nbp_col) + ! ptr_col=this%fire_c_to_atm_col) + ! ptr_col=this%nep_col) + + ! Locals + integer :: s ! The local site index + integer :: io_si ! The site index of the IO array + + + associate( hio_nep_si => this%hvars(ih_nep_si)%r81d, & + hio_nbp_si => this%hvars(ih_nbp_si)%r81d, & + hio_fire_c_to_atm_si => this%hvars(ih_fire_c_to_atm_si)%r81d, & + hio_totecosysc_si => this%hvars(ih_totecosysc_si)%r81d, & + hio_cbal_err_fates_si => this%hvars(ih_cbal_err_fates_si)%r81d, & + hio_cbal_err_bgc_si => this%hvars(ih_cbal_err_bgc_si)%r81d, & + hio_cbal_err_tot_si => this%hvars(ih_cbal_err_tot_si)%r81d, & + hio_biomass_stock_si => this%hvars(ih_biomass_stock_si)%r81d, & + hio_litter_stock_si => this%hvars(ih_litter_stock_si)%r81d, & + hio_cwd_stock_si => this%hvars(ih_cwd_stock_si)%r81d, & + hio_seed_stock_si => this%hvars(ih_seed_stock_si)%r81d ) + + ! --------------------------------------------------------------------------------- + ! Flush arrays to values defined by %flushval (see registry entry in + ! subroutine define_history_vars() + ! --------------------------------------------------------------------------------- + call this%flush_hvars(nc,upfreq_in=3) + + + do s = 1,nsites + + io_si = this%iovar_map(nc)%site_index(s) + + hio_nep_si(io_si) = sites(s)%nep + hio_nbp_si(io_si) = sites(s)%nbp + hio_fire_c_to_atm_si(io_si) = sites(s)%fire_c_to_atm + hio_totecosysc_si(io_si) = sites(s)%totecosysc + hio_cbal_err_fates_si(io_si) = sites(s)%cbal_err_fates + hio_cbal_err_bgc_si(io_si) = sites(s)%cbal_err_bgc + hio_cbal_err_tot_si(io_si) = sites(s)%cbal_err_tot + hio_biomass_stock_si(io_si) = sites(s)%biomass_stock + hio_litter_stock_si(io_si) = sites(s)%ed_litter_stock + hio_cwd_stock_si(io_si) = sites(s)%cwd_stock + hio_seed_stock_si(io_si) = sites(s)%seed_stock + + end do + + end associate + + end subroutine update_history_cbal + + ! ==================================================================================== - subroutine update_history_dyn(this,nc,sites,nsites,fcolumn) + subroutine update_history_dyn(this,nc,sites,nsites) ! --------------------------------------------------------------------------------- ! This is the call to update the history IO arrays that are expected to only change @@ -261,7 +323,6 @@ subroutine update_history_dyn(this,nc,sites,nsites,fcolumn) integer , intent(in) :: nc ! clump index type(ed_site_type) , intent(inout), target :: sites(nsites) integer , intent(in) :: nsites - integer , intent(in) :: fcolumn(nsites) ! Locals integer :: s ! The local site index @@ -545,7 +606,7 @@ end subroutine update_history_dyn ! ====================================================================================== - subroutine update_history_prod(this,nc,sites,nsites,fcolumn,dt_tstep) + subroutine update_history_prod(this,nc,sites,nsites,dt_tstep) ! --------------------------------------------------------------------------------- ! This is the call to update the history IO arrays that are expected to only change @@ -561,7 +622,6 @@ subroutine update_history_prod(this,nc,sites,nsites,fcolumn,dt_tstep) integer , intent(in) :: nc ! clump index type(ed_site_type) , intent(inout), target :: sites(nsites) integer , intent(in) :: nsites - integer , intent(in) :: fcolumn(nsites) real(r8) , intent(in) :: dt_tstep ! Locals @@ -1039,6 +1099,65 @@ subroutine define_history_vars(this,callstep,nvar) upfreq=1, ivar=ivar,callstep=callstep, index = ih_m5_si_scpf ) + ! CARBON BALANCE VARIABLES THAT DEPEND ON HLM BGC INPUTS + + call this%set_history_var(vname='NEP', units='gC/m^2/s', & + long='net ecosystem production', use_default='active', & + avgflag='A', vtype='SI_R8',hlms='CLM:ALM',flushval=cp_hio_ignore_val, & + upfreq=3, ivar=ivar,callstep=callstep, index = ih_nep_si ) + + + call this%set_history_var(vname='Fire_Closs', units='gC/m^2/s', & + long='ED/SPitfire Carbon loss to atmosphere', use_default='active', & + avgflag='A', vtype='SI_R8',hlms='CLM:ALM',flushval=cp_hio_ignore_val, & + upfreq=3, ivar=ivar,callstep=callstep, index = ih_fire_c_to_atm_si ) + + call this%set_history_var(vname='NBP', units='gC/m^2/s', & + long='net biosphere production', use_default='active', & + avgflag='A', vtype='SI_R8',hlms='CLM:ALM',flushval=cp_hio_ignore_val, & + upfreq=3, ivar=ivar,callstep=callstep, index = ih_nbp_si ) + + call this%set_history_var(vname='TOTECOSYSC', units='gC/m^2', & + long='total ecosystem carbon', use_default='active', & + avgflag='A', vtype='SI_R8',hlms='CLM:ALM',flushval=cp_hio_ignore_val, & + upfreq=3, ivar=ivar,callstep=callstep, index = ih_totecosysc_si ) + + call this%set_history_var(vname='CBALANCE_ERROR_ED', units='gC/m^2/s', & + long='total carbon balance error on ED side', use_default='active', & + avgflag='A', vtype='SI_R8',hlms='CLM:ALM',flushval=cp_hio_ignore_val, & + upfreq=3, ivar=ivar,callstep=callstep, index = ih_cbal_err_fates_si ) + + call this%set_history_var(vname='CBALANCE_ERROR_BGC', units='gC/m^2/s', & + long='total carbon balance error on HLMs BGC side', use_default='active', & + avgflag='A', vtype='SI_R8',hlms='CLM:ALM',flushval=cp_hio_ignore_val, & + upfreq=3, ivar=ivar,callstep=callstep, index = ih_cbal_err_bgc_si ) + + call this%set_history_var(vname='CBALANCE_ERROR_TOTAL', units='gC/m^2/s', & + long='total carbon balance error total', use_default='active', & + avgflag='A', vtype='SI_R8',hlms='CLM:ALM',flushval=cp_hio_ignore_val, & + upfreq=3, ivar=ivar,callstep=callstep, index = ih_cbal_err_tot_si ) + + call this%set_history_var(vname='BIOMASS_STOCK_COL', units='gC/m^2', & + long='total ED biomass carbon at the column level', use_default='active', & + avgflag='A', vtype='SI_R8',hlms='CLM:ALM',flushval=cp_hio_ignore_val, & + upfreq=3, ivar=ivar,callstep=callstep, index = ih_biomass_stock_si ) + + call this%set_history_var(vname='ED_LITTER_STOCK_COL', units='gC/m^2', & + long='total ED litter carbon at the column level', use_default='active', & + avgflag='A', vtype='SI_R8',hlms='CLM:ALM',flushval=cp_hio_ignore_val, & + upfreq=3, ivar=ivar,callstep=callstep, index = ih_litter_stock_si ) + + call this%set_history_var(vname='CWD_STOCK_COL', units='gC/m^2', & + long='total CWD carbon at the column level', use_default='active', & + avgflag='A', vtype='SI_R8',hlms='CLM:ALM',flushval=cp_hio_ignore_val, & + upfreq=3, ivar=ivar,callstep=callstep, index = ih_cwd_stock_si ) + + call this%set_history_var(vname='SEED_STOCK_COL', units='gC/m^2', & + long='total seed carbon at the column level', use_default='active', & + avgflag='A', vtype='SI_R8',hlms='CLM:ALM', flushval=cp_hio_ignore_val, & + upfreq=3, ivar=ivar,callstep=callstep, index = ih_seed_stock_si ) + + ! Must be last thing before return if(present(nvar)) nvar = ivar From c6d553ec54ca3373c823f124f8a3e1f1759cd51e Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 31 Aug 2016 17:58:27 -0700 Subject: [PATCH 185/437] commented out unused code (will delete prior to PR). --- main/EDCLMLinkMod.F90 | 254 +++++++++++++++++++++--------------------- 1 file changed, 127 insertions(+), 127 deletions(-) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 7c9e4d33..4095bba5 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -106,8 +106,8 @@ module EDCLMLinkMod ! Private routines procedure , private :: ed_clm_leaf_area_profile - procedure , private :: InitAllocate - procedure , private :: InitHistory +! procedure , private :: InitAllocate +! procedure , private :: InitHistory end type ed_clm_type @@ -127,148 +127,148 @@ subroutine Init(this, bounds) type(bounds_type), intent(in) :: bounds !----------------------------------------------------------------------- - call this%InitAllocate(bounds) - call this%InitHistory(bounds) +! call this%InitAllocate(bounds) +! call this%InitHistory(bounds) end subroutine Init !------------------------------------------------------------------------ - subroutine InitAllocate(this, bounds) - ! - ! !USES: - use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) - use clm_varpar , only : nlevgrnd, nlevdecomp_full - use EDtypesMod , only : numpft_ed - ! - ! !ARGUMENTS: - class (ed_clm_type) :: this - type(bounds_type), intent(in) :: bounds - ! - ! !LOCAL VARIABLES: - integer :: begp,endp - integer :: begc,endc !bounds - integer :: begg,endg - !------------------------------------------------------------------------ - - begp = bounds%begp; endp = bounds%endp - begc = bounds%begc; endc = bounds%endc - - allocate(this%ed_to_bgc_this_edts_col (begc:endc)) ; this%ed_to_bgc_this_edts_col (:) = nan - allocate(this%ed_to_bgc_last_edts_col (begc:endc)) ; this%ed_to_bgc_last_edts_col (:) = nan - allocate(this%seed_rain_flux_col (begc:endc)) ; this%seed_rain_flux_col (:) = nan - - allocate(this%nep_col (begc:endc)) ; this%nep_col (:) = nan - allocate(this%nep_timeintegrated_col (begc:endc)) ; this%nep_timeintegrated_col (:) = nan - allocate(this%npp_timeintegrated_col (begc:endc)) ; this%npp_timeintegrated_col (:) = nan - allocate(this%hr_timeintegrated_col (begc:endc)) ; this%hr_timeintegrated_col (:) = nan - - allocate(this%nbp_col (begc:endc)) ; this%nbp_col (:) = nan - allocate(this%npp_col (begc:endc)) ; this%npp_col (:) = nan - allocate(this%fire_c_to_atm_col (begc:endc)) ; this%fire_c_to_atm_col (:) = nan - - allocate(this%totecosysc_col (begc:endc)) ; this%totecosysc_col (:) = nan - allocate(this%totecosysc_old_col (begc:endc)) ; this%totecosysc_old_col (:) = nan - allocate(this%totedc_col (begc:endc)) ; this%totedc_col (:) = nan - allocate(this%totedc_old_col (begc:endc)) ; this%totedc_old_col (:) = nan - allocate(this%totbgcc_col (begc:endc)) ; this%totbgcc_col (:) = nan - allocate(this%totbgcc_old_col (begc:endc)) ; this%totbgcc_old_col (:) = nan - allocate(this%biomass_stock_col (begc:endc)) ; this%biomass_stock_col (:) = nan - allocate(this%ed_litter_stock_col (begc:endc)) ; this%ed_litter_stock_col (:) = nan - allocate(this%cwd_stock_col (begc:endc)) ; this%cwd_stock_col (:) = nan - allocate(this%seed_stock_col (begc:endc)) ; this%seed_stock_col (:) = nan - - allocate(this%cbalance_error_ed_col (begc:endc)) ; this%cbalance_error_ed_col (:) = nan - allocate(this%cbalance_error_bgc_col (begc:endc)) ; this%cbalance_error_bgc_col (:) = nan - allocate(this%cbalance_error_total_col (begc:endc)) ; this%cbalance_error_total_col (:) = nan - - end subroutine InitAllocate +! subroutine InitAllocate(this, bounds) +! ! +! ! !USES: +! use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) +! use clm_varpar , only : nlevgrnd, nlevdecomp_full +! use EDtypesMod , only : numpft_ed +! ! +! ! !ARGUMENTS: +! class (ed_clm_type) :: this +! type(bounds_type), intent(in) :: bounds +! ! +! ! !LOCAL VARIABLES: +! integer :: begp,endp +! integer :: begc,endc !bounds +! integer :: begg,endg +! !------------------------------------------------------------------------ + +! begp = bounds%begp; endp = bounds%endp +! begc = bounds%begc; endc = bounds%endc + +! allocate(this%ed_to_bgc_this_edts_col (begc:endc)) ; this%ed_to_bgc_this_edts_col (:) = nan +! allocate(this%ed_to_bgc_last_edts_col (begc:endc)) ; this%ed_to_bgc_last_edts_col (:) = nan +! allocate(this%seed_rain_flux_col (begc:endc)) ; this%seed_rain_flux_col (:) = nan + +! allocate(this%nep_col (begc:endc)) ; this%nep_col (:) = nan +! allocate(this%nep_timeintegrated_col (begc:endc)) ; this%nep_timeintegrated_col (:) = nan +! allocate(this%npp_timeintegrated_col (begc:endc)) ; this%npp_timeintegrated_col (:) = nan +! allocate(this%hr_timeintegrated_col (begc:endc)) ; this%hr_timeintegrated_col (:) = nan + +! allocate(this%nbp_col (begc:endc)) ; this%nbp_col (:) = nan +! allocate(this%npp_col (begc:endc)) ; this%npp_col (:) = nan +! allocate(this%fire_c_to_atm_col (begc:endc)) ; this%fire_c_to_atm_col (:) = nan + +! allocate(this%totecosysc_col (begc:endc)) ; this%totecosysc_col (:) = nan +! allocate(this%totecosysc_old_col (begc:endc)) ; this%totecosysc_old_col (:) = nan +! allocate(this%totedc_col (begc:endc)) ; this%totedc_col (:) = nan +! allocate(this%totedc_old_col (begc:endc)) ; this%totedc_old_col (:) = nan +! allocate(this%totbgcc_col (begc:endc)) ; this%totbgcc_col (:) = nan +! allocate(this%totbgcc_old_col (begc:endc)) ; this%totbgcc_old_col (:) = nan +! allocate(this%biomass_stock_col (begc:endc)) ; this%biomass_stock_col (:) = nan +! allocate(this%ed_litter_stock_col (begc:endc)) ; this%ed_litter_stock_col (:) = nan +! allocate(this%cwd_stock_col (begc:endc)) ; this%cwd_stock_col (:) = nan +! allocate(this%seed_stock_col (begc:endc)) ; this%seed_stock_col (:) = nan +! +! allocate(this%cbalance_error_ed_col (begc:endc)) ; this%cbalance_error_ed_col (:) = nan +! allocate(this%cbalance_error_bgc_col (begc:endc)) ; this%cbalance_error_bgc_col (:) = nan +! allocate(this%cbalance_error_total_col (begc:endc)) ; this%cbalance_error_total_col (:) = nan +! +! end subroutine InitAllocate !------------------------------------------------------------------------ - subroutine InitHistory(this, bounds) +! 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 - use clm_varcon , only : spval - use histFileMod, only : hist_addfld1d, hist_addfld2d, hist_addfld_decomp +! use clm_varpar , only : ndecomp_cascade_transitions, ndecomp_pools +! use clm_varpar , only : nlevdecomp, nlevdecomp_full +! 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 +! 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 +! 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 - - this%nep_col(begc:endc) = spval - call hist_addfld1d (fname='NEP', units='gC/m^2/s', & - avgflag='A', long_name='net ecosystem production', & - ptr_col=this%nep_col) - - this%fire_c_to_atm_col(begc:endc) = spval - call hist_addfld1d (fname='Fire_Closs', units='gC/m^2/s', & - avgflag='A', long_name='ED/SPitfire Carbon loss to atmosphere', & - ptr_col=this%fire_c_to_atm_col) - - this%nbp_col(begc:endc) = spval - call hist_addfld1d (fname='NBP', units='gC/m^2/s', & - avgflag='A', long_name='net biosphere production', & - ptr_col=this%nbp_col) - - this%totecosysc_col(begc:endc) = spval - call hist_addfld1d (fname='TOTECOSYSC', units='gC/m^2', & - avgflag='A', long_name='total ecosystem carbon', & - ptr_col=this%totecosysc_col) - - this%cbalance_error_ed_col(begc:endc) = spval - call hist_addfld1d (fname='CBALANCE_ERROR_ED', units='gC/m^2/s', & - avgflag='A', long_name='total carbon balance error on ED side', & - ptr_col=this%cbalance_error_ed_col) - - this%cbalance_error_bgc_col(begc:endc) = spval - call hist_addfld1d (fname='CBALANCE_ERROR_BGC', units='gC/m^2/s', & - avgflag='A', long_name='total carbon balance error on BGC side', & - ptr_col=this%cbalance_error_bgc_col) - - this%cbalance_error_total_col(begc:endc) = spval - call hist_addfld1d (fname='CBALANCE_ERROR_TOTAL', units='gC/m^2/s', & - avgflag='A', long_name='total carbon balance error total', & - ptr_col=this%cbalance_error_total_col) - - this%biomass_stock_col(begc:endc) = spval - call hist_addfld1d (fname='BIOMASS_STOCK_COL', units='gC/m^2', & - avgflag='A', long_name='total ED biomass carbon at the column level', & - ptr_col=this%biomass_stock_col) - - this%ed_litter_stock_col(begc:endc) = spval - call hist_addfld1d (fname='ED_LITTER_STOCK_COL', units='gC/m^2', & - avgflag='A', long_name='total ED litter carbon at the column level', & - ptr_col=this%ed_litter_stock_col) - - this%cwd_stock_col(begc:endc) = spval - call hist_addfld1d (fname='CWD_STOCK_COL', units='gC/m^2', & - avgflag='A', long_name='total CWD carbon at the column level', & - ptr_col=this%cwd_stock_col) - - this%seed_stock_col(begc:endc) = spval - call hist_addfld1d (fname='SEED_STOCK_COL', units='gC/m^2', & - avgflag='A', long_name='total seed carbon at the column level', & - ptr_col=this%seed_stock_col) - - end subroutine InitHistory +! begp = bounds%begp; endp = bounds%endp +! begc = bounds%begc; endc = bounds%endc + +! this%nep_col(begc:endc) = spval +! call hist_addfld1d (fname='NEP', units='gC/m^2/s', & +! avgflag='A', long_name='net ecosystem production', & +! ptr_col=this%nep_col) + +! this%fire_c_to_atm_col(begc:endc) = spval +! call hist_addfld1d (fname='Fire_Closs', units='gC/m^2/s', & +! avgflag='A', long_name='ED/SPitfire Carbon loss to atmosphere', & +! ptr_col=this%fire_c_to_atm_col) + +! this%nbp_col(begc:endc) = spval +! call hist_addfld1d (fname='NBP', units='gC/m^2/s', & +! avgflag='A', long_name='net biosphere production', & +! ptr_col=this%nbp_col) + +! this%totecosysc_col(begc:endc) = spval +! call hist_addfld1d (fname='TOTECOSYSC', units='gC/m^2', & +! avgflag='A', long_name='total ecosystem carbon', & +! ptr_col=this%totecosysc_col) + +! this%cbalance_error_ed_col(begc:endc) = spval +! call hist_addfld1d (fname='CBALANCE_ERROR_ED', units='gC/m^2/s', & +! avgflag='A', long_name='total carbon balance error on ED side', & +! ptr_col=this%cbalance_error_ed_col) + +! this%cbalance_error_bgc_col(begc:endc) = spval +! call hist_addfld1d (fname='CBALANCE_ERROR_BGC', units='gC/m^2/s', & +! avgflag='A', long_name='total carbon balance error on BGC side', & +! ptr_col=this%cbalance_error_bgc_col) + +! this%cbalance_error_total_col(begc:endc) = spval +! call hist_addfld1d (fname='CBALANCE_ERROR_TOTAL', units='gC/m^2/s', & +! avgflag='A', long_name='total carbon balance error total', & +! ptr_col=this%cbalance_error_total_col) + +! this%biomass_stock_col(begc:endc) = spval +! call hist_addfld1d (fname='BIOMASS_STOCK_COL', units='gC/m^2', & +! avgflag='A', long_name='total ED biomass carbon at the column level', & +! ptr_col=this%biomass_stock_col) + +! this%ed_litter_stock_col(begc:endc) = spval +! call hist_addfld1d (fname='ED_LITTER_STOCK_COL', units='gC/m^2', & +! avgflag='A', long_name='total ED litter carbon at the column level', & +! ptr_col=this%ed_litter_stock_col) + +! this%cwd_stock_col(begc:endc) = spval +! call hist_addfld1d (fname='CWD_STOCK_COL', units='gC/m^2', & +! avgflag='A', long_name='total CWD carbon at the column level', & +! ptr_col=this%cwd_stock_col) + +! this%seed_stock_col(begc:endc) = spval +! call hist_addfld1d (fname='SEED_STOCK_COL', units='gC/m^2', & +! avgflag='A', long_name='total seed carbon at the column level', & +! ptr_col=this%seed_stock_col) + +! end subroutine InitHistory !----------------------------------------------------------------------- ! subroutine InitCold(this, bounds) From b26394847a5b9c976228fc02876c6a149856ba73 Mon Sep 17 00:00:00 2001 From: Ben Andre Date: Thu, 1 Sep 2016 12:14:33 -0600 Subject: [PATCH 186/437] 'pull clm4_5_12_r194 tags from svn' --- biogeochem/EDCanopyStructureMod.F90 | 5 +- biogeochem/EDSharedParamsMod.F90 | 7 +- biogeophys/EDPhotosynthesisMod.F90 | 7 +- main/EDCLMLinkMod.F90 | 9 +- main/EDRestVectorMod.F90 | 131 ++++++++++++++-------------- 5 files changed, 87 insertions(+), 72 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 44cb1b99..34bff850 100755 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -23,6 +23,9 @@ module EDCanopyStructureMod public :: canopy_spread public :: calc_areaindex + character(len=*), parameter, private :: sourcefile = & + __FILE__ + ! 10/30/09: Created by Rosie Fisher ! ============================================================================ @@ -693,7 +696,7 @@ function calc_areaindex(cpatch,ai_type) result(ai) enddo else write(iulog,*) 'Unsupported area index sent to calc_areaindex' - call endrun(msg=errMsg(__FILE__, __LINE__)) + call endrun(msg=errMsg(sourcefile, __LINE__)) end if ai = max(ai_min,ai) diff --git a/biogeochem/EDSharedParamsMod.F90 b/biogeochem/EDSharedParamsMod.F90 index a51fbb5f..c4111c12 100644 --- a/biogeochem/EDSharedParamsMod.F90 +++ b/biogeochem/EDSharedParamsMod.F90 @@ -17,6 +17,9 @@ module EDSharedParamsMod type(EDParamsShareType), protected :: EDParamsShareInst + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !----------------------------------------------------------------------- contains @@ -41,12 +44,12 @@ subroutine EDParamsReadShared(ncid) ! 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__)) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __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__)) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) EDParamsShareInst%froz_q10=tempr end subroutine EDParamsReadShared diff --git a/biogeophys/EDPhotosynthesisMod.F90 b/biogeophys/EDPhotosynthesisMod.F90 index 4d2e924c..ecad4352 100644 --- a/biogeophys/EDPhotosynthesisMod.F90 +++ b/biogeophys/EDPhotosynthesisMod.F90 @@ -21,6 +21,9 @@ module EDPhotosynthesisMod ! PUBLIC MEMBER FUNCTIONS: public :: Photosynthesis_ED !ED specific photosynthesis routine + + character(len=*), parameter, private :: sourcefile = & + __FILE__ !------------------------------------------------------------------------------ contains @@ -739,7 +742,7 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) if (gs_mol < 0._r8) then write (iulog,*)'Negative stomatal conductance:' write (iulog,*)'ifp,iv,gs_mol= ',ifp,iv,gs_mol - call endrun(msg=errmsg(__FILE__, __LINE__)) + call endrun(msg=errmsg(sourcefile, __LINE__)) end if ! Compare with Ball-Berry model: gs_mol = m * an * hs/cs p + b @@ -1100,7 +1103,7 @@ subroutine quadratic_f (a, b, c, r1, r2) if (a == 0._r8) then write (iulog,*) 'Quadratic solution error: a = ',a - call endrun(msg=errmsg(__FILE__, __LINE__)) + call endrun(msg=errmsg(sourcefile, __LINE__)) end if if (b >= 0._r8) then diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 517d1829..340b19c4 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -170,6 +170,9 @@ module EDCLMLinkMod end type ed_clm_type + character(len=*), parameter, private :: sourcefile = & + __FILE__ + ! 10/30/09: Created by Rosie Fisher !----------------------------------------------------------------------- @@ -886,7 +889,7 @@ subroutine ed_clm_link( this, bounds, nsites, sites, fcolumn, waterstate_inst, c if(c .ne. clmpatch%column(p))then write(iulog,*) ' fcolumn(s) does not match clmpatch%column(p)' - call endrun(msg=errMsg(__FILE__, __LINE__)) + call endrun(msg=errMsg(sourcefile, __LINE__)) end if clmpatch%is_veg(p) = .true. !this .is. a tile filled with vegetation... @@ -1313,7 +1316,7 @@ subroutine ed_update_history_variables( this, bounds, nsites, sites, fcolumn, ca currentcohort%npp_bsw,currentcohort%npp_bdead, & currentcohort%npp_bseed,currentcohort%npp_store write(iulog,*) ' NPP components during FATES-HLM linking does not balance ' - call endrun(msg=errMsg(__FILE__, __LINE__)) + call endrun(msg=errMsg(sourcefile, __LINE__)) end if ! Woody State Variables (basal area and number density and mortality) @@ -1670,7 +1673,7 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, colindex, waterstate_ins if( clmpatch%column(currentPatch%clm_pno) .ne. colindex .or. currentPatch%clm_pno .ne. p )then ! ERROR write(fates_log(), *) ' clmpatch%column(currentPatch%clm_pno) .ne. colindex .or. currentPatch%clm_pno .ne. p ' - call endrun(msg=errMsg(__FILE__, __LINE__)) + call endrun(msg=errMsg(sourcefile, __LINE__)) end if diff --git a/main/EDRestVectorMod.F90 b/main/EDRestVectorMod.F90 index 89d485be..a4290e04 100755 --- a/main/EDRestVectorMod.F90 +++ b/main/EDRestVectorMod.F90 @@ -156,6 +156,9 @@ module EDRestVectorMod ! non type-bound procedures ! public :: EDRest + + character(len=*), parameter, private :: sourcefile = & + __FILE__ !-------------------------------------------------------------------------------! contains @@ -269,58 +272,58 @@ function newEDRestartVectorClass( bounds ) allocate(new%numPatchesPerCol & (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%numPatchesPerCol(:) = invalidValue allocate(new%old_stock & (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%old_stock(:) = 0.0_r8 allocate(new%cd_status & (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%cd_status(:) = 0_r8 allocate(new%dd_status & (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%dd_status(:) = 0_r8 allocate(new%ncd & (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%ncd(:) = 0_r8 allocate(new%leafondate & (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%leafondate(:) = 0_r8 allocate(new%leafoffdate & (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%leafoffdate(:) = 0_r8 allocate(new%dleafondate & (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%dleafondate(:) = 0_r8 allocate(new%dleafoffdate & (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%dleafoffdate(:) = 0_r8 allocate(new%acc_NI & (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%acc_NI(:) = 0_r8 allocate(new%ED_GDD_site & (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%ED_GDD_site(:) = 0_r8 @@ -330,172 +333,172 @@ function newEDRestartVectorClass( bounds ) allocate(new%cohortsPerPatch & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%cohortsPerPatch(:) = invalidValue allocate(new%balive & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%balive(:) = 0.0_r8 allocate(new%bdead & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%bdead(:) = 0.0_r8 allocate(new%bl & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%bl(:) = 0.0_r8 allocate(new%br & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%br(:) = 0.0_r8 allocate(new%bstore & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%bstore(:) = 0.0_r8 allocate(new%canopy_layer & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%canopy_layer(:) = 0.0_r8 allocate(new%canopy_trim & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%canopy_trim(:) = 0.0_r8 allocate(new%dbh & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%dbh(:) = 0.0_r8 allocate(new%hite & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%hite(:) = 0.0_r8 allocate(new%laimemory & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%laimemory(:) = 0.0_r8 allocate(new%leaf_md & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%leaf_md(:) = 0.0_r8 allocate(new%root_md & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%root_md(:) = 0.0_r8 allocate(new%n & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%n(:) = 0.0_r8 allocate(new%gpp_acc & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%gpp_acc(:) = 0.0_r8 allocate(new%npp_acc & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%npp_acc(:) = 0.0_r8 allocate(new%gpp & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%gpp(:) = 0.0_r8 allocate(new%npp & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%npp(:) = 0.0_r8 allocate(new%npp_leaf & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%npp_leaf(:) = 0.0_r8 allocate(new%npp_froot & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%npp_froot(:) = 0.0_r8 allocate(new%npp_bsw & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%npp_bsw(:) = 0.0_r8 allocate(new%npp_bdead & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%npp_bdead(:) = 0.0_r8 allocate(new%npp_bseed & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%npp_bseed(:) = 0.0_r8 allocate(new%npp_store & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%npp_store(:) = 0.0_r8 allocate(new%bmort & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%bmort(:) = 0.0_r8 allocate(new%hmort & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%hmort(:) = 0.0_r8 allocate(new%cmort & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%cmort(:) = 0.0_r8 allocate(new%imort & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%imort(:) = 0.0_r8 allocate(new%fmort & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%fmort(:) = 0.0_r8 allocate(new%ddbhdt & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%ddbhdt(:) = 0.0_r8 allocate(new%resp_tstep & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%resp_tstep(:) = 0.0_r8 allocate(new%pft & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%pft(:) = 0 allocate(new%status_coh & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%status_coh(:) = 0 allocate(new%isnew & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%isnew(:) = new_cohort ! @@ -503,82 +506,82 @@ function newEDRestartVectorClass( bounds ) ! allocate(new%cwd_ag & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%cwd_ag(:) = 0.0_r8 allocate(new%cwd_bg & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%cwd_bg(:) = 0.0_r8 allocate(new%leaf_litter & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%leaf_litter(:) = 0.0_r8 allocate(new%root_litter & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __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__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __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__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __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__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%seed_bank(:) = 0.0_r8 allocate(new%spread & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%spread(:) = 0.0_r8 allocate(new%livegrass & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%livegrass(:) = 0.0_r8 allocate(new%age & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%age(:) = 0.0_r8 allocate(new%areaRestart & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%areaRestart(:) = 0.0_r8 allocate(new%f_sun & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%f_sun(:) = 0.0_r8 allocate(new%fabd_sun_z & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%fabd_sun_z(:) = 0.0_r8 allocate(new%fabi_sun_z & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%fabi_sun_z(:) = 0.0_r8 allocate(new%fabd_sha_z & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%fabd_sha_z(:) = 0.0_r8 allocate(new%fabi_sha_z & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%fabi_sha_z(:) = 0.0_r8 ! @@ -588,7 +591,7 @@ function newEDRestartVectorClass( bounds ) allocate(new%water_memory & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(sourcefile, __LINE__)) new%water_memory(:) = 0.0_r8 @@ -1529,7 +1532,7 @@ subroutine convertCohortListToVector( this, bounds, nsites, sites, fcolumn ) ! (fcolumn(1)-1)*cohorts_per_col+1.ne.bounds%begCohort) then ! write(iulog,*) 'fcolumn(1) in this clump, points to the first column of the clump' ! write(iulog,*) 'but the assumption on first cohort index does not jive' -! call endrun(msg=errMsg(__FILE__, __LINE__)) +! call endrun(msg=errMsg(sourcefile, __LINE__)) ! end if @@ -1819,7 +1822,7 @@ subroutine createPatchCohortStructure( this, bounds, nsites, sites, fcolumn ) if (this%numPatchesPerCol(c)<0 .or. this%numPatchesPerCol(c)>10000) then write(iulog,*) 'a column was expected to contain a valid number of patches' write(iulog,*) '0 is a valid number, but this column seems uninitialized',this%numPatchesPerCol(c) - call endrun(msg=errMsg(__FILE__, __LINE__)) + call endrun(msg=errMsg(sourcefile, __LINE__)) end if ! Initialize the site pointers to null From 79a2b0aa7a02133be1e46db84fdd834a931eff1a Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 1 Sep 2016 11:34:31 -0700 Subject: [PATCH 187/437] cleaning out unused subs and funcs and their calls --- biogeophys/EDAccumulateFluxesMod.F90 | 1 - main/EDCLMLinkMod.F90 | 182 +++++++++++++------------ main/EDRestVectorMod.F90 | 190 ++++++++++++++++++++++++--- main/HistoryIOMod.F90 | 35 +++-- 4 files changed, 277 insertions(+), 131 deletions(-) diff --git a/biogeophys/EDAccumulateFluxesMod.F90 b/biogeophys/EDAccumulateFluxesMod.F90 index bc756f4d..c33044d0 100644 --- a/biogeophys/EDAccumulateFluxesMod.F90 +++ b/biogeophys/EDAccumulateFluxesMod.F90 @@ -84,7 +84,6 @@ subroutine AccumulateFluxes_ED(sites, nsites, bc_in, bc_out, dt_time) endif if ( .not. ccohort%isnew ) then sites(s)%npp = sites(s)%npp + ccohort%npp_tstep * n_perm2 * 1.e3_r8 / dt_time - endif do iv=1,ccohort%nv diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 4095bba5..edceafda 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -37,9 +37,9 @@ module EDCLMLinkMod type, public :: ed_clm_type - 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. +! 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. @@ -91,14 +91,14 @@ module EDCLMLinkMod ! real(r8), pointer, private :: cbalance_error_total_col(:) ! [gC/m2/s] total carbon balance error for the whole thing ! ED patch/cohort data - real(r8), pointer, private :: ed_npatches_col(:) ! [#] the number of patches per ED site - real(r8), pointer, private :: ed_ncohorts_col(:) ! [#] the number of cohorts per ED site +! real(r8), pointer, private :: ed_npatches_col(:) ! [#] the number of patches per ED site +! real(r8), pointer, private :: ed_ncohorts_col(:) ! [#] the number of cohorts per ED site contains ! Public routines - procedure , public :: Init - procedure , public :: Restart +! procedure , public :: Init +! procedure , public :: Restart procedure , public :: ed_clm_link ! procedure , public :: SummarizeNetFluxes ! procedure , public :: SummarizeProductivityFluxes @@ -117,20 +117,20 @@ module EDCLMLinkMod contains !------------------------------------------------------------------------ - subroutine Init(this, bounds) +! subroutine Init(this, bounds) ! ! !DESCRIPTION: ! Initialize module data structure instance ! ! !ARGUMENTS: - class(ed_clm_type) :: this - type(bounds_type), intent(in) :: bounds +! class(ed_clm_type) :: this +! type(bounds_type), intent(in) :: bounds !----------------------------------------------------------------------- ! call this%InitAllocate(bounds) ! call this%InitHistory(bounds) - end subroutine Init +! end subroutine Init !------------------------------------------------------------------------ ! subroutine InitAllocate(this, bounds) @@ -291,93 +291,93 @@ end subroutine Init ! end subroutine InitCold !----------------------------------------------------------------------- - subroutine Restart ( this, bounds, ncid, flag ) +! subroutine Restart ( this, bounds, ncid, flag ) ! ! !DESCRIPTION: ! Read/write restart data ! ! !USES: - use restUtilMod - use ncdio_pio +! use restUtilMod +! use ncdio_pio ! use EDtypesMod , only : numpft_ed ! ! !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' +! 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 - real(r8), pointer :: ptr2d(:,:) ! temp. pointers for slicing larger arrays - real(r8), pointer :: ptr1d(:) ! temp. pointers for slicing larger arrays +! logical :: readvar +! real(r8), pointer :: ptr2d(:,:) ! temp. pointers for slicing larger arrays +! real(r8), pointer :: ptr1d(:) ! temp. pointers for slicing larger arrays ! character(LEN=3) :: istr1 ! integer :: k !------------------------------------------------------------------------ - ptr1d => this%nep_timeintegrated_col(:) - call restartvar(ncid=ncid, flag=flag, varname='nep_timeintegrated_col', xtype=ncd_double, & - dim1name='column', long_name='', units='', & - interpinic_flag='interp', readvar=readvar, data=ptr1d) - - ptr1d => this%npp_timeintegrated_col(:) - call restartvar(ncid=ncid, flag=flag, varname='npp_timeintegrated_col', xtype=ncd_double, & - dim1name='column', long_name='', units='', & - interpinic_flag='interp', readvar=readvar, data=ptr1d) - - ptr1d => this%hr_timeintegrated_col(:) - call restartvar(ncid=ncid, flag=flag, varname='hr_timeintegrated_col', xtype=ncd_double, & - dim1name='column', long_name='', units='', & - interpinic_flag='interp', readvar=readvar, data=ptr1d) - - ptr1d => this%totecosysc_old_col(:) - call restartvar(ncid=ncid, flag=flag, varname='totecosysc_old_col', xtype=ncd_double, & - dim1name='column', long_name='', units='', & - interpinic_flag='interp', readvar=readvar, data=ptr1d) +! ptr1d => this%nep_timeintegrated_col(:) +! call restartvar(ncid=ncid, flag=flag, varname='nep_timeintegrated_col', xtype=ncd_double, & +! dim1name='column', long_name='', units='', & +! interpinic_flag='interp', readvar=readvar, data=ptr1d) + +! ptr1d => this%npp_timeintegrated_col(:) +! call restartvar(ncid=ncid, flag=flag, varname='npp_timeintegrated_col', xtype=ncd_double, & +! dim1name='column', long_name='', units='', & +! interpinic_flag='interp', readvar=readvar, data=ptr1d) + +! ptr1d => this%hr_timeintegrated_col(:) +! call restartvar(ncid=ncid, flag=flag, varname='hr_timeintegrated_col', xtype=ncd_double, & +! dim1name='column', long_name='', units='', & +! interpinic_flag='interp', readvar=readvar, data=ptr1d) + +! ptr1d => this%totecosysc_old_col(:) +! call restartvar(ncid=ncid, flag=flag, varname='totecosysc_old_col', xtype=ncd_double, & +! dim1name='column', long_name='', units='', & +! interpinic_flag='interp', readvar=readvar, data=ptr1d) - ptr1d => this%cbalance_error_ed_col(:) - call restartvar(ncid=ncid, flag=flag, varname='cbalance_error_ed_col', xtype=ncd_double, & - dim1name='column', long_name='', units='', & - interpinic_flag='interp', readvar=readvar, data=ptr1d) +! ptr1d => this%cbalance_error_ed_col(:) +! call restartvar(ncid=ncid, flag=flag, varname='cbalance_error_ed_col', xtype=ncd_double, & +! dim1name='column', long_name='', units='', & +! interpinic_flag='interp', readvar=readvar, data=ptr1d) - ptr1d => this%cbalance_error_bgc_col(:) - call restartvar(ncid=ncid, flag=flag, varname='cbalance_error_bgc_col', xtype=ncd_double, & - dim1name='column', long_name='', units='', & - interpinic_flag='interp', readvar=readvar, data=ptr1d) +! ptr1d => this%cbalance_error_bgc_col(:) +! call restartvar(ncid=ncid, flag=flag, varname='cbalance_error_bgc_col', xtype=ncd_double, & +! dim1name='column', long_name='', units='', & +! interpinic_flag='interp', readvar=readvar, data=ptr1d) - ptr1d => this%cbalance_error_total_col(:) - call restartvar(ncid=ncid, flag=flag, varname='cbalance_error_total_col', xtype=ncd_double, & - dim1name='column', long_name='', units='', & - interpinic_flag='interp', readvar=readvar, data=ptr1d) +! ptr1d => this%cbalance_error_total_col(:) +! call restartvar(ncid=ncid, flag=flag, varname='cbalance_error_total_col', xtype=ncd_double, & +! dim1name='column', long_name='', units='', & +! interpinic_flag='interp', readvar=readvar, data=ptr1d) - ptr1d => this%totedc_old_col(:) - call restartvar(ncid=ncid, flag=flag, varname='totedc_old_col', xtype=ncd_double, & - dim1name='column', long_name='', units='', & - interpinic_flag='interp', readvar=readvar, data=ptr1d) +! ptr1d => this%totedc_old_col(:) +! call restartvar(ncid=ncid, flag=flag, varname='totedc_old_col', xtype=ncd_double, & +! dim1name='column', long_name='', units='', & +! interpinic_flag='interp', readvar=readvar, data=ptr1d) - ptr1d => this%totbgcc_old_col(:) - call restartvar(ncid=ncid, flag=flag, varname='totbgcc_old_col', xtype=ncd_double, & - dim1name='column', long_name='', units='', & - interpinic_flag='interp', readvar=readvar, data=ptr1d) +! ptr1d => this%totbgcc_old_col(:) +! call restartvar(ncid=ncid, flag=flag, varname='totbgcc_old_col', xtype=ncd_double, & +! dim1name='column', long_name='', units='', & +! interpinic_flag='interp', readvar=readvar, data=ptr1d) - ptr1d => this%ed_to_bgc_this_edts_col(:) - call restartvar(ncid=ncid, flag=flag, varname='ed_to_bgc_this_edts_col', xtype=ncd_double, & - dim1name='column', long_name='', units='', & - interpinic_flag='interp', readvar=readvar, data=ptr1d) +! ptr1d => this%ed_to_bgc_this_edts_col(:) +! call restartvar(ncid=ncid, flag=flag, varname='ed_to_bgc_this_edts_col', xtype=ncd_double, & +! dim1name='column', long_name='', units='', & +! interpinic_flag='interp', readvar=readvar, data=ptr1d) - ptr1d => this%ed_to_bgc_last_edts_col(:) - call restartvar(ncid=ncid, flag=flag, varname='ed_to_bgc_last_edts_col', xtype=ncd_double, & - dim1name='column', long_name='', units='', & - interpinic_flag='interp', readvar=readvar, data=ptr1d) - - ptr1d => this%seed_rain_flux_col(:) - call restartvar(ncid=ncid, flag=flag, varname='seed_rain_flux_col', xtype=ncd_double, & - dim1name='column', long_name='', units='', & - interpinic_flag='interp', readvar=readvar, data=ptr1d) +! ptr1d => this%ed_to_bgc_last_edts_col(:) +! call restartvar(ncid=ncid, flag=flag, varname='ed_to_bgc_last_edts_col', xtype=ncd_double, & +! dim1name='column', long_name='', units='', & +! interpinic_flag='interp', readvar=readvar, data=ptr1d) + +! ptr1d => this%seed_rain_flux_col(:) +! call restartvar(ncid=ncid, flag=flag, varname='seed_rain_flux_col', xtype=ncd_double, & +! dim1name='column', long_name='', units='', & +! interpinic_flag='interp', readvar=readvar, data=ptr1d) - end subroutine Restart +! end subroutine Restart !----------------------------------------------------------------------- @@ -1163,9 +1163,9 @@ subroutine SummarizeNetFluxes( sites, nsites, bc_in, is_beg_day ) implicit none ! ! !ARGUMENTS - type(ed_site_type) , intent(in), target :: sites(nsites) + type(ed_site_type) , intent(inout), target :: sites(nsites) integer , intent(in) :: nsites - type(bc_in_type) , intent(in) :: bc_in + type(bc_in_type) , intent(in) :: bc_in(nsites) logical , intent(in) :: is_beg_day ! @@ -1237,7 +1237,7 @@ subroutine SummarizeNetFluxes( sites, nsites, bc_in, is_beg_day ) ! order of operations in the next to lines is quite important ;) sites(s)%fates_to_bgc_last_ts = sites(s)%fates_to_bgc_this_ts sites(s)%fates_to_bgc_this_ts = 0._r8 - sites(s)%seed_rain_flux = 0._r8 + sites(s)%seed_rain_flux = 0._r8 currentPatch => sites(s)%oldest_patch do while(associated(currentPatch)) @@ -1253,10 +1253,8 @@ subroutine SummarizeNetFluxes( sites, nsites, bc_in, is_beg_day ) end do endif - - end associate - - end subroutine SummarizeNetFluxes + return + end subroutine SummarizeNetFluxes subroutine ED_BGC_Carbon_Balancecheck(sites, nsites, bc_in, is_beg_day, dtime, nstep) @@ -1267,13 +1265,14 @@ subroutine ED_BGC_Carbon_Balancecheck(sites, nsites, bc_in, is_beg_day, dtime, n ! Written by Charlie Koven, Feb 2016 ! ! !USES: + use FatesInterfaceMod , only : bc_in_type ! implicit none ! ! !ARGUMENTS - type(ed_site_type) , intent(in), target :: sites(nsites) + type(ed_site_type) , intent(inout), target :: sites(nsites) integer , intent(in) :: nsites - type(bc_in_type) , intent(in) :: bc_in + type(bc_in_type) , intent(in) :: bc_in(nsites) logical , intent(in) :: is_beg_day real(r8) , intent(in) :: dtime ! time-step length (s) integer , intent(in) :: nstep ! time-step index @@ -1320,19 +1319,19 @@ subroutine ED_BGC_Carbon_Balancecheck(sites, nsites, bc_in, is_beg_day, dtime, n sites(s)%seed_rain_flux * SHR_CONST_CDAY - sites(s)%cbal_err_fates = sites(s)%totfatesc(c) - & - sites(s)%totfatesc_old(c) - & + sites(s)%cbal_err_fates = sites(s)%totfatesc - & + sites(s)%totfatesc_old - & (sites(s)%npp_timeintegrated + & sites(s)%seed_rain_flux*SHR_CONST_CDAY - & sites(s)%fates_to_bgc_this_ts*SHR_CONST_CDAY - & - this(s)%fire_c_to_atm*SHR_CONST_CDAY) + sites(s)%fire_c_to_atm*SHR_CONST_CDAY) sites(s)%cbal_err_fates = sites(s)%cbal_err_fates / SHR_CONST_CDAY - sites(s)%cbal_err_bgc = this(s)%totbgcc - & - this(s)%totbgcc_old - & - (this(s)%fates_to_bgc_last_ts*SHR_CONST_CDAY - & - this(s)%hr_timeintegrated) + sites(s)%cbal_err_bgc = sites(s)%totbgcc - & + sites(s)%totbgcc_old - & + (sites(s)%fates_to_bgc_last_ts*SHR_CONST_CDAY - & + sites(s)%hr_timeintegrated) sites(s)%cbal_err_bgc = sites(s)%cbal_err_bgc / SHR_CONST_CDAY sites(s)%cbal_err_tot = sites(s)%totecosysc - & @@ -1354,8 +1353,7 @@ subroutine ED_BGC_Carbon_Balancecheck(sites, nsites, bc_in, is_beg_day, dtime, n endif - end associate - + return end subroutine ED_BGC_Carbon_Balancecheck end module EDCLMLinkMod diff --git a/main/EDRestVectorMod.F90 b/main/EDRestVectorMod.F90 index 3f37c521..48410479 100755 --- a/main/EDRestVectorMod.F90 +++ b/main/EDRestVectorMod.F90 @@ -119,6 +119,20 @@ module EDRestVectorMod real(r8), pointer :: dleafondate(:) real(r8), pointer :: dleafoffdate(:) real(r8), pointer :: acc_NI(:) + + ! Site level carbon state/flux checks + real(r8), pointer :: nep_timeintegrated_si(:) + real(r8), pointer :: npp_timeintegrated_si(:) + real(r8), pointer :: hr_timeintegrated_si(:) + real(r8), pointer :: totecosys_old_si(:) + real(r8), pointer :: cbal_err_fates_si(:) + real(r8), pointer :: cbal_err_bgc_si(:) + real(r8), pointer :: cbal_err_tot_si(:) + real(r8), pointer :: tot_fatesc_old_si(:) + real(r8), pointer :: tot_bgcc_old_si(:) + real(r8), pointer :: fates_to_bgc_this_ts_si(:) + real(r8), pointer :: fates_to_bgc_last_ts_si(:) + real(r8), pointer :: seedrain_flux_si(:) contains @@ -239,6 +253,19 @@ subroutine deleteEDRestartVectorClass( this ) deallocate(this%dleafoffdate ) deallocate(this%acc_NI ) + deallocate(this%nep_timeintegrated_si) + deallocate(this%npp_timeintegrated_si) + deallocate(this%hr_timeintegrated_si) + deallocate(this%totecosys_old_si) + deallocate(this%cbal_err_fates_si) + deallocate(this%cbal_err_bgc_si) + deallocate(this%cbal_err_tot_si) + deallocate(this%tot_fatesc_old_si) + deallocate(this%tot_bgcc_old_si) + deallocate(this%fates_to_bgc_this_ts_si) + deallocate(this%fates_to_bgc_last_ts_si) + deallocate(this%seedrain_flux_si) + end subroutine deleteEDRestartVectorClass !-------------------------------------------------------------------------------! @@ -324,10 +351,69 @@ function newEDRestartVectorClass( bounds ) new%ED_GDD_site(:) = 0_r8 - ! cohort level variables + allocate(new%nep_timeintegrated_si & + (bounds%begc:bounds%endc), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%nep_timeintegrated_si(:) = 0_r8 + + allocate(new%npp_timeintegrated_si & + (bounds%begc:bounds%endc), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%npp_timeintegrated_si(:) = 0_r8 + + allocate(new%hr_timeintegrated_si & + (bounds%begc:bounds%endc), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%hr_timeintegrated_si(:) = 0_r8 + + allocate(new%totecosys_old_si & + (bounds%begc:bounds%endc), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%totecosys_old_si(:) = 0_r8 + + allocate(new%cbal_err_fates_si & + (bounds%begc:bounds%endc), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%cbal_err_fates_si(:) = 0_r8 + + allocate(new%cbal_err_bgc_si & + (bounds%begc:bounds%endc), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%cbal_err_bgc_si(:) = 0_r8 + + allocate(new%cbal_err_tot_si & + (bounds%begc:bounds%endc), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%cbal_err_tot_si(:) = 0_r8 + + allocate(new%tot_fatesc_old_si & + (bounds%begc:bounds%endc), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%tot_fatesc_old_si(:) = 0_r8 + + allocate(new%tot_bgcc_old_si & + (bounds%begc:bounds%endc), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%tot_bgcc_old_si(:) = 0_r8 + + allocate(new%fates_to_bgc_this_ts_si & + (bounds%begc:bounds%endc), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%fates_to_bgc_this_ts_si(:) = 0_r8 + + allocate(new%fates_to_bgc_last_ts_si & + (bounds%begc:bounds%endc), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%fates_to_bgc_last_ts_si(:) = 0_r8 + allocate(new%seedrain_flux_si & + (bounds%begc:bounds%endc), stat=retVal) + SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + new%seedrain_flux_si(:) = 0_r8 + ! cohort level variables + allocate(new%cohortsPerPatch & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) @@ -783,12 +869,62 @@ subroutine doVectorIO( this, ncid, flag ) interpinic_flag='interp', data=this%ED_GDD_site, & readvar=readvar) + call restartvar(ncid=ncid, flag=flag, varname='nep_timeintegrated_col', xtype=ncd_double, & + dim1name=col_dimName, long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%nep_timeintegrated_si) + + call restartvar(ncid=ncid, flag=flag, varname='npp_timeintegrated_col', xtype=ncd_double, & + dim1name='column', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%npp_timeintegrated_si) + + call restartvar(ncid=ncid, flag=flag, varname='hr_timeintegrated_col', xtype=ncd_double, & + dim1name='column', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%hr_timeintegrated_si) + + call restartvar(ncid=ncid, flag=flag, varname='totecosysc_old_col', xtype=ncd_double, & + dim1name='column', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%totecosys_old_si) + + call restartvar(ncid=ncid, flag=flag, varname='cbalance_error_ed_col', xtype=ncd_double, & + dim1name='column', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%cbal_err_fates_si) + + call restartvar(ncid=ncid, flag=flag, varname='cbalance_error_bgc_col', xtype=ncd_double, & + dim1name='column', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%cbal_err_bgc_si) + + call restartvar(ncid=ncid, flag=flag, varname='cbalance_error_total_col', xtype=ncd_double, & + dim1name='column', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%cbal_err_tot_si) + + call restartvar(ncid=ncid, flag=flag, varname='totedc_old_col', xtype=ncd_double, & + dim1name='column', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%tot_fatesc_old_si) + + call restartvar(ncid=ncid, flag=flag, varname='totbgcc_old_col', xtype=ncd_double, & + dim1name='column', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%tot_bgcc_old_si) + + call restartvar(ncid=ncid, flag=flag, varname='ed_to_bgc_this_edts_col', xtype=ncd_double, & + dim1name='column', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%fates_to_bgc_this_ts_si) + + call restartvar(ncid=ncid, flag=flag, varname='ed_to_bgc_last_edts_col', xtype=ncd_double, & + dim1name='column', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%fates_to_bgc_last_ts_si) + + call restartvar(ncid=ncid, flag=flag, varname='seed_rain_flux_col', xtype=ncd_double, & + dim1name='column', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%seedrain_flux_si) + + call restartvar(ncid=ncid, flag=flag, varname='ed_balive', xtype=ncd_double, & dim1name=coh_dimName, & long_name='ed cohort ed_balive', units='unitless', & interpinic_flag='interp', data=this%balive, & readvar=readvar) + ! ! cohort level vars ! @@ -1099,6 +1235,11 @@ subroutine doVectorIO( this, ncid, flag ) interpinic_flag='interp', data=this%water_memory, & readvar=readvar) + + + + + end subroutine doVectorIO !-------------------------------------------------------------------------------! @@ -1525,14 +1666,6 @@ subroutine convertCohortListToVector( this, bounds, sites, nsites, fcolumn ) totalCohorts = 0 -! if(fcolumn(1).eq.bounds%begc .and. & -! (fcolumn(1)-1)*cohorts_per_col+1.ne.bounds%begCohort) then -! write(iulog,*) 'fcolumn(1) in this clump, points to the first column of the clump' -! write(iulog,*) 'but the assumption on first cohort index does not jive' -! call endrun(msg=errMsg(__FILE__, __LINE__)) -! end if - - do s = 1,nsites ! Calculate the offsets @@ -1542,14 +1675,6 @@ subroutine convertCohortListToVector( this, bounds, sites, nsites, fcolumn ) c = fcolumn(s) -! incrementOffset = (c-1)*cohorts_per_col + 1 -! countCohort = (c-1)*cohorts_per_col + 1 -! countPft = (c-1)*cohorts_per_col + 1 -! countNcwd = (c-1)*cohorts_per_col + 1 -! countNclmax = (c-1)*cohorts_per_col + 1 -! countWaterMem = (c-1)*cohorts_per_col + 1 -! countSunZ = (c-1)*cohorts_per_col + 1 - incrementOffset = bounds%begCohort+(c-bounds%begc)*cohorts_per_col + 1 countCohort = bounds%begCohort+(c-bounds%begc)*cohorts_per_col + 1 countPft = bounds%begCohort+(c-bounds%begc)*cohorts_per_col + 1 @@ -1724,6 +1849,21 @@ subroutine convertCohortListToVector( this, bounds, sites, nsites, fcolumn ) this%dleafoffdate(c) = sites(s)%dleafoffdate this%acc_NI(c) = sites(s)%acc_NI this%ED_GDD_site(c) = sites(s)%ED_GDD_site + + ! Carbon Balance and Checks + this%nep_timeintegrated_si(c) = sites(s)%nep_timeintegrated + this%npp_timeintegrated_si(c) = sites(s)%npp_timeintegrated + this%hr_timeintegrated_si(c) = sites(s)%hr_timeintegrated + this%totecosys_old_si(c) = sites(s)%totecosysc_old + this%tot_fatesc_old_si(c) = sites(s)%totfatesc_old + this%tot_bgcc_old_si(c) = sites(s)%totbgcc_old + this%cbal_err_fates_si(c) = sites(s)%cbal_err_fates + this%cbal_err_bgc_si(c) = sites(s)%cbal_err_bgc + this%cbal_err_tot_si(c) = sites(s)%cbal_err_tot + this%fates_to_bgc_this_ts_si(c) = sites(s)%fates_to_bgc_this_ts + this%fates_to_bgc_last_ts_si(c) = sites(s)%fates_to_bgc_last_ts + this%seedrain_flux_si(c) = sites(s)%seed_rain_flux + ! set numpatches for this column this%numPatchesPerCol(c) = numPatches @@ -2066,8 +2206,6 @@ subroutine convertCohortVectorToList( this, bounds, sites, nsites, fcolumn ) currentPatch%age = this%age(incrementOffset) currentPatch%area = this%areaRestart(incrementOffset) - - ! set cohorts per patch for IO if (this%DEBUG) then @@ -2151,6 +2289,20 @@ subroutine convertCohortVectorToList( this, bounds, sites, nsites, fcolumn ) sites(s)%dleafoffdate = this%dleafoffdate(c) sites(s)%acc_NI = this%acc_NI(c) sites(s)%ED_GDD_site = this%ED_GDD_site(c) + + ! Carbon Balance and Checks + sites(s)%nep_timeintegrated = this%nep_timeintegrated_si(c) + sites(s)%npp_timeintegrated = this%npp_timeintegrated_si(c) + sites(s)%hr_timeintegrated = this%hr_timeintegrated_si(c) + sites(s)%totecosysc_old = this%totecosys_old_si(c) + sites(s)%totfatesc_old = this%tot_fatesc_old_si(c) + sites(s)%totbgcc_old = this%tot_bgcc_old_si(c) + sites(s)%cbal_err_fates = this%cbal_err_fates_si(c) + sites(s)%cbal_err_bgc = this%cbal_err_bgc_si(c) + sites(s)%cbal_err_tot = this%cbal_err_tot_si(c) + sites(s)%fates_to_bgc_this_ts = this%fates_to_bgc_this_ts_si(c) + sites(s)%fates_to_bgc_last_ts = this%fates_to_bgc_last_ts_si(c) + sites(s)%seed_rain_flux = this%seedrain_flux_si(c) enddo diff --git a/main/HistoryIOMod.F90 b/main/HistoryIOMod.F90 index 15ffaee1..08c7cbc8 100644 --- a/main/HistoryIOMod.F90 +++ b/main/HistoryIOMod.F90 @@ -88,7 +88,7 @@ Module HistoryIOMod integer, private :: ih_seed_stock_si integer, private :: ih_cbal_err_fates_si integer, private :: ih_cbal_err_bgc_si - integer, private :: ih_cbal_err_total_si + integer, private :: ih_cbal_err_tot_si integer, private :: ih_npatches_si integer, private :: ih_ncohorts_si @@ -242,24 +242,21 @@ Module HistoryIOMod ! =================================================================================== subroutine update_history_cbal(this,nc,sites,nsites) - !ptr_col=this%seed_stock_col) - !ptr_col=this%cwd_stock_col) - !ptr_col=this%ed_litter_stock_col) - !ptr_col=this%biomass_stock_col) - !ptr_col=this%cbalance_error_total_col) - !ptr_col=this%cbalance_error_bgc_col) - !ptr_col=this%cbalance_error_ed_col) - ! ptr_col=this%totecosysc_col) - ! ptr_col=this%nbp_col) - ! ptr_col=this%fire_c_to_atm_col) - ! ptr_col=this%nep_col) - - ! Locals - integer :: s ! The local site index - integer :: io_si ! The site index of the IO array - - - associate( hio_nep_si => this%hvars(ih_nep_si)%r81d, & + + use EDtypesMod , only : ed_site_type + + ! Arguments + class(fates_hio_interface_type) :: this + integer , intent(in) :: nc ! clump index + type(ed_site_type) , intent(inout), target :: sites(nsites) + integer , intent(in) :: nsites + + ! Locals + integer :: s ! The local site index + integer :: io_si ! The site index of the IO array + + + associate( hio_nep_si => this%hvars(ih_nep_si)%r81d, & hio_nbp_si => this%hvars(ih_nbp_si)%r81d, & hio_fire_c_to_atm_si => this%hvars(ih_fire_c_to_atm_si)%r81d, & hio_totecosysc_si => this%hvars(ih_totecosysc_si)%r81d, & From 47005a52cdd4dd35e56fad9515440236af45a8d5 Mon Sep 17 00:00:00 2001 From: ckoven Date: Thu, 1 Sep 2016 11:39:32 -0700 Subject: [PATCH 188/437] fixed old patch fusion issue and also moved patch fusion threshold parameter to EDTypesMod --- biogeochem/EDPatchDynamicsMod.F90 | 16 ++++++---------- main/EDTypesMod.F90 | 3 ++- 2 files changed, 8 insertions(+), 11 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 3ae1337d..a8c47504 100755 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -996,6 +996,7 @@ subroutine fuse_patches( csite ) ! Decide to fuse patches if their cohort structures are similar ! ! !USES: + use EDTypesMod , only : patchfusion_profile_tolerance ! ! !ARGUMENTS: type(ed_site_type), intent(inout), target :: csite @@ -1017,7 +1018,7 @@ subroutine fuse_patches( csite ) currentSite => csite - profiletol = 0.6_r8 !start off with a very small profile tol, or a predefined parameter? + profiletol = patchfusion_profile_tolerance nopatches = 0 currentPatch => currentSite%youngest_patch @@ -1411,6 +1412,7 @@ subroutine patch_pft_size_profile(cp_pnt) real(r8) :: delta_dbh ! Size of DBH bin integer :: p ! Counter for PFT integer :: j ! Counter for DBH bins + real(r8), parameter :: gigantictrees = 1.e8_r8 !--------------------------------------------------------------------- currentPatch => cp_pnt @@ -1427,6 +1429,9 @@ subroutine patch_pft_size_profile(cp_pnt) if (j == 1) then mind(j) = 0.0_r8 maxd(j) = delta_dbh + else if (j == N_DBH_BINS) then + mind(j) = (j-1) * delta_dbh + maxd(j) = gigantictrees else mind(j) = (j-1) * delta_dbh maxd(j) = (j)*delta_dbh @@ -1444,15 +1449,6 @@ subroutine patch_pft_size_profile(cp_pnt) 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 diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index bbf86899..7acf0b31 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -56,9 +56,10 @@ module EDTypesMod 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 + real(r8), parameter :: FUSETOL = 0.05_r8 ! min fractional difference in dbh between cohorts ! PATCH FUSION + real(r8), parameter :: patchfusion_profile_tolerance = 0.05_r8 ! minimum fraction in difference in profiles between patches 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 From 65515899210040b5ee1f091cbbaf24aba2dcbd38 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 1 Sep 2016 13:13:23 -0700 Subject: [PATCH 189/437] Syntax cleaning, zerod sites(s)%fates_to_bgc_this_ts which may had been uninitialized on cold-starts --- main/EDCLMLinkMod.F90 | 9 ++++++++- main/EDInitMod.F90 | 4 ++++ main/EDRestVectorMod.F90 | 10 +++++----- main/FatesInterfaceMod.F90 | 1 + main/HistoryIOMod.F90 | 1 + 5 files changed, 19 insertions(+), 6 deletions(-) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index edceafda..9674b10b 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -27,6 +27,10 @@ module EDCLMLinkMod ! implicit none private + + public :: SummarizeNetFluxes + public :: ED_BGC_Carbon_Balancecheck + ! logical :: DEBUG = .false. ! for debugging this module (EDCLMLinkMod.F90) @@ -1201,7 +1205,8 @@ subroutine SummarizeNetFluxes( sites, nsites, bc_in, is_beg_day ) currentCohort => currentPatch%tallest do while(associated(currentCohort)) - ! for quantities that are natively at column level or higher, calculate plant density using whole area (for grid cell averages) + ! for quantities that are natively at column level or higher, + ! calculate plant density using whole area (for grid cell averages) n_perm2 = currentCohort%n/AREA ! map biomass pools to column level @@ -1281,6 +1286,8 @@ subroutine ED_BGC_Carbon_Balancecheck(sites, nsites, bc_in, is_beg_day, dtime, n real(r8) :: error_tolerance = 1.e-6_r8 integer :: s + ! TODO: THIS INITIALIZATION SHOULD BE IN AN INITIALIZATION PART OF THE CODE + ! COLD-START PORTION, NSTEP IS >1 FOR RESTARTS RIGHT? (RGK) if (nstep .le. 1) then ! when starting up the model, initialize the integrator variables do s = 1,nsites diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 29a370c0..a76e1edc 100755 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -79,6 +79,10 @@ subroutine zero_site( site_in ) 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 + ! BGC Balance Checks + site_in%fates_to_bgc_this_ts = 0.0_r8 + site_in%fates_to_bgc_last_ts = 0.0_r8 + end subroutine zero_site ! ============================================================================ diff --git a/main/EDRestVectorMod.F90 b/main/EDRestVectorMod.F90 index 48410479..2c2e8131 100755 --- a/main/EDRestVectorMod.F90 +++ b/main/EDRestVectorMod.F90 @@ -881,10 +881,6 @@ subroutine doVectorIO( this, ncid, flag ) dim1name='column', long_name='', units='', & interpinic_flag='interp', readvar=readvar, data=this%hr_timeintegrated_si) - call restartvar(ncid=ncid, flag=flag, varname='totecosysc_old_col', xtype=ncd_double, & - dim1name='column', long_name='', units='', & - interpinic_flag='interp', readvar=readvar, data=this%totecosys_old_si) - call restartvar(ncid=ncid, flag=flag, varname='cbalance_error_ed_col', xtype=ncd_double, & dim1name='column', long_name='', units='', & interpinic_flag='interp', readvar=readvar, data=this%cbal_err_fates_si) @@ -896,7 +892,11 @@ subroutine doVectorIO( this, ncid, flag ) call restartvar(ncid=ncid, flag=flag, varname='cbalance_error_total_col', xtype=ncd_double, & dim1name='column', long_name='', units='', & interpinic_flag='interp', readvar=readvar, data=this%cbal_err_tot_si) - + + call restartvar(ncid=ncid, flag=flag, varname='totecosysc_old_col', xtype=ncd_double, & + dim1name='column', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%totecosys_old_si) + call restartvar(ncid=ncid, flag=flag, varname='totedc_old_col', xtype=ncd_double, & dim1name='column', long_name='', units='', & interpinic_flag='interp', readvar=readvar, data=this%tot_fatesc_old_si) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index e82c822e..8f0740e6 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -329,6 +329,7 @@ subroutine allocate_bcin(bc_in) allocate(bc_in%albgr_dir_rb(cp_numSWb)) allocate(bc_in%albgr_dif_rb(cp_numSWb)) + ! Carbon Balance Checking diff --git a/main/HistoryIOMod.F90 b/main/HistoryIOMod.F90 index 08c7cbc8..a2db4831 100644 --- a/main/HistoryIOMod.F90 +++ b/main/HistoryIOMod.F90 @@ -223,6 +223,7 @@ Module HistoryIOMod procedure, public :: update_history_dyn procedure, public :: update_history_prod + procedure, public :: update_history_cbal procedure, public :: define_history_vars procedure, public :: set_history_var procedure, public :: init_iovar_dk_maps From 6cb32555182836e27128b8431f56deff91764f99 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 1 Sep 2016 16:00:23 -0700 Subject: [PATCH 190/437] somehow the order of sites, nsites and fcolumn got swapped on the call to SummarizeNetFluxes, fixed it --- main/EDCLMLinkMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index af4d8070..efbcb713 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -1154,7 +1154,7 @@ end subroutine ed_clm_leaf_area_profile !------------------------------------------------------------------------ subroutine SummarizeNetFluxes(this, bounds, num_soilc, filter_soilc, & - sites, nsites, fcolumn, soilbiogeochem_carbonflux_inst, & + nsites, sites, fcolumn, soilbiogeochem_carbonflux_inst, & soilbiogeochem_carbonstate_inst) ! Summarize the combined production and decomposition fluxes into net fluxes From 0e980328b7a35dd03c876c9fe76691a0ae719dff Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 2 Sep 2016 13:36:32 -0700 Subject: [PATCH 191/437] As suggested by bandre-ucar, 1) changed iulogs in HistoryIO to use fates internals, 2) removed excessive code for string parsing and now using the scan() intrinsice and 3) changed argument order on nsites so that it comes first (for NAG). --- biogeophys/EDAccumulateFluxesMod.F90 | 2 +- main/FatesUtilsMod.F90 | 111 ++------------------------- main/HistoryIOMod.F90 | 82 ++++++++++++-------- 3 files changed, 57 insertions(+), 138 deletions(-) diff --git a/biogeophys/EDAccumulateFluxesMod.F90 b/biogeophys/EDAccumulateFluxesMod.F90 index b87a7202..78563a3a 100644 --- a/biogeophys/EDAccumulateFluxesMod.F90 +++ b/biogeophys/EDAccumulateFluxesMod.F90 @@ -21,7 +21,7 @@ module EDAccumulateFluxesMod !------------------------------------------------------------------------------ - subroutine AccumulateFluxes_ED(sites, nsites, bc_in, bc_out, dt_time) + subroutine AccumulateFluxes_ED(nsites, sites, bc_in, bc_out, dt_time) ! ! !DESCRIPTION: diff --git a/main/FatesUtilsMod.F90 b/main/FatesUtilsMod.F90 index 20557310..08bf3069 100644 --- a/main/FatesUtilsMod.F90 +++ b/main/FatesUtilsMod.F90 @@ -17,113 +17,18 @@ function check_hlm_list(hlms,hlm_name) result(astatus) character(len=*),intent(in) :: hlms character(len=*),intent(in) :: hlm_name + integer :: index logical :: astatus - integer :: nargs,ih - character(len=16),dimension(10) :: args - - call parse(hlms,':', args, nargs) + astatus = .false. - do ih=1,nargs - if(trim(args(ih)).eq.trim(hlm_name))then - astatus = .true. - return - end if - end do + index = scan(trim(hlms),trim(hlm_name)) + + if(index>0)then + astatus=.true. + end if return + end function check_hlm_list - ! ==================================================================================== - - - subroutine parse(str,delims,args,nargs) - - ! ---------------------------------------------------------------------------------- - ! Original Code by: George Benthien - ! Stripped down for simplified use by RGK - ! Parses the string 'str' into arguments args(1), ..., args(nargs) based on - ! the delimiters contained in the string 'delims'. Preceding a delimiter in - ! 'str' by a backslash (\) makes this particular instance not a delimiter. - ! The integer output variable nargs contains the number of arguments found. - ! --------------------------------------------------------------------------------- - - character(len=*),intent(in) :: str - character(len=*),intent(in) :: delims - character(len=len_trim(str)) :: strsav - character(len=*),dimension(:) :: args - integer,intent(out) :: nargs - integer :: i,na,k,lenstr - - strsav=str - na=size(args) - do i=1,na - args(i)=' ' - end do - nargs=0 - lenstr=len_trim(strsav) - if(lenstr==0) return - k=0 - do - if(len_trim(strsav) == 0) exit - nargs=nargs+1 - call split(strsav,delims,args(nargs)) - end do - - end subroutine parse - - ! ==================================================================================== - - subroutine split(str,delims,before) - - ! ---------------------------------------------------------------------------------- - ! OriGeorge Benthen - ! Routine finds the first instance of a character from 'delims' in the - ! the string 'str'. The characters before the found delimiter are - ! output in 'before'. The characters after the found delimiter are - ! output in 'str'. The optional output character 'sep' contains the - ! found delimiter. - ! ---------------------------------------------------------------------------------- - - character(len=*) :: str,delims,before - character(len=64) :: strtemp - character :: ch, cha - integer :: lenstr,k,i,iposa,ipos - - lenstr=len_trim(str) - if(lenstr == 0) return ! string str is empty - k=0 - before=' ' - do i=1,lenstr - ch=str(i:i) - ipos=index(delims,ch) - if(ipos == 0) then ! character is not a delimiter - k=k+1 - before(k:k)=ch - cycle - end if - if(ch /= ' ') then ! character is a delimiter that is not a space - strtemp=str(i+1:) - str = strtemp - exit - end if - cha=str(i+1:i+1) ! character is a space delimiter - iposa=index(delims,cha) - if(iposa > 0) then ! next character is a delimiter - strtemp=str(i+2:) - str = strtemp - exit - else - strtemp=str(i+1:) - str = strtemp - exit - end if - end do - - if(i >= lenstr) str='' - str=adjustl(str) ! remove initial spaces - - return - - end subroutine split - end module FatesUtilsMod diff --git a/main/HistoryIOMod.F90 b/main/HistoryIOMod.F90 index c0ef7c0f..ed9aaf1b 100644 --- a/main/HistoryIOMod.F90 +++ b/main/HistoryIOMod.F90 @@ -2,7 +2,7 @@ Module HistoryIOMod use shr_kind_mod , only : r8 => shr_kind_r8 - use clm_varctl , only : iulog + use FatesGlobals , only : fates_log use EDTypesMod , only : cp_hio_ignore_val use pftconMod , only : pftcon @@ -241,7 +241,7 @@ Module HistoryIOMod ! ==================================================================================== - subroutine update_history_dyn(this,nc,sites,nsites,fcolumn) + subroutine update_history_dyn(this,nc,nsites,sites,fcolumn) ! --------------------------------------------------------------------------------- ! This is the call to update the history IO arrays that are expected to only change @@ -259,8 +259,8 @@ subroutine update_history_dyn(this,nc,sites,nsites,fcolumn) ! Arguments class(fates_hio_interface_type) :: this integer , intent(in) :: nc ! clump index - type(ed_site_type) , intent(inout), target :: sites(nsites) integer , intent(in) :: nsites + type(ed_site_type) , intent(inout), target :: sites(nsites) integer , intent(in) :: fcolumn(nsites) ! Locals @@ -438,28 +438,39 @@ subroutine update_history_dyn(this,nc,sites,nsites,fcolumn) ! have any meaning, otherwise they are just inialization values if( .not.(ccohort%isnew) ) then - hio_gpp_si_scpf(io_si,scpf) = hio_gpp_si_scpf(io_si,scpf) + n_perm2*ccohort%gpp ! [kgC/m2/yr] - hio_npp_totl_si_scpf(io_si,scpf) = hio_npp_totl_si_scpf(io_si,scpf) + ccohort%npp*n_perm2 - hio_npp_leaf_si_scpf(io_si,scpf) = hio_npp_leaf_si_scpf(io_si,scpf) + ccohort%npp_leaf*n_perm2 - hio_npp_fnrt_si_scpf(io_si,scpf) = hio_npp_fnrt_si_scpf(io_si,scpf) + ccohort%npp_froot*n_perm2 - hio_npp_bgsw_si_scpf(io_si,scpf) = hio_npp_bgsw_si_scpf(io_si,scpf) + ccohort%npp_bsw*(1._r8-ED_val_ag_biomass)*n_perm2 - hio_npp_agsw_si_scpf(io_si,scpf) = hio_npp_agsw_si_scpf(io_si,scpf) + ccohort%npp_bsw*ED_val_ag_biomass*n_perm2 - hio_npp_bgdw_si_scpf(io_si,scpf) = hio_npp_bgdw_si_scpf(io_si,scpf) + ccohort%npp_bdead*(1._r8-ED_val_ag_biomass)*n_perm2 - hio_npp_agdw_si_scpf(io_si,scpf) = hio_npp_agdw_si_scpf(io_si,scpf) + ccohort%npp_bdead*ED_val_ag_biomass*n_perm2 - hio_npp_seed_si_scpf(io_si,scpf) = hio_npp_seed_si_scpf(io_si,scpf) + ccohort%npp_bseed*n_perm2 - hio_npp_stor_si_scpf(io_si,scpf) = hio_npp_stor_si_scpf(io_si,scpf) + ccohort%npp_store*n_perm2 + hio_gpp_si_scpf(io_si,scpf) = hio_gpp_si_scpf(io_si,scpf) + & + n_perm2*ccohort%gpp ! [kgC/m2/yr] + hio_npp_totl_si_scpf(io_si,scpf) = hio_npp_totl_si_scpf(io_si,scpf) + & + ccohort%npp*n_perm2 + hio_npp_leaf_si_scpf(io_si,scpf) = hio_npp_leaf_si_scpf(io_si,scpf) + & + ccohort%npp_leaf*n_perm2 + hio_npp_fnrt_si_scpf(io_si,scpf) = hio_npp_fnrt_si_scpf(io_si,scpf) + & + ccohort%npp_froot*n_perm2 + hio_npp_bgsw_si_scpf(io_si,scpf) = hio_npp_bgsw_si_scpf(io_si,scpf) + & + ccohort%npp_bsw*(1._r8-ED_val_ag_biomass)*n_perm2 + hio_npp_agsw_si_scpf(io_si,scpf) = hio_npp_agsw_si_scpf(io_si,scpf) + & + ccohort%npp_bsw*ED_val_ag_biomass*n_perm2 + hio_npp_bgdw_si_scpf(io_si,scpf) = hio_npp_bgdw_si_scpf(io_si,scpf) + & + ccohort%npp_bdead*(1._r8-ED_val_ag_biomass)*n_perm2 + hio_npp_agdw_si_scpf(io_si,scpf) = hio_npp_agdw_si_scpf(io_si,scpf) + & + ccohort%npp_bdead*ED_val_ag_biomass*n_perm2 + hio_npp_seed_si_scpf(io_si,scpf) = hio_npp_seed_si_scpf(io_si,scpf) + & + ccohort%npp_bseed*n_perm2 + hio_npp_stor_si_scpf(io_si,scpf) = hio_npp_stor_si_scpf(io_si,scpf) + & + ccohort%npp_store*n_perm2 if( abs(ccohort%npp-(ccohort%npp_leaf+ccohort%npp_froot+ & ccohort%npp_bsw+ccohort%npp_bdead+ & ccohort%npp_bseed+ccohort%npp_store))>1.e-9) then - write(iulog,*) 'NPP Partitions are not balancing' - write(iulog,*) 'Fractional Error: ',abs(ccohort%npp-(ccohort%npp_leaf+ccohort%npp_froot+ & + write(fates_log(),*) 'NPP Partitions are not balancing' + write(fates_log(),*) 'Fractional Error: ', & + abs(ccohort%npp-(ccohort%npp_leaf+ccohort%npp_froot+ & ccohort%npp_bsw+ccohort%npp_bdead+ & ccohort%npp_bseed+ccohort%npp_store))/ccohort%npp - write(iulog,*) 'Terms: ',ccohort%npp,ccohort%npp_leaf,ccohort%npp_froot, & + write(fates_log(),*) 'Terms: ',ccohort%npp,ccohort%npp_leaf,ccohort%npp_froot, & ccohort%npp_bsw,ccohort%npp_bdead, & ccohort%npp_bseed,ccohort%npp_store - write(iulog,*) ' NPP components during FATES-HLM linking does not balance ' + write(fates_log(),*) ' NPP components during FATES-HLM linking does not balance ' stop ! we need termination control for FATES!!! ! call endrun(msg=errMsg(__FILE__, __LINE__)) end if @@ -524,9 +535,12 @@ subroutine update_history_dyn(this,nc,sites,nsites,fcolumn) hio_litter_out_pa(io_pa) = (sum(cpatch%CWD_AG_out)+sum(cpatch%leaf_litter_out)) & * 1.e3_r8 * 365.0_r8 * daysecs * patch_scaling_scalar hio_seed_bank_pa(io_pa) = sum(cpatch%seed_bank) * 1.e3_r8 * patch_scaling_scalar - hio_seeds_in_pa(io_pa) = sum(cpatch%seeds_in) * 1.e3_r8 * 365.0_r8 * daysecs * patch_scaling_scalar - hio_seed_decay_pa(io_pa) = sum(cpatch%seed_decay) * 1.e3_r8 * 365.0_r8 * daysecs * patch_scaling_scalar - hio_seed_germination_pa(io_pa) = sum(cpatch%seed_germination) * 1.e3_r8 * 365.0_r8 * daysecs * patch_scaling_scalar + hio_seeds_in_pa(io_pa) = sum(cpatch%seeds_in) * & + 1.e3_r8 * 365.0_r8 * daysecs * patch_scaling_scalar + hio_seed_decay_pa(io_pa) = sum(cpatch%seed_decay) & + * 1.e3_r8 * 365.0_r8 * daysecs * patch_scaling_scalar + hio_seed_germination_pa(io_pa) = sum(cpatch%seed_germination) & + * 1.e3_r8 * 365.0_r8 * daysecs * patch_scaling_scalar hio_canopy_spread_pa(io_pa) = cpatch%spread(1) @@ -545,7 +559,7 @@ end subroutine update_history_dyn ! ====================================================================================== - subroutine update_history_prod(this,nc,sites,nsites,fcolumn,dt_tstep) + subroutine update_history_prod(this,nc,nsites,sites,fcolumn,dt_tstep) ! --------------------------------------------------------------------------------- ! This is the call to update the history IO arrays that are expected to only change @@ -559,8 +573,8 @@ subroutine update_history_prod(this,nc,sites,nsites,fcolumn,dt_tstep) ! Arguments class(fates_hio_interface_type) :: this integer , intent(in) :: nc ! clump index - type(ed_site_type) , intent(inout), target :: sites(nsites) integer , intent(in) :: nsites + type(ed_site_type) , intent(inout), target :: sites(nsites) integer , intent(in) :: fcolumn(nsites) real(r8) , intent(in) :: dt_tstep @@ -682,7 +696,7 @@ subroutine flush_hvars(this,nc,upfreq_in) case('PA_INT') hvar%int1d(lb1:ub1) = nint(hvar%flushval) case default - write(iulog,*) 'iotyp undefined while flushing history variables' + write(fates_log(),*) 'iotyp undefined while flushing history variables' stop !end_run end select @@ -728,7 +742,7 @@ subroutine define_history_vars(this,callstep,nvar) integer :: ivar if(.not. (trim(callstep).eq.'count' .or. trim(callstep).eq.'initialize') ) then - write(iulog,*) 'defining history variables in FATES requires callstep count or initialize' + write(fates_log(),*) 'defining history variables in FATES requires callstep count or initialize' ! end_run('MESSAGE') end if @@ -1122,8 +1136,8 @@ subroutine set_history_var(this,vname,units,long,use_default,avgflag,vtype,hlms, case('SI_SCPF_R8') allocate(hvar%r82d(lb1:ub1,lb2:ub2)) case default - write(iulog,*) 'Incompatible vtype passed to set_history_var' - write(iulog,*) 'vtype = ',trim(vtype),' ?' + write(fates_log(),*) 'Incompatible vtype passed to set_history_var' + write(fates_log(),*) 'vtype = ',trim(vtype),' ?' stop ! end_run end select @@ -1295,9 +1309,9 @@ subroutine set_dim_ptrs(this,dk_name,idim,dim_target) ! First check to see if the dimension is allocated if(this%iovar_dk(ityp)%ndims Date: Fri, 2 Sep 2016 14:02:28 -0700 Subject: [PATCH 192/437] cleaned up some some patch%site pointers and made them explicit site arguments --- biogeochem/EDPhysiologyMod.F90 | 70 +++++++++++++++++----------------- main/EDMainMod.F90 | 6 +-- 2 files changed, 37 insertions(+), 39 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 9888fb0c..620b1a47 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -27,15 +27,15 @@ module EDPhysiologyMod public :: non_canopy_derivs public :: trim_canopy public :: phenology - public :: phenology_leafonoff - public :: Growth_Derivatives + private :: phenology_leafonoff + private :: Growth_Derivatives public :: recruitment - public :: cwd_input - public :: cwd_out - public :: fragmentation_scaler - public :: seeds_in - public :: seed_decay - public :: seed_germination + private :: cwd_input + private :: cwd_out + private :: fragmentation_scaler + private :: seeds_in + private :: seed_decay + private :: seed_germination public :: flux_into_litter_pools logical, parameter :: DEBUG = .false. ! local debug flag @@ -45,7 +45,7 @@ module EDPhysiologyMod contains ! ============================================================================ - subroutine canopy_derivs( currentPatch ) + subroutine canopy_derivs( currentSite, currentPatch ) ! ! !DESCRIPTION: ! spawn new cohorts of juveniles of each PFT @@ -53,6 +53,7 @@ subroutine canopy_derivs( currentPatch ) ! !USES: ! ! !ARGUMENTS + type(ed_site_type), intent(inout), target :: currentSite type(ed_patch_type) , intent(inout), target :: currentPatch ! ! !LOCAL VARIABLES: @@ -64,7 +65,7 @@ subroutine canopy_derivs( currentPatch ) currentCohort => currentPatch%shortest do while(associated(currentCohort)) - call Growth_Derivatives(currentCohort) + call Growth_Derivatives(currentSite, currentCohort) currentCohort => currentCohort%taller enddo @@ -103,13 +104,13 @@ subroutine non_canopy_derivs( currentSite, currentPatch, temperature_inst ) currentPatch%seed_germination(:) = 0.0_r8 ! update seed fluxes - call seeds_in(currentPatch) - call seed_decay(currentPatch) - call seed_germination(currentPatch) + call seeds_in(currentSite, currentPatch) + call seed_decay(currentSite, currentPatch) + call seed_germination(currentSite, currentPatch) ! update fragmenting pool fluxes call cwd_input(currentPatch) - call cwd_out( currentPatch, temperature_inst) + call cwd_out( currentSite, currentPatch, temperature_inst) do p = 1,numpft_ed currentSite%dseed_dt(p) = currentSite%dseed_dt(p) + (currentPatch%seeds_in(p) - currentPatch%seed_decay(p) - currentPatch%seed_germination(p)) * currentPatch%area/AREA @@ -632,7 +633,7 @@ end subroutine phenology_leafonoff ! ============================================================================ - subroutine seeds_in( cp_pnt ) + subroutine seeds_in( currentSite, cp_pnt ) ! ! !DESCRIPTION: ! Flux from plants into seed pool. @@ -641,17 +642,16 @@ subroutine seeds_in( cp_pnt ) use EDTypesMod, only : AREA ! ! !ARGUMENTS + type(ed_site_type), intent(inout), target :: currentSite 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 @@ -668,7 +668,7 @@ subroutine seeds_in( cp_pnt ) 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 - currentPatch%siteptr%seed_rain_flux(p) = currentPatch%siteptr%seed_rain_flux(p) + EDecophyscon%seed_rain(p) * currentPatch%area/AREA !KgC/m2/year + currentSite%seed_rain_flux(p) = currentSite%seed_rain_flux(p) + EDecophyscon%seed_rain(p) * currentPatch%area/AREA !KgC/m2/year enddo endif currentPatch => currentPatch%younger @@ -677,7 +677,7 @@ subroutine seeds_in( cp_pnt ) end subroutine seeds_in ! ============================================================================ - subroutine seed_decay( currentPatch ) + subroutine seed_decay( currentSite, currentPatch ) ! ! !DESCRIPTION: ! Flux from seed pool into leaf litter pool @@ -685,6 +685,7 @@ subroutine seed_decay( currentPatch ) ! !USES: ! ! !ARGUMENTS + type(ed_site_type), intent(inout), target :: currentSite type(ed_patch_type),intent(inout) :: currentPatch ! seeds go to these patches. ! ! !LOCAL VARIABLES: @@ -696,13 +697,13 @@ subroutine seed_decay( currentPatch ) ! decays the seed pool according to exponential model ! sd_mort is in yr-1 do p = 1,numpft_ed - currentPatch%seed_decay(p) = currentPatch%siteptr%seed_bank(p) * seed_turnover + currentPatch%seed_decay(p) = currentSite%seed_bank(p) * seed_turnover enddo end subroutine seed_decay ! ============================================================================ - subroutine seed_germination( currentPatch ) + subroutine seed_germination( currentSite, currentPatch ) ! ! !DESCRIPTION: ! Flux from seed pool into sapling pool @@ -710,6 +711,7 @@ subroutine seed_germination( currentPatch ) ! !USES: ! ! !ARGUMENTS + type(ed_site_type), intent(inout), target :: currentSite type(ed_patch_type),intent(inout) :: currentPatch ! seeds go to these patches. ! ! !LOCAL VARIABLES: @@ -722,13 +724,13 @@ subroutine seed_germination( currentPatch ) max_germination = 1.0_r8 !this is arbitrary do p = 1,numpft_ed - currentPatch%seed_germination(p) = min(currentPatch%siteptr%seed_bank(p) * germination_timescale,max_germination) + currentPatch%seed_germination(p) = min(currentSite%seed_bank(p) * germination_timescale,max_germination) enddo end subroutine seed_germination ! ============================================================================ - subroutine Growth_Derivatives( currentCohort) + subroutine Growth_Derivatives( currentSite, currentCohort) ! ! !DESCRIPTION: ! Main subroutine controlling growth and allocation derivatives @@ -738,10 +740,10 @@ subroutine Growth_Derivatives( currentCohort) use EDTypesMod , only : udata ! ! !ARGUMENTS + type(ed_site_type), intent(inout), target :: currentSite 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 @@ -759,8 +761,6 @@ subroutine Growth_Derivatives( currentCohort) 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 @@ -979,7 +979,7 @@ subroutine Growth_Derivatives( currentCohort) end subroutine Growth_Derivatives ! ============================================================================ - subroutine recruitment( t, currentPatch ) + subroutine recruitment( t, currentSite, currentPatch ) ! ! !DESCRIPTION: ! spawn new cohorts of juveniles of each PFT @@ -990,6 +990,7 @@ subroutine recruitment( t, currentPatch ) ! ! !ARGUMENTS integer, intent(in) :: t + type(ed_site_type), intent(inout), target :: currentSite type(ed_patch_type), intent(inout), pointer :: currentPatch ! ! !LOCAL VARIABLES: @@ -1023,18 +1024,18 @@ subroutine recruitment( t, currentPatch ) endif temp_cohort%laimemory = 0.0_r8 - if (pftcon%season_decid(temp_cohort%pft) == 1.and.currentPatch%siteptr%status == 1)then + if (pftcon%season_decid(temp_cohort%pft) == 1.and.currentSite%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 + if (pftcon%stress_decid(temp_cohort%pft) == 1.and.currentSite%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 + cohortstatus = currentSite%status if (pftcon%stress_decid(ft) == 1)then !drought decidous, override status. - cohortstatus = currentPatch%siteptr%dstatus + cohortstatus = currentSite%dstatus endif if (temp_cohort%n > 0.0_r8 )then @@ -1154,7 +1155,6 @@ subroutine fragmentation_scaler( currentPatch, temperature_inst ) ! ! !LOCAL VARIABLES: logical :: use_century_tfunc = .false. - type(ed_site_type), pointer :: currentSite integer :: p,j real(r8) :: t_scalar real(r8) :: w_scalar @@ -1172,7 +1172,6 @@ subroutine fragmentation_scaler( currentPatch, temperature_inst ) catanf_30 = catanf(30._r8) -! c = currentPatch%siteptr%clmcolumn p = currentPatch%clm_pno ! set "froz_q10" parameter @@ -1204,7 +1203,7 @@ subroutine fragmentation_scaler( currentPatch, temperature_inst ) end subroutine fragmentation_scaler ! ============================================================================ - subroutine cwd_out( currentPatch, temperature_inst ) + subroutine cwd_out( currentSite, currentPatch, temperature_inst ) ! ! !DESCRIPTION: ! Simple CWD fragmentation Model @@ -1215,15 +1214,14 @@ subroutine cwd_out( currentPatch, temperature_inst ) use EDTypesMod , only : udata ! ! !ARGUMENTS + type(ed_site_type), intent(inout), target :: currentSite type(ed_patch_type) , intent(inout), target :: currentPatch type(temperature_type) , intent(in) :: temperature_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 diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 02662b50..5a651473 100755 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -86,7 +86,7 @@ subroutine ed_ecosystem_dynamics(currentSite, & do while (associated(currentPatch)) ! adds small cohort of each PFT - call recruitment(0,currentPatch) + call recruitment(0, currentSite, currentPatch) currentPatch => currentPatch%younger enddo @@ -173,7 +173,7 @@ subroutine ed_integrate_state_variables(currentSite, temperature_inst ) endif ! Find the derivatives of the growth and litter processes. - call canopy_derivs(currentPatch) + call canopy_derivs(currentSite, currentPatch) ! Update Canopy Biomass Pools currentCohort => currentPatch%shortest @@ -336,7 +336,7 @@ subroutine ed_update_site( currentSite ) ! 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) + !call recruitment(1, currentSite, currentPatch) ! write(iulog,*) 'patch empty',currentPatch%area,currentPatch%age endif From e341edf609e2aa9a79372e93ff6e27e84ec2f8c5 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 2 Sep 2016 16:57:00 -0700 Subject: [PATCH 193/437] Cleaned up checks and balances routines and moved them to their own module. --- main/ChecksBalancesMod.F90 | 243 ++++++++++++++++ main/EDCLMLinkMod.F90 | 563 +------------------------------------ 2 files changed, 244 insertions(+), 562 deletions(-) create mode 100644 main/ChecksBalancesMod.F90 diff --git a/main/ChecksBalancesMod.F90 b/main/ChecksBalancesMod.F90 new file mode 100644 index 00000000..d946f9d9 --- /dev/null +++ b/main/ChecksBalancesMod.F90 @@ -0,0 +1,243 @@ +module ChecksBalancesMod + + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_const_mod, only: SHR_CONST_CDAY + + implicit none + + private + public :: SummarizeNetFluxes + public :: FATES_BGC_Carbon_Balancecheck + +contains + + !------------------------------------------------------------------------ + + subroutine SummarizeNetFluxes( nsites, sites, bc_in, is_beg_day ) + + ! Summarize the combined production and decomposition fluxes into net fluxes + ! This is done on the fast timestep, and to be called after both daily ED calls and + ! fast BGC calls. Does not include summarization of fast-timestsp productivity calls + ! because these must be summarized prior to daily ED calls + ! + ! Written by Charlie Koven, Feb 2016 + ! + ! !USES: + use FatesInterfaceMod , only : bc_in_type + use EDtypesMod , only : ed_site_type,ed_patch_type,ed_cohort_type + use EDtypesMod , only : AREA + ! + implicit none + ! + ! !ARGUMENTS + + integer , intent(in) :: nsites + type(ed_site_type) , intent(inout), target :: sites(nsites) + type(bc_in_type) , intent(in) :: bc_in(nsites) + logical , intent(in) :: is_beg_day + + ! + ! !LOCAL VARIABLES: + integer :: s + + type (ed_patch_type) , pointer :: currentPatch + type (ed_cohort_type) , pointer :: currentCohort + real(r8) :: n_perm2 ! individuals per m2 of the whole column + + do s = 1,nsites + + sites(s)%fire_c_to_atm = 0._r8 ! REMOVE THIS VARIABLE? + sites(s)%ed_litter_stock = 0._r8 + sites(s)%cwd_stock = 0._r8 + sites(s)%seed_stock = 0._r8 + sites(s)%biomass_stock = 0._r8 + + ! map ed site-level fire fluxes to clm column fluxes + sites(s)%fire_c_to_atm = sites(s)%total_burn_flux_to_atm / & + ( AREA * SHR_CONST_CDAY * 1.e3_r8) + + currentPatch => sites(s)%oldest_patch + do while(associated(currentPatch)) + + ! map litter, CWD, and seed pools to column level + sites(s)%cwd_stock = sites(s)%cwd_stock + & + (currentPatch%area / AREA) * & + (sum(currentPatch%cwd_ag)+sum(currentPatch%cwd_bg)) * 1.e3_r8 + + sites(s)%ed_litter_stock = sites(s)%ed_litter_stock + & + (currentPatch%area / AREA) * & + (sum(currentPatch%leaf_litter)+sum(currentPatch%root_litter)) * 1.e3_r8 + + sites(s)%seed_stock = sites(s)%seed_stock + (currentPatch%area / AREA) * & + sum(currentPatch%seed_bank) * 1.e3_r8 + + currentCohort => currentPatch%tallest + do while(associated(currentCohort)) + ! for quantities that are natively at column level or higher, + ! calculate plant density using whole area (for grid cell averages) + n_perm2 = currentCohort%n/AREA + + ! map biomass pools to column level + sites(s)%biomass_stock = sites(s)%biomass_stock + & + (currentCohort%bdead + currentCohort%balive + & + currentCohort%bstore) * n_perm2 * 1.e3_r8 + + currentCohort => currentCohort%shorter + enddo !currentCohort + currentPatch => currentPatch%younger + end do ! patch loop + + ! calculate NEP and NBP fluxes + sites(s)%nep = sites(s)%npp - bc_in(s)%tot_het_resp + sites(s)%nbp = sites(s)%npp - ( bc_in(s)%tot_het_resp + sites(s)%fire_c_to_atm ) + + ! FATES stocks + sites(s)%totfatesc = sites(s)%ed_litter_stock + sites(s)%cwd_stock + & + sites(s)%seed_stock + sites(s)%biomass_stock + + ! BGC stocks (used for error checking, totlitc should be zero?) + sites(s)%totbgcc = bc_in(s)%tot_somc + bc_in(s)%tot_litc + + ! Total Ecosystem Carbon Stocks + sites(s)%totecosysc = sites(s)%totfatesc + sites(s)%totbgcc + + end do + + ! in FATES timesteps, because of offset between when ED and BGC reconcile the gain + ! and loss of litterfall carbon, (i.e. FATES reconciles it instantly, while BGC + ! reconciles it incrementally over the subsequent day) calculate the total + ! ED -> BGC flux and keep track of the last day's info for balance checking purposes + if ( is_beg_day ) then + ! + do s = 1,nsites + ! order of operations in the next to lines is quite important ;) + sites(s)%fates_to_bgc_last_ts = sites(s)%fates_to_bgc_this_ts + sites(s)%fates_to_bgc_this_ts = 0._r8 + sites(s)%seed_rain_flux = 0._r8 + + currentPatch => sites(s)%oldest_patch + do while(associated(currentPatch)) + ! + sites(s)%fates_to_bgc_this_ts = sites(s)%fates_to_bgc_this_ts + & + (sum(currentPatch%CWD_AG_out) + sum(currentPatch%CWD_BG_out) + & + sum(currentPatch%seed_decay) + sum(currentPatch%leaf_litter_out) + & + sum(currentPatch%root_litter_out)) * & + ( currentPatch%area/AREA ) * 1.e3_r8 / ( 365.0_r8*SHR_CONST_CDAY ) + ! + sites(s)%seed_rain_flux = sites(s)%seed_rain_flux + & + sum(currentPatch%seed_rain_flux) * 1.e3_r8 / ( 365.0_r8*SHR_CONST_CDAY ) + ! + currentPatch => currentPatch%younger + end do !currentPatch + end do + endif + + return + end subroutine SummarizeNetFluxes + + ! ==================================================================================== + + subroutine FATES_BGC_Carbon_Balancecheck(nsites, sites, bc_in, is_beg_day, dtime, nstep) + + ! Integrate in time the fluxes into and out of the ecosystem, and compare these + ! on a daily timestep to the chagne in carbon stocks of the ecosystem + ! + ! Written by Charlie Koven, Feb 2016 + ! + ! !USES: + use FatesInterfaceMod , only : bc_in_type + use EDtypesMod , only : ed_site_type + ! + implicit none + ! + ! !ARGUMENTS + integer , intent(in) :: nsites + type(ed_site_type) , intent(inout), target :: sites(nsites) + type(bc_in_type) , intent(in) :: bc_in(nsites) + logical , intent(in) :: is_beg_day + real(r8) , intent(in) :: dtime ! time-step length (s) + integer , intent(in) :: nstep ! time-step index + + ! !LOCAL VARIABLES: + real(r8) :: error_tolerance = 1.e-6_r8 + integer :: s + + ! TODO: THIS INITIALIZATION SHOULD BE IN AN INITIALIZATION PART OF THE CODE + ! COLD-START PORTION, NSTEP IS >1 FOR RESTARTS RIGHT? (RGK) + if (nstep .le. 1) then + ! when starting up the model, initialize the integrator variables + do s = 1,nsites + sites(s)%totecosysc_old = sites(s)%totecosysc + sites(s)%totfatesc_old = sites(s)%totfatesc + sites(s)%totbgcc_old = sites(s)%totbgcc + sites(s)%nep_timeintegrated = 0._r8 + sites(s)%hr_timeintegrated = 0._r8 + sites(s)%npp_timeintegrated = 0._r8 + ! + ! also initialize the ed-BGC flux variables + sites(s)%fates_to_bgc_this_ts = 0._r8 + sites(s)%fates_to_bgc_last_ts = 0._r8 + ! + sites(s)%cbal_err_fates = 0._r8 + sites(s)%cbal_err_bgc = 0._r8 + sites(s)%cbal_err_tot = 0._r8 + end do + endif + + do s = 1,nsites + sites(s)%nep_timeintegrated = sites(s)%nep_timeintegrated + sites(s)%nep * dtime + sites(s)%hr_timeintegrated = sites(s)%hr_timeintegrated + bc_in(s)%tot_het_resp * dtime + sites(s)%npp_timeintegrated = sites(s)%npp_timeintegrated + sites(s)%npp * dtime + end do + + ! If this is on the dynamics time-step, then we calculate the balance checks + + if ( is_beg_day ) then + + do s = 1,nsites + + ! NBP can only be updated when dynamics level information is available + sites(s)%nbp_integrated = sites(s)%nep_timeintegrated - & + sites(s)%fire_c_to_atm * SHR_CONST_CDAY + & + sites(s)%seed_rain_flux * SHR_CONST_CDAY + + + sites(s)%cbal_err_fates = sites(s)%totfatesc - & + sites(s)%totfatesc_old - & + (sites(s)%npp_timeintegrated + & + sites(s)%seed_rain_flux*SHR_CONST_CDAY - & + sites(s)%fates_to_bgc_this_ts*SHR_CONST_CDAY - & + sites(s)%fire_c_to_atm*SHR_CONST_CDAY) + sites(s)%cbal_err_fates = sites(s)%cbal_err_fates / SHR_CONST_CDAY + + + sites(s)%cbal_err_bgc = sites(s)%totbgcc - & + sites(s)%totbgcc_old - & + (sites(s)%fates_to_bgc_last_ts*SHR_CONST_CDAY - & + sites(s)%hr_timeintegrated) + sites(s)%cbal_err_bgc = sites(s)%cbal_err_bgc / SHR_CONST_CDAY + + sites(s)%cbal_err_tot = sites(s)%totecosysc - & + sites(s)%totecosysc_old - & + (sites(s)%nbp_integrated + & + sites(s)%fates_to_bgc_last_ts*SHR_CONST_CDAY - & + sites(s)%fates_to_bgc_this_ts*SHR_CONST_CDAY) + sites(s)%cbal_err_tot = sites(s)%cbal_err_tot / SHR_CONST_CDAY + + ! Send the current to the previous/last + sites(s)%totecosysc_old = sites(s)%totecosysc + sites(s)%totfatesc_old = sites(s)%totfatesc + sites(s)%totbgcc_old = sites(s)%totbgcc + sites(s)%nep_timeintegrated = 0._r8 + sites(s)%npp_timeintegrated = 0._r8 + sites(s)%hr_timeintegrated = 0._r8 + + end do + + endif + + return + end subroutine FATES_BGC_Carbon_Balancecheck + + +end module ChecksBalancesMod diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 653a8642..b573e344 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -27,10 +27,6 @@ module EDCLMLinkMod ! implicit none private - - public :: SummarizeNetFluxes - public :: ED_BGC_Carbon_Balancecheck - ! logical :: DEBUG = .false. ! for debugging this module (EDCLMLinkMod.F90) @@ -40,78 +36,13 @@ module EDCLMLinkMod type, public :: ed_clm_type - -! 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. - - ! RGK: LEAVING SOME OLD DEFINITIONS IN UNTIL UNIT DISCREPANCIES ARE RECTIFIED - -! 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. -! Vegetation carbon fluxes at the patch scale -! 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 -! real(r8), pointer, private :: ar_patch (:) ! (gC/m2/s) patch autotrophic respiration -! real(r8), pointer, private :: maint_resp_patch (:) ! (gC/m2/s) patch maintenance respiration -! real(r8), pointer, private :: growth_resp_patch (:) ! (gC/m2/s) patch growth respiration - - ! summary carbon fluxes at the column level -! real(r8), pointer, private :: nep_col(:) ! [gC/m2/s] Net ecosystem production, i.e. fast-timescale carbon balance that does not include disturbance -! real(r8), pointer, private :: nep_timeintegrated_col(:) ! [gC/m2/s] Net ecosystem production, i.e. fast-timescale carbon balance that does not include disturbance -! real(r8), pointer, private :: npp_timeintegrated_col(:) ! [gC/m2/s] Net primary production, time integrated at column level for carbon balance checking -! real(r8), pointer, private :: hr_timeintegrated_col(:) ! [gC/m2/s] heterotrophic respiration, time integrated for carbon balance checking -! real(r8), pointer, private :: nbp_col(:) ! [gC/m2/s] Net biosphere production, i.e. slow-timescale carbon balance that integrates to total carbon change -! real(r8), pointer, private :: npp_col(:) ! [gC/m2/s] Net primary production at the fast timescale, aggregated to the column level -! real(r8), pointer, private :: fire_c_to_atm_col(:) ! [gC/m2/s] total fire carbon loss to atmosphere -! real(r8), pointer, private :: ed_to_bgc_this_edts_col(:) ! [gC/m2/s] total flux of carbon from ED to BGC models on current ED timestep -! real(r8), pointer, private :: ed_to_bgc_last_edts_col(:) ! [gC/m2/s] total flux of carbon from ED to BGC models on prior ED timestep -! real(r8), pointer, private :: seed_rain_flux_col(:) ! [gC/m2/s] total flux of carbon from seed rain - - ! summary carbon states at the column level -! real(r8), pointer, private :: totecosysc_col(:) ! [gC/m2] Total ecosystem carbon at the column level, including vegetation, CWD, litter, and soil pools -! real(r8), pointer, private :: totecosysc_old_col(:) ! [gC/m2] Total ecosystem C at the column level from last call to balance check -! real(r8), pointer, private :: totedc_col(:) ! [gC/m2] Total ED carbon at the column level, including vegetation, CWD, seeds, and ED litter -! real(r8), pointer, private :: totedc_old_col(:) ! [gC/m2] Total ED C at the column level from last call to balance check -! real(r8), pointer, private :: totbgcc_col(:) ! [gC/m2] Total BGC carbon at the column level, including litter, and soil pools -! real(r8), pointer, private :: totbgcc_old_col(:) ! [gC/m2] Total BGC C at the column level from last call to balance check -! real(r8), pointer, private :: biomass_stock_col(:) ! [gC/m2] total biomass at the column level in gC / m2 -! real(r8), pointer, private :: ed_litter_stock_col(:) ! [gC/m2] ED litter at the column level in gC / m2 -! real(r8), pointer, private :: cwd_stock_col(:) ! [gC/m2] ED CWD at the column level in gC / m2 -! real(r8), pointer, private :: seed_stock_col(:) ! [gC/m2] ED seed mass carbon at the column level in gC / m2 - - ! carbon balance errors. at some point we'll reduce these to close to zero and delete, but for now we'll just keep[ track of them -! real(r8), pointer, private :: cbalance_error_ed_col(:) ! [gC/m2/s] total carbon balance error for the ED side -! real(r8), pointer, private :: cbalance_error_bgc_col(:) ! [gC/m2/s] total carbon balance error for the BGC side -! real(r8), pointer, private :: cbalance_error_total_col(:) ! [gC/m2/s] total carbon balance error for the whole thing - - ! ED patch/cohort data -! real(r8), pointer, private :: ed_npatches_col(:) ! [#] the number of patches per ED site -! real(r8), pointer, private :: ed_ncohorts_col(:) ! [#] the number of cohorts per ED site - contains ! Public routines -! procedure , public :: Init -! procedure , public :: Restart procedure , public :: ed_clm_link -! procedure , public :: SummarizeNetFluxes -! procedure , public :: SummarizeProductivityFluxes -! procedure , public :: ED_BGC_Carbon_Balancecheck ! Private routines procedure , private :: ed_clm_leaf_area_profile -! procedure , private :: InitAllocate -! procedure , private :: InitHistory end type ed_clm_type @@ -120,269 +51,6 @@ module EDCLMLinkMod 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) - -! end subroutine Init - - !------------------------------------------------------------------------ -! subroutine InitAllocate(this, bounds) -! ! -! ! !USES: -! use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) -! use clm_varpar , only : nlevgrnd, nlevdecomp_full -! use EDtypesMod , only : numpft_ed -! ! -! ! !ARGUMENTS: -! class (ed_clm_type) :: this -! type(bounds_type), intent(in) :: bounds -! ! -! ! !LOCAL VARIABLES: -! integer :: begp,endp -! integer :: begc,endc !bounds -! integer :: begg,endg -! !------------------------------------------------------------------------ - -! begp = bounds%begp; endp = bounds%endp -! begc = bounds%begc; endc = bounds%endc - -! allocate(this%ed_to_bgc_this_edts_col (begc:endc)) ; this%ed_to_bgc_this_edts_col (:) = nan -! allocate(this%ed_to_bgc_last_edts_col (begc:endc)) ; this%ed_to_bgc_last_edts_col (:) = nan -! allocate(this%seed_rain_flux_col (begc:endc)) ; this%seed_rain_flux_col (:) = nan - -! allocate(this%nep_col (begc:endc)) ; this%nep_col (:) = nan -! allocate(this%nep_timeintegrated_col (begc:endc)) ; this%nep_timeintegrated_col (:) = nan -! allocate(this%npp_timeintegrated_col (begc:endc)) ; this%npp_timeintegrated_col (:) = nan -! allocate(this%hr_timeintegrated_col (begc:endc)) ; this%hr_timeintegrated_col (:) = nan - -! allocate(this%nbp_col (begc:endc)) ; this%nbp_col (:) = nan -! allocate(this%npp_col (begc:endc)) ; this%npp_col (:) = nan -! allocate(this%fire_c_to_atm_col (begc:endc)) ; this%fire_c_to_atm_col (:) = nan - -! allocate(this%totecosysc_col (begc:endc)) ; this%totecosysc_col (:) = nan -! allocate(this%totecosysc_old_col (begc:endc)) ; this%totecosysc_old_col (:) = nan -! allocate(this%totedc_col (begc:endc)) ; this%totedc_col (:) = nan -! allocate(this%totedc_old_col (begc:endc)) ; this%totedc_old_col (:) = nan -! allocate(this%totbgcc_col (begc:endc)) ; this%totbgcc_col (:) = nan -! allocate(this%totbgcc_old_col (begc:endc)) ; this%totbgcc_old_col (:) = nan -! allocate(this%biomass_stock_col (begc:endc)) ; this%biomass_stock_col (:) = nan -! allocate(this%ed_litter_stock_col (begc:endc)) ; this%ed_litter_stock_col (:) = nan -! allocate(this%cwd_stock_col (begc:endc)) ; this%cwd_stock_col (:) = nan -! allocate(this%seed_stock_col (begc:endc)) ; this%seed_stock_col (:) = nan -! -! allocate(this%cbalance_error_ed_col (begc:endc)) ; this%cbalance_error_ed_col (:) = nan -! allocate(this%cbalance_error_bgc_col (begc:endc)) ; this%cbalance_error_bgc_col (:) = nan -! allocate(this%cbalance_error_total_col (begc:endc)) ; this%cbalance_error_total_col (:) = 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 -! 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 - -! this%nep_col(begc:endc) = spval -! call hist_addfld1d (fname='NEP', units='gC/m^2/s', & -! avgflag='A', long_name='net ecosystem production', & -! ptr_col=this%nep_col) - -! this%fire_c_to_atm_col(begc:endc) = spval -! call hist_addfld1d (fname='Fire_Closs', units='gC/m^2/s', & -! avgflag='A', long_name='ED/SPitfire Carbon loss to atmosphere', & -! ptr_col=this%fire_c_to_atm_col) - -! this%nbp_col(begc:endc) = spval -! call hist_addfld1d (fname='NBP', units='gC/m^2/s', & -! avgflag='A', long_name='net biosphere production', & -! ptr_col=this%nbp_col) - -! this%totecosysc_col(begc:endc) = spval -! call hist_addfld1d (fname='TOTECOSYSC', units='gC/m^2', & -! avgflag='A', long_name='total ecosystem carbon', & -! ptr_col=this%totecosysc_col) - -! this%cbalance_error_ed_col(begc:endc) = spval -! call hist_addfld1d (fname='CBALANCE_ERROR_ED', units='gC/m^2/s', & -! avgflag='A', long_name='total carbon balance error on ED side', & -! ptr_col=this%cbalance_error_ed_col) - -! this%cbalance_error_bgc_col(begc:endc) = spval -! call hist_addfld1d (fname='CBALANCE_ERROR_BGC', units='gC/m^2/s', & -! avgflag='A', long_name='total carbon balance error on BGC side', & -! ptr_col=this%cbalance_error_bgc_col) - -! this%cbalance_error_total_col(begc:endc) = spval -! call hist_addfld1d (fname='CBALANCE_ERROR_TOTAL', units='gC/m^2/s', & -! avgflag='A', long_name='total carbon balance error total', & -! ptr_col=this%cbalance_error_total_col) - -! this%biomass_stock_col(begc:endc) = spval -! call hist_addfld1d (fname='BIOMASS_STOCK_COL', units='gC/m^2', & -! avgflag='A', long_name='total ED biomass carbon at the column level', & -! ptr_col=this%biomass_stock_col) - -! this%ed_litter_stock_col(begc:endc) = spval -! call hist_addfld1d (fname='ED_LITTER_STOCK_COL', units='gC/m^2', & -! avgflag='A', long_name='total ED litter carbon at the column level', & -! ptr_col=this%ed_litter_stock_col) - -! this%cwd_stock_col(begc:endc) = spval -! call hist_addfld1d (fname='CWD_STOCK_COL', units='gC/m^2', & -! avgflag='A', long_name='total CWD carbon at the column level', & -! ptr_col=this%cwd_stock_col) - -! this%seed_stock_col(begc:endc) = spval -! call hist_addfld1d (fname='SEED_STOCK_COL', units='gC/m^2', & -! avgflag='A', long_name='total seed carbon at the column level', & -! ptr_col=this%seed_stock_col) - -! 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 - ! use EDtypesMod , only : numpft_ed - - ! - ! !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 -! real(r8), pointer :: ptr2d(:,:) ! temp. pointers for slicing larger arrays -! real(r8), pointer :: ptr1d(:) ! temp. pointers for slicing larger arrays - ! character(LEN=3) :: istr1 - ! integer :: k - !------------------------------------------------------------------------ - -! ptr1d => this%nep_timeintegrated_col(:) -! call restartvar(ncid=ncid, flag=flag, varname='nep_timeintegrated_col', xtype=ncd_double, & -! dim1name='column', long_name='', units='', & -! interpinic_flag='interp', readvar=readvar, data=ptr1d) - -! ptr1d => this%npp_timeintegrated_col(:) -! call restartvar(ncid=ncid, flag=flag, varname='npp_timeintegrated_col', xtype=ncd_double, & -! dim1name='column', long_name='', units='', & -! interpinic_flag='interp', readvar=readvar, data=ptr1d) - -! ptr1d => this%hr_timeintegrated_col(:) -! call restartvar(ncid=ncid, flag=flag, varname='hr_timeintegrated_col', xtype=ncd_double, & -! dim1name='column', long_name='', units='', & -! interpinic_flag='interp', readvar=readvar, data=ptr1d) - -! ptr1d => this%totecosysc_old_col(:) -! call restartvar(ncid=ncid, flag=flag, varname='totecosysc_old_col', xtype=ncd_double, & -! dim1name='column', long_name='', units='', & -! interpinic_flag='interp', readvar=readvar, data=ptr1d) - -! ptr1d => this%cbalance_error_ed_col(:) -! call restartvar(ncid=ncid, flag=flag, varname='cbalance_error_ed_col', xtype=ncd_double, & -! dim1name='column', long_name='', units='', & -! interpinic_flag='interp', readvar=readvar, data=ptr1d) - -! ptr1d => this%cbalance_error_bgc_col(:) -! call restartvar(ncid=ncid, flag=flag, varname='cbalance_error_bgc_col', xtype=ncd_double, & -! dim1name='column', long_name='', units='', & -! interpinic_flag='interp', readvar=readvar, data=ptr1d) - -! ptr1d => this%cbalance_error_total_col(:) -! call restartvar(ncid=ncid, flag=flag, varname='cbalance_error_total_col', xtype=ncd_double, & -! dim1name='column', long_name='', units='', & -! interpinic_flag='interp', readvar=readvar, data=ptr1d) - -! ptr1d => this%totedc_old_col(:) -! call restartvar(ncid=ncid, flag=flag, varname='totedc_old_col', xtype=ncd_double, & -! dim1name='column', long_name='', units='', & -! interpinic_flag='interp', readvar=readvar, data=ptr1d) - -! ptr1d => this%totbgcc_old_col(:) -! call restartvar(ncid=ncid, flag=flag, varname='totbgcc_old_col', xtype=ncd_double, & -! dim1name='column', long_name='', units='', & -! interpinic_flag='interp', readvar=readvar, data=ptr1d) - -! ptr1d => this%ed_to_bgc_this_edts_col(:) -! call restartvar(ncid=ncid, flag=flag, varname='ed_to_bgc_this_edts_col', xtype=ncd_double, & -! dim1name='column', long_name='', units='', & -! interpinic_flag='interp', readvar=readvar, data=ptr1d) - -! ptr1d => this%ed_to_bgc_last_edts_col(:) -! call restartvar(ncid=ncid, flag=flag, varname='ed_to_bgc_last_edts_col', xtype=ncd_double, & -! dim1name='column', long_name='', units='', & -! interpinic_flag='interp', readvar=readvar, data=ptr1d) - -! ptr1d => this%seed_rain_flux_col(:) -! call restartvar(ncid=ncid, flag=flag, varname='seed_rain_flux_col', xtype=ncd_double, & -! dim1name='column', long_name='', units='', & -! interpinic_flag='interp', readvar=readvar, data=ptr1d) - - -! end subroutine Restart - !----------------------------------------------------------------------- subroutine ed_clm_link( this, bounds, nsites, sites, fcolumn, waterstate_inst, canopystate_inst) @@ -1038,25 +706,11 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, colindex, waterstate_ins 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 @@ -1155,221 +809,6 @@ subroutine ed_clm_leaf_area_profile( this, currentSite, colindex, waterstate_ins end subroutine ed_clm_leaf_area_profile - !------------------------------------------------------------------------ - - subroutine SummarizeNetFluxes( nsites, sites, bc_in, is_beg_day ) - - ! Summarize the combined production and decomposition fluxes into net fluxes - ! This is done on the fast timestep, and to be called after both daily ED calls and - ! fast BGC calls. Does not include summarization of fast-timestsp productivity calls - ! because these must be summarized prior to daily ED calls - ! - ! Written by Charlie Koven, Feb 2016 - ! - ! !USES: - use FatesInterfaceMod , only : bc_in_type - ! - implicit none - ! - ! !ARGUMENTS - - integer , intent(in) :: nsites - type(ed_site_type) , intent(inout), target :: sites(nsites) - type(bc_in_type) , intent(in) :: bc_in(nsites) - logical , intent(in) :: is_beg_day - - ! - ! !LOCAL VARIABLES: - integer :: s - - type (ed_patch_type) , pointer :: currentPatch - type (ed_cohort_type) , pointer :: currentCohort - real(r8) :: n_perm2 ! individuals per m2 of the whole column - - do s = 1,nsites - - sites(s)%fire_c_to_atm = 0._r8 ! REMOVE THIS VARIABLE? - sites(s)%ed_litter_stock = 0._r8 - sites(s)%cwd_stock = 0._r8 - sites(s)%seed_stock = 0._r8 - sites(s)%biomass_stock = 0._r8 - - ! map ed site-level fire fluxes to clm column fluxes - sites(s)%fire_c_to_atm = sites(s)%total_burn_flux_to_atm / ( AREA * SHR_CONST_CDAY * 1.e3_r8) - - currentPatch => sites(s)%oldest_patch - do while(associated(currentPatch)) - - ! map litter, CWD, and seed pools to column level - sites(s)%cwd_stock = sites(s)%cwd_stock + (currentPatch%area / AREA) * & - (sum(currentPatch%cwd_ag) + sum(currentPatch%cwd_bg)) * 1.e3_r8 - - sites(s)%ed_litter_stock = sites(s)%ed_litter_stock + (currentPatch%area / AREA) * & - (sum(currentPatch%leaf_litter)+sum(currentPatch%root_litter)) * 1.e3_r8 - - sites(s)%seed_stock = sites(s)%seed_stock + (currentPatch%area / AREA) * sum(currentPatch%seed_bank) * 1.e3_r8 - - currentCohort => currentPatch%tallest - do while(associated(currentCohort)) - ! for quantities that are natively at column level or higher, - ! calculate plant density using whole area (for grid cell averages) - n_perm2 = currentCohort%n/AREA - - ! map biomass pools to column level - sites(s)%biomass_stock = sites(s)%biomass_stock + (currentCohort%bdead + currentCohort%balive + & - currentCohort%bstore) * n_perm2 * 1.e3_r8 - - currentCohort => currentCohort%shorter - enddo !currentCohort - currentPatch => currentPatch%younger - end do ! patch loop - - ! calculate NEP and NBP fluxes - sites(s)%nep = sites(s)%npp - bc_in(s)%tot_het_resp - sites(s)%nbp = sites(s)%npp - ( bc_in(s)%tot_het_resp + sites(s)%fire_c_to_atm ) - - ! FATES stocks - sites(s)%totfatesc = sites(s)%ed_litter_stock + sites(s)%cwd_stock + sites(s)%seed_stock + sites(s)%biomass_stock - - ! BGC stocks (used for error checking, totlitc should be zero?) - sites(s)%totbgcc = bc_in(s)%tot_somc + bc_in(s)%tot_litc - - ! Total Ecosystem Carbon Stocks - sites(s)%totecosysc = sites(s)%totfatesc + sites(s)%totbgcc - - end do - - ! in FATES timesteps, because of offset between when ED and BGC reconcile the gain and loss of litterfall carbon, - ! (i.e. FATES reconciles it instantly, while BGC reconciles it incrementally over the subsequent day) - ! calculate the total ED -> BGC flux and keep track of the last day's info for balance checking purposes - if ( is_beg_day ) then - ! - do s = 1,nsites - ! order of operations in the next to lines is quite important ;) - sites(s)%fates_to_bgc_last_ts = sites(s)%fates_to_bgc_this_ts - sites(s)%fates_to_bgc_this_ts = 0._r8 - sites(s)%seed_rain_flux = 0._r8 - - currentPatch => sites(s)%oldest_patch - do while(associated(currentPatch)) - ! - sites(s)%fates_to_bgc_this_ts = sites(s)%fates_to_bgc_this_ts + & - (sum(currentPatch%CWD_AG_out) + sum(currentPatch%CWD_BG_out) + & - sum(currentPatch%seed_decay) + sum(currentPatch%leaf_litter_out) + & - sum(currentPatch%root_litter_out)) * & - ( currentPatch%area/AREA ) * 1.e3_r8 / ( 365.0_r8*SHR_CONST_CDAY ) - ! - sites(s)%seed_rain_flux = sites(s)%seed_rain_flux + & - sum(currentPatch%seed_rain_flux) * 1.e3_r8 / ( 365.0_r8*SHR_CONST_CDAY ) - ! - currentPatch => currentPatch%younger - end do !currentPatch - end do - endif - - return - end subroutine SummarizeNetFluxes - - - subroutine ED_BGC_Carbon_Balancecheck(nsites, sites, bc_in, is_beg_day, dtime, nstep) - - ! Integrate in time the fluxes into and out of the ecosystem, and compare these on a daily timestep - ! to the chagne in carbon stocks of the ecosystem - ! - ! Written by Charlie Koven, Feb 2016 - ! - ! !USES: - use FatesInterfaceMod , only : bc_in_type - ! - implicit none - ! - ! !ARGUMENTS - integer , intent(in) :: nsites - type(ed_site_type) , intent(inout), target :: sites(nsites) - type(bc_in_type) , intent(in) :: bc_in(nsites) - logical , intent(in) :: is_beg_day - real(r8) , intent(in) :: dtime ! time-step length (s) - integer , intent(in) :: nstep ! time-step index - - ! !LOCAL VARIABLES: - real(r8) :: error_tolerance = 1.e-6_r8 - integer :: s - - ! TODO: THIS INITIALIZATION SHOULD BE IN AN INITIALIZATION PART OF THE CODE - ! COLD-START PORTION, NSTEP IS >1 FOR RESTARTS RIGHT? (RGK) - if (nstep .le. 1) then - ! when starting up the model, initialize the integrator variables - do s = 1,nsites - sites(s)%totecosysc_old = sites(s)%totecosysc - sites(s)%totfatesc_old = sites(s)%totfatesc - sites(s)%totbgcc_old = sites(s)%totbgcc - sites(s)%nep_timeintegrated = 0._r8 - sites(s)%hr_timeintegrated = 0._r8 - sites(s)%npp_timeintegrated = 0._r8 - ! - ! also initialize the ed-BGC flux variables - sites(s)%fates_to_bgc_this_ts = 0._r8 - sites(s)%fates_to_bgc_last_ts = 0._r8 - ! - sites(s)%cbal_err_fates = 0._r8 - sites(s)%cbal_err_bgc = 0._r8 - sites(s)%cbal_err_tot = 0._r8 - end do - endif - - do s = 1,nsites - sites(s)%nep_timeintegrated = sites(s)%nep_timeintegrated + sites(s)%nep * dtime - sites(s)%hr_timeintegrated = sites(s)%hr_timeintegrated + bc_in(s)%tot_het_resp * dtime - sites(s)%npp_timeintegrated = sites(s)%npp_timeintegrated + sites(s)%npp * dtime - end do - - ! If this is on the dynamics time-step, then we calculate the balance checks - - if ( is_beg_day ) then - - do s = 1,nsites - - ! NBP can only be updated when dynamics level information is available - sites(s)%nbp_integrated = sites(s)%nep_timeintegrated - & - sites(s)%fire_c_to_atm * SHR_CONST_CDAY + & - sites(s)%seed_rain_flux * SHR_CONST_CDAY - - - sites(s)%cbal_err_fates = sites(s)%totfatesc - & - sites(s)%totfatesc_old - & - (sites(s)%npp_timeintegrated + & - sites(s)%seed_rain_flux*SHR_CONST_CDAY - & - sites(s)%fates_to_bgc_this_ts*SHR_CONST_CDAY - & - sites(s)%fire_c_to_atm*SHR_CONST_CDAY) - sites(s)%cbal_err_fates = sites(s)%cbal_err_fates / SHR_CONST_CDAY - - - sites(s)%cbal_err_bgc = sites(s)%totbgcc - & - sites(s)%totbgcc_old - & - (sites(s)%fates_to_bgc_last_ts*SHR_CONST_CDAY - & - sites(s)%hr_timeintegrated) - sites(s)%cbal_err_bgc = sites(s)%cbal_err_bgc / SHR_CONST_CDAY - - sites(s)%cbal_err_tot = sites(s)%totecosysc - & - sites(s)%totecosysc_old - & - (sites(s)%nbp_integrated + & - sites(s)%fates_to_bgc_last_ts*SHR_CONST_CDAY - & - sites(s)%fates_to_bgc_this_ts*SHR_CONST_CDAY) - sites(s)%cbal_err_tot = sites(s)%cbal_err_tot / SHR_CONST_CDAY - - ! Send the current to the previous/last - sites(s)%totecosysc_old = sites(s)%totecosysc - sites(s)%totfatesc_old = sites(s)%totfatesc - sites(s)%totbgcc_old = sites(s)%totbgcc - sites(s)%nep_timeintegrated = 0._r8 - sites(s)%npp_timeintegrated = 0._r8 - sites(s)%hr_timeintegrated = 0._r8 - - end do - - endif - - return -end subroutine ED_BGC_Carbon_Balancecheck + end module EDCLMLinkMod From 7533a65556425a803a8532e633bf1aee99aae61e Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 2 Sep 2016 17:17:21 -0700 Subject: [PATCH 194/437] added implicit none to FatesInterfaceMod. Corrected the name of the global variable cp_hio_ignore_val --- main/FatesInterfaceMod.F90 | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index ed3600f5..dd177f5c 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -23,11 +23,13 @@ module FatesInterfaceMod cp_maxSWb, & cp_numlevdecomp, & cp_numlevdecomp_full, & - cp_hlm_name + cp_hlm_name, & + cp_hio_ignore_val use shr_kind_mod , only : r8 => shr_kind_r8 ! INTERF-TODO: REMOVE THIS + implicit none ! ------------------------------------------------------------------------------------ ! Notes on types @@ -489,7 +491,7 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) cp_numlevdecomp_full = unset_int cp_numlevdecomp = unset_int cp_hlm_name = 'unset' - cp_hio_ignore = unset_double + cp_hio_ignore_val = unset_double case('check_allset') @@ -546,7 +548,7 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) ! end_run('MESSAGE') end if - if( abs(cp_hio_ignore-unset_double)<1e-10 ) then + if( abs(cp_hio_ignore_val-unset_double)<1e-10 ) then if (fates_global_verbose()) then write(fates_log(),*) 'FATES dimension/parameter unset: hio_ignore' end if From a188ed6aac112dd3195fb9e944245512736f7288 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 5 Sep 2016 16:45:12 -0700 Subject: [PATCH 195/437] Have most of the code moved around, towards removing ed_clm_link. Have not tested compilation yet. --- biogeochem/EDCanopyStructureMod.F90 | 634 ++++++++++++++++++++++- main/EDCLMLinkMod.F90 | 764 +--------------------------- main/EDMainMod.F90 | 3 +- 3 files changed, 639 insertions(+), 762 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 44cb1b99..fa92f155 100755 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -639,6 +639,638 @@ subroutine canopy_spread( currentSite ) end subroutine canopy_spread + + ! ===================================================================================== + + subroutine canopy_summariziation( nsites, sites, bc_in ) + + ! ---------------------------------------------------------------------------------- + ! Much of this routine was once ed_clm_link minus all the IO and history stuff + ! --------------------------------------------------------------------------------- + + + ! + ! !USES: + use EDGrowthFunctionsMod , only : tree_lai, c_area + use EDEcophysConType , only : EDecophyscon + use EDtypesMod , only : area + use pftconMod , only : pftcon + + ! !ARGUMENTS + class(ed_clm_type) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: nsites + type(ed_site_type) , intent(inout), target :: sites(nsites) + type(bc_in_type) , intent(inout) :: bc_in(nsites) + ! + ! !LOCAL VARIABLES: + type (ed_patch_type) , pointer :: currentPatch + type (ed_cohort_type) , pointer :: currentCohort + integer :: g,l,p,c,s + integer :: ft ! plant functional type + integer :: patchn ! identification number for each patch. + 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. + + !---------------------------------------------------------------------- + + if ( DEBUG ) then + write(fates_log(),*) 'in canopy_summarization' + endif + + do s = 1,nsites + + currentPatch => sites(s)%oldest_patch + do while(associated(currentPatch)) + + 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) + + currentCohort%livecrootn = 0.0_r8 + + if (pftcon%woody(ft) == 1) then + coarse_wood_frac = 0.5_r8 + else + coarse_wood_frac = 0.0_r8 + end if + + if ( DEBUG ) then + write(iulog,*) 'EDCLMLink 618 ',currentCohort%livecrootn + write(iulog,*) 'EDCLMLink 619 ',currentCohort%br + write(iulog,*) 'EDCLMLink 620 ',coarse_wood_frac + write(iulog,*) 'EDCLMLink 621 ',pftcon%leafcn(ft) + endif + + currentCohort%livecrootn = currentCohort%br * coarse_wood_frac / pftcon%leafcn(ft) + + if ( DEBUG ) write(iulog,*) 'EDCLMLink 625 ',currentCohort%livecrootn + + currentCohort%b = currentCohort%balive+currentCohort%bdead+currentCohort%bstore + currentCohort%treelai = tree_lai(currentCohort) + + currentCohort%c_area = c_area(currentCohort) + canopy_leaf_area = canopy_leaf_area + currentCohort%treelai *currentCohort%c_area + + if(currentCohort%canopy_layer==1)then + currentPatch%total_canopy_area = currentPatch%total_canopy_area + currentCohort%c_area + if(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)) + + end do !patch loop + + call leaf_area_profile(sites(s),bc_in(s)%snow_depth,bc_in(s)%frac_sno_eff) + + end do ! site loop + + return + end subroutine canopy_summariziation + + ! ===================================================================================== + + subroutine leaf_area_profile( this, currentSite , snow_depth, frac_sno_eff) + ! + ! !DESCRIPTION: + ! + ! !USES: + use FatesGlobals, only : fates_log + + 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 + + ! + ! !ARGUMENTS + class(ed_clm_type) :: this + type(ed_site_type) , intent(inout) :: currentSite + real(r8) , intent(in) :: snow_depth + real(r8) , intent(in) :: frac_sno_eff + ! + ! !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 + 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 + real(r8) :: snow_depth_col ! averaged snow over whole colum (why calc over patch? RGK) + integer :: NC ! number of cohorts, for bug fixing. + + !---------------------------------------------------------------------- + + smooth_leaf_distribution = 0 + + ! 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) + + currentPatch => currentSite%oldest_patch ! ed 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,cp_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 + + 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 + !write(fates_log(), *) 'calc snow' + snow_depth_col = snow_depth * frac_sno_eff + if(snow_depth_col > maxh(iv))then + fraction_exposed = 0._r8 + endif + if(snow_depth_col < minh(iv))then + fraction_exposed = 1._r8 + endif + if(snow_depth_col>= minh(iv).and.snow_depth_col <= maxh(iv))then !only partly hidden... + fraction_exposed = max(0._r8,(min(1.0_r8,(snow_depth_col-minh(iv))/dh))) + endif + fraction_exposed = 1.0_r8 + ! no m2 of leaf per m2 of ground in each height class + ! FIX(SPM,032414) these should be uncommented this and double check + + if ( DEBUG ) write(fates_log(), *) 'EDCLMLink 1154 ', currentPatch%elai_profile(1,ft,iv) + + currentPatch%elai_profile(1,ft,iv) = currentPatch%tlai_profile(1,ft,iv) * fraction_exposed + currentPatch%esai_profile(1,ft,iv) = currentPatch%tsai_profile(1,ft,iv) * fraction_exposed + + if ( DEBUG ) write(fates_log(), *) 'EDCLMLink 1159 ', currentPatch%elai_profile(1,ft,iv) + + 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(fates_log(), *) 'ED: 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%layer_height_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(fates_log(), *) 'ED: 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(fates_log(), *) 'ED: issue with NV',currentCohort%NV,currentCohort%pft,currentCohort%canopy_layer + endif + + !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 + + ! 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)) + + write(fates_log(), *) 'calc snow 2', snow_depth , frac_sno_eff + + fraction_exposed =1.0_r8 + + currentPatch%tlai_profile(L,ft,iv) = currentPatch%tlai_profile(L,ft,iv)+ dinc_ed * fleaf * & + currentCohort%c_area/currentPatch%total_canopy_area + currentPatch%elai_profile(L,ft,iv) = currentPatch%elai_profile(L,ft,iv)+ dinc_ed * fleaf * & + currentCohort%c_area/currentPatch%total_canopy_area * fraction_exposed + + 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%esai_profile(L,ft,iv) = currentPatch%esai_profile(L,ft,iv)+ dinc_ed * (1._r8 - fleaf) * & + currentCohort%c_area/currentPatch%total_canopy_area * 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) + currentPatch%layer_height_profile(L,ft,iv) = currentPatch%layer_height_profile(L,ft,iv) + (dinc_ed * fleaf * & + currentCohort%c_area/currentPatch%total_canopy_area *(layer_top_hite+layer_bottom_hite)/2.0_r8) !average height of layer. + + write(fates_log(), *) 'LHP', currentPatch%layer_height_profile(L,ft,iv) + if ( DEBUG ) write(fates_log(), *) 'EDCLMLink 1246 ', currentPatch%elai_profile(1,ft,iv) + + 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. + snow_depth_col = snow_depth * bc_in(s)%frac_sno_eff + if(snow_depth_col > layer_top_hite)then + fraction_exposed = 0._r8 + endif + if(snow_depth_col < layer_bottom_hite)then + fraction_exposed = 1._r8 + + endif + if(snow_depth_col>= layer_bottom_hite.and.snow_depth_col <= layer_top_hite)then !only partly hidden... + fraction_exposed = max(0._r8,(min(1.0_r8,(snow_depth_col-layer_bottom_hite)/ & + (layer_top_hite-layer_bottom_hite )))) + endif + fraction_exposed= 1.0_r8 + + + remainder = (currentCohort%treelai + currentCohort%treesai) - (dinc_ed*(currentCohort%NV-1)) + if(remainder > 1.0_r8)then + write(fates_log(), *)'ED: 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 + currentPatch%elai_profile(L,ft,iv) = currentPatch%elai_profile(L,ft,iv) + remainder * fleaf * & + currentCohort%c_area/currentPatch%total_canopy_area * fraction_exposed + !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%esai_profile(L,ft,iv) = currentPatch%esai_profile(L,ft,iv)+ remainder * & + (1.0_r8-fleaf) * currentCohort%c_area/currentPatch%total_canopy_area * 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) + currentPatch%layer_height_profile(L,ft,iv) = currentPatch%layer_height_profile(L,ft,iv) + (remainder * fleaf * & + currentCohort%c_area/currentPatch%total_canopy_area*(layer_top_hite+layer_bottom_hite)/2.0_r8) + write(fates_log(), *) 'LHP', currentPatch%layer_height_profile(L,ft,iv) + if(currentCohort%dbh <= 0._r8.or.currentCohort%n == 0._r8)then + write(fates_log(), *) '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(fates_log(), *) '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(fates_log(), *) '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) + + if ( DEBUG ) write(fates_log(), *) 'EDCLMLink 1293 ', currentPatch%elai_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) + currentPatch%layer_height_profile(L,ft,iv) = currentPatch%layer_height_profile(L,ft,iv) & + /currentPatch%tlai_profile(L,ft,iv) + enddo + + currentPatch%tlai_profile(L,ft,currentPatch%nrad(L,ft)+1: cp_nlevcan) = 0._r8 + currentPatch%tsai_profile(L,ft,currentPatch%nrad(L,ft)+1: cp_nlevcan) = 0._r8 + currentPatch%elai_profile(L,ft,currentPatch%nrad(L,ft)+1: cp_nlevcan) = 0._r8 + currentPatch%esai_profile(L,ft,currentPatch%nrad(L,ft)+1: cp_nlevcan) = 0._r8 + + enddo + enddo + + currentPatch%nrad = currentPatch%ncan + do L = 1,currentPatch%NCL_p + do ft = 1,numpft_ed + if(currentPatch%nrad(L,ft) > 30)then + write(fates_log(), *) '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(fates_log(), *) 'ED: canopy area too small',sum(currentPatch%canopy_area_profile(1,1:numpft_ed,1)) + write(fates_log(), *) 'ED: cohort areas', currentPatch%canopy_area_profile(1,1:numpft_ed,:) + 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(fates_log(), *) 'ED: not enough area in the top canopy', & + sum(currentPatch%canopy_area_profile(L,1:numpft_ed,1)), & + currentPatch%canopy_area_profile(L,1:numpft_ed,1) + endif + + if(abs(sum(currentPatch%canopy_area_profile(L,1:numpft_ed,1))) > 1.00001)then + write(fates_log(), *) 'ED: canopy-area-profile wrong', & + sum(currentPatch%canopy_area_profile(L,1:numpft_ed,1)), & + currentPatch%patchno, L + write(fates_log(), *) 'ED: 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(fates_log(), *) 'ED: cohorts',currentCohort%dbh,currentCohort%c_area, & + currentPatch%total_canopy_area,currentPatch%area,currentPatch%canopy_area + write(fates_log(), *) 'ED: 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(fates_log(), *) 'ED: 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 + + return + end subroutine leaf_area_profile + + ! ====================================================================================== + + subroutine update_hlm_dynamics(nsites,sites,bc_out) + + ! ---------------------------------------------------------------------------------- + ! The purpose of this routine is to package output boundary conditions related + ! to vegetation coverage to the host land model. + ! ---------------------------------------------------------------------------------- + + use shr_kind_mod , only : r8 => shr_kind_r8 + use EDTypesMod , only : ed_patch_type, ed_cohort_type, & + ed_site_type, AREA + use FatesInterfaceMod , only : bc_in_type,bc_out_type + use FatesGlobals , only : fates_log + ! + ! !ARGUMENTS + integer, intent(in) :: nsites + type(ed_site_type), intent(inout), target :: sites(nsites) + type(bc_out_type), intent(inout) :: bc_out(nsites) + + ! Locals + integer :: s, ifp + type (ed_patch_type) , pointer :: currentPatch + real(r8) :: bare_frac_area + real(r8) :: total_patch_area + + do s = 1,nsites + + ifp = 0 + total_bare_ground = 0.0_r8 + total_patch_area = 0._r8 + currentPatch => sites(s)%oldest_patch + do while(associated(currentPatch)) + ifp = ifp+1 + + if ( currentPatch%total_canopy_area-currentPatch%area > 0.000001_r8 ) then + write(fates_log(),*) 'ED: canopy area bigger than area',currentPatch%total_canopy_area ,currentPatch%area + currentPatch%total_canopy_area = currentPatch%area + endif + + + if (associated(currentPatch%tallest)) then + bc_out(s)%htop(ifp) = currentPatch%tallest%hite + else + ! FIX(RF,040113) - should this be a parameter for the minimum possible vegetation height? + bc_out(s)%htop(ifp) = 0.1_r8 + endif + + bc_out(s)%hbot(ifp) = max(0._r8, min(0.2_r8, htop(p)- 1.0_r8)) + + + ! 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. + + bc_out(s)%site_canopy_fraction(ifp) = min(1.0_r8,currentPatch%total_canopy_area/currentPatch%area) * & + (currentPatch%area/AREA) + + bare_frac_area = (1.0_r8-min(1.0_r8,currentPatch%total_canopy_area/currentPatch%area))* & + (currentPatch%area/AREA) + + total_patch_area = total_patch_area + bc_out(s)%site_canopy_fraction(ifp) + bare_frac_area + + ! Calculate area indices for output boundary to HLM + ! It is assumed that cpatch%canopy_area_profile and cpat%xai_profiles + ! have been updated (ie ed_leaf_area_profile has been called since dynamics has been called) + + bc_out(s)%elai(ifp) = calc_areaindex(currentPatch,'elai') + bc_out(s)%tlai(ifp) = calc_areaindex(currentPatch,'tlai') + bc_out(s)%esai(ifp) = calc_areaindex(currentPatch,'esai') + bc_out(s)%tsai(ifp) = calc_areaindex(currentPatch,'tsai') + + ! Fraction of vegetation free of snow. This is used to flag those + ! patches which shall under-go photosynthesis + ! INTERF-TODO: we may want to stop using frac_veg_nosno_alb and let + ! FATES internal variables decide if photosynthesis is possible + ! we are essentially calculating it inside FATES to tell the + ! host to tell itself when to do things (circuitous). Just have + ! to determine where else it is used + + if ((bc_out(s)%elai(ifp) + bc_out(s)%esai(ifp)) > 0._r8) then + bc_out(s)%frac_veg_nosno_alb(ifp) = 1.0_r8 + else + bc_out(s)%frac_veg_nosno_alb(ifp) = 0.0_r8 + end if + + + end do + + if(abs(total_patch_area-1.0_r8)>1e-9)then + write(fates_log(),*) 'total area is wrong in update_hlm_dynamics',total_patch_area + endif + + + end do + + + end subroutine update_hlm_dynamics + ! ===================================================================================== function calc_areaindex(cpatch,ai_type) result(ai) @@ -702,6 +1334,4 @@ function calc_areaindex(cpatch,ai_type) result(ai) end function calc_areaindex - - end module EDCanopyStructureMod diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index b573e344..f06e0452 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -34,17 +34,11 @@ module EDCLMLinkMod real(r8), public :: cwd_fcel_ed real(r8), public :: cwd_flig_ed - type, public :: ed_clm_type - - contains - - ! Public routines - procedure , public :: ed_clm_link - - ! Private routines - procedure , private :: ed_clm_leaf_area_profile - - end type ed_clm_type + ! Public routines + procedure , public :: ed_clm_link + + ! Private routines + procedure , private :: ed_clm_leaf_area_profile ! 10/30/09: Created by Rosie Fisher !----------------------------------------------------------------------- @@ -53,251 +47,7 @@ module EDCLMLinkMod !----------------------------------------------------------------------- - subroutine ed_clm_link( this, bounds, nsites, sites, fcolumn, waterstate_inst, canopystate_inst) - ! - ! !USES: - use landunit_varcon , only : istsoil - use EDGrowthFunctionsMod , only : tree_lai, c_area - use EDEcophysConType , only : EDecophyscon - use EDtypesMod , only : area - use PatchType , only : clmpatch => patch - 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 - integer , intent(in) :: nsites - type(ed_site_type) , intent(inout), target :: sites(nsites) - integer , intent(in) :: fcolumn(nsites) - 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,s - integer :: ft ! plant functional type - integer :: patchn ! identification number for each patch. - 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 :: begp_fp, endp_fp ! Valid range of patch indices that are associated with - ! FATES (F) for each parent (P) iteration (grid/column) - !---------------------------------------------------------------------- - - 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 & - ) - - - do s = 1,nsites - - c = fcolumn(s) - - ! ============================================================================ - ! Zero the bare ground tile BGC variables. - ! Valid Range for zero'ing here is the soil_patch and non crop patches - ! If the crops are not turned on, don't worry, they were zero'd once and should - ! not change again (RGK). - ! col%patchi(c) + numpft - numcft - ! ============================================================================ - - begp_fp = col%patchi(c) - endp_fp = col%patchi(c) + numpft - numcft - - clmpatch%is_veg(begp_fp:endp_fp) = .false. - clmpatch%is_bareground(begp_fp:endp_fp) = .false. - - tlai(begp_fp:endp_fp) = 0.0_r8 - htop(begp_fp:endp_fp) = 0.0_r8 - hbot(begp_fp:endp_fp) = 0.0_r8 - elai(begp_fp:endp_fp) = 0.0_r8 - tsai(begp_fp:endp_fp) = 0.0_r8 - esai(begp_fp:endp_fp) = 0.0_r8 - - - patchn = 0 - total_bare_ground = 0.0_r8 - total_patch_area = 0._r8 - - currentPatch => sites(s)%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 = col%patchi(c) + patchn !the first 'soil' patch is unvegetated... - - ! INTERF-TODO: currentPatch%clm_pno should be removed (FATES internal variable with CLM iformation) - - p = col%patchi(c) + patchn - - if(c .ne. clmpatch%column(p))then - write(iulog,*) ' fcolumn(s) does not match clmpatch%column(p)' - call endrun(msg=errMsg(__FILE__, __LINE__)) - end if - - 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) - - currentCohort%livecrootn = 0.0_r8 - - if (pftcon%woody(ft) == 1) then - coarse_wood_frac = 0.5_r8 - else - coarse_wood_frac = 0.0_r8 - end if - - if ( DEBUG ) then - write(iulog,*) 'EDCLMLink 618 ',currentCohort%livecrootn - write(iulog,*) 'EDCLMLink 619 ',currentCohort%br - write(iulog,*) 'EDCLMLink 620 ',coarse_wood_frac - write(iulog,*) 'EDCLMLink 621 ',pftcon%leafcn(ft) - endif - - currentCohort%livecrootn = currentCohort%br * coarse_wood_frac / pftcon%leafcn(ft) - - if ( DEBUG ) write(iulog,*) 'EDCLMLink 625 ',currentCohort%livecrootn - - currentCohort%b = currentCohort%balive+currentCohort%bdead+currentCohort%bstore - currentCohort%treelai = tree_lai(currentCohort) - - currentCohort%c_area = c_area(currentCohort) - canopy_leaf_area = canopy_leaf_area + currentCohort%treelai *currentCohort%c_area - - - if(currentCohort%canopy_layer==1)then - currentPatch%total_canopy_area = currentPatch%total_canopy_area + currentCohort%c_area - if(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,*) 'ED: 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 - - - ! 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) - - if ( DEBUG ) then - write(iulog, *) 'EDCLMLinkMod bare frac', currentPatch%bare_frac_area - end if - - total_patch_area = total_patch_area + clmpatch%wt_ed(p) + currentPatch%bare_frac_area - total_bare_ground = total_bare_ground + currentPatch%bare_frac_area - - 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 - ! while ED's domain of influence only extends to non-crop patches - ! wt_ed should not be non-zero anwhere but ED patches, so this loop is ok - do p = col%patchi(c)+patchn+1,col%patchi(c)+numpft - clmpatch%wt_ed(p) = 0.0_r8 - enddo - - !set the area of the bare ground patch. - p = col%patchi(c) - clmpatch%wt_ed(p) = total_bare_ground - clmpatch%is_bareground = .true. - - call this%ed_clm_leaf_area_profile(sites(s), c, waterstate_inst, canopystate_inst ) - - end do ! column loop - - end associate - - end subroutine ed_clm_link + !------------------------------------------------------------------------ @@ -305,509 +55,7 @@ end subroutine ed_clm_link ! AS WELL AS VARIABLES FOR CLM/ALM. - subroutine ed_clm_leaf_area_profile( this, currentSite, colindex, waterstate_inst, canopystate_inst ) - ! - ! !DESCRIPTION: - ! Load LAI in each layer into array to send to CLM - ! - ! !USES: - use FatesGlobals, only : fates_log - - 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 - integer , intent(in) :: colindex ! ALM/CLM column index of this site - 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 - - 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 - real(r8) :: snow_depth_col ! averaged snow over whole columb - 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) - - currentPatch => currentSite%oldest_patch ! ed patch - p = col%patchi(colindex) ! first patch of the column of interest, for vegetated - ! columns this is the non-veg patch - - ! Zero some soil values - tlai(p) = 0.0_r8 - elai(p) = 0.0_r8 - tsai(p) = 0.0_r8 - esai(p) = 0.0_r8 - - do while(associated(currentPatch)) - p = p + 1 ! First CLM/ALM patch is non-veg, increment at loop start - - !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,cp_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 -!write(fates_log(), *) 'calc snow' - snow_depth_col = snow_depth(colindex) * frac_sno_eff(colindex) - if(snow_depth_col > maxh(iv))then - fraction_exposed = 0._r8 - endif - if(snow_depth_col < minh(iv))then - fraction_exposed = 1._r8 - endif - if(snow_depth_col>= minh(iv).and.snow_depth_col <= maxh(iv))then !only partly hidden... - fraction_exposed = max(0._r8,(min(1.0_r8,(snow_depth_col-minh(iv))/dh))) - endif - fraction_exposed = 1.0_r8 - ! no m2 of leaf per m2 of ground in each height class - ! FIX(SPM,032414) these should be uncommented this and double check - - if ( DEBUG ) write(fates_log(), *) 'EDCLMLink 1154 ', currentPatch%elai_profile(1,ft,iv) - - currentPatch%elai_profile(1,ft,iv) = currentPatch%tlai_profile(1,ft,iv) * fraction_exposed - currentPatch%esai_profile(1,ft,iv) = currentPatch%tsai_profile(1,ft,iv) * fraction_exposed - - if ( DEBUG ) write(fates_log(), *) 'EDCLMLink 1159 ', currentPatch%elai_profile(1,ft,iv) - - 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(fates_log(), *) 'ED: 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%layer_height_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(fates_log(), *) 'ED: 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(fates_log(), *) 'ED: issue with NV',currentCohort%NV,currentCohort%pft,currentCohort%canopy_layer - endif - - ! c = clmpatch%column(currentPatch%clm_pno) - ! INTERF-TODO: REMOVE THIS AT SOME POINT, THIS SANITY CHECK IS NOT NEEDED WHEN THE - ! COLUMNIZATION IS COMPLETE - if( clmpatch%column(currentPatch%clm_pno) .ne. colindex .or. currentPatch%clm_pno .ne. p )then - ! ERROR - write(fates_log(), *) ' clmpatch%column(currentPatch%clm_pno) .ne. colindex .or. currentPatch%clm_pno .ne. p ' - call endrun(msg=errMsg(__FILE__, __LINE__)) - end if - - - !Whole layers. Make a weighted average of the leaf area in each layer before dividing it by the total area. - !fill up layer for whole layers. FIX(RF,032414)- for debugging jan 2012 - do iv = 1,currentCohort%NV-1 - - ! 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)) - - write(fates_log(), *) 'calc snow 2', colindex, snow_depth(colindex) , frac_sno_eff(colindex) - ! fraction_exposed = 1.0_r8 !default. - - ! snow_depth_col = snow_depth(c) ! * frac_sno_eff(c) - ! if(snow_depth_col > layer_top_hite)then - ! fraction_exposed = 0._r8 - ! endif - ! if(snow_depth_col < layer_bottom_hite)then - ! fraction_exposed = 1._r8 - ! endif - ! if(snow_depth_col>= layer_bottom_hite.and.snow_depth_col <= layer_top_hite)then !only partly hidden... - ! fraction_exposed = max(0._r8,(min(1.0_r8,(snow_depth_col-layer_bottom_hite)/ & - ! (layer_top_hite-layer_bottom_hite )))) - ! endif -fraction_exposed =1.0_r8 - - currentPatch%tlai_profile(L,ft,iv) = currentPatch%tlai_profile(L,ft,iv)+ dinc_ed * fleaf * & - currentCohort%c_area/currentPatch%total_canopy_area - currentPatch%elai_profile(L,ft,iv) = currentPatch%elai_profile(L,ft,iv)+ dinc_ed * fleaf * & - currentCohort%c_area/currentPatch%total_canopy_area * fraction_exposed - - 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%esai_profile(L,ft,iv) = currentPatch%esai_profile(L,ft,iv)+ dinc_ed * (1._r8 - fleaf) * & - currentCohort%c_area/currentPatch%total_canopy_area * 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) - currentPatch%layer_height_profile(L,ft,iv) = currentPatch%layer_height_profile(L,ft,iv) + (dinc_ed * fleaf * & - currentCohort%c_area/currentPatch%total_canopy_area *(layer_top_hite+layer_bottom_hite)/2.0_r8) !average height of layer. - - write(fates_log(), *) 'LHP', currentPatch%layer_height_profile(L,ft,iv) - if ( DEBUG ) write(fates_log(), *) 'EDCLMLink 1246 ', currentPatch%elai_profile(1,ft,iv) - - 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)) - -!write(fates_log(), *) 'calc snow 3', snow_depth(c) , frac_sno_eff(c) - fraction_exposed = 1.0_r8 !default. - snow_depth_col = snow_depth(colindex) * frac_sno_eff(colindex) - if(snow_depth_col > layer_top_hite)then - fraction_exposed = 0._r8 - endif - if(snow_depth_col < layer_bottom_hite)then - fraction_exposed = 1._r8 - endif - if(snow_depth_col>= layer_bottom_hite.and.snow_depth_col <= layer_top_hite)then !only partly hidden... - fraction_exposed = max(0._r8,(min(1.0_r8,(snow_depth_col-layer_bottom_hite)/ & - (layer_top_hite-layer_bottom_hite )))) - endif -fraction_exposed= 1.0_r8 - - - remainder = (currentCohort%treelai + currentCohort%treesai) - (dinc_ed*(currentCohort%NV-1)) - if(remainder > 1.0_r8)then - write(fates_log(), *)'ED: 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 - currentPatch%elai_profile(L,ft,iv) = currentPatch%elai_profile(L,ft,iv) + remainder * fleaf * & - currentCohort%c_area/currentPatch%total_canopy_area * fraction_exposed - !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%esai_profile(L,ft,iv) = currentPatch%esai_profile(L,ft,iv)+ remainder * & - (1.0_r8-fleaf) * currentCohort%c_area/currentPatch%total_canopy_area * 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) - currentPatch%layer_height_profile(L,ft,iv) = currentPatch%layer_height_profile(L,ft,iv) + (remainder * fleaf * & - currentCohort%c_area/currentPatch%total_canopy_area*(layer_top_hite+layer_bottom_hite)/2.0_r8) - write(fates_log(), *) 'LHP', currentPatch%layer_height_profile(L,ft,iv) - if(currentCohort%dbh <= 0._r8.or.currentCohort%n == 0._r8)then - write(fates_log(), *) '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(fates_log(), *) '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(fates_log(), *) '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) - - if ( DEBUG ) write(fates_log(), *) 'EDCLMLink 1293 ', currentPatch%elai_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) - currentPatch%layer_height_profile(L,ft,iv) = currentPatch%layer_height_profile(L,ft,iv) & - /currentPatch%tlai_profile(L,ft,iv) - enddo - - currentPatch%tlai_profile(L,ft,currentPatch%nrad(L,ft)+1: cp_nlevcan) = 0._r8 - currentPatch%tsai_profile(L,ft,currentPatch%nrad(L,ft)+1: cp_nlevcan) = 0._r8 - currentPatch%elai_profile(L,ft,currentPatch%nrad(L,ft)+1: cp_nlevcan) = 0._r8 - currentPatch%esai_profile(L,ft,currentPatch%nrad(L,ft)+1: cp_nlevcan) = 0._r8 - - enddo - enddo - - !what is the resultant leaf area? - tlai_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))) - enddo - enddo - - ! This should not had changed -! p = currentPatch%clm_pno - if(abs(tlai(p)-tlai_temp) > 0.0001_r8) then - - write(fates_log(), *) 'ED: error with tlai calcs',& - NC,colindex, abs(tlai(p)-tlai_temp), tlai_temp,tlai(p) - - do L = 1,currentPatch%NCL_p - write(fates_log(), *) 'ED: carea profile',L,currentPatch%canopy_area_profile(L,1,1:currentPatch%nrad(L,1)) - write(fates_log(), *) 'ED: tlai profile',L,currentPatch%tlai_profile(L,1,1:currentPatch%nrad(L,1)) - end do - - endif - - elai(p) = calc_areaindex(currentPatch,'elai') - tlai(p) = calc_areaindex(currentPatch,'tlai') - esai(p) = calc_areaindex(currentPatch,'esai') - tsai(p) = calc_areaindex(currentPatch,'tsai') - - ! 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 - - currentPatch%nrad = currentPatch%ncan - do L = 1,currentPatch%NCL_p - do ft = 1,numpft_ed - if(currentPatch%nrad(L,ft) > 30)then - write(fates_log(), *) '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(fates_log(), *) 'ED: canopy area too small',sum(currentPatch%canopy_area_profile(1,1:numpft_ed,1)) - write(fates_log(), *) 'ED: cohort areas', currentPatch%canopy_area_profile(1,1:numpft_ed,:) - 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(fates_log(), *) 'ED: not enough area in the top canopy', & - sum(currentPatch%canopy_area_profile(L,1:numpft_ed,1)), & - currentPatch%canopy_area_profile(L,1:numpft_ed,1) - endif - - if(abs(sum(currentPatch%canopy_area_profile(L,1:numpft_ed,1))) > 1.00001)then - write(fates_log(), *) 'ED: canopy-area-profile wrong', & - sum(currentPatch%canopy_area_profile(L,1:numpft_ed,1)), & - colindex, currentPatch%patchno, L - write(fates_log(), *) 'ED: 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(fates_log(), *) 'ED: cohorts',currentCohort%dbh,currentCohort%c_area, & - currentPatch%total_canopy_area,currentPatch%area,currentPatch%canopy_area - write(fates_log(), *) 'ED: 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(fates_log(), *) 'ED: 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 - - end associate - - end subroutine ed_clm_leaf_area_profile diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index f920f397..a783f280 100755 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -41,7 +41,7 @@ module EDMainMod !-------------------------------------------------------------------------------! subroutine ed_ecosystem_dynamics(currentSite, & - ed_clm_inst, atm2lnd_inst, & + atm2lnd_inst, & soilstate_inst, temperature_inst, waterstate_inst) ! ! !DESCRIPTION: @@ -49,7 +49,6 @@ subroutine ed_ecosystem_dynamics(currentSite, & ! ! !ARGUMENTS: type(ed_site_type) , intent(inout), target :: currentSite - 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 From 61618e9756c8eaae3fdb9082e50824b97183d1e0 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 5 Sep 2016 23:52:29 -0700 Subject: [PATCH 196/437] fully removed EDCLMLinkMod.F90. first clean build. --- biogeochem/EDCanopyStructureMod.F90 | 156 +++++++++++++--------------- biogeochem/EDPhysiologyMod.F90 | 25 +++-- main/EDCLMLinkMod.F90 | 62 ----------- main/EDInitMod.F90 | 1 - main/EDMainMod.F90 | 1 - main/EDRestVectorMod.F90 | 2 - main/FatesInterfaceMod.F90 | 49 ++++++++- 7 files changed, 139 insertions(+), 157 deletions(-) delete mode 100755 main/EDCLMLinkMod.F90 diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index fa92f155..e7c5bf3b 100755 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -6,12 +6,12 @@ module EDCanopyStructureMod ! ============================================================================ use shr_kind_mod , only : r8 => shr_kind_r8; - use clm_varctl , only : iulog + use FatesGlobals , only : fates_log 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 - use EDtypesMod , only : cp_nclmax + use EDtypesMod , only : cp_nclmax,cp_nlevcan use EDtypesMod , only : numpft_ed use shr_log_mod , only : errMsg => shr_log_errMsg use abortutils , only : endrun @@ -22,6 +22,10 @@ module EDCanopyStructureMod public :: canopy_structure public :: canopy_spread public :: calc_areaindex + public :: canopy_summarization + public :: update_hlm_dynamics + + logical, parameter :: DEBUG=.false. ! 10/30/09: Created by Rosie Fisher ! ============================================================================ @@ -80,6 +84,7 @@ subroutine canopy_structure( currentSite ) type(ed_patch_type) , pointer :: currentPatch type(ed_cohort_type), pointer :: currentCohort,copyc integer :: i,j + integer :: c ! index for CWD integer :: z ! Current number of canopy layers. (1= canopy, 2 = understorey) real(r8) :: checkarea real(r8) :: cc_loss @@ -92,7 +97,6 @@ subroutine canopy_structure( currentSite ) 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 !---------------------------------------------------------------------- @@ -126,7 +130,7 @@ subroutine canopy_structure( currentSite ) ! 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 + !write(fates_log(),*) 'CANOPY CLOSURE', z z = z + 1 endif @@ -193,7 +197,7 @@ subroutine canopy_structure( currentSite ) !kill the ones which go into canopy layers that are not allowed... (default nclmax=2) if(i+1 > cp_nclmax)then !put the litter from the terminated cohorts into the fragmenting pools - ! write(iulog,*) '3rd canopy layer' + ! write(fates_log(),*) '3rd canopy layer' do c=1,ncwd currentPatch%CWD_AG(c) = currentPatch%CWD_AG(c) + (currentCohort%bdead+currentCohort%bsw) * & @@ -264,7 +268,7 @@ subroutine canopy_structure( currentSite ) currentCohort%c_area = c_area(currentCohort) endif - !write(iulog,*) 'demoting whole cohort', currentCohort%c_area,cc_loss, & + !write(fates_log(),*) 'demoting whole cohort', currentCohort%c_area,cc_loss, & !currentCohort%canopy_layer,currentCohort%dbh endif @@ -284,7 +288,7 @@ subroutine canopy_structure( currentSite ) enddo !arealayer loop if(arealayer(i)-currentPatch%area > 0.00001_r8)then - write(iulog,*) 'lossarea problem', lossarea,sumloss,z,currentPatch%patchno,currentPatch%clm_pno + write(fates_log(),*) 'lossarea problem', lossarea,sumloss,z,currentPatch%patchno,currentPatch%clm_pno endif enddo !z @@ -358,7 +362,7 @@ subroutine canopy_structure( currentSite ) currentCohort%canopy_layer = i currentCohort%c_area = c_area(currentCohort) - ! write(iulog,*) 'promoting very small cohort', currentCohort%c_area,currentCohort%canopy_layer + ! write(fates_log(),*) '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 @@ -451,18 +455,18 @@ subroutine canopy_structure( currentSite ) promswitch = 1 - ! write(iulog,*) 'promoting whole cohort', currentCohort%c_area,cc_gain,currentCohort%canopy_layer, & + ! write(fates_log(),*) '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 + ! write(fates_log(),*) '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, & + ! write(fates_log(),*) 'cohort list',currentCohort%pft,currentCohort%indexnumber, & ! currentCohort%canopy_layer,currentCohort%c_area endif endif @@ -473,21 +477,21 @@ subroutine canopy_structure( currentSite ) 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, & + ! write(fates_log(),*) '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, & + ! write(fates_log(),*) '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, & + !write(fates_log(),*) '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 + ! write(fates_log(),*) 'z loop',arealayer(1:3),currentPatch%patchno,z endif enddo !z @@ -507,13 +511,13 @@ subroutine canopy_structure( currentSite ) 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) + ! write(fates_log(),*) 'correcting MI',j,currentPatch%area - arealayer(j) endif endif enddo currentPatch%ncl_p = min(z,cp_nclmax) if(promswitch == 1)then - ! write(iulog,*) 'missingarea loop',arealayer(1:3),currentPatch%patchno,missing_area,z + ! write(fates_log(),*) 'missingarea loop',arealayer(1:3),currentPatch%patchno,missing_area,z endif enddo !is there still not enough canopy area in any layer? @@ -522,7 +526,7 @@ subroutine canopy_structure( currentSite ) call terminate_cohorts(currentPatch) if(promswitch == 1)then - !write(iulog,*) 'going into cohort check',currentPatch%clm_pno + !write(fates_log(),*) 'going into cohort check',currentPatch%clm_pno endif ! ----------- Check cohort area ------------------------------! do i = 1,z @@ -538,11 +542,11 @@ subroutine canopy_structure( currentSite ) enddo if(((checkarea-currentPatch%area)) > 0.0001)then - write(iulog,*) 'problem with canopy area', checkarea,currentPatch%area,checkarea-currentPatch%area,i,z,missing_area + write(fates_log(),*) '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) + write(fates_log(),*) 'c_areas in top layer', c_area(currentCohort) endif currentCohort => currentCohort%shorter @@ -552,18 +556,18 @@ subroutine canopy_structure( currentSite ) 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), & + write(fates_log(),*) '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 + ! write(fates_log(),*) 'end patch loop',currentSite%clmgcell endif else !terminate logic to only do if patch_area_sufficiently large - write(iulog,*) 'canopy_structure: patch area too small.', currentPatch%area + write(fates_log(),*) 'canopy_structure: patch area too small.', currentPatch%area end if @@ -571,7 +575,7 @@ subroutine canopy_structure( currentSite ) enddo !patch if(promswitch == 1)then - ! write(iulog,*) 'end canopy structure',currentSite%clmgcell + ! write(fates_log(),*) 'end canopy structure',currentSite%clmgcell endif end subroutine canopy_structure @@ -629,10 +633,10 @@ subroutine canopy_spread( currentSite ) currentPatch%spread(z) = ED_val_minspread endif enddo !z - !write(iulog,*) 'spread',currentPatch%spread(1:2) + !write(fates_log(),*) '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) + !write(fates_log(),*) 'canopy_spread',currentPatch%area,currentPatch%spread(1:2) currentPatch => currentPatch%younger enddo !currentPatch @@ -642,35 +646,29 @@ end subroutine canopy_spread ! ===================================================================================== - subroutine canopy_summariziation( nsites, sites, bc_in ) + subroutine canopy_summarization( nsites, sites, bc_in ) ! ---------------------------------------------------------------------------------- ! Much of this routine was once ed_clm_link minus all the IO and history stuff ! --------------------------------------------------------------------------------- - - ! - ! !USES: + use FatesInterfaceMod , only : bc_in_type use EDGrowthFunctionsMod , only : tree_lai, c_area use EDEcophysConType , only : EDecophyscon use EDtypesMod , only : area use pftconMod , only : pftcon ! !ARGUMENTS - class(ed_clm_type) :: this - type(bounds_type) , intent(in) :: bounds integer , intent(in) :: nsites type(ed_site_type) , intent(inout), target :: sites(nsites) - type(bc_in_type) , intent(inout) :: bc_in(nsites) + type(bc_in_type) , intent(in) :: bc_in(nsites) ! ! !LOCAL VARIABLES: type (ed_patch_type) , pointer :: currentPatch type (ed_cohort_type) , pointer :: currentCohort - integer :: g,l,p,c,s + integer :: s integer :: ft ! plant functional type integer :: patchn ! identification number for each patch. - 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. @@ -709,15 +707,15 @@ subroutine canopy_summariziation( nsites, sites, bc_in ) end if if ( DEBUG ) then - write(iulog,*) 'EDCLMLink 618 ',currentCohort%livecrootn - write(iulog,*) 'EDCLMLink 619 ',currentCohort%br - write(iulog,*) 'EDCLMLink 620 ',coarse_wood_frac - write(iulog,*) 'EDCLMLink 621 ',pftcon%leafcn(ft) + write(fates_log(),*) 'EDCLMLink 618 ',currentCohort%livecrootn + write(fates_log(),*) 'EDCLMLink 619 ',currentCohort%br + write(fates_log(),*) 'EDCLMLink 620 ',coarse_wood_frac + write(fates_log(),*) 'EDCLMLink 621 ',pftcon%leafcn(ft) endif currentCohort%livecrootn = currentCohort%br * coarse_wood_frac / pftcon%leafcn(ft) - if ( DEBUG ) write(iulog,*) 'EDCLMLink 625 ',currentCohort%livecrootn + if ( DEBUG ) write(fates_log(),*) 'EDCLMLink 625 ',currentCohort%livecrootn currentCohort%b = currentCohort%balive+currentCohort%bdead+currentCohort%bstore currentCohort%treelai = tree_lai(currentCohort) @@ -734,13 +732,13 @@ subroutine canopy_summariziation( nsites, sites, bc_in ) ! 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 + write(fates_log(),*) '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 + write(fates_log(),*) '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 + write(fates_log(),*) 'ED: balive is zero in clmedlink',currentCohort%balive endif currentCohort => currentCohort%taller @@ -749,21 +747,20 @@ subroutine canopy_summariziation( nsites, sites, bc_in ) end do !patch loop - call leaf_area_profile(sites(s),bc_in(s)%snow_depth,bc_in(s)%frac_sno_eff) + call leaf_area_profile(sites(s),bc_in(s)%snow_depth_si,bc_in(s)%frac_sno_eff_si) end do ! site loop return - end subroutine canopy_summariziation + end subroutine canopy_summarization ! ===================================================================================== - subroutine leaf_area_profile( this, currentSite , snow_depth, frac_sno_eff) + subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) ! ! !DESCRIPTION: ! ! !USES: - use FatesGlobals, only : fates_log use EDGrowthFunctionsMod , only : tree_lai, tree_sai, c_area use EDtypesMod , only : area, dinc_ed, hitemax, numpft_ed, n_hite_bins @@ -771,10 +768,10 @@ subroutine leaf_area_profile( this, currentSite , snow_depth, frac_sno_eff) ! ! !ARGUMENTS - class(ed_clm_type) :: this type(ed_site_type) , intent(inout) :: currentSite - real(r8) , intent(in) :: snow_depth - real(r8) , intent(in) :: frac_sno_eff + real(r8) , intent(in) :: snow_depth_si + real(r8) , intent(in) :: frac_sno_eff_si + ! ! !LOCAL VARIABLES: type (ed_patch_type) , pointer :: currentPatch @@ -796,7 +793,7 @@ subroutine leaf_area_profile( this, currentSite , snow_depth, frac_sno_eff) 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 - real(r8) :: snow_depth_col ! averaged snow over whole colum (why calc over patch? RGK) + real(r8) :: snow_depth_avg ! avg snow over whole site integer :: NC ! number of cohorts, for bug fixing. !---------------------------------------------------------------------- @@ -902,15 +899,15 @@ subroutine leaf_area_profile( this, currentSite , snow_depth, frac_sno_eff) !snow burial !write(fates_log(), *) 'calc snow' - snow_depth_col = snow_depth * frac_sno_eff - if(snow_depth_col > maxh(iv))then + snow_depth_avg = snow_depth_si * frac_sno_eff_si + if(snow_depth_avg > maxh(iv))then fraction_exposed = 0._r8 endif - if(snow_depth_col < minh(iv))then + if(snow_depth_avg < minh(iv))then fraction_exposed = 1._r8 endif - if(snow_depth_col>= minh(iv).and.snow_depth_col <= maxh(iv))then !only partly hidden... - fraction_exposed = max(0._r8,(min(1.0_r8,(snow_depth_col-minh(iv))/dh))) + if(snow_depth_avg>= minh(iv).and.snow_depth_avg <= maxh(iv))then !only partly hidden... + fraction_exposed = max(0._r8,(min(1.0_r8,(snow_depth_avg-minh(iv))/dh))) endif fraction_exposed = 1.0_r8 ! no m2 of leaf per m2 of ground in each height class @@ -989,7 +986,7 @@ subroutine leaf_area_profile( this, currentSite , snow_depth, frac_sno_eff) layer_bottom_hite = currentCohort%hite-(((iv+1)/currentCohort%NV) * currentCohort%hite * & EDecophyscon%crown(currentCohort%pft)) ! pftcon%vertical_canopy_frac(ft)) - write(fates_log(), *) 'calc snow 2', snow_depth , frac_sno_eff + write(fates_log(), *) 'calc snow 2', snow_depth_si , frac_sno_eff_si fraction_exposed =1.0_r8 @@ -1023,16 +1020,16 @@ subroutine leaf_area_profile( this, currentSite , snow_depth, frac_sno_eff) EDecophyscon%crown(currentCohort%pft)) fraction_exposed = 1.0_r8 !default. - snow_depth_col = snow_depth * bc_in(s)%frac_sno_eff - if(snow_depth_col > layer_top_hite)then + snow_depth_avg = snow_depth_si * frac_sno_eff_si + if(snow_depth_avg > layer_top_hite)then fraction_exposed = 0._r8 endif - if(snow_depth_col < layer_bottom_hite)then + if(snow_depth_avg < layer_bottom_hite)then fraction_exposed = 1._r8 endif - if(snow_depth_col>= layer_bottom_hite.and.snow_depth_col <= layer_top_hite)then !only partly hidden... - fraction_exposed = max(0._r8,(min(1.0_r8,(snow_depth_col-layer_bottom_hite)/ & + if(snow_depth_avg>= layer_bottom_hite.and.snow_depth_avg <= layer_top_hite)then !only partly hidden... + fraction_exposed = max(0._r8,(min(1.0_r8,(snow_depth_avg-layer_bottom_hite)/ & (layer_top_hite-layer_bottom_hite )))) endif fraction_exposed= 1.0_r8 @@ -1179,11 +1176,9 @@ subroutine update_hlm_dynamics(nsites,sites,bc_out) ! to vegetation coverage to the host land model. ! ---------------------------------------------------------------------------------- - use shr_kind_mod , only : r8 => shr_kind_r8 use EDTypesMod , only : ed_patch_type, ed_cohort_type, & ed_site_type, AREA - use FatesInterfaceMod , only : bc_in_type,bc_out_type - use FatesGlobals , only : fates_log + use FatesInterfaceMod , only : bc_out_type ! ! !ARGUMENTS integer, intent(in) :: nsites @@ -1199,7 +1194,6 @@ subroutine update_hlm_dynamics(nsites,sites,bc_out) do s = 1,nsites ifp = 0 - total_bare_ground = 0.0_r8 total_patch_area = 0._r8 currentPatch => sites(s)%oldest_patch do while(associated(currentPatch)) @@ -1212,13 +1206,13 @@ subroutine update_hlm_dynamics(nsites,sites,bc_out) if (associated(currentPatch%tallest)) then - bc_out(s)%htop(ifp) = currentPatch%tallest%hite + bc_out(s)%htop_pa(ifp) = currentPatch%tallest%hite else ! FIX(RF,040113) - should this be a parameter for the minimum possible vegetation height? - bc_out(s)%htop(ifp) = 0.1_r8 + bc_out(s)%htop_pa(ifp) = 0.1_r8 endif - bc_out(s)%hbot(ifp) = max(0._r8, min(0.2_r8, htop(p)- 1.0_r8)) + bc_out(s)%hbot_pa(ifp) = max(0._r8, min(0.2_r8, bc_out(s)%htop_pa(ifp)- 1.0_r8)) ! We are assuming here that grass is all located underneath tree canopies. @@ -1226,23 +1220,23 @@ subroutine update_hlm_dynamics(nsites,sites,bc_out) ! In which case, the bare area would have to be reduced by the grass area... ! currentPatch%total_canopy_area/currentPatch%area is fraction of this patch cover by plants ! currentPatch%area/AREA is the fraction of the soil covered by this patch. - - bc_out(s)%site_canopy_fraction(ifp) = min(1.0_r8,currentPatch%total_canopy_area/currentPatch%area) * & + + bc_out(s)%canopy_fraction_pa(ifp) = min(1.0_r8,currentPatch%total_canopy_area/currentPatch%area) * & (currentPatch%area/AREA) bare_frac_area = (1.0_r8-min(1.0_r8,currentPatch%total_canopy_area/currentPatch%area))* & (currentPatch%area/AREA) - total_patch_area = total_patch_area + bc_out(s)%site_canopy_fraction(ifp) + bare_frac_area + total_patch_area = total_patch_area + bc_out(s)%canopy_fraction_pa(ifp) + bare_frac_area ! Calculate area indices for output boundary to HLM ! It is assumed that cpatch%canopy_area_profile and cpat%xai_profiles ! have been updated (ie ed_leaf_area_profile has been called since dynamics has been called) - bc_out(s)%elai(ifp) = calc_areaindex(currentPatch,'elai') - bc_out(s)%tlai(ifp) = calc_areaindex(currentPatch,'tlai') - bc_out(s)%esai(ifp) = calc_areaindex(currentPatch,'esai') - bc_out(s)%tsai(ifp) = calc_areaindex(currentPatch,'tsai') + bc_out(s)%elai_pa(ifp) = calc_areaindex(currentPatch,'elai') + bc_out(s)%tlai_pa(ifp) = calc_areaindex(currentPatch,'tlai') + bc_out(s)%esai_pa(ifp) = calc_areaindex(currentPatch,'esai') + bc_out(s)%tsai_pa(ifp) = calc_areaindex(currentPatch,'tsai') ! Fraction of vegetation free of snow. This is used to flag those ! patches which shall under-go photosynthesis @@ -1252,10 +1246,10 @@ subroutine update_hlm_dynamics(nsites,sites,bc_out) ! host to tell itself when to do things (circuitous). Just have ! to determine where else it is used - if ((bc_out(s)%elai(ifp) + bc_out(s)%esai(ifp)) > 0._r8) then - bc_out(s)%frac_veg_nosno_alb(ifp) = 1.0_r8 + if ((bc_out(s)%elai_pa(ifp) + bc_out(s)%esai_pa(ifp)) > 0._r8) then + bc_out(s)%frac_veg_nosno_alb_pa(ifp) = 1.0_r8 else - bc_out(s)%frac_veg_nosno_alb(ifp) = 0.0_r8 + bc_out(s)%frac_veg_nosno_alb_pa(ifp) = 0.0_r8 end if @@ -1324,7 +1318,7 @@ function calc_areaindex(cpatch,ai_type) result(ai) enddo enddo else - write(iulog,*) 'Unsupported area index sent to calc_areaindex' + write(fates_log(),*) 'Unsupported area index sent to calc_areaindex' call endrun(msg=errMsg(__FILE__, __LINE__)) end if diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 4bdbef36..d8db7f0a 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1289,7 +1289,9 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) use EDTypesMod, only : AREA, numpft_ed, cp_numlevdecomp_full, cp_numlevdecomp use SoilBiogeochemVerticalProfileMod, only: surfprof_exp - use EDCLMLinkMod, only: cwd_fcel_ed, cwd_flig_ed + + !use EDCLMLinkMod, only: cwd_fcel_ed, cwd_flig + use pftconMod, only : pftcon use shr_const_mod, only: SHR_CONST_CDAY use clm_varcon, only : zisoi, dzsoi_decomp, zsoi @@ -1348,6 +1350,11 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) real(r8) :: froot_prof(1:nsites, 1:numpft_ed, 1:cp_numlevdecomp) real(r8) :: croot_prof(1:nsites, 1:cp_numlevdecomp) real(r8) :: stem_prof(1:nsites, 1:cp_numlevdecomp) + + ! INTERF-TODO: THESE PARAMETERS WERE ORIGINALLY SET BY params_inst% + ! THEY NEED THEIR OWN ENTRIES IN THE PARAMETER FILE (RGK) + real(r8), parameter :: cwd_fcel = 0.76 + real(r8), parameter :: cwd_flig = 0.24 delta = 0.001_r8 @@ -1570,26 +1577,26 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) ! now disaggregate, vertically and by decomposition substrate type, the actual fluxes from CWD and litter pools ! ! do c = 1, ncwd - ! write(iulog,*)'cdk CWD_AG_out', c, currentpatch%CWD_AG_out(c), cwd_fcel_ed, currentpatch%area/AREA - ! write(iulog,*)'cdk CWD_BG_out', c, currentpatch%CWD_BG_out(c), cwd_fcel_ed, currentpatch%area/AREA + ! write(iulog,*)'cdk CWD_AG_out', c, currentpatch%CWD_AG_out(c), cwd_fcel, currentpatch%area/AREA + ! write(iulog,*)'cdk CWD_BG_out', c, currentpatch%CWD_BG_out(c), cwd_fcel, currentpatch%area/AREA ! end do ! do ft = 1,numpft_ed - ! write(iulog,*)'cdk leaf_litter_out', ft, currentpatch%leaf_litter_out(ft), cwd_fcel_ed, currentpatch%area/AREA - ! write(iulog,*)'cdk root_litter_out', ft, currentpatch%root_litter_out(ft), cwd_fcel_ed, currentpatch%area/AREA + ! write(iulog,*)'cdk leaf_litter_out', ft, currentpatch%leaf_litter_out(ft), cwd_fcel, currentpatch%area/AREA + ! write(iulog,*)'cdk root_litter_out', ft, currentpatch%root_litter_out(ft), cwd_fcel, currentpatch%area/AREA ! end do ! ! ! CWD pools fragmenting into decomposing litter pools. do ci = 1, ncwd do j = 1, cp_numlevdecomp bc_out(s)%FATES_c_to_litr_cel_c_col(j) = bc_out(s)%FATES_c_to_litr_cel_c_col(j) + & - currentpatch%CWD_AG_out(ci) * cwd_fcel_ed * currentpatch%area/AREA * stem_prof(s,j) + currentpatch%CWD_AG_out(ci) * cwd_fcel * currentpatch%area/AREA * stem_prof(s,j) bc_out(s)%FATES_c_to_litr_lig_c_col(j) = bc_out(s)%FATES_c_to_litr_lig_c_col(j) + & - currentpatch%CWD_AG_out(ci) * cwd_flig_ed * currentpatch%area/AREA * stem_prof(s,j) + currentpatch%CWD_AG_out(ci) * cwd_flig * currentpatch%area/AREA * stem_prof(s,j) ! bc_out(s)%FATES_c_to_litr_cel_c_col(j) = bc_out(s)%FATES_c_to_litr_cel_c_col(j) + & - currentpatch%CWD_BG_out(ci) * cwd_fcel_ed * currentpatch%area/AREA * croot_prof_perpatch(j) + currentpatch%CWD_BG_out(ci) * cwd_fcel * currentpatch%area/AREA * croot_prof_perpatch(j) bc_out(s)%FATES_c_to_litr_lig_c_col(j) = bc_out(s)%FATES_c_to_litr_lig_c_col(j) + & - currentpatch%CWD_BG_out(ci) * cwd_flig_ed * currentpatch%area/AREA * croot_prof_perpatch(j) + currentpatch%CWD_BG_out(ci) * cwd_flig * currentpatch%area/AREA * croot_prof_perpatch(j) end do end do diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 deleted file mode 100755 index f06e0452..00000000 --- a/main/EDCLMLinkMod.F90 +++ /dev/null @@ -1,62 +0,0 @@ -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 shr_infnan_mod, only : isnan => shr_infnan_isnan - use decompMod , only : bounds_type - use clm_varpar , only : numpft, numcft, mxpft - use clm_varctl , only : iulog - use ColumnType , only : col - use EDtypesMod , only : ed_site_type, ed_cohort_type, ed_patch_type, ncwd - use EDtypesMod , only : sclass_ed, nlevsclass_ed, AREA, cp_nclmax, cp_nlevcan - use CanopyStateType , only : canopystate_type - use clm_varctl , only : use_vertsoilc - use EDParamsMod , only : ED_val_ag_biomass - use SoilBiogeochemCarbonFluxType , only : soilbiogeochem_carbonflux_type - use SoilBiogeochemCarbonStatetype , only : soilbiogeochem_carbonstate_type - use clm_time_manager , only : is_beg_curr_day, get_step_size, get_nstep - use shr_const_mod, only: SHR_CONST_CDAY - use abortutils , only : endrun - use shr_log_mod , only : errMsg => shr_log_errMsg - use EDCanopyStructureMod, only : calc_areaindex - - ! - implicit none - private - ! - logical :: DEBUG = .false. ! for debugging this module (EDCLMLinkMod.F90) - - ! !PUBLIC DATA MEMBERS - real(r8), public :: cwd_fcel_ed - real(r8), public :: cwd_flig_ed - - ! Public routines - procedure , public :: ed_clm_link - - ! Private routines - procedure , private :: ed_clm_leaf_area_profile - - ! 10/30/09: Created by Rosie Fisher - !----------------------------------------------------------------------- - -contains - - !----------------------------------------------------------------------- - - - - !------------------------------------------------------------------------ - - ! INTERF-TODO: THIS ROUTINE COULD BE SPLIT. IT CALCULATES BOTH FATES/ED INTERNALS - ! AS WELL AS VARIABLES FOR CLM/ALM. - - - - - - -end module EDCLMLinkMod diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index f7d62d29..bc3ff427 100755 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -21,7 +21,6 @@ module EDInitMod use EDPatchDynamicsMod , only : create_patch use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type, area use EDTypesMod , only : cohorts_per_col, ncwd, numpft_ed, udata - use EDCLMLinkMod , only : ed_clm_type implicit none private diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index a783f280..16572495 100755 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -17,7 +17,6 @@ module EDMainMod use SFMainMod , only : fire_model use EDtypesMod , only : ncwd, numpft_ed, udata use EDtypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type - use EDCLMLinkMod , only : ed_clm_type implicit none private diff --git a/main/EDRestVectorMod.F90 b/main/EDRestVectorMod.F90 index 0729cd23..83cdac56 100755 --- a/main/EDRestVectorMod.F90 +++ b/main/EDRestVectorMod.F90 @@ -729,7 +729,6 @@ subroutine getVectors( this, bounds, nsites, sites, fcolumn) ! ! !USES: use clm_time_manager , only : get_nstep - use EDCLMLinkMod , only : ed_clm_type use EDMainMod , only : ed_update_site ! ! !ARGUMENTS: @@ -2326,7 +2325,6 @@ subroutine EDRest ( bounds, nsites, sites, fcolumn, ncid, flag ) ! !USES: use ncdio_pio , only : file_desc_t - use EDCLMLinkMod , only : ed_clm_type ! ! !ARGUMENTS: type(bounds_type) , intent(in) :: bounds ! bounds diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 45760c98..048b759d 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -149,6 +149,12 @@ module FatesInterfaceMod real(r8) :: tot_somc ! total soil organic matter carbon (gc/m2) real(r8) :: tot_litc ! total litter carbon tracked in the HLM (gc/m2) + ! Canopy Structure + + real(r8) :: snow_depth_si ! Depth of snow in snowy areas of site (m) + real(r8) :: frac_sno_eff_si ! Fraction of ground covered by snow (0-1) + + end type bc_in_type @@ -226,6 +232,25 @@ module FatesInterfaceMod !total lignin litter coming from ED. gC/m3/s real(r8), allocatable :: FATES_c_to_litr_lig_c_col(:) + ! Canopy Structure + + real(r8), allocatable :: elai_pa(:) ! exposed leaf area index + real(r8), allocatable :: esai_pa(:) ! exposed stem area index + real(r8), allocatable :: tlai_pa(:) ! total leaf area index + real(r8), allocatable :: tsai_pa(:) ! total stem area index + real(r8), allocatable :: htop_pa(:) ! top of the canopy [m] + real(r8), allocatable :: hbot_pa(:) ! bottom of canopy? [m] + + real(r8), allocatable :: canopy_fraction_pa(:) ! Area fraction of each patch in the site + ! Use most likely for weighting + ! This is currently the projected canopy + ! area of each patch [0-1] + + real(r8), allocatable :: frac_veg_nosno_alb_pa(:) ! This is not really a fraction + ! this is actually binary based on if any + ! vegetation in the patch is exposed. + ! [0,1] + end type bc_out_type @@ -296,7 +321,7 @@ subroutine fates_clean(this) ! Deallocate the site list - deallocate (this%sites) +! deallocate (this%sites) return end subroutine fates_clean @@ -393,6 +418,17 @@ subroutine allocate_bcout(bc_out) allocate(bc_out%FATES_c_to_litr_cel_c_col(cp_numlevdecomp_full)) allocate(bc_out%FATES_c_to_litr_lig_c_col(cp_numlevdecomp_full)) + ! Canopy Structure + allocate(bc_out%elai_pa(numPatchesPerCol)) + allocate(bc_out%esai_pa(numPatchesPerCol)) + allocate(bc_out%tlai_pa(numPatchesPerCol)) + allocate(bc_out%tsai_pa(numPatchesPerCol)) + allocate(bc_out%htop_pa(numPatchesPerCol)) + allocate(bc_out%hbot_pa(numPatchesPerCol)) + allocate(bc_out%canopy_fraction_pa(numPatchesPerCol)) + allocate(bc_out%frac_veg_nosno_alb_pa(numPatchesPerCol)) + + return end subroutine allocate_bcout @@ -421,6 +457,8 @@ subroutine zero_bcs(this,s) this%bc_in(s)%tot_het_resp = 0.0_r8 this%bc_in(s)%tot_somc = 0.0_r8 this%bc_in(s)%tot_litc = 0.0_r8 + this%bc_in(s)%snow_depth_si = 0.0_r8 + this%bc_in(s)%frac_sno_eff_si = 0.0_r8 ! Output boundaries this%bc_out(s)%active_suction_gl(:) = .false. @@ -447,6 +485,15 @@ subroutine zero_bcs(this,s) this%bc_out(s)%ftdd_parb(:,:) = 0.0_r8 this%bc_out(s)%ftid_parb(:,:) = 0.0_r8 this%bc_out(s)%ftii_parb(:,:) = 0.0_r8 + + this%bc_out(s)%elai_pa(:) = 0.0_r8 + this%bc_out(s)%esai_pa(:) = 0.0_r8 + this%bc_out(s)%tlai_pa(:) = 0.0_r8 + this%bc_out(s)%tsai_pa(:) = 0.0_r8 + this%bc_out(s)%htop_pa(:) = 0.0_r8 + this%bc_out(s)%hbot_pa(:) = 0.0_r8 + this%bc_out(s)%canopy_fraction_pa(:) = 0.0_r8 + this%bc_out(s)%frac_veg_nosno_alb_pa(:) = 0.0_r8 return end subroutine zero_bcs From c54e538b48d42915b015d09fe1cf9c91300e1076 Mon Sep 17 00:00:00 2001 From: ckoven Date: Tue, 6 Sep 2016 16:49:19 -0700 Subject: [PATCH 197/437] fixed line-length issue --- biogeochem/EDPhysiologyMod.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 620b1a47..4f2d0025 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -113,7 +113,8 @@ subroutine non_canopy_derivs( currentSite, currentPatch, temperature_inst ) call cwd_out( currentSite, currentPatch, temperature_inst) do p = 1,numpft_ed - currentSite%dseed_dt(p) = currentSite%dseed_dt(p) + (currentPatch%seeds_in(p) - currentPatch%seed_decay(p) - currentPatch%seed_germination(p)) * currentPatch%area/AREA + currentSite%dseed_dt(p) = currentSite%dseed_dt(p) + & + (currentPatch%seeds_in(p) - currentPatch%seed_decay(p) - currentPatch%seed_germination(p)) * currentPatch%area/AREA enddo do c = 1,ncwd From dbbe6cba18a84f5dabac9ec6a9c5faca0c30d387 Mon Sep 17 00:00:00 2001 From: ckoven Date: Tue, 6 Sep 2016 19:04:55 -0700 Subject: [PATCH 198/437] reinstated patch fusion of seeds_in, seed_decay, and seed_germination fluxes --- biogeochem/EDPatchDynamicsMod.F90 | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index c46d98d7..ef13658c 100755 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -1166,6 +1166,12 @@ subroutine fuse_2_patches(dp, rp) !area weighted average of ages & litter rp%age = (dp%age * dp%area + rp%age * rp%area)/(dp%area + rp%area) + do p = 1,numpft_ed + 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) From 931fb8221d8d12ee6be9cb07cff694e6154bb4f8 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 7 Sep 2016 17:06:52 -0700 Subject: [PATCH 199/437] Fixes: Added zero initialization to site_in%total_burn_flux_to_atm = 0._r8 for cold-starts. Added flushing to hio variables on initialization (future proofing). Testing if setting area plant to 1.0_r8 is different from 1._r8. --- main/EDInitMod.F90 | 1 + main/HistoryIOMod.F90 | 20 +++++++++++++------- 2 files changed, 14 insertions(+), 7 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index dd263295..0ec37ded 100755 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -62,6 +62,7 @@ subroutine zero_site( site_in ) ! DISTURBANCE site_in%disturbance_rate = 0._r8 ! site level disturbance rates from mortality and fire. site_in%dist_type = 0 ! disturbance dist_type id. + site_in%total_burn_flux_to_atm = 0._r8 ! ! PHENOLOGY site_in%status = 0 ! are leaves in this pixel on or off? diff --git a/main/HistoryIOMod.F90 b/main/HistoryIOMod.F90 index ed9aaf1b..4ea3308a 100644 --- a/main/HistoryIOMod.F90 +++ b/main/HistoryIOMod.F90 @@ -398,7 +398,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,fcolumn) hio_trimming_pa(io_pa) = 0.0_r8 endif - hio_area_plant_pa(io_pa) = 1.0_r8 + hio_area_plant_pa(io_pa) = 1._r8 if (min(cpatch%total_canopy_area,cpatch%area)>0.0_r8) then hio_area_treespread_pa(io_pa) = cpatch%total_tree_area & @@ -1122,19 +1122,25 @@ subroutine set_history_var(this,vname,units,long,use_default,avgflag,vtype,hlms, call this%get_hvar_bounds(hvar,0,lb1,ub1,lb2,ub2) + ! currently, all array spaces are flushed each time + ! the update is called. The flush here on the initialization + ! may be redundant, but will prevent issues in the future + ! if we have host models where not all threads are updating + ! the HIO array spaces. (RGK:09-2016) + select case(trim(vtype)) case('PA_R8') - allocate(hvar%r81d(lb1:ub1)) + allocate(hvar%r81d(lb1:ub1));hvar%r81d(:)=flushval case('SI_R8') - allocate(hvar%r81d(lb1:ub1)) + allocate(hvar%r81d(lb1:ub1));hvar%r81d(:)=flushval case('PA_GRND_R8') - allocate(hvar%r82d(lb1:ub1,lb2:ub2)) + allocate(hvar%r82d(lb1:ub1,lb2:ub2));hvar%r82d(:,:)=flushval case('PA_SCPF_R8') - allocate(hvar%r82d(lb1:ub1,lb2:ub2)) + allocate(hvar%r82d(lb1:ub1,lb2:ub2));hvar%r82d(:,:)=flushval case('SI_GRND_R8') - allocate(hvar%r82d(lb1:ub1,lb2:ub2)) + allocate(hvar%r82d(lb1:ub1,lb2:ub2));hvar%r82d(:,:)=flushval case('SI_SCPF_R8') - allocate(hvar%r82d(lb1:ub1,lb2:ub2)) + allocate(hvar%r82d(lb1:ub1,lb2:ub2));hvar%r82d(:,:)=flushval case default write(fates_log(),*) 'Incompatible vtype passed to set_history_var' write(fates_log(),*) 'vtype = ',trim(vtype),' ?' From 645142f57dd12a1d5328a90a5a24354b5305ab4a Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 9 Sep 2016 12:06:15 -0700 Subject: [PATCH 200/437] Identified that the filter_soilc used in SummarizeNetFluxes is different from fcolumn in that it contains crops. The ideal looping structure should be over fates sites, which will be addressed in a later change group. For this changegroup, we should still get the same effective result, as the crops are not even represented with non-zero area weighting. --- main/EDCLMLinkMod.F90 | 15 +++------------ 1 file changed, 3 insertions(+), 12 deletions(-) diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index a2b0f7d0..5b2336cb 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -1252,28 +1252,19 @@ subroutine SummarizeNetFluxes(this, bounds, num_soilc, filter_soilc, & end do ! site loop ! calculate NEP and NBP fluxes. ????? - do fc = 1,num_soilc - c = filter_soilc(fc) + do s = 1, nsites + c = fcolumn(s) nep(c) = npp_col(c) - hr(c) nbp(c) = npp_col(c) - ( hr(c) + fire_c_to_atm(c) ) end do - if( sum(filter_soilc(1:num_soilc)) .ne. sum(fcolumn(1:nsites)) )then - write(fates_log(),*)'You have real problems' - call endrun(msg=errMsg(__FILE__, __LINE__)) - end if - - - ! calculate total stocks -! do fc = 1,num_soilc (THIS WILL BE REMOVED IN NEXT PR) -! c = filter_soilc(fc) (THIS WILL BE REMOVED IN NEXT PR) + ! calculate total stocks do s = 1, nsites c = fcolumn(s) site_total_seedbank = sum(sites(s)%seed_bank) * 1.e3_r8 totedc(c) = ed_litter_stock(c) + cwd_stock(c) + site_total_seedbank + biomass_stock(c) ! ED stocks totbgcc(c) = totsomc(c) + totlitc(c) ! BGC stocks totecosysc(c) = totedc(c) + totbgcc(c) - end do ! in ED timesteps, because of offset between when ED and BGC reconcile the gain and loss of litterfall carbon, From 034a1b95b8364be4c601c1330906642973b4d872 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 14 Sep 2016 17:37:02 -0700 Subject: [PATCH 201/437] fixed some patch loops that were not updating the patch pointer! Would had made for slow runs;) --- biogeochem/EDCanopyStructureMod.F90 | 15 +++++++++++++-- main/FatesInterfaceMod.F90 | 2 +- 2 files changed, 14 insertions(+), 3 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index e7c5bf3b..53a05040 100755 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -653,6 +653,7 @@ subroutine canopy_summarization( nsites, sites, bc_in ) ! --------------------------------------------------------------------------------- use FatesInterfaceMod , only : bc_in_type + use EDPatchDynamicsMod , only : set_patchno use EDGrowthFunctionsMod , only : tree_lai, c_area use EDEcophysConType , only : EDecophyscon use EDtypesMod , only : area @@ -668,6 +669,7 @@ subroutine canopy_summarization( nsites, sites, bc_in ) type (ed_cohort_type) , pointer :: currentCohort integer :: s integer :: ft ! plant functional type + integer :: ifp integer :: patchn ! identification number for each patch. real(r8) :: coarse_wood_frac real(r8) :: canopy_leaf_area ! total amount of leaf area in the vegetated area. m2. @@ -680,11 +682,19 @@ subroutine canopy_summarization( nsites, sites, bc_in ) do s = 1,nsites + ! -------------------------------------------------------------------------------- + ! Set the patch indices (this is usefull mostly for communicating with a host or + ! driving model. Loops through all patches and sets cpatch%patchno to the integer + ! order of oldest to youngest where the oldest is 1. + ! -------------------------------------------------------------------------------- + call set_patchno( sites(s) ) + currentPatch => sites(s)%oldest_patch + do while(associated(currentPatch)) call currentPatch%set_root_fraction() - + !zero cohort-summed variables. currentPatch%total_canopy_area = 0.0_r8 currentPatch%total_tree_area = 0.0_r8 @@ -745,6 +755,7 @@ subroutine canopy_summarization( nsites, sites, bc_in ) enddo ! ends 'do while(associated(currentCohort)) + currentPatch => currentPatch%younger end do !patch loop call leaf_area_profile(sites(s),bc_in(s)%snow_depth_si,bc_in(s)%frac_sno_eff_si) @@ -1252,7 +1263,7 @@ subroutine update_hlm_dynamics(nsites,sites,bc_out) bc_out(s)%frac_veg_nosno_alb_pa(ifp) = 0.0_r8 end if - + currentPatch => currentPatch%younger end do if(abs(total_patch_area-1.0_r8)>1e-9)then diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 048b759d..87626f09 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -371,7 +371,7 @@ subroutine allocate_bcin(bc_in) allocate(bc_in%albgr_dif_rb(cp_numSWb)) ! Carbon Balance Checking - + ! (snow-depth and snow fraction are site level and not vectors) return From cfec5d82e1108404b64b740d9bd1db3cae6b423d Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 16 Sep 2016 13:14:03 -0700 Subject: [PATCH 202/437] modified file name argument of error message calls during restart array allocation. The changes are designed to prevent line-length overflows, per recommendation by Ben Andre. --- main/EDRestVectorMod.F90 | 152 ++++++++++++++++++++------------------- 1 file changed, 77 insertions(+), 75 deletions(-) diff --git a/main/EDRestVectorMod.F90 b/main/EDRestVectorMod.F90 index 371c7104..347740e0 100755 --- a/main/EDRestVectorMod.F90 +++ b/main/EDRestVectorMod.F90 @@ -168,6 +168,8 @@ module EDRestVectorMod module procedure newEDRestartVectorClass end interface EDRestartVectorClass + character(len=*), private, parameter :: mod_filename = __FILE__ + ! ! non type-bound procedures ! @@ -298,119 +300,119 @@ function newEDRestartVectorClass( bounds ) allocate(new%numPatchesPerCol & (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%numPatchesPerCol(:) = invalidValue allocate(new%old_stock & (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%old_stock(:) = 0.0_r8 allocate(new%cd_status & (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%cd_status(:) = 0_r8 allocate(new%dd_status & (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%dd_status(:) = 0_r8 allocate(new%ncd & (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%ncd(:) = 0_r8 allocate(new%leafondate & (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%leafondate(:) = 0_r8 allocate(new%leafoffdate & (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%leafoffdate(:) = 0_r8 allocate(new%dleafondate & (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%dleafondate(:) = 0_r8 allocate(new%dleafoffdate & (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%dleafoffdate(:) = 0_r8 allocate(new%acc_NI & (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%acc_NI(:) = 0_r8 allocate(new%ED_GDD_site & (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%ED_GDD_site(:) = 0_r8 allocate(new%nep_timeintegrated_si & (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%nep_timeintegrated_si(:) = 0_r8 allocate(new%npp_timeintegrated_si & (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%npp_timeintegrated_si(:) = 0_r8 allocate(new%hr_timeintegrated_si & (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%hr_timeintegrated_si(:) = 0_r8 allocate(new%totecosys_old_si & (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%totecosys_old_si(:) = 0_r8 allocate(new%cbal_err_fates_si & (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%cbal_err_fates_si(:) = 0_r8 allocate(new%cbal_err_bgc_si & (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%cbal_err_bgc_si(:) = 0_r8 allocate(new%cbal_err_tot_si & (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%cbal_err_tot_si(:) = 0_r8 allocate(new%tot_fatesc_old_si & (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%tot_fatesc_old_si(:) = 0_r8 allocate(new%tot_bgcc_old_si & (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%tot_bgcc_old_si(:) = 0_r8 allocate(new%fates_to_bgc_this_ts_si & (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%fates_to_bgc_this_ts_si(:) = 0_r8 allocate(new%fates_to_bgc_last_ts_si & (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%fates_to_bgc_last_ts_si(:) = 0_r8 allocate(new%seedrain_flux_si & (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%seedrain_flux_si(:) = 0_r8 @@ -418,172 +420,172 @@ function newEDRestartVectorClass( bounds ) allocate(new%cohortsPerPatch & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%cohortsPerPatch(:) = invalidValue allocate(new%balive & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%balive(:) = 0.0_r8 allocate(new%bdead & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%bdead(:) = 0.0_r8 allocate(new%bl & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%bl(:) = 0.0_r8 allocate(new%br & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%br(:) = 0.0_r8 allocate(new%bstore & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%bstore(:) = 0.0_r8 allocate(new%canopy_layer & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%canopy_layer(:) = 0.0_r8 allocate(new%canopy_trim & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%canopy_trim(:) = 0.0_r8 allocate(new%dbh & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%dbh(:) = 0.0_r8 allocate(new%hite & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%hite(:) = 0.0_r8 allocate(new%laimemory & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%laimemory(:) = 0.0_r8 allocate(new%leaf_md & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%leaf_md(:) = 0.0_r8 allocate(new%root_md & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%root_md(:) = 0.0_r8 allocate(new%n & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%n(:) = 0.0_r8 allocate(new%gpp_acc & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%gpp_acc(:) = 0.0_r8 allocate(new%npp_acc & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%npp_acc(:) = 0.0_r8 allocate(new%gpp & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%gpp(:) = 0.0_r8 allocate(new%npp & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%npp(:) = 0.0_r8 allocate(new%npp_leaf & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%npp_leaf(:) = 0.0_r8 allocate(new%npp_froot & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%npp_froot(:) = 0.0_r8 allocate(new%npp_bsw & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%npp_bsw(:) = 0.0_r8 allocate(new%npp_bdead & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%npp_bdead(:) = 0.0_r8 allocate(new%npp_bseed & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%npp_bseed(:) = 0.0_r8 allocate(new%npp_store & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%npp_store(:) = 0.0_r8 allocate(new%bmort & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%bmort(:) = 0.0_r8 allocate(new%hmort & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%hmort(:) = 0.0_r8 allocate(new%cmort & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%cmort(:) = 0.0_r8 allocate(new%imort & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%imort(:) = 0.0_r8 allocate(new%fmort & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%fmort(:) = 0.0_r8 allocate(new%ddbhdt & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%ddbhdt(:) = 0.0_r8 allocate(new%resp_tstep & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%resp_tstep(:) = 0.0_r8 allocate(new%pft & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%pft(:) = 0 allocate(new%status_coh & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%status_coh(:) = 0 allocate(new%isnew & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%isnew(:) = new_cohort ! @@ -591,82 +593,82 @@ function newEDRestartVectorClass( bounds ) ! allocate(new%cwd_ag & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%cwd_ag(:) = 0.0_r8 allocate(new%cwd_bg & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%cwd_bg(:) = 0.0_r8 allocate(new%leaf_litter & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%leaf_litter(:) = 0.0_r8 allocate(new%root_litter & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __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__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __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__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __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__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%seed_bank(:) = 0.0_r8 allocate(new%spread & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%spread(:) = 0.0_r8 allocate(new%livegrass & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%livegrass(:) = 0.0_r8 allocate(new%age & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%age(:) = 0.0_r8 allocate(new%areaRestart & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%areaRestart(:) = 0.0_r8 allocate(new%f_sun & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%f_sun(:) = 0.0_r8 allocate(new%fabd_sun_z & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%fabd_sun_z(:) = 0.0_r8 allocate(new%fabi_sun_z & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%fabi_sun_z(:) = 0.0_r8 allocate(new%fabd_sha_z & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%fabd_sha_z(:) = 0.0_r8 allocate(new%fabi_sha_z & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%fabi_sha_z(:) = 0.0_r8 ! @@ -676,7 +678,7 @@ function newEDRestartVectorClass( bounds ) allocate(new%water_memory & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(__FILE__, __LINE__)) + SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%water_memory(:) = 0.0_r8 @@ -1963,7 +1965,7 @@ subroutine createPatchCohortStructure( this, bounds, nsites, sites, fcolumn ) if (this%numPatchesPerCol(c)<0 .or. this%numPatchesPerCol(c)>10000) then write(iulog,*) 'a column was expected to contain a valid number of patches' write(iulog,*) '0 is a valid number, but this column seems uninitialized',this%numPatchesPerCol(c) - call endrun(msg=errMsg(__FILE__, __LINE__)) + call endrun(msg=errMsg(mod_filename, __LINE__)) end if ! Initialize the site pointers to null From c2820620b508ab4872de1912cbbfb2005ea51ce2 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 16 Sep 2016 17:32:33 -0700 Subject: [PATCH 203/437] Partial progress passing in layer depths to sites. --- main/EDInitMod.F90 | 28 ++++++++++++++++++++++++---- main/EDTypesMod.F90 | 7 +++++-- 2 files changed, 29 insertions(+), 6 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 312cd642..64d4f709 100755 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -29,13 +29,34 @@ module EDInitMod public :: zero_site public :: init_patches + public :: init_site public :: set_site_properties - private :: init_cohorts + ! ============================================================================ contains + + subroutine init_site( site_in, bc_in ) + + ! + + ! !ARGUMENTS + type(ed_site_type), intent(inout) :: site_in + type(bc_in_type), intent(in) :: bc_in + + site_in%oldest_patch => null() ! pointer to oldest patch at the site + site_in%youngest_patch => null() ! pointer to yngest patch at the site + + ! Allocate static vectors + allocate(site_in%depth_gl(cp_nlevgrnd)) + site_in%depth_gl(:) = bc_in%depth_gl(:) + + + return + end subroutine init_site + ! ============================================================================ subroutine zero_site( site_in ) @@ -51,9 +72,6 @@ subroutine zero_site( 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 @@ -162,6 +180,8 @@ subroutine set_site_properties( nsites, sites) sites(s)%acc_NI = acc_NI sites(s)%frac_burnt = 0.0_r8 sites(s)%old_stock = 0.0_r8 + + end do return diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 567c889c..59c58f94 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -439,6 +439,9 @@ module EDTypesMod real(r8) :: lat ! latitude: degrees real(r8) :: lon ! longitude: degrees + ! Soil layer depths (dictated by the HLM) + real(r8), allocatable :: grnd_zi(:) ! Ground layer depth (nsoilev) + ! 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 @@ -613,8 +616,8 @@ subroutine set_root_fraction( this ) integer :: lev,p,c,ft !---------------------------------------------------------------------- - p = this%clm_pno - c = clmpatch%column(p) +! p = this%clm_pno +! c = clmpatch%column(p) do ft = 1,numpft_ed do lev = 1, nlevgrnd From d952171fa3aac9f8fa62f7e62d73ed912a9676f9 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 19 Sep 2016 11:08:58 -0700 Subject: [PATCH 204/437] zeroing patch level seed variables during patch creation, potential bug fix. --- biogeochem/EDPatchDynamicsMod.F90 | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index ef13658c..c7cf190d 100755 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -982,6 +982,10 @@ subroutine zero_patch(cp_p) 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 From 2e7226610d7e9bef95d3feffabfa208a8bfe9fbc Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 20 Sep 2016 08:59:38 -0700 Subject: [PATCH 205/437] depth to soil layer interface is needed while setting root fraction. This was previously using the col%zi() global, it is now passed as a boundary condition. --- biogeochem/EDCanopyStructureMod.F90 | 2 +- biogeophys/EDPhotosynthesisMod.F90 | 3 +-- main/EDInitMod.F90 | 24 +++--------------------- main/EDTypesMod.F90 | 27 ++++++++++----------------- main/FatesInterfaceMod.F90 | 26 ++++++++++++++++++++++++-- 5 files changed, 39 insertions(+), 43 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 53a05040..91fdb9cd 100755 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -693,7 +693,7 @@ subroutine canopy_summarization( nsites, sites, bc_in ) do while(associated(currentPatch)) - call currentPatch%set_root_fraction() + call currentPatch%set_root_fraction(bc_in(s)%depth_gl) !zero cohort-summed variables. currentPatch%total_canopy_area = 0.0_r8 diff --git a/biogeophys/EDPhotosynthesisMod.F90 b/biogeophys/EDPhotosynthesisMod.F90 index 4d2e924c..8a78d505 100644 --- a/biogeophys/EDPhotosynthesisMod.F90 +++ b/biogeophys/EDPhotosynthesisMod.F90 @@ -52,7 +52,6 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) use EDtypesMod , only : numpatchespercol, cp_nlevcan, cp_nclmax use EDCanopyStructureMod,only: calc_areaindex - ! ! !ARGUMENTS: integer,intent(in) :: nsites @@ -771,7 +770,7 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) ! Unpack fluxes from arrays into cohorts !==============================================================================! - call currentPatch%set_root_fraction() + call currentPatch%set_root_fraction(bc_in(s)%depth_gl) if(currentPatch%countcohorts > 0.0)then !avoid errors caused by empty patches diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 64d4f709..18a52c16 100755 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -29,7 +29,6 @@ module EDInitMod public :: zero_site public :: init_patches - public :: init_site public :: set_site_properties private :: init_cohorts @@ -37,26 +36,6 @@ module EDInitMod contains - - subroutine init_site( site_in, bc_in ) - - ! - - ! !ARGUMENTS - type(ed_site_type), intent(inout) :: site_in - type(bc_in_type), intent(in) :: bc_in - - site_in%oldest_patch => null() ! pointer to oldest patch at the site - site_in%youngest_patch => null() ! pointer to yngest patch at the site - - ! Allocate static vectors - allocate(site_in%depth_gl(cp_nlevgrnd)) - site_in%depth_gl(:) = bc_in%depth_gl(:) - - - return - end subroutine init_site - ! ============================================================================ subroutine zero_site( site_in ) @@ -72,6 +51,9 @@ subroutine zero_site( 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 diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 59c58f94..9f64aefa 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -128,8 +128,8 @@ module EDTypesMod ! specturm to track ! (typically 2 as a default, VIS/NIR, in ED variants <2016) - - integer :: cp_numlevgrnd ! Number of soil layers + integer :: cp_numlevgrnd ! Number of ground layers + integer :: cp_numlevsoil ! Number of soil layers ! Number of GROUND layers for the purposes of biogeochemistry; can be either 1 ! or the total number of soil layers (includes bedrock) @@ -439,9 +439,6 @@ module EDTypesMod real(r8) :: lat ! latitude: degrees real(r8) :: lon ! longitude: degrees - ! Soil layer depths (dictated by the HLM) - real(r8), allocatable :: grnd_zi(:) ! Ground layer depth (nsoilev) - ! 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 @@ -598,38 +595,34 @@ function map_clmpatch_to_edpatch(site, clmpatch_number) result(edpatch_pointer) end function map_clmpatch_to_edpatch !-------------------------------------------------------------------------------------! - subroutine set_root_fraction( this ) + subroutine set_root_fraction( this , depth_gl) ! ! !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 + real(r8),intent(in) :: depth_gl(0:cp_numlevgrnd) ! ! !LOCAL VARIABLES: integer :: lev,p,c,ft !---------------------------------------------------------------------- -! p = this%clm_pno -! c = clmpatch%column(p) - do ft = 1,numpft_ed - do lev = 1, nlevgrnd + do lev = 1, cp_numlevgrnd this%rootfr_ft(ft,lev) = 0._r8 enddo - do lev = 1, nlevsoi-1 + do lev = 1, cp_numlevsoil-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))) + exp(-pftcon%roota_par(ft) * depth_gl(lev-1)) & + + exp(-pftcon%rootb_par(ft) * depth_gl(lev-1)) & + - exp(-pftcon%roota_par(ft) * depth_gl(lev)) & + - exp(-pftcon%rootb_par(ft) * depth_gl(lev))) end do end do diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 87626f09..356951bc 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -24,7 +24,8 @@ module FatesInterfaceMod cp_numlevdecomp, & cp_numlevdecomp_full, & cp_hlm_name, & - cp_hio_ignore_val + cp_hio_ignore_val, & + cp_numlevsoil use shr_kind_mod , only : r8 => shr_kind_r8 ! INTERF-TODO: REMOVE THIS @@ -154,6 +155,9 @@ module FatesInterfaceMod real(r8) :: snow_depth_si ! Depth of snow in snowy areas of site (m) real(r8) :: frac_sno_eff_si ! Fraction of ground covered by snow (0-1) + ! Ground Layer Structure + real(r8),allocatable :: depth_gl(:) ! Depth in vertical direction of ground layers + ! Interface level below a "z" level (m) (1:cp_nlevgrnd) end type bc_in_type @@ -372,7 +376,9 @@ subroutine allocate_bcin(bc_in) ! Carbon Balance Checking ! (snow-depth and snow fraction are site level and not vectors) - + + ! Ground layer structure + allocate(bc_in%depth_gl(0:cp_numlevgrnd)) return end subroutine allocate_bcin @@ -459,6 +465,7 @@ subroutine zero_bcs(this,s) this%bc_in(s)%tot_litc = 0.0_r8 this%bc_in(s)%snow_depth_si = 0.0_r8 this%bc_in(s)%frac_sno_eff_si = 0.0_r8 + this%bc_in(s)%depth_gl(:) = 0.0_r8 ! Output boundaries this%bc_out(s)%active_suction_gl(:) = .false. @@ -546,6 +553,7 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) end if cp_numSwb = unset_int cp_numlevgrnd = unset_int + cp_numlevsoil = unset_int cp_numlevdecomp_full = unset_int cp_numlevdecomp = unset_int cp_hlm_name = 'unset' @@ -582,6 +590,14 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) ! end_run('MESSAGE') end if + if(cp_numlevsoil .eq. unset_int) then + if (fates_global_verbose()) then + write(fates_log(), *) 'FATES dimension/parameter unset: numlevground' + end if + ! INTERF-TODO: FATES NEEDS INTERNAL end_run + ! end_run('MESSAGE') + end if + if(cp_numlevdecomp_full .eq. unset_int) then if (fates_global_verbose()) then write(fates_log(), *) 'FATES dimension/parameter unset: numlevdecomp_full' @@ -637,6 +653,12 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) if (fates_global_verbose()) then write(fates_log(),*) 'Transfering num_lev_ground = ',ival,' to FATES' end if + case('num_lev_soil') + + cp_numlevsoil = ival + if (fates_global_verbose()) then + write(fates_log(),*) 'Transfering num_lev_ground = ',ival,' to FATES' + end if case('num_levdecomp_full') From 75310f10557b9a4a339d768230336580f33e68bd Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 26 Sep 2016 23:17:35 -0700 Subject: [PATCH 206/437] re-integrated clm_pno. Will remove its set when its use is no longer necessary. --- biogeochem/EDCanopyStructureMod.F90 | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 91fdb9cd..87d32489 100755 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1180,7 +1180,7 @@ end subroutine leaf_area_profile ! ====================================================================================== - subroutine update_hlm_dynamics(nsites,sites,bc_out) + subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) ! ---------------------------------------------------------------------------------- ! The purpose of this routine is to package output boundary conditions related @@ -1190,14 +1190,17 @@ subroutine update_hlm_dynamics(nsites,sites,bc_out) use EDTypesMod , only : ed_patch_type, ed_cohort_type, & ed_site_type, AREA use FatesInterfaceMod , only : bc_out_type + use ColumnType , only : col ! THIS MUST BE REMOVED WITH CLM_PNO + ! ! !ARGUMENTS integer, intent(in) :: nsites type(ed_site_type), intent(inout), target :: sites(nsites) + integer, intent(in) :: fcolumn(nsites) type(bc_out_type), intent(inout) :: bc_out(nsites) ! Locals - integer :: s, ifp + integer :: s, ifp, c type (ed_patch_type) , pointer :: currentPatch real(r8) :: bare_frac_area real(r8) :: total_patch_area @@ -1207,9 +1210,12 @@ subroutine update_hlm_dynamics(nsites,sites,bc_out) ifp = 0 total_patch_area = 0._r8 currentPatch => sites(s)%oldest_patch + c = fcolumn(s) do while(associated(currentPatch)) ifp = ifp+1 - + + currentPatch%clm_pno = ifp + col%patchi(c) ! THIS IS SLOWLY BEING REMOVED + if ( currentPatch%total_canopy_area-currentPatch%area > 0.000001_r8 ) then write(fates_log(),*) 'ED: canopy area bigger than area',currentPatch%total_canopy_area ,currentPatch%area currentPatch%total_canopy_area = currentPatch%area From ab20b12b0de857ab998a6cfe193d6d79667f47d9 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 27 Sep 2016 16:40:34 -0700 Subject: [PATCH 207/437] Added a check to total_canopy_area that was omitted while clearing out ed_clm_link. Fixed some diagnostic messages that were describing the originating file as EDCLMLinkMod. --- biogeochem/EDCanopyStructureMod.F90 | 26 ++++++++++++++++---------- 1 file changed, 16 insertions(+), 10 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index af7d68e5..a0056056 100755 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -721,15 +721,15 @@ subroutine canopy_summarization( nsites, sites, bc_in ) end if if ( DEBUG ) then - write(fates_log(),*) 'EDCLMLink 618 ',currentCohort%livecrootn - write(fates_log(),*) 'EDCLMLink 619 ',currentCohort%br - write(fates_log(),*) 'EDCLMLink 620 ',coarse_wood_frac - write(fates_log(),*) 'EDCLMLink 621 ',pftcon%leafcn(ft) + write(fates_log(),*) 'canopy_summarization 724 ',currentCohort%livecrootn + write(fates_log(),*) 'canopy_summarization 725 ',currentCohort%br + write(fates_log(),*) 'canopy_summarization 726 ',coarse_wood_frac + write(fates_log(),*) 'canopy_summarization 727 ',pftcon%leafcn(ft) endif currentCohort%livecrootn = currentCohort%br * coarse_wood_frac / pftcon%leafcn(ft) - if ( DEBUG ) write(fates_log(),*) 'EDCLMLink 625 ',currentCohort%livecrootn + if ( DEBUG ) write(fates_log(),*) 'canopy_summarization 732 ',currentCohort%livecrootn currentCohort%b = currentCohort%balive+currentCohort%bdead+currentCohort%bstore currentCohort%treelai = tree_lai(currentCohort) @@ -746,19 +746,25 @@ subroutine canopy_summarization( nsites, sites, bc_in ) ! Check for erroneous zero values. if(currentCohort%dbh <= 0._r8 .or. currentCohort%n == 0._r8)then - write(fates_log(),*) 'ED: dbh or n is zero in clmedlink', currentCohort%dbh,currentCohort%n + write(fates_log(),*) 'ED: dbh or n is zero in canopy_summarization', currentCohort%dbh,currentCohort%n endif if(currentCohort%pft == 0.or.currentCohort%canopy_trim <= 0._r8)then - write(fates_log(),*) 'ED: PFT or trim is zero in clmedlink',currentCohort%pft,currentCohort%canopy_trim + write(fates_log(),*) 'ED: PFT or trim is zero in canopy_summarization',currentCohort%pft,currentCohort%canopy_trim endif if(currentCohort%balive <= 0._r8)then - write(fates_log(),*) 'ED: balive is zero in clmedlink',currentCohort%balive + write(fates_log(),*) 'ED: balive is zero in canopy_summarization',currentCohort%balive endif currentCohort => currentCohort%taller enddo ! ends 'do while(associated(currentCohort)) + if ( currentPatch%total_canopy_area-currentPatch%area > 0.000001_r8 ) then + write(fates_log(),*) 'ED: canopy area bigger than area',currentPatch%total_canopy_area ,currentPatch%area + currentPatch%total_canopy_area = currentPatch%area + endif + + currentPatch => currentPatch%younger end do !patch loop @@ -928,12 +934,12 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) ! no m2 of leaf per m2 of ground in each height class ! FIX(SPM,032414) these should be uncommented this and double check - if ( DEBUG ) write(fates_log(), *) 'EDCLMLink 1154 ', currentPatch%elai_profile(1,ft,iv) + if ( DEBUG ) write(fates_log(), *) 'leaf_area_profile()', currentPatch%elai_profile(1,ft,iv) currentPatch%elai_profile(1,ft,iv) = currentPatch%tlai_profile(1,ft,iv) * fraction_exposed currentPatch%esai_profile(1,ft,iv) = currentPatch%tsai_profile(1,ft,iv) * fraction_exposed - if ( DEBUG ) write(fates_log(), *) 'EDCLMLink 1159 ', currentPatch%elai_profile(1,ft,iv) + if ( DEBUG ) write(fates_log(), *) 'leaf_area_profile()', currentPatch%elai_profile(1,ft,iv) enddo ! (iv) hite bins From 1aebf3e6a1b74de1f89d3dde2b8bfb34de4cfcb2 Mon Sep 17 00:00:00 2001 From: Rosie Fisher Date: Fri, 7 Oct 2016 14:02:33 -0600 Subject: [PATCH 208/437] Modified two bugs in effective windspeed and in livegrass moisture found in SPITFIRE. --- fire/SFMainMod.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index f63c60c2..e907a013 100755 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -222,7 +222,7 @@ subroutine charecteristics_of_fuel ( currentSite ) ! 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) + fuel_moisture(lg_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)) @@ -363,7 +363,7 @@ subroutine wind_effect ( currentSite, atm2lnd_inst) 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%effect_wspeed = wind * (tree_fraction*0.4+(grass_fraction+bare_fraction)*0.6) currentPatch => currentPatch%younger enddo !end patch loop From c89563c41aa26ce3512cc2ec2287961a736c4420 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 7 Oct 2016 16:52:56 -0700 Subject: [PATCH 209/437] Science fixes on sapwood and fine root respiration. First pass, no testing, compiles. --- biogeochem/EDCohortDynamicsMod.F90 | 10 --- biogeophys/EDPhotosynthesisMod.F90 | 114 +++++++++++++++++------------ main/EDCLMLinkMod.F90 | 21 ------ main/EDTypesMod.F90 | 12 ++- 4 files changed, 75 insertions(+), 82 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index fca32709..7c948f0b 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -381,11 +381,6 @@ subroutine nan_cohort(cc_p) 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 @@ -1047,11 +1042,6 @@ subroutine copy_cohort( currentCohort,copyc ) 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 diff --git a/biogeophys/EDPhotosynthesisMod.F90 b/biogeophys/EDPhotosynthesisMod.F90 index ecad4352..f46d5e40 100644 --- a/biogeophys/EDPhotosynthesisMod.F90 +++ b/biogeophys/EDPhotosynthesisMod.F90 @@ -46,7 +46,8 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) use clm_varpar , only : nlevsoi, mxpft use clm_varctl , only : iulog use pftconMod , only : pftcon - use EDParamsMod , only : ED_val_grperc + use EDParamsMod , only : ED_val_grperc, & + ED_val_ag_biomass 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 @@ -181,7 +182,6 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) real(r8) :: an(cp_nclmax,mxpft,cp_nlevcan) ! net leaf photosynthesis (umol CO2/m**2/s) real(r8) :: an_av(cp_nclmax,mxpft,cp_nlevcan) ! 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 @@ -189,7 +189,7 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) 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) @@ -198,6 +198,26 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) real(r8) :: gs_cohort real(r8) :: rscanopy real(r8) :: elai + + real(r8) :: live_agstem_n ! Live above-ground stem (sapwood) nitrogen content (gN/plant) + real(r8) :: live_bgstem_n ! Live below-ground stem (sapwood) nitrogen content (gN/plant) + real(r8) :: froot_n ! Fine root nitrogen content (gN/plant) + + ! Parameters + + ! ----------------------------------------------------------------------- + ! base maintenance respiration rate for plant tissues base_mr_20 + ! 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 + ! (gC/gN/s) + ! ------------------------------------------------------------------------ + + real(r8),parameter :: base_mr_20 = 2.525e-6_r8 + associate( & c3psn => pftcon%c3psn , & ! photosynthetic pathway: 0. = c4, 1. = c3 @@ -410,13 +430,6 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) ! 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 @@ -853,60 +866,67 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) !------------------------------------------------------------------------------ ! 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 ( DEBUG ) write(iulog,*) 'EDPhoto 874 ', currentCohort%livecroot_mr - if ( DEBUG ) write(iulog,*) 'EDPhoto 875 ', currentCohort%livecrootn - - if (woody(FT) == 1) then + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! THIS CALCULATION SHOULD BE MOVED TO THE ALLOMETRY MODULE (RGK 10-8-2016) + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + currentCohort%bsw = EDecophyscon%sapwood_ratio(currentCohort%pft) * & + currentCohort%hite * (currentCohort%balive + currentCohort%laimemory)*leaf_frac + + ! Calculate the amount of nitrogen in the above and below ground + ! stem and root pools, used for maint resp + ! ------------------------------------------------------------------ + live_agstem_n = ED_val_ag_biomass * currentCohort%bsw / & + pftcon%leafcn(currentCohort%pft) + live_bgstem_n = (1.0_r8-ED_val_ag_biomass) * currentCohort%bsw / & + pftcon%leafcn(currentCohort%pft) + froot_n = currentCohort%br / leafcn(currentCohort%pft) + + ! Above ground Live stem MR + ! ------------------------------------------------------------------ + if (woody(ft) == 1) then tc = q10**((bc_in(s)%t_veg_pa(ifp)-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) - + currentCohort%livestem_mr = live_agstem_n * base_mr_20 * tc !convert from gC /indiv/s-1 to kgC/indiv/s-1 - ! TODO: CHANGE THAT 1000 to 1000.0_r8 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - currentCohort%livestem_mr = currentCohort%livestem_mr /1000 - currentCohort%livecroot_mr = currentCohort%livecroot_mr /1000 + currentCohort%livestem_mr = currentCohort%livestem_mr /1000.0_r8 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. + ! Fine Root MR + ! ------------------------------------------------------------------ currentCohort%froot_mr = 0._r8 - do j = 1,nlevsoi tcsoi = q10**((bc_in(s)%t_soisno_gl(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 + currentCohort%froot_mr = currentCohort%froot_mr + & + froot_n * base_mr_20 * tcsoi * currentPatch%rootfr_ft(ft,j) enddo + ! convert from gC/indiv/s-1 to kgC/indiv/s-1 + currentCohort%froot_mr = currentCohort%froot_mr /1000.0_r8 + + + ! Coarse Root MR + ! ------------------------------------------------------------------ + if (woody(ft) == 1) then + currentCohort%livecroot_mr = 0._r8 + do j = 1,nlevsoi + ! Soil temperature used to adjust base rate of MR + tcsoi = q10**((bc_in(s)%t_soisno_gl(j)-tfrz - 20.0_r8)/10.0_r8) + currentCohort%livecroot_mr = currentCohort%livecroot_mr + & + live_bgstem_n * base_mr_20 * tcsoi * & + currentPatch%rootfr_ft(ft,j)* currentPatch%rootfr_ft(ft,j) + enddo + ! convert from gC/indiv/s-1 to kgC/indiv/s-1 + currentCohort%livecroot_mr = currentCohort%livecroot_mr /1000.0_r8 + else + currentCohort%livecroot_mr = 0._r8 + end if ! 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 diff --git a/main/EDCLMLinkMod.F90 b/main/EDCLMLinkMod.F90 index 1c7d6649..eab8da5a 100755 --- a/main/EDCLMLinkMod.F90 +++ b/main/EDCLMLinkMod.F90 @@ -175,27 +175,6 @@ subroutine ed_clm_link( this, bounds, nsites, sites, fcolumn, waterstate_inst, c do while(associated(currentCohort)) ft = currentCohort%pft - currentCohort%livestemn = currentCohort%bsw / pftcon%leafcn(currentCohort%pft) - - currentCohort%livecrootn = 0.0_r8 - - if (pftcon%woody(ft) == 1) then - coarse_wood_frac = 0.5_r8 - else - coarse_wood_frac = 0.0_r8 - end if - - if ( DEBUG ) then - write(iulog,*) 'EDCLMLink 618 ',currentCohort%livecrootn - write(iulog,*) 'EDCLMLink 619 ',currentCohort%br - write(iulog,*) 'EDCLMLink 620 ',coarse_wood_frac - write(iulog,*) 'EDCLMLink 621 ',pftcon%leafcn(ft) - endif - - currentCohort%livecrootn = currentCohort%br * coarse_wood_frac / pftcon%leafcn(ft) - - if ( DEBUG ) write(iulog,*) 'EDCLMLink 625 ',currentCohort%livecrootn - currentCohort%b = currentCohort%balive+currentCohort%bdead+currentCohort%bstore currentCohort%treelai = tree_lai(currentCohort) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 567c889c..f9dff3af 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -216,7 +216,9 @@ module EDTypesMod 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 + ! (Above ground) + real(r8) :: livecroot_mr ! Live stem maintenance respiration: kgC/indiv/s + ! (below ground) real(r8) :: froot_mr ! Live fine root maintenance respiration: kgC/indiv/s ! ALLOCATION @@ -239,9 +241,11 @@ module EDTypesMod real(r8) :: fmort ! fire mortality n/year ! 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 + ! ---------------------------------------------------------------------------------- + ! Nitrogen pools are not prognostic in the current implementation. + ! They are diagnosed during photosynthesis using a simple C2N parameter. Local values + ! used in that routine. + ! ---------------------------------------------------------------------------------- ! GROWTH DERIVIATIVES real(r8) :: dndt ! time derivative of cohort size : n/year From 101f01dd438f783fcb930c040266b81dc75c740b Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 7 Oct 2016 17:02:50 -0700 Subject: [PATCH 210/437] fixed typo where MR of bg sapwood was double multiplied by bg root fraction --- biogeophys/EDPhotosynthesisMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeophys/EDPhotosynthesisMod.F90 b/biogeophys/EDPhotosynthesisMod.F90 index f46d5e40..79ed24f3 100644 --- a/biogeophys/EDPhotosynthesisMod.F90 +++ b/biogeophys/EDPhotosynthesisMod.F90 @@ -920,7 +920,7 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) tcsoi = q10**((bc_in(s)%t_soisno_gl(j)-tfrz - 20.0_r8)/10.0_r8) currentCohort%livecroot_mr = currentCohort%livecroot_mr + & live_bgstem_n * base_mr_20 * tcsoi * & - currentPatch%rootfr_ft(ft,j)* currentPatch%rootfr_ft(ft,j) + currentPatch%rootfr_ft(ft,j) enddo ! convert from gC/indiv/s-1 to kgC/indiv/s-1 currentCohort%livecroot_mr = currentCohort%livecroot_mr /1000.0_r8 From 79be4212d4dadd68a5934779fd046f71d73ae9af Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 10 Oct 2016 16:42:22 -0700 Subject: [PATCH 211/437] Added several AR diagnostics. Also changed the units of dark-respiration to be consistent with the other maintenance pools. However, the unit of kgC/plant/sec is likely to be a very very small number that is wasting precision. Contemplating changing units to umol/sec or kgC/yr. --- biogeochem/EDCohortDynamicsMod.F90 | 6 +- biogeophys/EDPhotosynthesisMod.F90 | 44 ++++++++------ main/EDTypesMod.F90 | 2 +- main/HistoryIOMod.F90 | 96 ++++++++++++++++++++++++++++-- 4 files changed, 123 insertions(+), 25 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 7c948f0b..d35afdb1 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -361,7 +361,7 @@ subroutine nan_cohort(cc_p) !RESPIRATION - currentCohort%rd = nan + currentCohort%rdark = 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 @@ -418,7 +418,7 @@ subroutine zero_cohort(cc_p) currentCohort%NV = 0 currentCohort%status_coh = 0 - currentCohort%rd = 0._r8 + currentCohort%rdark = 0._r8 currentCohort%resp_m = 0._r8 currentCohort%resp_g = 0._r8 currentCohort%livestem_mr = 0._r8 @@ -1035,7 +1035,7 @@ subroutine copy_cohort( currentCohort,copyc ) n%npp_store = o%npp_store !RESPIRATION - n%rd = o%rd + n%rdark = o%rdark n%resp_m = o%resp_m n%resp_g = o%resp_g n%livestem_mr = o%livestem_mr diff --git a/biogeophys/EDPhotosynthesisMod.F90 b/biogeophys/EDPhotosynthesisMod.F90 index 79ed24f3..35334fa7 100644 --- a/biogeophys/EDPhotosynthesisMod.F90 +++ b/biogeophys/EDPhotosynthesisMod.F90 @@ -205,6 +205,12 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) ! Parameters + ! Conversion factor umols of Carbon -> kg of Carbon (1 mol = 12g) + real(r8), parameter :: umolC_to_kgC = 12.0E-9_r8 + + ! Conversion factor: grams per kilograms + real(r8), parameter :: g_per_kg = 1000.0_r8 + ! ----------------------------------------------------------------------- ! base maintenance respiration rate for plant tissues base_mr_20 ! M. Ryan, 1991. Effects of climate change on plant respiration. @@ -437,7 +443,7 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) ! 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 + lmr25top(FT) = lmr25top(FT) * lnc(FT) / (umolC_to_kgC * g_per_kg) end do !FT @@ -801,7 +807,7 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) currentCohort%npp_tstep = 0.0_r8 currentCohort%resp_tstep = 0.0_r8 currentCohort%gpp_tstep = 0.0_r8 - currentCohort%rd = 0.0_r8 + currentCohort%rdark = 0.0_r8 currentCohort%resp_m = 0.0_r8 ! Select canopy layer and PFT. @@ -824,16 +830,16 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) currentCohort%gpp_tstep = 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) * & + currentCohort%rdark = 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)+bc_in(s)%rb_pa(ifp)))) * tree_area - currentCohort%ts_net_uptake(1:currentCohort%nv) = an_av(cl,ft,1:currentCohort%nv) * 12E-9 * dtime + currentCohort%ts_net_uptake(1:currentCohort%nv) = an_av(cl,ft,1:currentCohort%nv) * umolC_to_kgC * dtime else currentCohort%gpp_tstep = 0.0_r8 - currentCohort%rd = 0.0_r8 + currentCohort%rdark = 0.0_r8 currentCohort%gscan = 0.0_r8 currentCohort%ts_net_uptake(:) = 0.0_r8 @@ -858,15 +864,14 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) currentCohort%gpp_tstep = currentCohort%gpp_tstep + currentPatch%psn_z(cl,ft,currentCohort%nv) * & currentPatch%elai_profile(cl,ft,currentCohort%nv) * laifrac * tree_area - if ( DEBUG ) write(iulog,*) 'EDPhoto 843 ', currentCohort%rd + if ( DEBUG ) write(iulog,*) 'EDPhoto 843 ', currentCohort%rdark - currentCohort%rd = currentCohort%rd + lmr_z(cl,ft,currentCohort%nv) * & + + currentCohort%rdark = currentCohort%rdark + lmr_z(cl,ft,currentCohort%nv) * & currentPatch%elai_profile(cl,ft,currentCohort%nv) * laifrac * tree_area - !------------------------------------------------------------------------------ - ! 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. - !------------------------------------------------------------------------------ + ! Convert dark respiration from umol/plant/s to kgC/plant/s + currentCohort%rdark = currentCohort%rdark * umolC_to_kgC leaf_frac = 1.0_r8/(currentCohort%canopy_trim + EDecophyscon%sapwood_ratio(currentCohort%pft) * & currentCohort%hite + pftcon%froot_leaf(currentCohort%pft)) @@ -887,6 +892,12 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) pftcon%leafcn(currentCohort%pft) froot_n = currentCohort%br / leafcn(currentCohort%pft) + + !------------------------------------------------------------------------------ + ! 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. + !------------------------------------------------------------------------------ + ! Above ground Live stem MR ! ------------------------------------------------------------------ if (woody(ft) == 1) then @@ -928,20 +939,19 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) currentCohort%livecroot_mr = 0._r8 end if - ! 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 + ! convert gpp from umol/indiv/s-1 to kgC/indiv/s-1 = X * 12 *10-6 * 10-3 if ( DEBUG ) write(iulog,*) 'EDPhoto 904 ', currentCohort%resp_m - if ( DEBUG ) write(iulog,*) 'EDPhoto 905 ', currentCohort%rd + if ( DEBUG ) write(iulog,*) 'EDPhoto 905 ', currentCohort%rdark if ( DEBUG ) write(iulog,*) 'EDPhoto 906 ', currentCohort%livestem_mr if ( DEBUG ) write(iulog,*) 'EDPhoto 907 ', currentCohort%livecroot_mr if ( DEBUG ) write(iulog,*) 'EDPhoto 908 ', currentCohort%froot_mr - currentCohort%gpp_tstep = currentCohort%gpp_tstep * 12.0E-9 + currentCohort%gpp_tstep = currentCohort%gpp_tstep * umolC_to_kgC ! 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 + currentCohort%resp_m = currentCohort%resp_m + currentCohort%rdark ! convert from kgC/indiv/s to kgC/indiv/timestep currentCohort%resp_m = currentCohort%resp_m * dtime @@ -951,7 +961,7 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) if ( DEBUG ) write(iulog,*) 'EDPhoto 912 ', currentCohort%resp_tstep if ( DEBUG ) write(iulog,*) 'EDPhoto 913 ', currentCohort%resp_m - currentCohort%resp_g = ED_val_grperc(1) * (max(0._r8,currentCohort%gpp_tstep - currentCohort%resp_m)) + currentCohort%resp_g = ED_val_grperc(1) * (max(0._r8,currentCohort%gpp_tstep - currentCohort%resp_m)) currentCohort%resp_tstep = currentCohort%resp_m + currentCohort%resp_g ! kgC/indiv/ts currentCohort%npp_tstep = currentCohort%gpp_tstep - currentCohort%resp_tstep ! kgC/indiv/ts diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index f9dff3af..4af5b32b 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -212,7 +212,7 @@ module EDTypesMod real(r8) :: year_net_uptake(cp_nlevcan) ! Net uptake of leaf layers: kgC/m2/year ! RESPIRATION COMPONENTS - real(r8) :: rd ! Dark respiration: umol/indiv/s + real(r8) :: rdark ! Dark respiration: kgC/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 diff --git a/main/HistoryIOMod.F90 b/main/HistoryIOMod.F90 index 6faa0d9e..c746c33d 100644 --- a/main/HistoryIOMod.F90 +++ b/main/HistoryIOMod.F90 @@ -119,6 +119,13 @@ Module HistoryIOMod integer, private :: ih_m4_si_scpf integer, private :: ih_m5_si_scpf + integer, private :: ih_ar_si_scpf + integer, private :: ih_ar_grow_si_scpf + integer, private :: ih_ar_maint_si_scpf + integer, private :: ih_ar_darkm_si_scpf + integer, private :: ih_ar_agsapm_si_scpf + integer, private :: ih_ar_crootm_si_scpf + integer, private :: ih_ar_frootm_si_scpf ! The number of variable dim/kind types we have defined (static) integer, parameter :: n_iovar_dk = 6 @@ -627,7 +634,9 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) use EDtypesMod , only : ed_site_type, & ed_cohort_type, & ed_patch_type, & - AREA + AREA, & + sclass_ed, & + nlevsclass_ed ! Arguments class(fates_hio_interface_type) :: this integer , intent(in) :: nc ! clump index @@ -644,7 +653,9 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) integer :: io_soipa integer :: lb1,ub1,lb2,ub2 ! IO array bounds for the calling thread integer :: ivar ! index of IO variable object vector - + integer :: ft ! functional type index + integer :: scpf ! index of the size-class x pft bin + integer :: sc ! index of the size-class bin real(r8) :: n_density ! individual of cohort per m2. real(r8) :: n_perm2 ! individuals per m2 for the whole column @@ -660,7 +671,15 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) hio_aresp_pa => this%hvars(ih_aresp_pa)%r81d, & hio_maint_resp_pa => this%hvars(ih_maint_resp_pa)%r81d, & hio_growth_resp_pa => this%hvars(ih_growth_resp_pa)%r81d, & - hio_npp_si => this%hvars(ih_npp_si)%r81d ) + hio_npp_si => this%hvars(ih_npp_si)%r81d, & + hio_ar_si_scpf => this%hvars(ih_ar_si_scpf)%r82d, & + hio_ar_grow_si_scpf => this%hvars(ih_ar_grow_si_scpf)%r82d, & + hio_ar_maint_si_scpf => this%hvars(ih_ar_maint_si_scpf)%r82d, & + hio_ar_agsapm_si_scpf => this%hvars(ih_ar_agsapm_si_scpf)%r82d, & + hio_ar_darkm_si_scpf => this%hvars(ih_ar_darkm_si_scpf)%r82d, & + hio_ar_crootm_si_scpf => this%hvars(ih_ar_crootm_si_scpf)%r82d, & + hio_ar_frootm_si_scpf => this%hvars(ih_ar_frootm_si_scpf)%r82d ) + ! Flush the relevant history variables call this%flush_hvars(nc,upfreq_in=2) @@ -706,6 +725,39 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) ! map ed cohort-level npp fluxes to clm column fluxes hio_npp_si(io_si) = hio_npp_si(io_si) + ccohort%npp_tstep * n_perm2 * 1.e3_r8 /dt_tstep + ! Calculate index for the scpf class + sc = count(ccohort%dbh-sclass_ed.ge.0.0) + scpf = (ft-1)*nlevsclass_ed+sc + + ! Total AR (kgC/m2/yr) = (kgC/plant/step) / (s/step) * (plant/m2) * (s/yr) + hio_ar_si_scpf(io_si,scpf) = hio_ar_si_scpf(io_si,scpf) + & + (ccohort%resp_tstep/dt_tstep) * n_perm2 * daysecs * yeardays + + ! Growth AR (kgC/m2/yr) + hio_ar_grow_si_scpf(io_si,scpf) = hio_ar_grow_si_scpf(io_si,scpf) + & + (ccohort%resp_g/dt_tstep) * n_perm2 * daysecs * yeardays + + ! Maint AR (kgC/m2/yr) + hio_ar_maint_si_scpf(io_si,scpf) = hio_ar_maint_si_scpf(io_si,scpf) + & + (ccohort%resp_m/dt_tstep) * n_perm2 * daysecs * yeardays + + ! Maintenance AR partition variables are stored as rates (kgC/plant/s) + ! (kgC/m2/yr) = (kgC/plant/s) * (plant/m2) * (s/yr) + hio_ar_agsapm_si_scpf(io_si,scpf) = hio_ar_agsapm_si_scpf(io_si,scpf) + & + ccohort%livestem_mr * n_perm2 * daysecs * yeardays + + ! (kgC/m2/yr) = (kgC/plant/s) * (plant/m2) * (s/yr) + hio_ar_darkm_si_scpf(io_si,scpf) = hio_ar_darkm_si_scpf(io_si,scpf) + & + ccohort%rdark * n_perm2 * daysecs * yeardays + + ! (kgC/m2/yr) = (kgC/plant/s) * (plant/m2) * (s/yr) + hio_ar_crootm_si_scpf(io_si,scpf) = hio_ar_crootm_si_scpf(io_si,scpf) + & + ccohort%livecroot_mr * n_perm2 * daysecs * yeardays + + ! (kgC/m2/yr) = (kgC/plant/s) * (plant/m2) * (s/yr) + hio_ar_frootm_si_scpf(io_si,scpf) = hio_ar_frootm_si_scpf(io_si,scpf) + & + ccohort%froot_mr * n_perm2 * daysecs * yeardays + endif ccohort => ccohort%taller @@ -1028,7 +1080,6 @@ subroutine define_history_vars(this,callstep,nvar) avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & upfreq=1, ivar=ivar,callstep=callstep, index = ih_npp_totl_si_scpf ) - call this%set_history_var(vname='NPP_LEAF_SCPF',units='kgC/m2/yr', & long='NPP flux into leaves', use_default='inactive', & avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & @@ -1109,6 +1160,43 @@ subroutine define_history_vars(this,callstep,nvar) avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & upfreq=1, ivar=ivar,callstep=callstep, index = ih_m5_si_scpf ) + ! Size structured diagnostics that require rapid updates (upfreq=2) + + call this%set_history_var(vname='AR_SCPF',units = 'kgC/m2/yr', & + long='total autotrophic respiration per m2 per year',use_default='inactive',& + avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & + upfreq=2, ivar=ivar,callstep=callstep, index = ih_ar_si_scpf ) + + call this%set_history_var(vname='AR_GROW_SCPF',units = 'kgC/m2/yr', & + long='growth autotrophic respiration per m2 per year',use_default='inactive',& + avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & + upfreq=2, ivar=ivar,callstep=callstep, index = ih_ar_grow_si_scpf ) + + call this%set_history_var(vname='AR_MAINT_SCPF',units = 'kgC/m2/yr', & + long='maintenance autotrophic respiration per m2 per year',use_default='inactive',& + avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & + upfreq=2, ivar=ivar,callstep=callstep, index = ih_ar_maint_si_scpf ) + + call this%set_history_var(vname='AR_DARKM_SCPF',units = 'kgC/m2/yr', & + long='dark portion of maintenance autotrophic respiration per m2 per year',use_default='inactive',& + avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & + upfreq=2, ivar=ivar,callstep=callstep, index = ih_ar_darkm_si_scpf ) + + call this%set_history_var(vname='AR_AGSAPM_SCPF',units = 'kgC/m2/yr', & + long='above-ground sapwood maintenance autotrophic respiration per m2 per year',use_default='inactive',& + avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & + upfreq=2, ivar=ivar,callstep=callstep, index = ih_ar_agsapm_si_scpf ) + + call this%set_history_var(vname='AR_CROOTM_SCPF',units = 'kgC/m2/yr', & + long='below-ground sapwood maintenance autotrophic respiration per m2 per year',use_default='inactive',& + avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & + upfreq=2, ivar=ivar,callstep=callstep, index = ih_ar_crootm_si_scpf ) + + call this%set_history_var(vname='AR_FROOTM_SCPF',units = 'kgC/m2/yr', & + long='fine root maintenance autotrophic respiration per m2 per year',use_default='inactive',& + avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & + upfreq=2, ivar=ivar,callstep=callstep, index = ih_ar_frootm_si_scpf ) + ! CARBON BALANCE VARIABLES THAT DEPEND ON HLM BGC INPUTS From fdcd6953965523dbe69c2b4b71e642b27884f691 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 11 Oct 2016 21:22:20 -0700 Subject: [PATCH 212/437] minor fix to update the pft index during the scpf output for photosynthesis --- main/HistoryIOMod.F90 | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/main/HistoryIOMod.F90 b/main/HistoryIOMod.F90 index c746c33d..85c51ffd 100644 --- a/main/HistoryIOMod.F90 +++ b/main/HistoryIOMod.F90 @@ -710,6 +710,11 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) if ( .not. ccohort%isnew ) then + ! Calculate index for the scpf class + ft = ccohort%pft + sc = count(ccohort%dbh-sclass_ed.ge.0.0) + scpf = (ft-1)*nlevsclass_ed+sc + ! scale up cohort fluxes to their patches hio_npp_pa(io_pa) = hio_npp_pa(io_pa) + & ccohort%npp_tstep * 1.e3_r8 * n_density / dt_tstep @@ -725,9 +730,6 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) ! map ed cohort-level npp fluxes to clm column fluxes hio_npp_si(io_si) = hio_npp_si(io_si) + ccohort%npp_tstep * n_perm2 * 1.e3_r8 /dt_tstep - ! Calculate index for the scpf class - sc = count(ccohort%dbh-sclass_ed.ge.0.0) - scpf = (ft-1)*nlevsclass_ed+sc ! Total AR (kgC/m2/yr) = (kgC/plant/step) / (s/step) * (plant/m2) * (s/yr) hio_ar_si_scpf(io_si,scpf) = hio_ar_si_scpf(io_si,scpf) + & From e517f348beece1712544c3813bb82ef8d2a9602a Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 11 Oct 2016 21:37:58 -0700 Subject: [PATCH 213/437] minor fix, livecrootn was still in a print statement that I overlooked. I removed it. --- biogeochem/EDCanopyStructureMod.F90 | 2 -- 1 file changed, 2 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 5e311097..5b8ad923 100755 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -711,8 +711,6 @@ subroutine canopy_summarization( nsites, sites, bc_in ) ft = currentCohort%pft - if ( DEBUG ) write(fates_log(),*) 'canopy_summarization 732 ',currentCohort%livecrootn - currentCohort%b = currentCohort%balive+currentCohort%bdead+currentCohort%bstore currentCohort%treelai = tree_lai(currentCohort) From 05f6b6474df5405b2b0dba4afc24cdd8260d1903 Mon Sep 17 00:00:00 2001 From: Ben Andre Date: Tue, 11 Oct 2016 16:18:35 -0600 Subject: [PATCH 214/437] Create FatesConstantMod to hold global constants Create FatesConstantMod to hold global cosntants for things like string length, kind types, spval and other immutable data. Initial values based on similar constants in CLM. Fixes: #135 User interface changes?: none Code review: self Test suite: ed - yellowstone gnu, intel, pgi Test baseline: 49733e8 Test namelist changes: none Test answer changes: bit for bit Test summary: all tests pass Test suite: clm_short - yellowstone gnu, intel, pgi Test baseline: clm4_5_12_r195 Test namelist changes: none Test answer changes: bit for bit Test summary: all tests pass --- main/FatesConstantsMod.F90 | 21 +++++++++++++++++++++ main/HistoryIOMod.F90 | 19 ++++++++++--------- 2 files changed, 31 insertions(+), 9 deletions(-) create mode 100644 main/FatesConstantsMod.F90 diff --git a/main/FatesConstantsMod.F90 b/main/FatesConstantsMod.F90 new file mode 100644 index 00000000..be01937c --- /dev/null +++ b/main/FatesConstantsMod.F90 @@ -0,0 +1,21 @@ +module FatesConstantsMod + ! This module is used to define global _immutable_ data. Everything in + ! this module must have the parameter attribute. + + implicit none + + public + + ! kinds + integer, parameter :: fates_r8 = selected_real_kind(12) ! 8 byte real + + ! string lengths + integer, parameter :: fates_avg_flag_length = 3 + integer, parameter :: fates_short_string_length = 32 + integer, parameter :: fates_long_string_length = 199 + + ! various magic numbers + real(fates_r8), parameter :: fates_special_value = 1.0e36_fates_r8 ! special value for real data, compatible with clm. + integer, parameter :: fates_int_special_value = -9999 ! keep this negative to avoid conflicts with possible valid values + +end module FatesConstantsMod diff --git a/main/HistoryIOMod.F90 b/main/HistoryIOMod.F90 index 3456b54e..b21edabe 100644 --- a/main/HistoryIOMod.F90 +++ b/main/HistoryIOMod.F90 @@ -1,7 +1,8 @@ Module HistoryIOMod - use shr_kind_mod , only : r8 => shr_kind_r8 + use FatesConstantsMod, only : r8 => fates_r8 + use FatesConstantsMod, only : fates_avg_flag_length, fates_short_string_length, fates_long_string_length use FatesGlobals , only : fates_log use EDTypesMod , only : cp_hio_ignore_val use pftconMod , only : pftcon @@ -127,7 +128,7 @@ Module HistoryIOMod ! This structure is not allocated by thread, but the upper and lower boundaries ! of the dimension for each thread is saved in the clump_ entry type iovar_dim_type - character(len=32) :: name ! This should match the name of the dimension + character(fates_short_string_length) :: name ! This should match the name of the dimension integer :: lb ! lower bound integer :: ub ! upper bound integer,allocatable :: clump_lb(:) ! lower bound of thread's portion of HIO array @@ -150,7 +151,7 @@ Module HistoryIOMod ! This structure is not multi-threaded type iovar_dimkind_type - character(len=32) :: name ! String labelling this IO type + character(fates_short_string_length) :: name ! String labelling this IO type integer :: ndims ! number of dimensions in this IO type integer, allocatable :: dimsize(:) ! The size of each dimension logical :: active @@ -162,15 +163,15 @@ Module HistoryIOMod ! This type is instanteated in the HLM-FATES interface (clmfates_interfaceMod.F90) type iovar_def_type - character(len=32) :: vname - character(len=24) :: units - character(len=128) :: long - character(len=24) :: use_default ! States whether a variable should be turned + character(len=fates_short_string_length) :: vname + character(len=fates_short_string_length) :: units + character(len=fates_long_string_length) :: long + character(len=fates_short_string_length) :: use_default ! States whether a variable should be turned ! on the output files by default (active/inactive) ! It is a good idea to set inactive for very large ! or infrequently used output datasets - character(len=24) :: vtype - character(len=1) :: avgflag + character(len=fates_short_string_length) :: vtype + character(len=fates_avg_flag_length) :: avgflag integer :: upfreq ! Update frequency (this is for checks and flushing) ! 1 = dynamics "dyn" (daily) ! 2 = production "prod" (prob model tstep) From f9776d6047876c8f9eeed72a534f9085e189f6e3 Mon Sep 17 00:00:00 2001 From: Ben Andre Date: Wed, 12 Oct 2016 16:28:57 -0600 Subject: [PATCH 215/437] Remove special value constants from FatesConstantsmod The special values added int FatestConstantsMod weren't used at this time, and it's unclear if we need a fates specific set of special values, or if we only want to use the host value. Removing until needed. Testing: since this only removed unused code, compiled and ran: SMS_D_Ld5.f45_f45.ICLM45ED.yellowstone_intel.clm-edTest - passed --- main/FatesConstantsMod.F90 | 4 ---- 1 file changed, 4 deletions(-) diff --git a/main/FatesConstantsMod.F90 b/main/FatesConstantsMod.F90 index be01937c..244f6f65 100644 --- a/main/FatesConstantsMod.F90 +++ b/main/FatesConstantsMod.F90 @@ -14,8 +14,4 @@ module FatesConstantsMod integer, parameter :: fates_short_string_length = 32 integer, parameter :: fates_long_string_length = 199 - ! various magic numbers - real(fates_r8), parameter :: fates_special_value = 1.0e36_fates_r8 ! special value for real data, compatible with clm. - integer, parameter :: fates_int_special_value = -9999 ! keep this negative to avoid conflicts with possible valid values - end module FatesConstantsMod From 552842b8fe153ff4318b0ec0e30e35a7939fdded Mon Sep 17 00:00:00 2001 From: Ben Andre Date: Wed, 12 Oct 2016 16:35:39 -0600 Subject: [PATCH 216/437] Refactor fates history dimensions into standalone module Move the fates history dimensions class into a standalone module, along with the procedures for initialization and setting threads. Test suite: ERS_D_Ld5.f10_f10.ICLM45ED.yellowstone_intel.clm-edTest Test baseline: 49733e8 Test namelist changes: none Test answer changes: bit for bit Test summary: pass --- main/FatesHistoryDimensionMod.F90 | 70 ++++++++++++++ main/HistoryIOMod.F90 | 148 ++++++++++++++++-------------- 2 files changed, 149 insertions(+), 69 deletions(-) create mode 100644 main/FatesHistoryDimensionMod.F90 diff --git a/main/FatesHistoryDimensionMod.F90 b/main/FatesHistoryDimensionMod.F90 new file mode 100644 index 00000000..6fb3d5c5 --- /dev/null +++ b/main/FatesHistoryDimensionMod.F90 @@ -0,0 +1,70 @@ +module FatesHistoryDimensionMod + + use FatesConstantsMod, only : fates_short_string_length + + implicit none + + ! FIXME(bja, 2016-10) do these need to be strings, or can they be integer enumerations? + character(*), parameter :: patch_r8 = 'PA_R8' + character(*), parameter :: patch_ground_r8 = 'PA_GRND_R8' + character(*), parameter :: patch_class_pft_r8 = 'PA_SCPF_R8' + character(*), parameter :: site_r8 = 'SI_R8' + character(*), parameter :: site_ground_r8 = 'SI_GRND_R8' + character(*), parameter :: site_class_pft_r8 = 'SI_SCPF_R8' + + ! This structure is not allocated by thread, but the upper and lower boundaries + ! of the dimension for each thread is saved in the clump_ entry + type fates_history_dimension_type + character(len=fates_short_string_length) :: name + integer :: lower_bound + integer :: upper_bound + integer, allocatable :: clump_lower_bound(:) ! lower bound of thread's portion of HIO array + integer, allocatable :: clump_upper_bound(:) ! upper bound of thread's portion of HIO array + contains + procedure, public :: Init => InitHistoryDimensions + procedure, public :: SetThreadBounds => SetHistoryDimensionThreadBounds + end type fates_history_dimension_type + +contains + + ! ===================================================================================== + subroutine InitHistoryDimensions(this, name, num_threads, lower_bound, upper_bound) + + implicit none + + ! arguments + class(fates_history_dimension_type), intent(inout) :: this + character(len=*), intent(in) :: name + integer, intent(in) :: num_threads + integer, intent(in) :: lower_bound + integer, intent(in) :: upper_bound + + this%name = trim(name) + this%lower_bound = lower_bound + this%upper_bound = upper_bound + + allocate(this%clump_lower_bound(num_threads)) + this%clump_lower_bound(:) = -1 + + allocate(this%clump_upper_bound(num_threads)) + this%clump_upper_bound(:) = -1 + + end subroutine InitHistoryDimensions + + ! ===================================================================================== + + subroutine SetHistoryDimensionThreadBounds(this, thread_index, lower_bound, upper_bound) + + implicit none + + class(fates_history_dimension_type), intent(inout) :: this + integer, intent(in) :: thread_index + integer, intent(in) :: lower_bound + integer, intent(in) :: upper_bound + + this%clump_lower_bound(thread_index) = lower_bound + this%clump_upper_bound(thread_index) = upper_bound + + end subroutine SetHistoryDimensionThreadBounds + +end module FatesHistoryDimensionMod diff --git a/main/HistoryIOMod.F90 b/main/HistoryIOMod.F90 index b21edabe..669d86c6 100644 --- a/main/HistoryIOMod.F90 +++ b/main/HistoryIOMod.F90 @@ -4,7 +4,12 @@ Module HistoryIOMod use FatesConstantsMod, only : r8 => fates_r8 use FatesConstantsMod, only : fates_avg_flag_length, fates_short_string_length, fates_long_string_length use FatesGlobals , only : fates_log + + use FatesHistoryDimensionMod, only : fates_history_dimension_type + use EDTypesMod , only : cp_hio_ignore_val + + ! FIXME(bja, 2016-10) need to remove CLM dependancy use pftconMod , only : pftcon implicit none @@ -124,17 +129,16 @@ Module HistoryIOMod ! The number of variable dim/kind types we have defined (static) integer, parameter :: n_iovar_dk = 6 - - ! This structure is not allocated by thread, but the upper and lower boundaries - ! of the dimension for each thread is saved in the clump_ entry - type iovar_dim_type - character(fates_short_string_length) :: name ! This should match the name of the dimension - integer :: lb ! lower bound - integer :: ub ! upper bound - integer,allocatable :: clump_lb(:) ! lower bound of thread's portion of HIO array - integer,allocatable :: clump_ub(:) ! upper bound of thread's portion of HIO array - end type iovar_dim_type - + type, public :: fates_bounds_type + integer :: patch_begin + integer :: patch_end + integer :: column_begin + integer :: column_end + integer :: ground_begin + integer :: ground_end + integer :: pft_class_begin + integer :: pft_class_end + end type fates_bounds_type ! This structure is allocated by thread, and must be calculated after the FATES @@ -155,8 +159,8 @@ Module HistoryIOMod integer :: ndims ! number of dimensions in this IO type integer, allocatable :: dimsize(:) ! The size of each dimension logical :: active - type(iovar_dim_type), pointer :: dim1_ptr - type(iovar_dim_type), pointer :: dim2_ptr + type(fates_history_dimension_type), pointer :: dim1_ptr + type(fates_history_dimension_type), pointer :: dim2_ptr end type iovar_dimkind_type @@ -200,26 +204,29 @@ Module HistoryIOMod ! This is a structure that explains where FATES patch boundaries ! on each thread point to in the host IO array, this structure ! is allocated by number of threads - type(iovar_dim_type) :: iopa_dim + type(fates_history_dimension_type) :: iopa_dim ! This is a structure that explains where FATES patch boundaries ! on each thread point to in the host IO array, this structure ! is allocated by number of threads - type(iovar_dim_type) :: iosi_dim + type(fates_history_dimension_type) :: iosi_dim ! This is a structure that contains the boundaries for the ! ground level (includes rock) dimension - type(iovar_dim_type) :: iogrnd_dim + type(fates_history_dimension_type) :: iogrnd_dim ! This is a structure that contains the boundaries for the ! number of size-class x pft dimension - type(iovar_dim_type) :: ioscpf_dim + type(fates_history_dimension_type) :: ioscpf_dim type(iovar_map_type), pointer :: iovar_map(:) contains + procedure, public :: Init => InitFatesHistoryOutput + procedure, public :: SetThreadBounds => SetHistoryThreadBounds + procedure, public :: update_history_dyn procedure, public :: update_history_prod procedure, public :: update_history_cbal @@ -229,8 +236,6 @@ Module HistoryIOMod procedure, public :: iotype_index procedure, public :: set_dim_ptrs procedure, public :: get_hvar_bounds - procedure, public :: dim_init - procedure, public :: set_dim_thread_bounds procedure, private :: flush_hvars end type fates_hio_interface_type @@ -239,9 +244,52 @@ Module HistoryIOMod contains - ! =================================================================================== + ! ====================================================================== + + subroutine InitFatesHistoryOutput(this, num_threads, fates_bounds) + + implicit none + + class(fates_hio_interface_type), intent(inout) :: this + integer, intent(in) :: num_threads + type(fates_bounds_type), intent(in) :: fates_bounds + + call this%iopa_dim%Init('patch', num_threads, fates_bounds%patch_begin, fates_bounds%patch_end) + call this%iosi_dim%Init('column', num_threads, fates_bounds%column_begin, fates_bounds%column_end) + call this%iogrnd_dim%Init('levgrnd', num_threads, fates_bounds%ground_begin, fates_bounds%ground_end) + call this%ioscpf_dim%Init('levscpf', num_threads, fates_bounds%pft_class_begin, fates_bounds%pft_class_end) + + ! Allocate the mapping between FATES indices and the IO indices + allocate(this%iovar_map(num_threads)) + + end subroutine InitFatesHistoryOutput + + ! ====================================================================== + subroutine SetHistoryThreadBounds(this, thread_index, thread_bounds) + + implicit none + + class(fates_hio_interface_type), intent(inout) :: this + + integer, intent(in) :: thread_index + type(fates_bounds_type), intent(in) :: thread_bounds + + call this%iopa_dim%SetThreadBounds(thread_index, & + thread_bounds%patch_begin, thread_bounds%patch_end) + + call this%iosi_dim%SetThreadBounds(thread_index, & + thread_bounds%column_begin, thread_bounds%column_end) + + call this%iogrnd_dim%SetThreadBounds(thread_index, & + thread_bounds%ground_begin, thread_bounds%ground_end) + + call this%ioscpf_dim%SetThreadBounds(thread_index, & + thread_bounds%pft_class_begin, thread_bounds%pft_class_end) + + end subroutine SetHistoryThreadBounds - subroutine update_history_cbal(this,nc,nsites,sites) + ! ======================================================================= + subroutine update_history_cbal(this,nc,nsites,sites) use EDtypesMod , only : ed_site_type @@ -733,7 +781,6 @@ subroutine flush_hvars(this,nc,upfreq_in) type(iovar_def_type),pointer :: hvar integer :: lb1,ub1,lb2,ub2 - do ivar=1,ubound(this%hvars,1) hvar => this%hvars(ivar) if (hvar%upfreq==upfreq_in) then ! Only flush variables with update on dynamics step @@ -1292,18 +1339,18 @@ subroutine get_hvar_bounds(this,hvar,thread,lb1,ub1,lb2,ub2) ! The thread = 0 case is the boundaries for the whole proc/node if (thread==0) then - lb1 = hvar%iovar_dk_ptr%dim1_ptr%lb - ub1 = hvar%iovar_dk_ptr%dim1_ptr%ub + lb1 = hvar%iovar_dk_ptr%dim1_ptr%lower_bound + ub1 = hvar%iovar_dk_ptr%dim1_ptr%upper_bound if(ndims>1)then - lb2 = hvar%iovar_dk_ptr%dim2_ptr%lb - ub2 = hvar%iovar_dk_ptr%dim2_ptr%ub + lb2 = hvar%iovar_dk_ptr%dim2_ptr%lower_bound + ub2 = hvar%iovar_dk_ptr%dim2_ptr%upper_bound end if else - lb1 = hvar%iovar_dk_ptr%dim1_ptr%clump_lb(thread) - ub1 = hvar%iovar_dk_ptr%dim1_ptr%clump_ub(thread) + lb1 = hvar%iovar_dk_ptr%dim1_ptr%clump_lower_bound(thread) + ub1 = hvar%iovar_dk_ptr%dim1_ptr%clump_upper_bound(thread) if(ndims>1)then - lb2 = hvar%iovar_dk_ptr%dim2_ptr%clump_lb(thread) - ub2 = hvar%iovar_dk_ptr%dim2_ptr%clump_ub(thread) + lb2 = hvar%iovar_dk_ptr%dim2_ptr%clump_lower_bound(thread) + ub2 = hvar%iovar_dk_ptr%dim2_ptr%clump_upper_bound(thread) end if end if @@ -1416,7 +1463,7 @@ subroutine set_dim_ptrs(this,dk_name,idim,dim_target) class(fates_hio_interface_type) :: this character(len=*),intent(in) :: dk_name integer,intent(in) :: idim ! dimension index - type(iovar_dim_type),target :: dim_target + type(fates_history_dimension_type),target :: dim_target ! local @@ -1440,7 +1487,7 @@ subroutine set_dim_ptrs(this,dk_name,idim,dim_target) end if ! With the map, we can set the dimension size - this%iovar_dk(ityp)%dimsize(idim) = dim_target%ub - dim_target%lb + 1 + this%iovar_dk(ityp)%dimsize(idim) = dim_target%upper_bound - dim_target%lower_bound + 1 return @@ -1467,43 +1514,6 @@ function iotype_index(this,iotype_name) result(ityp) end function iotype_index - ! ===================================================================================== - - subroutine dim_init(this,iovar_dim,dim_name,nthreads,lb_in,ub_in) - - ! arguments - class(fates_hio_interface_type) :: this - type(iovar_dim_type),target :: iovar_dim - character(len=*),intent(in) :: dim_name - integer,intent(in) :: nthreads - integer,intent(in) :: lb_in - integer,intent(in) :: ub_in - - allocate(iovar_dim%clump_lb(nthreads)) - allocate(iovar_dim%clump_ub(nthreads)) - - iovar_dim%name = trim(dim_name) - iovar_dim%lb = lb_in - iovar_dim%ub = ub_in - - return - end subroutine dim_init - - ! ===================================================================================== - - subroutine set_dim_thread_bounds(this,iovar_dim,nc,lb_in,ub_in) - - class(fates_hio_interface_type) :: this - type(iovar_dim_type),target :: iovar_dim - integer,intent(in) :: nc ! Thread index - integer,intent(in) :: lb_in - integer,intent(in) :: ub_in - - iovar_dim%clump_lb(nc) = lb_in - iovar_dim%clump_ub(nc) = ub_in - - return - end subroutine set_dim_thread_bounds ! ==================================================================================== ! DEPRECATED, TRANSITIONAL OR FUTURE CODE SECTION From 393875b48aa93fc76550789f8cab0edb6acdb775 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 13 Oct 2016 14:51:34 -0700 Subject: [PATCH 217/437] fixed hard-coded pft index in grperc found in photosynthesis --- biogeophys/EDPhotosynthesisMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeophys/EDPhotosynthesisMod.F90 b/biogeophys/EDPhotosynthesisMod.F90 index 18dd7e6d..96715703 100644 --- a/biogeophys/EDPhotosynthesisMod.F90 +++ b/biogeophys/EDPhotosynthesisMod.F90 @@ -960,7 +960,7 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) if ( DEBUG ) write(iulog,*) 'EDPhoto 912 ', currentCohort%resp_tstep if ( DEBUG ) write(iulog,*) 'EDPhoto 913 ', currentCohort%resp_m - currentCohort%resp_g = ED_val_grperc(1) * (max(0._r8,currentCohort%gpp_tstep - currentCohort%resp_m)) + currentCohort%resp_g = ED_val_grperc(ft) * (max(0._r8,currentCohort%gpp_tstep - currentCohort%resp_m)) currentCohort%resp_tstep = currentCohort%resp_m + currentCohort%resp_g ! kgC/indiv/ts currentCohort%npp_tstep = currentCohort%gpp_tstep - currentCohort%resp_tstep ! kgC/indiv/ts From b831c63cf6bcaa732901990df7065362f8d432b7 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 13 Oct 2016 18:12:53 -0700 Subject: [PATCH 218/437] added some more global constants and uses in photosynthesis. Also, fixed a unit conversion error in maintenance respiration. --- biogeochem/EDCanopyStructureMod.F90 | 1 - biogeophys/EDPhotosynthesisMod.F90 | 212 +++++++++++++++------------- main/FatesConstantsMod.F90 | 29 ++++ 3 files changed, 142 insertions(+), 100 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 5b8ad923..8ad6b71c 100755 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -675,7 +675,6 @@ subroutine canopy_summarization( nsites, sites, bc_in ) integer :: ft ! plant functional type integer :: ifp integer :: patchn ! identification number for each patch. - real(r8) :: coarse_wood_frac real(r8) :: canopy_leaf_area ! total amount of leaf area in the vegetated area. m2. !---------------------------------------------------------------------- diff --git a/biogeophys/EDPhotosynthesisMod.F90 b/biogeophys/EDPhotosynthesisMod.F90 index 96715703..79b48977 100644 --- a/biogeophys/EDPhotosynthesisMod.F90 +++ b/biogeophys/EDPhotosynthesisMod.F90 @@ -9,14 +9,14 @@ module EDPhotosynthesisMod ! ! !USES: ! - use shr_kind_mod , only : r8 => shr_kind_r8 - use shr_log_mod , only : errMsg => shr_log_errMsg - use abortutils , only : endrun - use clm_varctl , only : iulog + + use abortutils, only : endrun + use FatesGlobals, only : fates_log + use FatesConstantsMod, only : r8 => fates_r8 + use shr_log_mod , only : errMsg => shr_log_errMsg + implicit none private - ! - ! PUBLIC MEMBER FUNCTIONS: @@ -39,22 +39,39 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) ! 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 clm_varcon , only : rgas, tfrz, namep - use clm_varpar , only : nlevsoi, mxpft - use clm_varctl , only : iulog - use pftconMod , only : pftcon + use clm_varpar , only : mxpft ! THIS WILL BE DEPRECATED WHEN PARAMETER + ! READS ARE REFACTORED (RGK 10-13-2016) + use pftconMod , only : pftcon ! THIS WILL BE DEPRECATED WHEN PARAMETER + ! READS ARE REFACTORED (RGK 10-13-2016) use EDParamsMod , only : ED_val_grperc, & ED_val_ag_biomass 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 + use EDTypesMod , only : numpft_ed, & + dinc_ed, & + ed_patch_type, & + ed_cohort_type, & + ed_site_type, & + numpft_ed, & + numpatchespercol, & + cp_numlevsoil, & + cp_nlevcan, & + cp_nclmax + use EDEcophysContype , only : EDecophyscon - use FatesInterfaceMod , only : bc_in_type,bc_out_type - use EDtypesMod , only : numpatchespercol, cp_nlevcan, cp_nclmax + use FatesInterfaceMod , only : bc_in_type, & + bc_out_type + use EDCanopyStructureMod,only: calc_areaindex + + use FatesConstantsMod, only : umolC_to_kgC, & ! micromole conversion to kgC + g_per_kg, & ! number of grams per kg + mg_per_g, & ! number of miligrams per g + sec_per_min, & ! seconds per minute (60!) + rgas, & ! universal gas constant + + tfrz => t_water_freeze_k_1atm ! Freezing point of water at 1 atmosphere ! ! !ARGUMENTS: @@ -149,7 +166,7 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) integer :: c,CL,f,s,iv,j,ps,ft,ifp ! 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) @@ -191,7 +208,6 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) 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 @@ -203,15 +219,8 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) real(r8) :: froot_n ! Fine root nitrogen content (gN/plant) ! Parameters - - ! Conversion factor umols of Carbon -> kg of Carbon (1 mol = 12g) - real(r8), parameter :: umolC_to_kgC = 12.0E-9_r8 - - ! Conversion factor: grams per kilograms - real(r8), parameter :: g_per_kg = 1000.0_r8 - ! ----------------------------------------------------------------------- - ! base maintenance respiration rate for plant tissues base_mr_20 + ! Base maintenance respiration rate for plant tissues base_mr_20 ! 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) @@ -222,7 +231,15 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) ! ------------------------------------------------------------------------ real(r8),parameter :: base_mr_20 = 2.525e-6_r8 - + + ! maximum stomatal resistance [s/m] + real(r8),parameter :: rsmax0 = 2.e4_r8 + + ! First guess on ratio between intracellular co2 and the atmosphere + ! an iterator converges on actual + real(r8),parameter :: init_a2l_co2_c3 = 0.7 + real(r8),parameter :: init_a2l_co2_c4 = 0.4 + associate( & c3psn => pftcon%c3psn , & ! photosynthetic pathway: 0. = c4, 1. = c3 @@ -231,11 +248,9 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) woody => pftcon%woody , & ! Is vegetation woody or not? fnitr => pftcon%fnitr , & ! foliage nitrogen limitation factor (-) leafcn => pftcon%leafcn , & ! leaf C:N (gC/gN) + frootcn => pftcon%frootcn , & ! froot C:N (gc/gN) bb_slope => EDecophyscon%BB_slope ) ! slope of BB relationship - ! 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 @@ -252,7 +267,7 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) 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 + act25 = act25 * mg_per_g / sec_per_min ! Activation energy, from: ! Bernacchi et al (2001) Plant, Cell and Environment 24:253-259 @@ -399,12 +414,11 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) ! THIS CALL APPEARS TO BE REDUNDANT WITH LINE 650 (RGK) if (nint(c3psn(FT)) == 1)then - ci(:,FT,:) = 0.7_r8 * bc_in(s)%cair_pa(ifp) + ci(:,FT,:) = init_a2l_co2_c3 * bc_in(s)%cair_pa(ifp) else - ci(:,FT,:) = 0.4_r8 * bc_in(s)%cair_pa(ifp) + ci(:,FT,:) = init_a2l_co2_c4 * bc_in(s)%cair_pa(ifp) end if - ! Leaf nitrogen concentration at the top of the canopy (g N leaf / m**2 leaf) lnc(FT) = 1._r8 / (slatop(FT) * leafcn(FT)) @@ -416,7 +430,7 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) ! 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) = (2.59_r8 - 0.035_r8*min(max((t10(p)-tfrzc),11._r8),35._r8)) * vcmax25top(FT) jmax25top(FT) = 1.67_r8 * vcmax25top(FT) tpu25top(FT) = 0.167_r8 * vcmax25top(FT) @@ -454,7 +468,7 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) 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, & + write(fates_log(),*) '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,cp_nclmax currentPatch%present(CL,FT) = 1 @@ -539,10 +553,9 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) ! Leaf-level photosynthesis and stomatal conductance !==============================================================================! - rsmax0 = 2.e4_r8 - ! Leaf boundary layer conductance, umol/m**2/s + ! THESE HARD CODED CONVERSIONS NEED TO BE CALLED FROM GLOBAL CONSTANTS (RGK 10-13-2016) cf = bc_in(s)%forc_pbot/(rgas*1.e-3_r8*bc_in(s)%tgcm_pa(ifp))*1.e06_r8 gb = 1._r8/bc_in(s)%rb_pa(ifp) gb_mol = gb * cf @@ -561,7 +574,7 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) 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 ( DEBUG ) write(iulog,*) 'EDphoto 581 ',currentPatch%ed_parsun_z(CL,ft,iv) + if ( DEBUG ) write(fates_log(),*) 'EDphoto 581 ',currentPatch%ed_parsun_z(CL,ft,iv) if (currentPatch%ed_parsun_z(CL,FT,iv) <= 0._r8) then ! night time ac = 0._r8 @@ -576,12 +589,12 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) else ! day time !is there leaf area? - (NV can be larger than 0 with only stem area if deciduous) - if ( DEBUG ) write(iulog,*) 'EDphot 594 ',currentPatch%ed_laisun_z(CL,ft,iv) - if ( DEBUG ) write(iulog,*) 'EDphot 595 ',currentPatch%ed_laisha_z(CL,ft,iv) + if ( DEBUG ) write(fates_log(),*) 'EDphot 594 ',currentPatch%ed_laisun_z(CL,ft,iv) + if ( DEBUG ) write(fates_log(),*) 'EDphot 595 ',currentPatch%ed_laisha_z(CL,ft,iv) if(currentPatch%ed_laisun_z(CL,ft,iv)+currentPatch%ed_laisha_z(cl,ft,iv) > 0._r8)then - if ( DEBUG ) write(iulog,*) '600 in laisun, laisha loop ' + if ( DEBUG ) write(fates_log(),*) '600 in laisun, laisha loop ' !Loop aroun shaded and unshaded leaves currentPatch%psn_z(CL,ft,iv) = 0._r8 ! psn is accumulated across sun and shaded leaves. @@ -624,9 +637,9 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) ! THIS CALL APPEARS TO BE REDUNDANT WITH LINE 423 (RGK) if (nint(c3psn(FT)) == 1)then - ci(cl,ft,iv) = 0.7_r8 * bc_in(s)%cair_pa(ifp) + ci(cl,ft,iv) = init_a2l_co2_c3 * bc_in(s)%cair_pa(ifp) else - ci(cl,ft,iv) = 0.4_r8 * bc_in(s)%cair_pa(ifp) + ci(cl,ft,iv) = init_a2l_co2_c4 * bc_in(s)%cair_pa(ifp) end if niter = 0 @@ -727,9 +740,9 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) ! Convert gs_mol (umol H2O/m**2/s) to gs (m/s) and then to rs (s/m) gs = gs_mol / cf - if ( DEBUG ) write(iulog,*) 'EDPhoto 737 ', currentPatch%psn_z(cl,ft,iv) - if ( DEBUG ) write(iulog,*) 'EDPhoto 738 ', ag(cl,ft,iv) - if ( DEBUG ) write(iulog,*) 'EDPhoto 739 ', currentPatch%f_sun(cl,ft,iv) + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 737 ', currentPatch%psn_z(cl,ft,iv) + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 738 ', ag(cl,ft,iv) + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 739 ', currentPatch%f_sun(cl,ft,iv) !accumulate total photosynthesis umol/m2 ground/s-1. weight per unit sun and sha leaves. if(sunsha == 1)then !sunlit @@ -752,15 +765,15 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) end if - if ( DEBUG ) write(iulog,*) 'EDPhoto 758 ', currentPatch%psn_z(cl,ft,iv) - if ( DEBUG ) write(iulog,*) 'EDPhoto 759 ', ag(cl,ft,iv) - if ( DEBUG ) write(iulog,*) 'EDPhoto 760 ', currentPatch%f_sun(cl,ft,iv) + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 758 ', currentPatch%psn_z(cl,ft,iv) + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 759 ', ag(cl,ft,iv) + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 760 ', currentPatch%f_sun(cl,ft,iv) ! Make sure iterative solution is correct if (gs_mol < 0._r8) then - write (iulog,*)'Negative stomatal conductance:' - write (iulog,*)'ifp,iv,gs_mol= ',ifp,iv,gs_mol - call endrun(msg=errmsg(sourcefile, __LINE__)) + write (fates_log(),*)'Negative stomatal conductance:' + write (fates_log(),*)'ifp,iv,gs_mol= ',ifp,iv,gs_mol + call endrun(msg=errMsg(sourcefile, __LINE__)) end if ! Compare with Ball-Berry model: gs_mol = m * an * hs/cs p + b @@ -768,8 +781,8 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) gs_mol_err = bb_slope(ft)*max(an(cl,ft,iv), 0._r8)*hs/cs*bc_in(s)%forc_pbot + 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 + write (fates_log(),*) 'CF: Ball-Berry error check - stomatal conductance error:' + write (fates_log(),*) gs_mol, gs_mol_err end if enddo !sunsha loop @@ -817,12 +830,12 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) !------------------------------------------------------------------------------ ! Convert from umolC/m2leaf/s to umolC/indiv/s ( x canopy area x 1m2 leaf area). tree_area = currentCohort%c_area/currentCohort%n - if ( DEBUG ) write(iulog,*) 'EDPhoto 816 ', currentCohort%gpp_tstep - if ( DEBUG ) write(iulog,*) 'EDPhoto 817 ', currentPatch%psn_z(cl,ft,1:currentCohort%nv-1) - if ( DEBUG ) write(iulog,*) 'EDPhoto 818 ', cl - if ( DEBUG ) write(iulog,*) 'EDPhoto 819 ', ft - if ( DEBUG ) write(iulog,*) 'EDPhoto 820 ', currentCohort%nv - if ( DEBUG ) write(iulog,*) 'EDPhoto 821 ', currentPatch%elai_profile(cl,ft,1:currentCohort%nv-1) + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 816 ', currentCohort%gpp_tstep + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 817 ', currentPatch%psn_z(cl,ft,1:currentCohort%nv-1) + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 818 ', cl + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 819 ', ft + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 820 ', currentCohort%nv + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 821 ', currentPatch%elai_profile(cl,ft,1:currentCohort%nv-1) if (currentCohort%nv > 1) then !is there canopy, and are the leaves on? @@ -844,7 +857,7 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) end if - if ( DEBUG ) write(iulog,*) 'EDPhoto 832 ', currentCohort%gpp_tstep + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 832 ', currentCohort%gpp_tstep laifrac = (currentCohort%treelai+currentCohort%treesai)-(currentCohort%nv-1)*dinc_ed @@ -852,18 +865,18 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) currentCohort%gscan = currentCohort%gscan+gs_cohort if ( DEBUG ) then - write(iulog,*) 'EDPhoto 868 ', currentCohort%gpp_tstep - write(iulog,*) 'EDPhoto 869 ', currentPatch%psn_z(cl,ft,currentCohort%nv) - write(iulog,*) 'EDPhoto 870 ', currentPatch%elai_profile(cl,ft,currentCohort%nv) - write(iulog,*) 'EDPhoto 871 ', laifrac - write(iulog,*) 'EDPhoto 872 ', tree_area - write(iulog,*) 'EDPhoto 873 ', currentCohort%nv, cl, ft + write(fates_log(),*) 'EDPhoto 868 ', currentCohort%gpp_tstep + write(fates_log(),*) 'EDPhoto 869 ', currentPatch%psn_z(cl,ft,currentCohort%nv) + write(fates_log(),*) 'EDPhoto 870 ', currentPatch%elai_profile(cl,ft,currentCohort%nv) + write(fates_log(),*) 'EDPhoto 871 ', laifrac + write(fates_log(),*) 'EDPhoto 872 ', tree_area + write(fates_log(),*) 'EDPhoto 873 ', currentCohort%nv, cl, ft endif currentCohort%gpp_tstep = currentCohort%gpp_tstep + currentPatch%psn_z(cl,ft,currentCohort%nv) * & currentPatch%elai_profile(cl,ft,currentCohort%nv) * laifrac * tree_area - if ( DEBUG ) write(iulog,*) 'EDPhoto 843 ', currentCohort%rdark + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 843 ', currentCohort%rdark currentCohort%rdark = currentCohort%rdark + lmr_z(cl,ft,currentCohort%nv) * & @@ -884,12 +897,15 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) ! Calculate the amount of nitrogen in the above and below ground ! stem and root pools, used for maint resp + ! We are using the fine-root C:N ratio as an approximation for + ! the sapwood pools. + ! Units are in (kgN/plant) ! ------------------------------------------------------------------ live_agstem_n = ED_val_ag_biomass * currentCohort%bsw / & - pftcon%leafcn(currentCohort%pft) + frootcn(currentCohort%pft) live_bgstem_n = (1.0_r8-ED_val_ag_biomass) * currentCohort%bsw / & - pftcon%leafcn(currentCohort%pft) - froot_n = currentCohort%br / leafcn(currentCohort%pft) + frootcn(currentCohort%pft) + froot_n = currentCohort%br / frootcn(currentCohort%pft) !------------------------------------------------------------------------------ @@ -897,54 +913,48 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) ! Leaf respn needs to be in the sub-layer loop to account for changing N through canopy. !------------------------------------------------------------------------------ - ! Above ground Live stem MR + ! Above ground Live stem MR (kgC/plant/s) ! ------------------------------------------------------------------ if (woody(ft) == 1) then tc = q10**((bc_in(s)%t_veg_pa(ifp)-tfrz - 20.0_r8)/10.0_r8) + ! kgC/s = kgN * kgC/kgN/s currentCohort%livestem_mr = live_agstem_n * base_mr_20 * tc - !convert from gC /indiv/s-1 to kgC/indiv/s-1 - currentCohort%livestem_mr = currentCohort%livestem_mr /1000.0_r8 else currentCohort%livestem_mr = 0._r8 end if - ! Fine Root MR + ! Fine Root MR (kgC/plant/s) ! ------------------------------------------------------------------ currentCohort%froot_mr = 0._r8 - do j = 1,nlevsoi + do j = 1,cp_numlevsoil tcsoi = q10**((bc_in(s)%t_soisno_gl(j)-tfrz - 20.0_r8)/10.0_r8) currentCohort%froot_mr = currentCohort%froot_mr + & froot_n * base_mr_20 * tcsoi * currentPatch%rootfr_ft(ft,j) enddo - ! convert from gC/indiv/s-1 to kgC/indiv/s-1 - currentCohort%froot_mr = currentCohort%froot_mr /1000.0_r8 - ! Coarse Root MR ! ------------------------------------------------------------------ if (woody(ft) == 1) then currentCohort%livecroot_mr = 0._r8 - do j = 1,nlevsoi + do j = 1,cp_numlevsoil ! Soil temperature used to adjust base rate of MR tcsoi = q10**((bc_in(s)%t_soisno_gl(j)-tfrz - 20.0_r8)/10.0_r8) currentCohort%livecroot_mr = currentCohort%livecroot_mr + & live_bgstem_n * base_mr_20 * tcsoi * & currentPatch%rootfr_ft(ft,j) enddo - ! convert from gC/indiv/s-1 to kgC/indiv/s-1 - currentCohort%livecroot_mr = currentCohort%livecroot_mr /1000.0_r8 else currentCohort%livecroot_mr = 0._r8 end if ! convert gpp from umol/indiv/s-1 to kgC/indiv/s-1 = X * 12 *10-6 * 10-3 - if ( DEBUG ) write(iulog,*) 'EDPhoto 904 ', currentCohort%resp_m - if ( DEBUG ) write(iulog,*) 'EDPhoto 905 ', currentCohort%rdark - if ( DEBUG ) write(iulog,*) 'EDPhoto 906 ', currentCohort%livestem_mr - if ( DEBUG ) write(iulog,*) 'EDPhoto 907 ', currentCohort%livecroot_mr - if ( DEBUG ) write(iulog,*) 'EDPhoto 908 ', currentCohort%froot_mr + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 904 ', currentCohort%resp_m + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 905 ', currentCohort%rdark + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 906 ', currentCohort%livestem_mr + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 907 ', currentCohort%livecroot_mr + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 908 ', currentCohort%froot_mr currentCohort%gpp_tstep = currentCohort%gpp_tstep * umolC_to_kgC ! add on whole plant respiration values in kgC/indiv/s-1 @@ -956,9 +966,9 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) currentCohort%resp_m = currentCohort%resp_m * dtime currentCohort%gpp_tstep = currentCohort%gpp_tstep * dtime - if ( DEBUG ) write(iulog,*) 'EDPhoto 911 ', currentCohort%gpp_tstep - if ( DEBUG ) write(iulog,*) 'EDPhoto 912 ', currentCohort%resp_tstep - if ( DEBUG ) write(iulog,*) 'EDPhoto 913 ', currentCohort%resp_m + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 911 ', currentCohort%gpp_tstep + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 912 ', currentCohort%resp_tstep + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 913 ', currentCohort%resp_m currentCohort%resp_g = ED_val_grperc(ft) * (max(0._r8,currentCohort%gpp_tstep - currentCohort%resp_m)) currentCohort%resp_tstep = currentCohort%resp_m + currentCohort%resp_g ! kgC/indiv/ts @@ -979,7 +989,7 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) 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 + write(fates_log(),*) 'CF: pft 0 or n 0',currentCohort%pft,currentCohort%n,currentCohort%indexnumber currentCohort%gpp_tstep = 0._r8 currentCohort%resp_m = 0._r8 currentCohort%gscan = 0._r8 @@ -1009,7 +1019,7 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) end if bc_out(s)%rssun_pa(ifp) = rscanopy bc_out(s)%rssha_pa(ifp) = rscanopy - bc_out(s)%gccanopy_pa(ifp) = 1.0_r8/rscanopy*cf/1000 !convert into umol m02 s-1 then mmol m-2 s-1. + bc_out(s)%gccanopy_pa(ifp) = 1.0_r8/rscanopy*cf/1000.0 !convert into umol m-2 s-1 then mmol m-2 s-1. end if currentPatch => currentPatch%younger @@ -1034,7 +1044,8 @@ function ft1_f(tl, ha) result(ans) ! 7/23/16: Copied over from CLM by Ryan Knox ! !!USES - use clm_varcon , only : rgas, tfrz + use FatesConstantsMod, only : rgas, & ! universal gas constant + tfrz => t_water_freeze_k_1atm ! Freezing point of water at 1 atm ! ! !ARGUMENTS: real(r8), intent(in) :: tl ! leaf temperature in photosynthesis temperature function (K) @@ -1060,7 +1071,8 @@ function fth_f(tl,hd,se,scaleFactor) result(ans) ! Jinyun Tang separated it out from Photosynthesis, Feb. 07/2013 ! 7/23/16: Copied over from CLM by Ryan Knox ! - use clm_varcon , only : rgas, tfrz + use FatesConstantsMod, only : rgas, & ! universal gas constant + tfrz => t_water_freeze_k_1atm ! Freezing point of water at 1 atm ! ! !ARGUMENTS: real(r8), intent(in) :: tl ! leaf temperature in photosynthesis temperature function (K) @@ -1088,8 +1100,10 @@ function fth25_f(hd,se)result(ans) ! Jinyun Tang separated it out from Photosynthesis, Feb. 07/2013 ! 7/23/16: Copied over from CLM by Ryan Knox ! - !!USES - use clm_varcon , only : rgas, tfrz + !!USES + use FatesConstantsMod, only : rgas, & ! universal gas constant + tfrz => t_water_freeze_k_1atm ! Freezing point of water at 1 atm + ! ! !ARGUMENTS: real(r8), intent(in) :: hd ! deactivation energy in photosynthesis temperature function (J/mol) @@ -1131,8 +1145,8 @@ subroutine quadratic_f (a, b, c, r1, r2) !------------------------------------------------------------------------------ if (a == 0._r8) then - write (iulog,*) 'Quadratic solution error: a = ',a - call endrun(msg=errmsg(sourcefile, __LINE__)) + write (fates_log(),*) 'Quadratic solution error: a = ',a + call endrun(msg=errMsg(sourcefile, __LINE__)) end if if (b >= 0._r8) then diff --git a/main/FatesConstantsMod.F90 b/main/FatesConstantsMod.F90 index 244f6f65..8a9d6938 100644 --- a/main/FatesConstantsMod.F90 +++ b/main/FatesConstantsMod.F90 @@ -14,4 +14,33 @@ module FatesConstantsMod integer, parameter :: fates_short_string_length = 32 integer, parameter :: fates_long_string_length = 199 + + ! Unit conversion constants: + + ! Conversion factor umols of Carbon -> kg of Carbon (1 mol = 12g) + ! We do not use umolC_per_kg because it is a non-terminating decimal + real(fates_r8), parameter :: umolC_to_kgC = 12.0E-9_fates_r8 + + ! Conversion factor: grams per kilograms + real(fates_r8), parameter :: g_per_kg = 1000.0_fates_r8 + + ! Conversion factor: miligrams per grams + real(fates_r8), parameter :: mg_per_g = 1000.0_fates_r8 + + ! Conversion: secons per minute + real(fates_r8), parameter :: sec_per_min = 60.0_fates_r8 + + + ! Physical constants + + ! universal gas constant [J/K/kmole] + real(fates_r8), parameter :: rgas = 8314.4598_fates_r8 + + ! freezing point of water at 1 atm (K) + real(fates_r8), parameter :: t_water_freeze_k_1atm = 273.15_fates_r8 + + ! freezing point of water at triple point (K) + real(fates_r8), parameter :: t_water_freeze_k_triple = 273.16_fates_r8 + + end module FatesConstantsMod From 3185d951d5834cf5791ae3c36fe9fd42845afea0 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 13 Oct 2016 18:29:11 -0700 Subject: [PATCH 219/437] intercellular co2 in photosynthesis was being represented as an array that was unnecessary, a scalar was sufficient. It was also calculated twice in the call sequence, where the first calculation was unnecessary and unused. --- biogeophys/EDPhotosynthesisMod.F90 | 29 +++++++++++------------------ 1 file changed, 11 insertions(+), 18 deletions(-) diff --git a/biogeophys/EDPhotosynthesisMod.F90 b/biogeophys/EDPhotosynthesisMod.F90 index 79b48977..6179e97f 100644 --- a/biogeophys/EDPhotosynthesisMod.F90 +++ b/biogeophys/EDPhotosynthesisMod.F90 @@ -102,8 +102,8 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) real(r8) :: lmr_z(cp_nclmax,mxpft,cp_nlevcan) ! initial slope of CO2 response curve (C4 plants) real(r8) :: rs_z(cp_nclmax,mxpft,cp_nlevcan) ! stomatal resistance s/m real(r8) :: gs_z(cp_nclmax,mxpft,cp_nlevcan) ! stomatal conductance m/s - - real(r8) :: ci(cp_nclmax,mxpft,cp_nlevcan) ! intracellular leaf CO2 (Pa) + + real(r8) :: ci ! intracellular leaf CO2 (Pa) real(r8) :: lnc(mxpft) ! leaf N concentration (gN leaf/m^2) real(r8) :: kc( numpatchespercol ) ! Michaelis-Menten constant for CO2 (Pa) @@ -412,13 +412,6 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) end if bbb(FT) = max (bbbopt(ps)*currentPatch%btran_ft(FT), 1._r8) - ! THIS CALL APPEARS TO BE REDUNDANT WITH LINE 650 (RGK) - if (nint(c3psn(FT)) == 1)then - ci(:,FT,:) = init_a2l_co2_c3 * bc_in(s)%cair_pa(ifp) - else - ci(:,FT,:) = init_a2l_co2_c4 * bc_in(s)%cair_pa(ifp) - end if - ! Leaf nitrogen concentration at the top of the canopy (g N leaf / m**2 leaf) lnc(FT) = 1._r8 / (slatop(FT) * leafcn(FT)) @@ -637,9 +630,9 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) ! THIS CALL APPEARS TO BE REDUNDANT WITH LINE 423 (RGK) if (nint(c3psn(FT)) == 1)then - ci(cl,ft,iv) = init_a2l_co2_c3 * bc_in(s)%cair_pa(ifp) + ci = init_a2l_co2_c3 * bc_in(s)%cair_pa(ifp) else - ci(cl,ft,iv) = init_a2l_co2_c4 * bc_in(s)%cair_pa(ifp) + ci = init_a2l_co2_c4 * bc_in(s)%cair_pa(ifp) end if niter = 0 @@ -649,15 +642,15 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) niter = niter + 1 ! Save old ci - ciold = ci(cl,ft,iv) + ciold = ci ! 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(ifp), 0._r8) / (ci(cl,ft,iv)+kc(ifp)* & + ac = vcmax_z(cl,ft,iv) * max(ci-co2_cp(ifp), 0._r8) / (ci+kc(ifp)* & (1._r8+bc_in(s)%oair_pa(ifp)/ko(ifp))) ! C3: RuBP-limited photosynthesis - aj = je * max(ci(cl,ft,iv)-co2_cp(ifp), 0._r8) / (4._r8*ci(cl,ft,iv)+8._r8*co2_cp(ifp)) + aj = je * max(ci-co2_cp(ifp), 0._r8) / (4._r8*ci+8._r8*co2_cp(ifp)) ! C3: Product-limited photosynthesis ap = 3._r8 * tpu_z(cl,ft,iv) else @@ -681,7 +674,7 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) end if ! C4: PEP carboxylase-limited (CO2-limited) - ap = kp_z(cl,ft,iv) * max(ci(cl,ft,iv), 0._r8) / bc_in(s)%forc_pbot + ap = kp_z(cl,ft,iv) * max(ci, 0._r8) / bc_in(s)%forc_pbot end if ! Gross photosynthesis smoothing calculations. First co-limit ac and aj. Then co-limit ap aquad = theta_cj(ps) @@ -715,14 +708,14 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) gs_mol = max(r1,r2) ! Derive new estimate for ci - ci(cl,ft,iv) = bc_in(s)%cair_pa(ifp) - an(cl,ft,iv) * bc_in(s)%forc_pbot * & + ci = bc_in(s)%cair_pa(ifp) - an(cl,ft,iv) * bc_in(s)%forc_pbot * & (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)/bc_in(s)%forc_pbot*1.e06_r8 <= 2.e-06_r8) .or. niter == 5) then + if ((abs(ci-ciold)/bc_in(s)%forc_pbot*1.e06_r8 <= 2.e-06_r8) .or. niter == 5) then exitloop = 1 end if end do !iteration loop @@ -735,7 +728,7 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) ! Final estimates for cs and ci (needed for early exit of ci iteration when an < 0) cs = bc_in(s)%cair_pa(ifp) - 1.4_r8/gb_mol * an(cl,ft,iv) * bc_in(s)%forc_pbot cs = max(cs,1.e-06_r8) - ci(cl,ft,iv) = bc_in(s)%cair_pa(ifp) - & + ci = bc_in(s)%cair_pa(ifp) - & an(cl,ft,iv) * bc_in(s)%forc_pbot * (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 From 03e22fa1883d8fa4af6b4b0f2f328977f5e6fad2 Mon Sep 17 00:00:00 2001 From: Ben Andre Date: Fri, 14 Oct 2016 09:46:40 -0600 Subject: [PATCH 220/437] Refactor fates history variable kind Refactor the fates history dimension kind struct, move it into its own module, create init function to remove copy-paste variable initialization. Test suite: ERS_D_Ld5.f10_f10.ICLM45ED.yellowstone_intel.clm-edTest Test baseline: 49733e8 Test namelist changes: none Test answer changes: bit for bit Test summary: pass --- main/FatesConstantsMod.F90 | 2 + main/FatesHistoryVarKindMod.F90 | 55 ++++++++++++++++++ main/HistoryIOMod.F90 | 100 ++++++++------------------------ 3 files changed, 81 insertions(+), 76 deletions(-) create mode 100644 main/FatesHistoryVarKindMod.F90 diff --git a/main/FatesConstantsMod.F90 b/main/FatesConstantsMod.F90 index be01937c..a8b93fa9 100644 --- a/main/FatesConstantsMod.F90 +++ b/main/FatesConstantsMod.F90 @@ -14,6 +14,8 @@ module FatesConstantsMod integer, parameter :: fates_short_string_length = 32 integer, parameter :: fates_long_string_length = 199 + integer, parameter :: fates_unset_int = -9999 + ! various magic numbers real(fates_r8), parameter :: fates_special_value = 1.0e36_fates_r8 ! special value for real data, compatible with clm. integer, parameter :: fates_int_special_value = -9999 ! keep this negative to avoid conflicts with possible valid values diff --git a/main/FatesHistoryVarKindMod.F90 b/main/FatesHistoryVarKindMod.F90 new file mode 100644 index 00000000..869f16a1 --- /dev/null +++ b/main/FatesHistoryVarKindMod.F90 @@ -0,0 +1,55 @@ +module FatesHistoryVariableKindMod + + use FatesConstantsMod, only : fates_long_string_length + use FatesHistoryDimensionMod, only : fates_history_dimension_type + + implicit none + + ! NOTE(RGK, 2016) %active is not used yet. Was intended as a check on the HLM->FATES + ! control parameter passing to ensure all active dimension types received all + ! dimensioning specifications from the host, but we currently arent using those + ! passing functions.. + + ! This structure is not multi-threaded + type fates_history_variable_kind_type + character(len=fates_long_string_length) :: name ! String labelling this IO type + integer :: ndims ! number of dimensions in this IO type + integer, allocatable :: dimsize(:) ! The size of each dimension + logical :: active + type(fates_history_dimension_type), pointer :: dim1_ptr + type(fates_history_dimension_type), pointer :: dim2_ptr + + contains + + procedure, public :: Init => InitVariableKind + + end type fates_history_variable_kind_type + + + +contains + + ! =================================================================================== + subroutine InitVariableKind(this, name, num_dims) + + use FatesConstantsMod, only : fates_unset_int + + implicit none + + class(fates_history_variable_kind_type), intent(inout) :: this + character(*), intent(in) :: name + integer, intent(in) :: num_dims + + this%name = trim(name) + this%ndims = num_dims + allocate(this%dimsize(this%ndims)) + this%dimsize(:) = fates_unset_int + this%active = .false. + nullify(this%dim1_ptr) + nullify(this%dim2_ptr) + + end subroutine InitVariableKind + + + +end module FatesHistoryVariableKindMod diff --git a/main/HistoryIOMod.F90 b/main/HistoryIOMod.F90 index 669d86c6..7708b264 100644 --- a/main/HistoryIOMod.F90 +++ b/main/HistoryIOMod.F90 @@ -6,6 +6,7 @@ Module HistoryIOMod use FatesGlobals , only : fates_log use FatesHistoryDimensionMod, only : fates_history_dimension_type + use FatesHistoryVariableKindMod, only : fates_history_variable_kind_type use EDTypesMod , only : cp_hio_ignore_val @@ -153,18 +154,6 @@ Module HistoryIOMod - ! This structure is not multi-threaded - type iovar_dimkind_type - character(fates_short_string_length) :: name ! String labelling this IO type - integer :: ndims ! number of dimensions in this IO type - integer, allocatable :: dimsize(:) ! The size of each dimension - logical :: active - type(fates_history_dimension_type), pointer :: dim1_ptr - type(fates_history_dimension_type), pointer :: dim2_ptr - end type iovar_dimkind_type - - - ! This type is instanteated in the HLM-FATES interface (clmfates_interfaceMod.F90) type iovar_def_type character(len=fates_short_string_length) :: vname @@ -180,7 +169,7 @@ Module HistoryIOMod ! 1 = dynamics "dyn" (daily) ! 2 = production "prod" (prob model tstep) real(r8) :: flushval - type(iovar_dimkind_type),pointer :: iovar_dk_ptr + type(fates_history_variable_kind_type),pointer :: iovar_dk_ptr ! Pointers (only one of these is allocated per variable) real(r8), pointer :: r81d(:) real(r8), pointer :: r82d(:,:) @@ -199,7 +188,7 @@ Module HistoryIOMod ! Instanteat one registry of the different dimension/kinds (dk) ! All output variables will have a pointer to one of these dk's - type(iovar_dimkind_type), pointer :: iovar_dk(:) + type(fates_history_variable_kind_type), pointer :: iovar_dk(:) ! This is a structure that explains where FATES patch boundaries ! on each thread point to in the host IO array, this structure @@ -1372,89 +1361,48 @@ subroutine init_iovar_dk_maps(this) ! The allocation on the structures is not dynamic and should only add up to the ! number of entries listed here. ! - ! note (RGK) %active is not used yet. Was intended as a check on the HLM->FATES - ! control parameter passing to ensure all active dimension types received all - ! dimensioning specifications from the host, but we currently arent using those - ! passing functions.. ! ---------------------------------------------------------------------------------- + use FatesHistoryDimensionMod, only : patch_r8, patch_ground_r8, patch_class_pft_r8, & + site_r8, site_ground_r8, site_class_pft_r8 + + implicit none ! Arguments class(fates_hio_interface_type) :: this - ! Locals - integer :: ityp + ! Localsi + integer :: index integer, parameter :: unset_int = -999 - + allocate(this%iovar_dk(n_iovar_dk)) ! 1d Patch - ityp = 1 - this%iovar_dk(ityp)%name = 'PA_R8' - this%iovar_dk(ityp)%ndims = 1 - allocate(this%iovar_dk(ityp)%dimsize(this%iovar_dk(ityp)%ndims)) - this%iovar_dk(ityp)%dimsize(:) = unset_int - this%iovar_dk(ityp)%active = .false. - nullify(this%iovar_dk(ityp)%dim1_ptr) - nullify(this%iovar_dk(ityp)%dim2_ptr) + index = 1 + call this%iovar_dk(index)%Init(patch_r8, 1) ! 1d Site - ityp = 2 - this%iovar_dk(ityp)%name = 'SI_R8' - this%iovar_dk(ityp)%ndims = 1 - allocate(this%iovar_dk(ityp)%dimsize(this%iovar_dk(ityp)%ndims)) - this%iovar_dk(ityp)%dimsize(:) = unset_int - this%iovar_dk(ityp)%active = .false. - nullify(this%iovar_dk(ityp)%dim1_ptr) - nullify(this%iovar_dk(ityp)%dim2_ptr) + index = index + 1 + call this%iovar_dk(index)%Init(site_r8, 1) ! patch x ground - ityp = 3 - this%iovar_dk(ityp)%name = 'PA_GRND_R8' - this%iovar_dk(ityp)%ndims = 2 - allocate(this%iovar_dk(ityp)%dimsize(this%iovar_dk(ityp)%ndims)) - this%iovar_dk(ityp)%dimsize(:) = unset_int - this%iovar_dk(ityp)%active = .false. - nullify(this%iovar_dk(ityp)%dim1_ptr) - nullify(this%iovar_dk(ityp)%dim2_ptr) + index = index + 1 + call this%iovar_dk(index)%Init(patch_ground_r8, 2) ! patch x size-class/pft - ityp = 4 - this%iovar_dk(ityp)%name = 'PA_SCPF_R8' - this%iovar_dk(ityp)%ndims = 2 - allocate(this%iovar_dk(ityp)%dimsize(this%iovar_dk(ityp)%ndims)) - this%iovar_dk(ityp)%dimsize(:) = unset_int - this%iovar_dk(ityp)%active = .false. - nullify(this%iovar_dk(ityp)%dim1_ptr) - nullify(this%iovar_dk(ityp)%dim2_ptr) + index = index + 1 + call this%iovar_dk(index)%Init(patch_class_pft_r8, 2) ! site x ground - ityp = 5 - this%iovar_dk(ityp)%name = 'SI_GRND_R8' - this%iovar_dk(ityp)%ndims = 2 - allocate(this%iovar_dk(ityp)%dimsize(this%iovar_dk(ityp)%ndims)) - this%iovar_dk(ityp)%dimsize(:) = unset_int - this%iovar_dk(ityp)%active = .false. - nullify(this%iovar_dk(ityp)%dim1_ptr) - nullify(this%iovar_dk(ityp)%dim2_ptr) + index = index + 1 + call this%iovar_dk(index)%Init(site_ground_r8, 2) ! site x size-class/pft - ityp = 6 - this%iovar_dk(ityp)%name = 'SI_SCPF_R8' - this%iovar_dk(ityp)%ndims = 2 - allocate(this%iovar_dk(ityp)%dimsize(this%iovar_dk(ityp)%ndims)) - this%iovar_dk(ityp)%dimsize(:) = unset_int - this%iovar_dk(ityp)%active = .false. - nullify(this%iovar_dk(ityp)%dim1_ptr) - nullify(this%iovar_dk(ityp)%dim2_ptr) + index = index + 1 + call this%iovar_dk(index)%Init(site_class_pft_r8, 2) - - - - - - return + ! FIXME(bja, 2016-10) assert(index == n_iovar_dk) end subroutine init_iovar_dk_maps - + ! =================================================================================== subroutine set_dim_ptrs(this,dk_name,idim,dim_target) From 62dad1c1ccafa6027c4de70d8c214a044f6de63c Mon Sep 17 00:00:00 2001 From: Rosie Fisher Date: Fri, 14 Oct 2016 10:14:45 -0600 Subject: [PATCH 221/437] turned off SPITFIRE temporary switch for testing --- fire/SFMainMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index f86b006c..3e6606d2 100755 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -56,7 +56,7 @@ subroutine fire_model( currentSite, atm2lnd_inst, temperature_inst) !zero fire things currentPatch => currentSite%youngest_patch - temporary_SF_switch = 1 + temporary_SF_switch = 0 do while(associated(currentPatch)) currentPatch%frac_burnt = 0.0_r8 currentPatch%AB = 0.0_r8 From 7324d84c43bd2e36edc399b85885de499bbdf5e7 Mon Sep 17 00:00:00 2001 From: Ben Andre Date: Fri, 14 Oct 2016 15:54:39 -0600 Subject: [PATCH 222/437] Refactor fates history to class and module for hist variables. Test: ERS_D_Ld5.f10_f10.ICLM45ED.yellowstone_intel.clm-edTest Test baseline: 44aac42 Test status: pass --- main/FatesHistoryDimensionMod.F90 | 1 + main/FatesHistoryVariableType.F90 | 228 ++++++++++++++++++++++++++++++ main/HistoryIOMod.F90 | 219 +++++----------------------- 3 files changed, 261 insertions(+), 187 deletions(-) create mode 100644 main/FatesHistoryVariableType.F90 diff --git a/main/FatesHistoryDimensionMod.F90 b/main/FatesHistoryDimensionMod.F90 index 6fb3d5c5..da1598fd 100644 --- a/main/FatesHistoryDimensionMod.F90 +++ b/main/FatesHistoryDimensionMod.F90 @@ -11,6 +11,7 @@ module FatesHistoryDimensionMod character(*), parameter :: site_r8 = 'SI_R8' character(*), parameter :: site_ground_r8 = 'SI_GRND_R8' character(*), parameter :: site_class_pft_r8 = 'SI_SCPF_R8' + character(*), parameter :: patch_int = 'PA_INT' ! This structure is not allocated by thread, but the upper and lower boundaries ! of the dimension for each thread is saved in the clump_ entry diff --git a/main/FatesHistoryVariableType.F90 b/main/FatesHistoryVariableType.F90 new file mode 100644 index 00000000..1e15751f --- /dev/null +++ b/main/FatesHistoryVariableType.F90 @@ -0,0 +1,228 @@ +module FatesHistoryVariableType + + use FatesConstantsMod, only : r8 => fates_r8 + use FatesGlobals, only : fates_log + use FatesHistoryVariableKindMod, only : fates_history_variable_kind_type + + implicit none + + ! This type is instanteated in the HLM-FATES interface (clmfates_interfaceMod.F90) + + type fates_history_variable_type + character(len=32) :: vname + character(len=24) :: units + character(len=128) :: long + character(len=24) :: use_default ! States whether a variable should be turned + ! on the output files by default (active/inactive) + ! It is a good idea to set inactive for very large + ! or infrequently used output datasets + character(len=24) :: vtype + character(len=1) :: avgflag + integer :: upfreq ! Update frequency (this is for checks and flushing) + ! 1 = dynamics "dyn" (daily) + ! 2 = production "prod" (prob model tstep) + real(r8) :: flushval + type(fates_history_variable_kind_type),pointer :: iovar_dk_ptr + ! Pointers (only one of these is allocated per variable) + real(r8), pointer :: r81d(:) + real(r8), pointer :: r82d(:,:) + real(r8), pointer :: r83d(:,:,:) + integer, pointer :: int1d(:) + integer, pointer :: int2d(:,:) + integer, pointer :: int3d(:,:,:) + contains + procedure, public :: Init => InitHistoryVariableType + procedure, public :: Flush => FlushVar + procedure, private :: GetBounds + end type fates_history_variable_type + +contains + + subroutine InitHistoryVariableType(this, vname, units, long, use_default, & + vtype, avgflag, flushval, upfreq, n_iovar_dk, iovar_dk) + + use FatesHistoryDimensionMod, only : patch_r8, patch_ground_r8, patch_class_pft_r8, & + site_r8, site_ground_r8, site_class_pft_r8 + + implicit none + + class(fates_history_variable_type), intent(inout) :: this + character(len=*), intent(in) :: vname + character(len=*), intent(in) :: units + character(len=*), intent(in) :: long + character(len=*), intent(in) :: use_default + character(len=*), intent(in) :: vtype + character(len=*), intent(in) :: avgflag + real(r8), intent(in) :: flushval ! If the type is an int we will round with nint + integer, intent(in) :: upfreq + integer, intent(in) :: n_iovar_dk + type(fates_history_variable_kind_type), intent(in), target :: iovar_dk(:) + + integer :: ityp + integer :: lb1, ub1, lb2, ub2 + + this%vname = vname + this%units = units + this%long = long + this%use_default = use_default + this%vtype = vtype + this%avgflag = avgflag + this%flushval = flushval + this%upfreq = upfreq + + nullify(this%r81d) + nullify(this%r82d) + nullify(this%r83d) + nullify(this%int1d) + nullify(this%int2d) + nullify(this%int3d) + + ityp = iotype_index(trim(vtype), n_iovar_dk, iovar_dk) + this%iovar_dk_ptr => iovar_dk(ityp) + this%iovar_dk_ptr%active = .true. + + call this%GetBounds(0, lb1, ub1, lb2, ub2) + + ! NOTE(rgk, 2016-09) currently, all array spaces are flushed each + ! time the update is called. The flush here on the initialization + ! may be redundant, but will prevent issues in the future if we + ! have host models where not all threads are updating the HHistory + ! array spaces. + + select case(trim(vtype)) + case(patch_r8) + allocate(this%r81d(lb1:ub1)) + this%r81d(:) = flushval + + case(site_r8) + allocate(this%r81d(lb1:ub1)) + this%r81d(:) = flushval + + case(patch_ground_r8) + allocate(this%r82d(lb1:ub1, lb2:ub2)) + this%r82d(:,:) = flushval + + case(patch_class_pft_r8) + allocate(this%r82d(lb1:ub1, lb2:ub2)) + this%r82d(:,:) = flushval + + case(site_ground_r8) + allocate(this%r82d(lb1:ub1, lb2:ub2)) + this%r82d(:,:) = flushval + + case(site_class_pft_r8) + allocate(this%r82d(lb1:ub1, lb2:ub2)) + this%r82d(:,:) = flushval + + case default + write(fates_log(),*) 'Incompatible vtype passed to set_history_var' + write(fates_log(),*) 'vtype = ',trim(vtype),' ?' + stop + ! end_run + end select + + end subroutine InitHistoryVariableType + + ! ===================================================================================== + + subroutine GetBounds(this, thread, lb1, ub1, lb2, ub2) + + class(fates_history_variable_type), intent(inout) :: this + + integer, intent(in) :: thread + + integer, intent(out) :: lb1 + integer, intent(out) :: ub1 + integer, intent(out) :: lb2 + integer, intent(out) :: ub2 + + ! local + integer :: ndims + + lb1 = 0 + ub1 = 0 + lb2 = 0 + ub2 = 0 + + ndims = this%iovar_dk_ptr%ndims + + ! The thread = 0 case is the boundaries for the whole proc/node + if (thread==0) then + lb1 = this%iovar_dk_ptr%dim1_ptr%lower_bound + ub1 = this%iovar_dk_ptr%dim1_ptr%upper_bound + if(ndims>1)then + lb2 = this%iovar_dk_ptr%dim2_ptr%lower_bound + ub2 = this%iovar_dk_ptr%dim2_ptr%upper_bound + end if + else + lb1 = this%iovar_dk_ptr%dim1_ptr%clump_lower_bound(thread) + ub1 = this%iovar_dk_ptr%dim1_ptr%clump_upper_bound(thread) + if(ndims>1)then + lb2 = this%iovar_dk_ptr%dim2_ptr%clump_lower_bound(thread) + ub2 = this%iovar_dk_ptr%dim2_ptr%clump_upper_bound(thread) + end if + end if + + end subroutine GetBounds + + subroutine FlushVar(this, thread) + + use FatesHistoryDimensionMod, only : patch_r8, patch_ground_r8, patch_class_pft_r8, & + site_r8, site_ground_r8, site_class_pft_r8, patch_int + + implicit none + + class(fates_history_variable_type), intent(inout) :: this + integer, intent(in) :: thread + + integer :: lb1, ub1, lb2, ub2 + + call this%GetBounds(thread, lb1, ub1, lb2, ub2) + + select case(trim(this%iovar_dk_ptr%name)) + case(patch_r8) + this%r81d(lb1:ub1) = this%flushval + case(site_r8) + this%r81d(lb1:ub1) = this%flushval + case(patch_ground_r8) + this%r82d(lb1:ub1, lb2:ub2) = this%flushval + case(patch_class_pft_r8) + this%r82d(lb1:ub1, lb2:ub2) = this%flushval + case(site_ground_r8) + this%r82d(lb1:ub1, lb2:ub2) = this%flushval + case(site_class_pft_r8) + this%r82d(lb1:ub1, lb2:ub2) = this%flushval + case(patch_int) + this%int1d(lb1:ub1) = nint(this%flushval) + case default + write(fates_log(),*) 'fates history variable type undefined while flushing history variables' + stop + !end_run + end select + + end subroutine FlushVar + + ! ==================================================================================== + + function iotype_index(iotype_name, n_iovar_dk, iovar_dk) result(ityp) + + ! argument + character(len=*), intent(in) :: iotype_name + integer, intent(in) :: n_iovar_dk + type(fates_history_variable_kind_type), intent(in) :: iovar_dk(:) + + ! local + integer :: ityp + + do ityp=1, n_iovar_dk + if(trim(iotype_name).eq.trim(iovar_dk(ityp)%name))then + return + end if + end do + write(fates_log(),*) 'An IOTYPE THAT DOESNT EXIST WAS SPECIFIED' + !end_run + + end function iotype_index + + +end module FatesHistoryVariableType diff --git a/main/HistoryIOMod.F90 b/main/HistoryIOMod.F90 index 7708b264..cc1547a1 100644 --- a/main/HistoryIOMod.F90 +++ b/main/HistoryIOMod.F90 @@ -7,6 +7,7 @@ Module HistoryIOMod use FatesHistoryDimensionMod, only : fates_history_dimension_type use FatesHistoryVariableKindMod, only : fates_history_variable_kind_type + use FatesHistoryVariableType, only : fates_history_variable_type use EDTypesMod , only : cp_hio_ignore_val @@ -153,37 +154,10 @@ Module HistoryIOMod end type iovar_map_type - - ! This type is instanteated in the HLM-FATES interface (clmfates_interfaceMod.F90) - type iovar_def_type - character(len=fates_short_string_length) :: vname - character(len=fates_short_string_length) :: units - character(len=fates_long_string_length) :: long - character(len=fates_short_string_length) :: use_default ! States whether a variable should be turned - ! on the output files by default (active/inactive) - ! It is a good idea to set inactive for very large - ! or infrequently used output datasets - character(len=fates_short_string_length) :: vtype - character(len=fates_avg_flag_length) :: avgflag - integer :: upfreq ! Update frequency (this is for checks and flushing) - ! 1 = dynamics "dyn" (daily) - ! 2 = production "prod" (prob model tstep) - real(r8) :: flushval - type(fates_history_variable_kind_type),pointer :: iovar_dk_ptr - ! Pointers (only one of these is allocated per variable) - real(r8), pointer :: r81d(:) - real(r8), pointer :: r82d(:,:) - real(r8), pointer :: r83d(:,:,:) - integer, pointer :: int1d(:) - integer, pointer :: int2d(:,:) - integer, pointer :: int3d(:,:,:) - end type iovar_def_type - - type, public :: fates_hio_interface_type ! Instance of the list of history output varialbes - type(iovar_def_type), pointer :: hvars(:) + type(fates_history_variable_type), pointer :: hvars(:) integer :: n_hvars ! Instanteat one registry of the different dimension/kinds (dk) @@ -222,9 +196,7 @@ Module HistoryIOMod procedure, public :: define_history_vars procedure, public :: set_history_var procedure, public :: init_iovar_dk_maps - procedure, public :: iotype_index procedure, public :: set_dim_ptrs - procedure, public :: get_hvar_bounds procedure, private :: flush_hvars end type fates_hio_interface_type @@ -374,7 +346,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) real(r8) :: patch_scaling_scalar ! ratio of canopy to patch area for counteracting patch scaling real(r8) :: dbh ! diameter ("at breast height") - type(iovar_def_type),pointer :: hvar + type(fates_history_variable_type),pointer :: hvar type(ed_patch_type),pointer :: cpatch type(ed_cohort_type),pointer :: ccohort @@ -686,7 +658,7 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) real(r8) :: n_density ! individual of cohort per m2. real(r8) :: n_perm2 ! individuals per m2 for the whole column - type(iovar_def_type),pointer :: hvar + type(fates_history_variable_type),pointer :: hvar type(ed_patch_type),pointer :: cpatch type(ed_cohort_type),pointer :: ccohort @@ -767,33 +739,13 @@ subroutine flush_hvars(this,nc,upfreq_in) integer,intent(in) :: upfreq_in integer :: ivar - type(iovar_def_type),pointer :: hvar + type(fates_history_variable_type),pointer :: hvar integer :: lb1,ub1,lb2,ub2 do ivar=1,ubound(this%hvars,1) hvar => this%hvars(ivar) - if (hvar%upfreq==upfreq_in) then ! Only flush variables with update on dynamics step - call this%get_hvar_bounds(hvar,nc,lb1,ub1,lb2,ub2) - select case(trim(hvar%iovar_dk_ptr%name)) - case('PA_R8') - hvar%r81d(lb1:ub1) = hvar%flushval - case('SI_R8') - hvar%r81d(lb1:ub1) = hvar%flushval - case('PA_GRND_R8') - hvar%r82d(lb1:ub1,lb2:ub2) = hvar%flushval - case('PA_SCPF_R8') - hvar%r82d(lb1:ub1,lb2:ub2) = hvar%flushval - case('SI_GRND_R8') - hvar%r82d(lb1:ub1,lb2:ub2) = hvar%flushval - case('SI_SCPF_R8') - hvar%r82d(lb1:ub1,lb2:ub2) = hvar%flushval - case('PA_INT') - hvar%int1d(lb1:ub1) = nint(hvar%flushval) - case default - write(fates_log(),*) 'iotyp undefined while flushing history variables' - stop - !end_run - end select + if (hvar%upfreq == upfreq_in) then ! Only flush variables with update on dynamics step + call hvar%Flush(nc) end if end do @@ -1218,16 +1170,16 @@ subroutine set_history_var(this,vname,units,long,use_default,avgflag,vtype,hlms, ! arguments class(fates_hio_interface_type) :: this - character(len=*),intent(in) :: vname - character(len=*),intent(in) :: units - character(len=*),intent(in) :: long - character(len=*),intent(in) :: use_default - character(len=*),intent(in) :: avgflag - character(len=*),intent(in) :: vtype - character(len=*),intent(in) :: hlms - real(r8),intent(in) :: flushval ! IF THE TYPE IS AN INT WE WILL round with NINT - integer,intent(in) :: upfreq - character(len=*),intent(in) :: callstep + character(len=*), intent(in) :: vname + character(len=*), intent(in) :: units + character(len=*), intent(in) :: long + character(len=*), intent(in) :: use_default + character(len=*), intent(in) :: avgflag + character(len=*), intent(in) :: vtype + character(len=*), intent(in) :: hlms + real(r8), intent(in) :: flushval ! IF THE TYPE IS AN INT WE WILL round with NINT + integer, intent(in) :: upfreq + character(len=*), intent(in) :: callstep integer, intent(inout) :: ivar integer, intent(inout) :: index ! This is the index for the variable of ! interest that is associated with an @@ -1236,117 +1188,28 @@ subroutine set_history_var(this,vname,units,long,use_default,avgflag,vtype,hlms, ! not used ! locals - type(iovar_def_type),pointer :: hvar - integer :: ub1,lb1,ub2,lb2 ! Bounds for allocating the var + type(fates_history_variable_type), pointer :: hvar + integer :: ub1, lb1, ub2, lb2 ! Bounds for allocating the var integer :: ityp - - if( check_hlm_list(trim(hlms),trim(cp_hlm_name)) ) then - + + logical :: write_var + + write_var = check_hlm_list(trim(hlms), trim(cp_hlm_name)) + if( write_var ) then ivar = ivar+1 index = ivar - if(trim(callstep).eq.'initialize')then - - hvar => this%hvars(ivar) - hvar%vname = vname - hvar%units = units - hvar%long = long - hvar%use_default = use_default - hvar%vtype = vtype - hvar%avgflag = avgflag - hvar%flushval = flushval - hvar%upfreq = upfreq - ityp=this%iotype_index(trim(vtype)) - hvar%iovar_dk_ptr => this%iovar_dk(ityp) - this%iovar_dk(ityp)%active = .true. - - nullify(hvar%r81d) - nullify(hvar%r82d) - nullify(hvar%r83d) - nullify(hvar%int1d) - nullify(hvar%int2d) - nullify(hvar%int3d) - - call this%get_hvar_bounds(hvar,0,lb1,ub1,lb2,ub2) - - ! currently, all array spaces are flushed each time - ! the update is called. The flush here on the initialization - ! may be redundant, but will prevent issues in the future - ! if we have host models where not all threads are updating - ! the HIO array spaces. (RGK:09-2016) - - select case(trim(vtype)) - case('PA_R8') - allocate(hvar%r81d(lb1:ub1));hvar%r81d(:)=flushval - case('SI_R8') - allocate(hvar%r81d(lb1:ub1));hvar%r81d(:)=flushval - case('PA_GRND_R8') - allocate(hvar%r82d(lb1:ub1,lb2:ub2));hvar%r82d(:,:)=flushval - case('PA_SCPF_R8') - allocate(hvar%r82d(lb1:ub1,lb2:ub2));hvar%r82d(:,:)=flushval - case('SI_GRND_R8') - allocate(hvar%r82d(lb1:ub1,lb2:ub2));hvar%r82d(:,:)=flushval - case('SI_SCPF_R8') - allocate(hvar%r82d(lb1:ub1,lb2:ub2));hvar%r82d(:,:)=flushval - case default - write(fates_log(),*) 'Incompatible vtype passed to set_history_var' - write(fates_log(),*) 'vtype = ',trim(vtype),' ?' - stop - ! end_run - end select - + if (trim(callstep) .eq. 'initialize') then + call this%hvars(ivar)%Init(vname, units, long, use_default, & + vtype, avgflag, flushval, upfreq, n_iovar_dk, this%iovar_dk) end if else - index = 0 end if return end subroutine set_history_var - ! ===================================================================================== - - subroutine get_hvar_bounds(this,hvar,thread,lb1,ub1,lb2,ub2) - - class(fates_hio_interface_type) :: this - type(iovar_def_type),target,intent(in) :: hvar - integer,intent(in) :: thread - integer,intent(out) :: lb1 - integer,intent(out) :: ub1 - integer,intent(out) :: lb2 - integer,intent(out) :: ub2 - - ! local - integer :: ndims - - lb1 = 0 - ub1 = 0 - lb2 = 0 - ub2 = 0 - - ndims = hvar%iovar_dk_ptr%ndims - - ! The thread = 0 case is the boundaries for the whole proc/node - if (thread==0) then - lb1 = hvar%iovar_dk_ptr%dim1_ptr%lower_bound - ub1 = hvar%iovar_dk_ptr%dim1_ptr%upper_bound - if(ndims>1)then - lb2 = hvar%iovar_dk_ptr%dim2_ptr%lower_bound - ub2 = hvar%iovar_dk_ptr%dim2_ptr%upper_bound - end if - else - lb1 = hvar%iovar_dk_ptr%dim1_ptr%clump_lower_bound(thread) - ub1 = hvar%iovar_dk_ptr%dim1_ptr%clump_upper_bound(thread) - if(ndims>1)then - lb2 = hvar%iovar_dk_ptr%dim2_ptr%clump_lower_bound(thread) - ub2 = hvar%iovar_dk_ptr%dim2_ptr%clump_upper_bound(thread) - end if - end if - - return - end subroutine get_hvar_bounds - - ! ==================================================================================== subroutine init_iovar_dk_maps(this) @@ -1406,6 +1269,10 @@ end subroutine init_iovar_dk_maps ! =================================================================================== subroutine set_dim_ptrs(this,dk_name,idim,dim_target) + + use FatesHistoryVariableType, only : iotype_index + + implicit none ! arguments class(fates_hio_interface_type) :: this @@ -1417,7 +1284,7 @@ subroutine set_dim_ptrs(this,dk_name,idim,dim_target) ! local integer :: ityp - ityp = this%iotype_index(trim(dk_name)) + ityp = iotype_index(trim(dk_name), n_iovar_dk, this%iovar_dk) ! First check to see if the dimension is allocated if(this%iovar_dk(ityp)%ndims Date: Tue, 18 Oct 2016 13:33:47 -0700 Subject: [PATCH 223/437] renamed some local variables related to nitrogen content. --- biogeophys/EDPhotosynthesisMod.F90 | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/biogeophys/EDPhotosynthesisMod.F90 b/biogeophys/EDPhotosynthesisMod.F90 index 6179e97f..5e9c2ee3 100644 --- a/biogeophys/EDPhotosynthesisMod.F90 +++ b/biogeophys/EDPhotosynthesisMod.F90 @@ -214,9 +214,9 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) real(r8) :: rscanopy real(r8) :: elai - real(r8) :: live_agstem_n ! Live above-ground stem (sapwood) nitrogen content (gN/plant) - real(r8) :: live_bgstem_n ! Live below-ground stem (sapwood) nitrogen content (gN/plant) - real(r8) :: froot_n ! Fine root nitrogen content (gN/plant) + real(r8) :: live_stem_n ! Live stem (above-ground sapwood) nitrogen content (kgN/plant) + real(r8) :: live_croot_n ! Live coarse root (below-ground sapwood) nitrogen content (kgN/plant) + real(r8) :: froot_n ! Fine root nitrogen content (kgN/plant) ! Parameters ! ----------------------------------------------------------------------- @@ -894,9 +894,9 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) ! the sapwood pools. ! Units are in (kgN/plant) ! ------------------------------------------------------------------ - live_agstem_n = ED_val_ag_biomass * currentCohort%bsw / & + live_stem_n = ED_val_ag_biomass * currentCohort%bsw / & frootcn(currentCohort%pft) - live_bgstem_n = (1.0_r8-ED_val_ag_biomass) * currentCohort%bsw / & + live_croot_n = (1.0_r8-ED_val_ag_biomass) * currentCohort%bsw / & frootcn(currentCohort%pft) froot_n = currentCohort%br / frootcn(currentCohort%pft) @@ -906,12 +906,12 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) ! Leaf respn needs to be in the sub-layer loop to account for changing N through canopy. !------------------------------------------------------------------------------ - ! Above ground Live stem MR (kgC/plant/s) + ! Live stem MR (kgC/plant/s) (above ground sapwood) ! ------------------------------------------------------------------ if (woody(ft) == 1) then tc = q10**((bc_in(s)%t_veg_pa(ifp)-tfrz - 20.0_r8)/10.0_r8) ! kgC/s = kgN * kgC/kgN/s - currentCohort%livestem_mr = live_agstem_n * base_mr_20 * tc + currentCohort%livestem_mr = live_stem_n * base_mr_20 * tc else currentCohort%livestem_mr = 0._r8 end if @@ -926,7 +926,7 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) froot_n * base_mr_20 * tcsoi * currentPatch%rootfr_ft(ft,j) enddo - ! Coarse Root MR + ! Coarse Root MR (kgC/plant/s) (below ground sapwood) ! ------------------------------------------------------------------ if (woody(ft) == 1) then currentCohort%livecroot_mr = 0._r8 @@ -934,7 +934,7 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) ! Soil temperature used to adjust base rate of MR tcsoi = q10**((bc_in(s)%t_soisno_gl(j)-tfrz - 20.0_r8)/10.0_r8) currentCohort%livecroot_mr = currentCohort%livecroot_mr + & - live_bgstem_n * base_mr_20 * tcsoi * & + live_croot_n * base_mr_20 * tcsoi * & currentPatch%rootfr_ft(ft,j) enddo else From ffa9315359d8e80b908ce98b092bbfe7aec69314 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 18 Oct 2016 14:47:02 -0700 Subject: [PATCH 224/437] Added cohort type variables size_class and size_by_pft_class. These variables were added to reduce the number of times these are re-calculated. They are in some cases needed for history diagnostics updated at the finest model time-scale on cohort variables, this was likely a very expensive calculation, so it was moved to be calculated only on the dynamics timestep. --- biogeochem/EDCanopyStructureMod.F90 | 8 ++ biogeochem/EDCohortDynamicsMod.F90 | 29 +++++- main/EDTypesMod.F90 | 8 ++ main/HistoryIOMod.F90 | 138 ++++++++++++++-------------- 4 files changed, 111 insertions(+), 72 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 8ad6b71c..c3ea17dd 100755 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -658,6 +658,7 @@ subroutine canopy_summarization( nsites, sites, bc_in ) use FatesInterfaceMod , only : bc_in_type use EDPatchDynamicsMod , only : set_patchno + use EDCohortDynamicsMod , only : size_and_type_class_index use EDGrowthFunctionsMod , only : tree_lai, c_area use EDEcophysConType , only : EDecophyscon use EDtypesMod , only : area @@ -709,6 +710,13 @@ subroutine canopy_summarization( nsites, sites, bc_in ) do while(associated(currentCohort)) ft = currentCohort%pft + + + ! Update the cohort's index within the size bin classes + ! Update the cohort's index within the SCPF classification system + call size_and_type_class_index(currentCohort%dbh,currentCohort%pft, & + currentCohort%size_class,currentCohort%size_by_pft_class) + currentCohort%b = currentCohort%balive+currentCohort%bdead+currentCohort%bstore currentCohort%treelai = tree_lai(currentCohort) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index d35afdb1..8f4ebd11 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -27,7 +27,7 @@ module EDCohortDynamicsMod public :: sort_cohorts public :: copy_cohort public :: count_cohorts -! public :: countCohorts + public :: size_and_type_class_index public :: allocate_live_biomass logical, parameter :: DEBUG = .false. ! local debug flag @@ -92,6 +92,9 @@ subroutine create_cohort(patchptr, pft, nn, hite, dbh, & new_cohort%balive = balive new_cohort%bstore = bstore + call size_and_type_class_index(new_cohort%dbh,new_cohort%pft, & + new_cohort%size_class,new_cohort%size_by_pft_class) + if ( DEBUG ) write(iulog,*) 'EDCohortDyn I ',bstore if (new_cohort%dbh <= 0.0_r8 .or. new_cohort%n == 0._r8 .or. new_cohort%pft == 0 & @@ -316,6 +319,8 @@ subroutine nan_cohort(cc_p) 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%size_class = 999 ! size class index + currentCohort%size_by_pft_class = 999 ! size by pft classification index currentCohort%n = nan ! number of individuals in cohort per 'area' (10000m2 default) currentCohort%dbh = nan ! 'diameter at breast height' in cm @@ -1127,6 +1132,28 @@ function count_cohorts( currentPatch ) result ( backcount ) end function count_cohorts + ! ===================================================================================== + + subroutine size_and_type_class_index(dbh,pft,size_class,size_by_pft_class) + + use EDTypesMod, only: sclass_ed, & + nlevsclass_ed + + ! Arguments + real(r8),intent(in) :: dbh + integer,intent(in) :: pft + integer,intent(out) :: size_class + integer,intent(out) :: size_by_pft_class + + size_class = count(dbh-sclass_ed.ge.0.0) + + size_by_pft_class = (pft-1)*nlevsclass_ed+size_class + + return + end subroutine size_and_type_class_index + + + !-------------------------------------------------------------------------------------! ! function countCohorts( bounds, ed_allsites_inst ) result ( totNumCohorts ) ! diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 486db615..d02891cb 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -189,6 +189,14 @@ module EDTypesMod real(r8) :: treesai ! stem area index of tree (total stem area (m2) / canopy area (m2) logical :: isnew ! flag to signify a new cohort, new cohorts have not experienced ! npp or mortality and should therefore not be fused or averaged + integer :: size_class ! An index that indicates which diameter size bin the cohort currently resides in + ! this is used for history output. We maintain this in the main cohort memory + ! because we don't want to continually re-calculate the cohort's position when + ! performing size diagnostics at high-frequency calls + integer :: size_by_pft_class ! An index that indicates the cohorts position of the joint size-class x functional + ! type classification. We also maintain this in the main cohort memory + ! because we don't want to continually re-calculate the cohort's position when + ! performing size diagnostics at high-frequency calls ! CARBON FLUXES real(r8) :: gpp ! GPP: kgC/indiv/year diff --git a/main/HistoryIOMod.F90 b/main/HistoryIOMod.F90 index e1a0b295..3b424d2e 100644 --- a/main/HistoryIOMod.F90 +++ b/main/HistoryIOMod.F90 @@ -336,8 +336,6 @@ subroutine update_history_dyn(this,nc,nsites,sites) integer :: lb1,ub1,lb2,ub2 ! IO array bounds for the calling thread integer :: ivar ! index of IO variable object vector integer :: ft ! functional type index - integer :: scpf ! index of the size-class x pft bin - integer :: sc ! index of the size-class bin real(r8) :: n_density ! individual of cohort per m2. real(r8) :: n_perm2 ! individuals per m2 for the whole column @@ -497,75 +495,76 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! ------------------------------------------------------------------------ dbh = ccohort%dbh !-0.5*(1./365.25)*ccohort%ddbhdt - sc = count(dbh-sclass_ed.ge.0.0) - scpf = (ft-1)*nlevsclass_ed+sc ! Flux Variables (cohorts must had experienced a day before any of these values ! have any meaning, otherwise they are just inialization values if( .not.(ccohort%isnew) ) then - hio_gpp_si_scpf(io_si,scpf) = hio_gpp_si_scpf(io_si,scpf) + & - n_perm2*ccohort%gpp ! [kgC/m2/yr] - hio_npp_totl_si_scpf(io_si,scpf) = hio_npp_totl_si_scpf(io_si,scpf) + & - ccohort%npp*n_perm2 - hio_npp_leaf_si_scpf(io_si,scpf) = hio_npp_leaf_si_scpf(io_si,scpf) + & - ccohort%npp_leaf*n_perm2 - hio_npp_fnrt_si_scpf(io_si,scpf) = hio_npp_fnrt_si_scpf(io_si,scpf) + & - ccohort%npp_froot*n_perm2 - hio_npp_bgsw_si_scpf(io_si,scpf) = hio_npp_bgsw_si_scpf(io_si,scpf) + & - ccohort%npp_bsw*(1._r8-ED_val_ag_biomass)*n_perm2 - hio_npp_agsw_si_scpf(io_si,scpf) = hio_npp_agsw_si_scpf(io_si,scpf) + & - ccohort%npp_bsw*ED_val_ag_biomass*n_perm2 - hio_npp_bgdw_si_scpf(io_si,scpf) = hio_npp_bgdw_si_scpf(io_si,scpf) + & - ccohort%npp_bdead*(1._r8-ED_val_ag_biomass)*n_perm2 - hio_npp_agdw_si_scpf(io_si,scpf) = hio_npp_agdw_si_scpf(io_si,scpf) + & - ccohort%npp_bdead*ED_val_ag_biomass*n_perm2 - hio_npp_seed_si_scpf(io_si,scpf) = hio_npp_seed_si_scpf(io_si,scpf) + & - ccohort%npp_bseed*n_perm2 - hio_npp_stor_si_scpf(io_si,scpf) = hio_npp_stor_si_scpf(io_si,scpf) + & - ccohort%npp_store*n_perm2 - - if( abs(ccohort%npp-(ccohort%npp_leaf+ccohort%npp_froot+ & - ccohort%npp_bsw+ccohort%npp_bdead+ & - ccohort%npp_bseed+ccohort%npp_store))>1.e-9) then - write(fates_log(),*) 'NPP Partitions are not balancing' - write(fates_log(),*) 'Fractional Error: ', & - abs(ccohort%npp-(ccohort%npp_leaf+ccohort%npp_froot+ & - ccohort%npp_bsw+ccohort%npp_bdead+ & - ccohort%npp_bseed+ccohort%npp_store))/ccohort%npp - write(fates_log(),*) 'Terms: ',ccohort%npp,ccohort%npp_leaf,ccohort%npp_froot, & - ccohort%npp_bsw,ccohort%npp_bdead, & - ccohort%npp_bseed,ccohort%npp_store - write(fates_log(),*) ' NPP components during FATES-HLM linking does not balance ' - stop ! we need termination control for FATES!!! - ! call endrun(msg=errMsg(__FILE__, __LINE__)) - end if + associate( scpf => ccohort%size_by_pft_class ) + + hio_gpp_si_scpf(io_si,scpf) = hio_gpp_si_scpf(io_si,scpf) + & + n_perm2*ccohort%gpp ! [kgC/m2/yr] + hio_npp_totl_si_scpf(io_si,scpf) = hio_npp_totl_si_scpf(io_si,scpf) + & + ccohort%npp*n_perm2 + hio_npp_leaf_si_scpf(io_si,scpf) = hio_npp_leaf_si_scpf(io_si,scpf) + & + ccohort%npp_leaf*n_perm2 + hio_npp_fnrt_si_scpf(io_si,scpf) = hio_npp_fnrt_si_scpf(io_si,scpf) + & + ccohort%npp_froot*n_perm2 + hio_npp_bgsw_si_scpf(io_si,scpf) = hio_npp_bgsw_si_scpf(io_si,scpf) + & + ccohort%npp_bsw*(1._r8-ED_val_ag_biomass)*n_perm2 + hio_npp_agsw_si_scpf(io_si,scpf) = hio_npp_agsw_si_scpf(io_si,scpf) + & + ccohort%npp_bsw*ED_val_ag_biomass*n_perm2 + hio_npp_bgdw_si_scpf(io_si,scpf) = hio_npp_bgdw_si_scpf(io_si,scpf) + & + ccohort%npp_bdead*(1._r8-ED_val_ag_biomass)*n_perm2 + hio_npp_agdw_si_scpf(io_si,scpf) = hio_npp_agdw_si_scpf(io_si,scpf) + & + ccohort%npp_bdead*ED_val_ag_biomass*n_perm2 + hio_npp_seed_si_scpf(io_si,scpf) = hio_npp_seed_si_scpf(io_si,scpf) + & + ccohort%npp_bseed*n_perm2 + hio_npp_stor_si_scpf(io_si,scpf) = hio_npp_stor_si_scpf(io_si,scpf) + & + ccohort%npp_store*n_perm2 + + if( abs(ccohort%npp-(ccohort%npp_leaf+ccohort%npp_froot+ & + ccohort%npp_bsw+ccohort%npp_bdead+ & + ccohort%npp_bseed+ccohort%npp_store))>1.e-9) then + write(fates_log(),*) 'NPP Partitions are not balancing' + write(fates_log(),*) 'Fractional Error: ', & + abs(ccohort%npp-(ccohort%npp_leaf+ccohort%npp_froot+ & + ccohort%npp_bsw+ccohort%npp_bdead+ & + ccohort%npp_bseed+ccohort%npp_store))/ccohort%npp + write(fates_log(),*) 'Terms: ',ccohort%npp,ccohort%npp_leaf,ccohort%npp_froot, & + ccohort%npp_bsw,ccohort%npp_bdead, & + ccohort%npp_bseed,ccohort%npp_store + write(fates_log(),*) ' NPP components during FATES-HLM linking does not balance ' + stop ! we need termination control for FATES!!! + ! call endrun(msg=errMsg(__FILE__, __LINE__)) + end if - ! Woody State Variables (basal area and number density and mortality) - if (pftcon%woody(ft) == 1) then - - hio_m1_si_scpf(io_si,scpf) = hio_m1_si_scpf(io_si,scpf) + ccohort%bmort*n_perm2*AREA - hio_m2_si_scpf(io_si,scpf) = hio_m2_si_scpf(io_si,scpf) + ccohort%hmort*n_perm2*AREA - hio_m3_si_scpf(io_si,scpf) = hio_m3_si_scpf(io_si,scpf) + ccohort%cmort*n_perm2*AREA - hio_m4_si_scpf(io_si,scpf) = hio_m4_si_scpf(io_si,scpf) + ccohort%imort*n_perm2*AREA - hio_m5_si_scpf(io_si,scpf) = hio_m5_si_scpf(io_si,scpf) + ccohort%fmort*n_perm2*AREA - - ! basal area [m2/ha] - hio_ba_si_scpf(io_si,scpf) = hio_ba_si_scpf(io_si,scpf) + & - 0.25_r8*3.14159_r8*((dbh/100.0_r8)**2.0_r8)*n_perm2*AREA - - ! number density [/ha] - hio_nplant_si_scpf(io_si,scpf) = hio_nplant_si_scpf(io_si,scpf) + AREA*n_perm2 - - ! Growth Incrments must have NaN check and woody check - if(ccohort%ddbhdt == ccohort%ddbhdt) then - hio_ddbh_si_scpf(io_si,scpf) = hio_ddbh_si_scpf(io_si,scpf) + & - ccohort%ddbhdt*n_perm2*AREA - else - hio_ddbh_si_scpf(io_si,scpf) = -999.9 - end if - end if - + ! Woody State Variables (basal area and number density and mortality) + if (pftcon%woody(ft) == 1) then + + hio_m1_si_scpf(io_si,scpf) = hio_m1_si_scpf(io_si,scpf) + ccohort%bmort*n_perm2*AREA + hio_m2_si_scpf(io_si,scpf) = hio_m2_si_scpf(io_si,scpf) + ccohort%hmort*n_perm2*AREA + hio_m3_si_scpf(io_si,scpf) = hio_m3_si_scpf(io_si,scpf) + ccohort%cmort*n_perm2*AREA + hio_m4_si_scpf(io_si,scpf) = hio_m4_si_scpf(io_si,scpf) + ccohort%imort*n_perm2*AREA + hio_m5_si_scpf(io_si,scpf) = hio_m5_si_scpf(io_si,scpf) + ccohort%fmort*n_perm2*AREA + + ! basal area [m2/ha] + hio_ba_si_scpf(io_si,scpf) = hio_ba_si_scpf(io_si,scpf) + & + 0.25_r8*3.14159_r8*((dbh/100.0_r8)**2.0_r8)*n_perm2*AREA + + ! number density [/ha] + hio_nplant_si_scpf(io_si,scpf) = hio_nplant_si_scpf(io_si,scpf) + AREA*n_perm2 + + ! Growth Incrments must have NaN check and woody check + if(ccohort%ddbhdt == ccohort%ddbhdt) then + hio_ddbh_si_scpf(io_si,scpf) = hio_ddbh_si_scpf(io_si,scpf) + & + ccohort%ddbhdt*n_perm2*AREA + else + hio_ddbh_si_scpf(io_si,scpf) = -999.9 + end if + end if + + end associate end if ccohort => ccohort%taller @@ -655,8 +654,6 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) integer :: lb1,ub1,lb2,ub2 ! IO array bounds for the calling thread integer :: ivar ! index of IO variable object vector integer :: ft ! functional type index - integer :: scpf ! index of the size-class x pft bin - integer :: sc ! index of the size-class bin real(r8) :: n_density ! individual of cohort per m2. real(r8) :: n_perm2 ! individuals per m2 for the whole column @@ -710,11 +707,9 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) endif if ( .not. ccohort%isnew ) then - + ! Calculate index for the scpf class - ft = ccohort%pft - sc = count(ccohort%dbh-sclass_ed.ge.0.0) - scpf = (ft-1)*nlevsclass_ed+sc + associate( scpf => ccohort%size_by_pft_class ) ! scale up cohort fluxes to their patches hio_npp_pa(io_pa) = hio_npp_pa(io_pa) + & @@ -761,6 +756,7 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) hio_ar_frootm_si_scpf(io_si,scpf) = hio_ar_frootm_si_scpf(io_si,scpf) + & ccohort%froot_mr * n_perm2 * daysecs * yeardays + end associate endif ccohort => ccohort%taller From 458f24d51efabc672014a6c9207d6d141d76559b Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 18 Oct 2016 20:33:28 -0700 Subject: [PATCH 225/437] Converted %npp and friends to %npp_acc_hold and friends. Documentation included. One free gpp with any resp of equal or lesser value. --- biogeochem/EDCanopyStructureMod.F90 | 2 +- biogeochem/EDCohortDynamicsMod.F90 | 48 ++++++++++++++--------------- biogeochem/EDPhysiologyMod.F90 | 20 ++++++------ main/EDMainMod.F90 | 3 +- main/EDRestVectorMod.F90 | 44 +++++++++++++------------- main/EDTypesMod.F90 | 38 +++++++++++++++++------ main/HistoryIOMod.F90 | 12 ++++---- 7 files changed, 94 insertions(+), 73 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index a0056056..55d785fb 100755 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -754,7 +754,7 @@ subroutine canopy_summarization( nsites, sites, bc_in ) if(currentCohort%balive <= 0._r8)then write(fates_log(),*) 'ED: balive is zero in canopy_summarization',currentCohort%balive endif - + currentCohort => currentCohort%taller enddo ! ends 'do while(associated(currentCohort)) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index fca32709..719f1498 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -340,16 +340,16 @@ subroutine nan_cohort(cc_p) 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_tstep = nan ! GPP: kgC/indiv/timestep + currentCohort%gpp_acc_hold = nan ! GPP: kgC/indiv/year + currentCohort%gpp_tstep = nan ! GPP: kgC/indiv/timestep currentCohort%gpp_acc = nan ! GPP: kgC/indiv/day - currentCohort%npp = nan ! NPP: kgC/indiv/year - currentCohort%npp_tstep = nan ! NPP: kGC/indiv/timestep + currentCohort%npp_acc_hold = nan ! NPP: kgC/indiv/year + currentCohort%npp_tstep = nan ! NPP: kGC/indiv/timestep currentCohort%npp_acc = nan ! NPP: kgC/indiv/day currentCohort%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_tstep = nan ! RESP: kgC/indiv/timestep + currentCohort%resp_acc_hold = nan ! RESP: kgC/indiv/year + currentCohort%resp_tstep = nan ! RESP: kgC/indiv/timestep currentCohort%resp_acc = nan ! RESP: kGC/cohort/day currentCohort%npp_leaf = nan @@ -433,10 +433,10 @@ subroutine zero_cohort(cc_p) currentcohort%npp_acc = 0._r8 currentcohort%gpp_acc = 0._r8 currentcohort%resp_acc = 0._r8 - currentcohort%npp_tstep = 0._r8 - currentcohort%gpp_tstep = 0._r8 - currentcohort%resp_tstep = 0._r8 - currentcohort%resp = 0._r8 + currentcohort%npp_tstep = 0._r8 + currentcohort%gpp_tstep = 0._r8 + currentcohort%resp_tstep = 0._r8 + currentcohort%resp_acc_hold = 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. @@ -446,8 +446,8 @@ subroutine zero_cohort(cc_p) currentcohort%md = 0._r8 currentcohort%root_md = 0._r8 currentcohort%leaf_md = 0._r8 - currentcohort%npp = 0._r8 - currentcohort%gpp = 0._r8 + currentcohort%npp_acc_hold = 0._r8 + currentcohort%gpp_acc_hold = 0._r8 currentcohort%storage_flux = 0._r8 currentcohort%dmort = 0._r8 currentcohort%gscan = 0._r8 @@ -706,10 +706,10 @@ subroutine fuse_cohorts(patchptr) if ( DEBUG ) write(iulog,*) 'EDcohortDyn V ',currentCohort%npp_acc if ( DEBUG ) write(iulog,*) 'EDcohortDyn VI ',currentCohort%resp_acc - - 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%resp_acc_hold = (currentCohort%n*currentCohort%resp_acc_hold + nextc%n*nextc%resp_acc_hold)/newn + currentCohort%npp_acc_hold = (currentCohort%n*currentCohort%npp_acc_hold + nextc%n*nextc%npp_acc_hold)/newn + currentCohort%gpp_acc_hold = (currentCohort%n*currentCohort%gpp_acc_hold + nextc%n*nextc%gpp_acc_hold)/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 @@ -1015,20 +1015,20 @@ subroutine copy_cohort( currentCohort,copyc ) n%excl_weight = o%excl_weight n%prom_weight = o%prom_weight - ! CARBON FLUXES - n%gpp = o%gpp + ! CARBON FLUXES + n%gpp_acc_hold = o%gpp_acc_hold n%gpp_acc = o%gpp_acc - n%gpp_tstep = o%gpp_tstep - n%npp = o%npp - n%npp_tstep = o%npp_tstep + n%gpp_tstep = o%gpp_tstep + n%npp_acc_hold = o%npp_acc_hold + n%npp_tstep = o%npp_tstep if ( DEBUG ) write(iulog,*) 'EDcohortDyn Ia ',o%npp_acc if ( DEBUG ) write(iulog,*) 'EDcohortDyn Ib ',o%resp_acc - n%npp_acc = o%npp_acc - n%resp_tstep = o%resp_tstep + n%npp_acc_hold = o%npp_acc_hold + n%resp_tstep = o%resp_tstep n%resp_acc = o%resp_acc - n%resp = o%resp + n%resp_acc_hold = o%resp_acc_hold n%year_net_uptake = o%year_net_uptake n%ts_net_uptake = o%ts_net_uptake diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index c0d2b25d..aa2ba42c 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -789,9 +789,9 @@ subroutine Growth_Derivatives( currentSite, currentCohort) ! NPP if ( DEBUG ) write(iulog,*) 'EDphys 716 ',currentCohort%npp_acc - currentCohort%npp = currentCohort%npp_acc * udata%n_sub !Link to CLM. convert from kgC/indiv/day into kgC/indiv/year - currentCohort%gpp = currentCohort%gpp_acc * udata%n_sub !Link to CLM. convert from kgC/indiv/day into kgC/indiv/year - currentCohort%resp = currentCohort%resp_acc * udata%n_sub !Link to CLM. convert from kgC/indiv/day into kgC/indiv/year + currentCohort%npp_acc_hold = currentCohort%npp_acc * udata%n_sub ! convert from kgC/indiv/day into kgC/indiv/year + currentCohort%gpp_acc_hold = currentCohort%gpp_acc * udata%n_sub ! convert from kgC/indiv/day into kgC/indiv/year + currentCohort%resp_acc_hold = currentCohort%resp_acc * udata%n_sub ! convert from kgC/indiv/day into kgC/indiv/year currentSite%flux_in = currentSite%flux_in + currentCohort%npp_acc * currentCohort%n @@ -833,16 +833,16 @@ subroutine Growth_Derivatives( currentSite, currentCohort) ! Calculate carbon balance ! this is the fraction of maintenance demand we -have- to do... - if ( DEBUG ) write(iulog,*) 'EDphys 760 ',currentCohort%npp, currentCohort%md, & + if ( DEBUG ) write(iulog,*) 'EDphys 760 ',currentCohort%npp_acc_hold, currentCohort%md, & EDecophyscon%leaf_stor_priority(currentCohort%pft) - currentCohort%carbon_balance = currentCohort%npp - currentCohort%md * EDecophyscon%leaf_stor_priority(currentCohort%pft) + currentCohort%carbon_balance = currentCohort%npp_acc_hold - currentCohort%md * EDecophyscon%leaf_stor_priority(currentCohort%pft) ! Allowing only carbon from NPP pool to account for npp flux into the maintenance pools ! ie this does not include any use of storage carbon or balive to make up for missing carbon balance in the transfer - currentCohort%npp_leaf = min(currentCohort%npp*currentCohort%leaf_md/currentCohort%md, & + currentCohort%npp_leaf = min(currentCohort%npp_acc_hold*currentCohort%leaf_md/currentCohort%md, & currentCohort%leaf_md*EDecophyscon%leaf_stor_priority(currentCohort%pft)) - currentCohort%npp_froot = min(currentCohort%npp*currentCohort%root_md/currentCohort%md, & + currentCohort%npp_froot = min(currentCohort%npp_acc_hold*currentCohort%root_md/currentCohort%md, & currentCohort%root_md*EDecophyscon%leaf_stor_priority(currentCohort%pft)) @@ -944,12 +944,12 @@ subroutine Growth_Derivatives( currentSite, currentCohort) if ( DEBUG ) write(iulog,*) 'EDPhys dbstoredt I ',currentCohort%dbstoredt currentCohort%seed_prod = (1.0_r8 - gr_fract) * currentCohort%carbon_balance - if (abs(currentCohort%npp-(currentCohort%dbalivedt+currentCohort%dbdeaddt+currentCohort%dbstoredt+ & + if (abs(currentCohort%npp_acc_hold-(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- & + write(iulog,*) 'error in carbon check growth derivs',currentCohort%npp_acc_hold- & (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%npp_acc_hold,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 diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 559c4b91..9499f93d 100755 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -202,7 +202,8 @@ subroutine ed_integrate_state_variables(currentSite, temperature_inst ) currentCohort%bstore+udata%deltat* & (currentCohort%md+currentCohort%seed_prod)-cohort_biomass_store-currentCohort%npp_acc) endif - !do we need these any more? + + ! THESE SHOULD BE MOVED TO A MORE "VISIBLE" LOCATION (RGK 10-2016) currentCohort%npp_acc = 0.0_r8 currentCohort%gpp_acc = 0.0_r8 currentCohort%resp_acc = 0.0_r8 diff --git a/main/EDRestVectorMod.F90 b/main/EDRestVectorMod.F90 index f655c1be..5fbcb72c 100755 --- a/main/EDRestVectorMod.F90 +++ b/main/EDRestVectorMod.F90 @@ -58,8 +58,8 @@ module EDRestVectorMod real(r8), pointer :: n(:) real(r8), pointer :: gpp_acc(:) real(r8), pointer :: npp_acc(:) - real(r8), pointer :: gpp(:) - real(r8), pointer :: npp(:) + real(r8), pointer :: gpp_acc_hold(:) + real(r8), pointer :: npp_acc_hold(:) real(r8), pointer :: npp_leaf(:) real(r8), pointer :: npp_froot(:) real(r8), pointer :: npp_bsw(:) @@ -212,8 +212,8 @@ subroutine deleteEDRestartVectorClass( this ) deallocate(this%n ) deallocate(this%gpp_acc ) deallocate(this%npp_acc ) - deallocate(this%gpp ) - deallocate(this%npp ) + deallocate(this%gpp_acc_hold ) + deallocate(this%npp_acc_hold ) deallocate(this%npp_leaf ) deallocate(this%npp_froot ) deallocate(this%npp_bsw ) @@ -499,15 +499,15 @@ function newEDRestartVectorClass( bounds ) SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) new%npp_acc(:) = 0.0_r8 - allocate(new%gpp & + allocate(new%gpp_acc_hold & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%gpp(:) = 0.0_r8 + new%gpp_acc_hold(:) = 0.0_r8 - allocate(new%npp & + allocate(new%npp_acc_hold & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%npp(:) = 0.0_r8 + new%npp_acc_hold(:) = 0.0_r8 allocate(new%npp_leaf & (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) @@ -1022,16 +1022,16 @@ subroutine doVectorIO( this, ncid, flag ) interpinic_flag='interp', data=this%npp_acc, & readvar=readvar) - call restartvar(ncid=ncid, flag=flag, varname='ed_gpp', xtype=ncd_double, & + call restartvar(ncid=ncid, flag=flag, varname='ed_gpp_acc_hold', xtype=ncd_double, & dim1name=coh_dimName, & long_name='ed cohort - gpp', units='unitless', & - interpinic_flag='interp', data=this%gpp, & + interpinic_flag='interp', data=this%gpp_acc_hold, & readvar=readvar) - call restartvar(ncid=ncid, flag=flag, varname='ed_npp', xtype=ncd_double, & + call restartvar(ncid=ncid, flag=flag, varname='ed_npp_acc_hold', xtype=ncd_double, & dim1name=coh_dimName, & long_name='ed cohort - npp', units='unitless', & - interpinic_flag='interp', data=this%npp, & + interpinic_flag='interp', data=this%npp_acc_hold, & readvar=readvar) call restartvar(ncid=ncid, flag=flag, varname='ed_npp_leaf', xtype=ncd_double, & @@ -1306,9 +1306,9 @@ subroutine printDataInfoVector( this ) write(iulog,*) trim(methodName)//' :: npp_acc ', & this%npp_acc(iSta:iSto) write(iulog,*) trim(methodName)//' :: gpp ', & - this%gpp(iSta:iSto) + this%gpp_acc_hold(iSta:iSto) write(iulog,*) trim(methodName)//' :: npp ', & - this%npp(iSta:iSto) + this%npp_acc_hold(iSta:iSto) write(iulog,*) trim(methodName)//' :: npp_leaf ', & this%npp_leaf(iSta:iSto) write(iulog,*) trim(methodName)//' :: npp_froot ', & @@ -1461,8 +1461,8 @@ subroutine printDataInfoLL( this, bounds, nsites, sites ) 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)//' gpp ' ,totalCohorts,currentCohort%gpp - write(iulog,*) trim(methodName)//' npp ' ,totalCohorts,currentCohort%npp + write(iulog,*) trim(methodName)//' gpp_acc_hold ' ,totalCohorts,currentCohort%gpp_acc_hold + write(iulog,*) trim(methodName)//' npp_acc_hold ' ,totalCohorts,currentCohort%npp_acc_hold write(iulog,*) trim(methodName)//' npp_leaf ' ,totalCohorts,currentCohort%npp_leaf write(iulog,*) trim(methodName)//' npp_froot ' ,totalCohorts,currentCohort%npp_froot write(iulog,*) trim(methodName)//' npp_bsw ' ,totalCohorts,currentCohort%npp_bsw @@ -1597,8 +1597,8 @@ subroutine printIoInfoLL( this, bounds, nsites, sites, fcolumn ) 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)//' gpp ',currentCohort%gpp - write(iulog,*) trim(methodName)//' npp ',currentCohort%npp + write(iulog,*) trim(methodName)//' gpp_acc_hold ',currentCohort%gpp_acc_hold + write(iulog,*) trim(methodName)//' npp_acc_hold ',currentCohort%npp_acc_hold write(iulog,*) trim(methodName)//' npp_leaf ',currentCohort%npp_leaf write(iulog,*) trim(methodName)//' npp_froot ',currentCohort%npp_froot write(iulog,*) trim(methodName)//' npp_bsw ',currentCohort%npp_bsw @@ -1742,8 +1742,8 @@ subroutine convertCohortListToVector( this, bounds, nsites, sites, fcolumn ) this%n(countCohort) = currentCohort%n this%gpp_acc(countCohort) = currentCohort%gpp_acc this%npp_acc(countCohort) = currentCohort%npp_acc - this%gpp(countCohort) = currentCohort%gpp - this%npp(countCohort) = currentCohort%npp + this%gpp_acc_hold(countCohort) = currentCohort%gpp_acc_hold + this%npp_acc_hold(countCohort) = currentCohort%npp_acc_hold this%npp_leaf(countCohort) = currentCohort%npp_leaf this%npp_froot(countCohort) = currentCohort%npp_froot this%npp_bsw(countCohort) = currentCohort%npp_bsw @@ -2179,8 +2179,8 @@ subroutine convertCohortVectorToList( this, bounds, nsites, sites, fcolumn ) currentCohort%n = this%n(countCohort) currentCohort%gpp_acc = this%gpp_acc(countCohort) currentCohort%npp_acc = this%npp_acc(countCohort) - currentCohort%gpp = this%gpp(countCohort) - currentCohort%npp = this%npp(countCohort) + currentCohort%gpp_acc_hold = this%gpp_acc_hold(countCohort) + currentCohort%npp_acc_hold = this%npp_acc_hold(countCohort) currentCohort%npp_leaf = this%npp_leaf(countCohort) currentCohort%npp_froot = this%npp_froot(countCohort) currentCohort%npp_bsw = this%npp_bsw(countCohort) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 9f64aefa..959f0257 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -190,16 +190,36 @@ module EDTypesMod logical :: isnew ! flag to signify a new cohort, new cohorts have not experienced ! npp or mortality and should therefore not be fused or averaged + ! CARBON FLUXES - real(r8) :: gpp ! GPP: kgC/indiv/year - real(r8) :: gpp_acc ! GPP: kgC/indiv/day - real(r8) :: gpp_tstep ! GPP: kgC/indiv/timestep - real(r8) :: npp ! NPP: kgC/indiv/year - real(r8) :: npp_acc ! NPP: kgC/indiv/day - real(r8) :: npp_tstep ! NPP: kgC/indiv/timestep - real(r8) :: resp ! Resp: kgC/indiv/year - real(r8) :: resp_acc ! Resp: kgC/indiv/day - real(r8) :: resp_tstep ! Resp: kgC/indiv/timestep + + ! ---------------------------------------------------------------------------------- + ! NPP, GPP and RESP: Instantaneous, accumulated and accumulated-hold types.* + ! + ! _tstep: The instantaneous estimate that is calculated at each rapid plant biophysics + ! time-step (ie photosynthesis, sub-hourly). (kgC/indiv/timestep) + ! _acc: The accumulation of the _tstep variable from the beginning to ending of + ! the dynamics time-scale. This variable is zero'd during initialization and + ! after the dynamics call-sequence is completed. (kgC/indiv/day) + ! _acc_hold: While _acc is zero'd after the dynamics call sequence and then integrated, + ! _acc_hold "holds" the integrated value until the next time dynamics is + ! called. This is necessary for restarts. This variable also has units + ! converted to a useful rate (kgC/indiv/yr) + ! ---------------------------------------------------------------------------------- + + real(r8) :: gpp_tstep ! Gross Primary Production (see above *) + real(r8) :: gpp_acc + real(r8) :: gpp_acc_hold + + real(r8) :: npp_tstep ! Net Primary Production (see above *) + real(r8) :: npp_acc + real(r8) :: npp_acc_hold + + real(r8) :: resp_tstep ! Autotrophic respiration (see above *) + real(r8) :: resp_acc + real(r8) :: resp_acc_hold + + ! Net Primary Production Partitions real(r8) :: npp_leaf ! NPP into leaves (includes replacement of turnover): KgC/indiv/day real(r8) :: npp_froot ! NPP into fine roots (includes replacement of turnover): KgC/indiv/day diff --git a/main/HistoryIOMod.F90 b/main/HistoryIOMod.F90 index b21edabe..ca589dc2 100644 --- a/main/HistoryIOMod.F90 +++ b/main/HistoryIOMod.F90 @@ -498,9 +498,9 @@ subroutine update_history_dyn(this,nc,nsites,sites) if( .not.(ccohort%isnew) ) then hio_gpp_si_scpf(io_si,scpf) = hio_gpp_si_scpf(io_si,scpf) + & - n_perm2*ccohort%gpp ! [kgC/m2/yr] + n_perm2*ccohort%gpp_acc_hold ! [kgC/m2/yr] hio_npp_totl_si_scpf(io_si,scpf) = hio_npp_totl_si_scpf(io_si,scpf) + & - ccohort%npp*n_perm2 + ccohort%npp_acc_hold*n_perm2 hio_npp_leaf_si_scpf(io_si,scpf) = hio_npp_leaf_si_scpf(io_si,scpf) + & ccohort%npp_leaf*n_perm2 hio_npp_fnrt_si_scpf(io_si,scpf) = hio_npp_fnrt_si_scpf(io_si,scpf) + & @@ -518,15 +518,15 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_npp_stor_si_scpf(io_si,scpf) = hio_npp_stor_si_scpf(io_si,scpf) + & ccohort%npp_store*n_perm2 - if( abs(ccohort%npp-(ccohort%npp_leaf+ccohort%npp_froot+ & + if( abs(ccohort%npp_acc_hold-(ccohort%npp_leaf+ccohort%npp_froot+ & ccohort%npp_bsw+ccohort%npp_bdead+ & ccohort%npp_bseed+ccohort%npp_store))>1.e-9) then write(fates_log(),*) 'NPP Partitions are not balancing' write(fates_log(),*) 'Fractional Error: ', & - abs(ccohort%npp-(ccohort%npp_leaf+ccohort%npp_froot+ & + abs(ccohort%npp_acc_hold-(ccohort%npp_leaf+ccohort%npp_froot+ & ccohort%npp_bsw+ccohort%npp_bdead+ & - ccohort%npp_bseed+ccohort%npp_store))/ccohort%npp - write(fates_log(),*) 'Terms: ',ccohort%npp,ccohort%npp_leaf,ccohort%npp_froot, & + ccohort%npp_bseed+ccohort%npp_store))/ccohort%npp_acc_hold + write(fates_log(),*) 'Terms: ',ccohort%npp_acc_hold,ccohort%npp_leaf,ccohort%npp_froot, & ccohort%npp_bsw,ccohort%npp_bdead, & ccohort%npp_bseed,ccohort%npp_store write(fates_log(),*) ' NPP components during FATES-HLM linking does not balance ' From 6e12b9f2d5dc3b275c904263d7b3726b32b1de9e Mon Sep 17 00:00:00 2001 From: Rosie Fisher Date: Wed, 19 Oct 2016 08:22:38 -0600 Subject: [PATCH 226/437] turn temp_sf_switch on --- fire/SFMainMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index 3e6606d2..f86b006c 100755 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -56,7 +56,7 @@ subroutine fire_model( currentSite, atm2lnd_inst, temperature_inst) !zero fire things currentPatch => currentSite%youngest_patch - temporary_SF_switch = 0 + temporary_SF_switch = 1 do while(associated(currentPatch)) currentPatch%frac_burnt = 0.0_r8 currentPatch%AB = 0.0_r8 From ede4b914e59a94f02c1394bbae6d5e3010b7bf17 Mon Sep 17 00:00:00 2001 From: Ben Andre Date: Wed, 19 Oct 2016 17:02:40 -0600 Subject: [PATCH 227/437] Remove the pointers to fates history dims Remove the pointers to the fates_history_dimensions stored in the iovar_dimension kind types. Replace them with integer indicies. indicies point into an array of dimension types. The indices - name mapping and dim array is stored in the top level fates history io object passed into subroutines as read only data as needed. Test: ERS_D_Ld5.f10_f10.ICLM45ED.yellowstone_intel.clm-edTest Test baseline: 44aac42 Test status: pass Test suite: ed - yellowstone gnu, intel, pgi Test baseline: 44aac42 Test status: all tests pass --- main/FatesHistoryDimensionMod.F90 | 21 + main/FatesHistoryVarKindMod.F90 | 28 +- main/FatesHistoryVariableType.F90 | 78 +-- main/HistoryIOMod.F90 | 871 ++++++++++++++++-------------- 4 files changed, 564 insertions(+), 434 deletions(-) diff --git a/main/FatesHistoryDimensionMod.F90 b/main/FatesHistoryDimensionMod.F90 index da1598fd..143048ee 100644 --- a/main/FatesHistoryDimensionMod.F90 +++ b/main/FatesHistoryDimensionMod.F90 @@ -13,6 +13,27 @@ module FatesHistoryDimensionMod character(*), parameter :: site_class_pft_r8 = 'SI_SCPF_R8' character(*), parameter :: patch_int = 'PA_INT' + integer, parameter :: fates_num_dimension_types = 4 + character(*), parameter :: patch = 'patch' + character(*), parameter :: column = 'column' + character(*), parameter :: levgrnd = 'levgrnd' + character(*), parameter :: levscpf = 'levscpf' + + ! patch = This is a structure that records where FATES patch boundaries + ! on each thread point to in the host IO array, this structure + ! is allocated by number of threads + + ! column = This is a structure that records where FATES column boundaries + ! on each thread point to in the host IO array, this structure + ! is allocated by number of threads + + ! ground = This is a structure that records the boundaries for the + ! ground level (includes rock) dimension + + ! levscpf = This is a structure that records the boundaries for the + ! number of size-class x pft dimension + + ! This structure is not allocated by thread, but the upper and lower boundaries ! of the dimension for each thread is saved in the clump_ entry type fates_history_dimension_type diff --git a/main/FatesHistoryVarKindMod.F90 b/main/FatesHistoryVarKindMod.F90 index 869f16a1..22ed6c28 100644 --- a/main/FatesHistoryVarKindMod.F90 +++ b/main/FatesHistoryVarKindMod.F90 @@ -15,13 +15,15 @@ module FatesHistoryVariableKindMod character(len=fates_long_string_length) :: name ! String labelling this IO type integer :: ndims ! number of dimensions in this IO type integer, allocatable :: dimsize(:) ! The size of each dimension - logical :: active - type(fates_history_dimension_type), pointer :: dim1_ptr - type(fates_history_dimension_type), pointer :: dim2_ptr + logical, private :: active_ + integer :: dim1_index + integer :: dim2_index contains procedure, public :: Init => InitVariableKind + procedure, public :: set_active + procedure, public :: is_active end type fates_history_variable_kind_type @@ -44,12 +46,24 @@ subroutine InitVariableKind(this, name, num_dims) this%ndims = num_dims allocate(this%dimsize(this%ndims)) this%dimsize(:) = fates_unset_int - this%active = .false. - nullify(this%dim1_ptr) - nullify(this%dim2_ptr) + this%active_ = .false. + this%dim1_index = fates_unset_int + this%dim2_index = fates_unset_int end subroutine InitVariableKind - + ! ======================================================================= + subroutine set_active(this) + implicit none + class(fates_history_variable_kind_type), intent(inout) :: this + this%active_ = .true. + end subroutine set_active + + logical function is_active(this) + implicit none + class(fates_history_variable_kind_type), intent(in) :: this + is_active = this%active_ + end function is_active + end module FatesHistoryVariableKindMod diff --git a/main/FatesHistoryVariableType.F90 b/main/FatesHistoryVariableType.F90 index 1e15751f..54558a54 100644 --- a/main/FatesHistoryVariableType.F90 +++ b/main/FatesHistoryVariableType.F90 @@ -22,7 +22,7 @@ module FatesHistoryVariableType ! 1 = dynamics "dyn" (daily) ! 2 = production "prod" (prob model tstep) real(r8) :: flushval - type(fates_history_variable_kind_type),pointer :: iovar_dk_ptr + integer :: dim_kinds_index ! Pointers (only one of these is allocated per variable) real(r8), pointer :: r81d(:) real(r8), pointer :: r82d(:,:) @@ -32,15 +32,16 @@ module FatesHistoryVariableType integer, pointer :: int3d(:,:,:) contains procedure, public :: Init => InitHistoryVariableType - procedure, public :: Flush => FlushVar + procedure, public :: Flush procedure, private :: GetBounds end type fates_history_variable_type contains subroutine InitHistoryVariableType(this, vname, units, long, use_default, & - vtype, avgflag, flushval, upfreq, n_iovar_dk, iovar_dk) + vtype, avgflag, flushval, upfreq, n_dim_kinds, dim_kinds, dim_bounds) + use FatesHistoryDimensionMod, only : fates_history_dimension_type use FatesHistoryDimensionMod, only : patch_r8, patch_ground_r8, patch_class_pft_r8, & site_r8, site_ground_r8, site_class_pft_r8 @@ -55,10 +56,11 @@ subroutine InitHistoryVariableType(this, vname, units, long, use_default, & character(len=*), intent(in) :: avgflag real(r8), intent(in) :: flushval ! If the type is an int we will round with nint integer, intent(in) :: upfreq - integer, intent(in) :: n_iovar_dk - type(fates_history_variable_kind_type), intent(in), target :: iovar_dk(:) + integer, intent(in) :: n_dim_kinds + type(fates_history_dimension_type), intent(in) :: dim_bounds(:) + type(fates_history_variable_kind_type), intent(inout) :: dim_kinds(:) - integer :: ityp + integer :: dk_index integer :: lb1, ub1, lb2, ub2 this%vname = vname @@ -77,11 +79,11 @@ subroutine InitHistoryVariableType(this, vname, units, long, use_default, & nullify(this%int2d) nullify(this%int3d) - ityp = iotype_index(trim(vtype), n_iovar_dk, iovar_dk) - this%iovar_dk_ptr => iovar_dk(ityp) - this%iovar_dk_ptr%active = .true. + dk_index = iotype_index(trim(vtype), n_dim_kinds, dim_kinds) + this%dim_kinds_index = dk_index + call dim_kinds(dk_index)%set_active() - call this%GetBounds(0, lb1, ub1, lb2, ub2) + call this%GetBounds(0, dim_bounds, dim_kinds, lb1, ub1, lb2, ub2) ! NOTE(rgk, 2016-09) currently, all array spaces are flushed each ! time the update is called. The flush here on the initialization @@ -125,12 +127,16 @@ end subroutine InitHistoryVariableType ! ===================================================================================== - subroutine GetBounds(this, thread, lb1, ub1, lb2, ub2) + subroutine GetBounds(this, thread, dim_bounds, dim_kinds, lb1, ub1, lb2, ub2) - class(fates_history_variable_type), intent(inout) :: this + use FatesHistoryDimensionMod, only : fates_history_dimension_type - integer, intent(in) :: thread + implicit none + class(fates_history_variable_type), intent(inout) :: this + integer, intent(in) :: thread + class(fates_history_dimension_type), intent(in) :: dim_bounds(:) + type(fates_history_variable_kind_type), intent(in) :: dim_kinds(:) integer, intent(out) :: lb1 integer, intent(out) :: ub1 integer, intent(out) :: lb2 @@ -138,35 +144,41 @@ subroutine GetBounds(this, thread, lb1, ub1, lb2, ub2) ! local integer :: ndims + integer :: d_index lb1 = 0 ub1 = 0 lb2 = 0 ub2 = 0 - ndims = this%iovar_dk_ptr%ndims + ndims = dim_kinds(this%dim_kinds_index)%ndims ! The thread = 0 case is the boundaries for the whole proc/node if (thread==0) then - lb1 = this%iovar_dk_ptr%dim1_ptr%lower_bound - ub1 = this%iovar_dk_ptr%dim1_ptr%upper_bound + d_index = dim_kinds(this%dim_kinds_index)%dim1_index + lb1 = dim_bounds(d_index)%lower_bound + ub1 = dim_bounds(d_index)%upper_bound if(ndims>1)then - lb2 = this%iovar_dk_ptr%dim2_ptr%lower_bound - ub2 = this%iovar_dk_ptr%dim2_ptr%upper_bound + d_index = dim_kinds(this%dim_kinds_index)%dim2_index + lb2 = dim_bounds(d_index)%lower_bound + ub2 = dim_bounds(d_index)%upper_bound end if else - lb1 = this%iovar_dk_ptr%dim1_ptr%clump_lower_bound(thread) - ub1 = this%iovar_dk_ptr%dim1_ptr%clump_upper_bound(thread) + d_index = dim_kinds(this%dim_kinds_index)%dim1_index + lb1 = dim_bounds(d_index)%clump_lower_bound(thread) + ub1 = dim_bounds(d_index)%clump_upper_bound(thread) if(ndims>1)then - lb2 = this%iovar_dk_ptr%dim2_ptr%clump_lower_bound(thread) - ub2 = this%iovar_dk_ptr%dim2_ptr%clump_upper_bound(thread) + d_index = dim_kinds(this%dim_kinds_index)%dim2_index + lb2 = dim_bounds(d_index)%clump_lower_bound(thread) + ub2 = dim_bounds(d_index)%clump_upper_bound(thread) end if end if end subroutine GetBounds - subroutine FlushVar(this, thread) + subroutine Flush(this, thread, dim_bounds, dim_kinds) + use FatesHistoryDimensionMod, only : fates_history_dimension_type use FatesHistoryDimensionMod, only : patch_r8, patch_ground_r8, patch_class_pft_r8, & site_r8, site_ground_r8, site_class_pft_r8, patch_int @@ -174,12 +186,14 @@ subroutine FlushVar(this, thread) class(fates_history_variable_type), intent(inout) :: this integer, intent(in) :: thread + type(fates_history_dimension_type), intent(in) :: dim_bounds(:) + type(fates_history_variable_kind_type), intent(in) :: dim_kinds(:) integer :: lb1, ub1, lb2, ub2 - call this%GetBounds(thread, lb1, ub1, lb2, ub2) + call this%GetBounds(thread, dim_bounds, dim_kinds, lb1, ub1, lb2, ub2) - select case(trim(this%iovar_dk_ptr%name)) + select case(trim(dim_kinds(this%dim_kinds_index)%name)) case(patch_r8) this%r81d(lb1:ub1) = this%flushval case(site_r8) @@ -200,22 +214,22 @@ subroutine FlushVar(this, thread) !end_run end select - end subroutine FlushVar + end subroutine Flush ! ==================================================================================== - function iotype_index(iotype_name, n_iovar_dk, iovar_dk) result(ityp) + function iotype_index(iotype_name, n_dim_kinds, dim_kinds) result(dk_index) ! argument character(len=*), intent(in) :: iotype_name - integer, intent(in) :: n_iovar_dk - type(fates_history_variable_kind_type), intent(in) :: iovar_dk(:) + integer, intent(in) :: n_dim_kinds + type(fates_history_variable_kind_type), intent(in) :: dim_kinds(:) ! local - integer :: ityp + integer :: dk_index - do ityp=1, n_iovar_dk - if(trim(iotype_name).eq.trim(iovar_dk(ityp)%name))then + do dk_index=1, n_dim_kinds + if (trim(iotype_name) .eq. trim(dim_kinds(dk_index)%name)) then return end if end do diff --git a/main/HistoryIOMod.F90 b/main/HistoryIOMod.F90 index cc1547a1..aed6e531 100644 --- a/main/HistoryIOMod.F90 +++ b/main/HistoryIOMod.F90 @@ -5,7 +5,7 @@ Module HistoryIOMod use FatesConstantsMod, only : fates_avg_flag_length, fates_short_string_length, fates_long_string_length use FatesGlobals , only : fates_log - use FatesHistoryDimensionMod, only : fates_history_dimension_type + use FatesHistoryDimensionMod, only : fates_history_dimension_type, fates_num_dimension_types use FatesHistoryVariableKindMod, only : fates_history_variable_kind_type use FatesHistoryVariableType, only : fates_history_variable_type @@ -129,7 +129,7 @@ Module HistoryIOMod ! The number of variable dim/kind types we have defined (static) - integer, parameter :: n_iovar_dk = 6 + integer, parameter :: n_dim_kinds = 6 type, public :: fates_bounds_type integer :: patch_begin @@ -162,29 +162,17 @@ Module HistoryIOMod ! Instanteat one registry of the different dimension/kinds (dk) ! All output variables will have a pointer to one of these dk's - type(fates_history_variable_kind_type), pointer :: iovar_dk(:) + type(fates_history_variable_kind_type) :: dim_kinds(n_dim_kinds) ! This is a structure that explains where FATES patch boundaries - ! on each thread point to in the host IO array, this structure - ! is allocated by number of threads - type(fates_history_dimension_type) :: iopa_dim + ! on each thread point to in the host IO array, this structure is + ! allocated by number of threads. This could be dynamically + ! allocated, but is unlikely to change...? + type(fates_history_dimension_type) :: dim_bounds(fates_num_dimension_types) - ! This is a structure that explains where FATES patch boundaries - ! on each thread point to in the host IO array, this structure - ! is allocated by number of threads - type(fates_history_dimension_type) :: iosi_dim - - ! This is a structure that contains the boundaries for the - ! ground level (includes rock) dimension - type(fates_history_dimension_type) :: iogrnd_dim - - ! This is a structure that contains the boundaries for the - ! number of size-class x pft dimension - type(fates_history_dimension_type) :: ioscpf_dim - - type(iovar_map_type), pointer :: iovar_map(:) - + + integer, private :: patch_index_, column_index_, levgrnd_index_, levscpf_index_ contains procedure, public :: Init => InitFatesHistoryOutput @@ -195,9 +183,17 @@ Module HistoryIOMod procedure, public :: update_history_cbal procedure, public :: define_history_vars procedure, public :: set_history_var - procedure, public :: init_iovar_dk_maps - procedure, public :: set_dim_ptrs + procedure, public :: init_dim_kinds_maps + procedure, public :: set_dim_indicies procedure, private :: flush_hvars + procedure, public :: patch_index + procedure, public :: column_index + procedure, public :: levgrnd_index + procedure, public :: levscpf_index + procedure, private :: set_patch_index + procedure, private :: set_column_index + procedure, private :: set_levgrnd_index + procedure, private :: set_levscpf_index end type fates_hio_interface_type @@ -209,17 +205,37 @@ Module HistoryIOMod subroutine InitFatesHistoryOutput(this, num_threads, fates_bounds) + use FatesHistoryDimensionMod, only : patch, column, levgrnd, levscpf + implicit none class(fates_hio_interface_type), intent(inout) :: this integer, intent(in) :: num_threads type(fates_bounds_type), intent(in) :: fates_bounds - - call this%iopa_dim%Init('patch', num_threads, fates_bounds%patch_begin, fates_bounds%patch_end) - call this%iosi_dim%Init('column', num_threads, fates_bounds%column_begin, fates_bounds%column_end) - call this%iogrnd_dim%Init('levgrnd', num_threads, fates_bounds%ground_begin, fates_bounds%ground_end) - call this%ioscpf_dim%Init('levscpf', num_threads, fates_bounds%pft_class_begin, fates_bounds%pft_class_end) - + + integer :: dim_count = 0 + + dim_count = dim_count + 1 + call this%set_patch_index(dim_count) + call this%dim_bounds(dim_count)%Init(patch, num_threads, & + fates_bounds%patch_begin, fates_bounds%patch_end) + + dim_count = dim_count + 1 + call this%set_column_index(dim_count) + call this%dim_bounds(dim_count)%Init(column, num_threads, & + fates_bounds%column_begin, fates_bounds%column_end) + + dim_count = dim_count + 1 + call this%set_levgrnd_index(dim_count) + call this%dim_bounds(dim_count)%Init(levgrnd, num_threads, & + fates_bounds%ground_begin, fates_bounds%ground_end) + + dim_count = dim_count + 1 + call this%set_levscpf_index(dim_count) + call this%dim_bounds(dim_count)%Init(levscpf, num_threads, & + fates_bounds%pft_class_begin, fates_bounds%pft_class_end) + ! FIXME(bja, 2016-10) assert(dim_count == FatesHistorydimensionmod::num_dimension_types) + ! Allocate the mapping between FATES indices and the IO indices allocate(this%iovar_map(num_threads)) @@ -234,22 +250,253 @@ subroutine SetHistoryThreadBounds(this, thread_index, thread_bounds) integer, intent(in) :: thread_index type(fates_bounds_type), intent(in) :: thread_bounds + + integer :: index - call this%iopa_dim%SetThreadBounds(thread_index, & + index = this%patch_index() + call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%patch_begin, thread_bounds%patch_end) - call this%iosi_dim%SetThreadBounds(thread_index, & + index = this%column_index() + call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%column_begin, thread_bounds%column_end) - call this%iogrnd_dim%SetThreadBounds(thread_index, & + index = this%levgrnd_index() + call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%ground_begin, thread_bounds%ground_end) - call this%ioscpf_dim%SetThreadBounds(thread_index, & + index = this%levscpf_index() + call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%pft_class_begin, thread_bounds%pft_class_end) end subroutine SetHistoryThreadBounds - ! ======================================================================= + ! =================================================================================== + + subroutine set_dim_indicies(this, dk_name, idim, dim_index) + + use FatesHistoryVariableType, only : iotype_index + + implicit none + + ! arguments + class(fates_hio_interface_type), intent(inout) :: this + character(len=*), intent(in) :: dk_name + integer, intent(in) :: idim ! dimension index + integer, intent(in) :: dim_index + + + ! local + integer :: ityp + + ityp = iotype_index(trim(dk_name), n_dim_kinds, this%dim_kinds) + + ! First check to see if the dimension is allocated + if (this%dim_kinds(ityp)%ndims < idim) then + write(fates_log(), *) 'Trying to define dimension size to a dim-type structure' + write(fates_log(), *) 'but the dimension index does not exist' + write(fates_log(), *) 'type: ',dk_name,' ndims: ',this%dim_kinds(ityp)%ndims,' input dim:',idim + stop + !end_run + end if + + if (idim == 1) then + this%dim_kinds(ityp)%dim1_index = dim_index + else if (idim == 2) then + this%dim_kinds(ityp)%dim2_index = dim_index + end if + + ! With the map, we can set the dimension size + this%dim_kinds(ityp)%dimsize(idim) = this%dim_bounds(dim_index)%upper_bound - & + this%dim_bounds(dim_index)%lower_bound + 1 + + end subroutine set_dim_indicies + + ! ======================================================================= + subroutine set_patch_index(this, index) + implicit none + class(fates_hio_interface_type), intent(inout) :: this + integer, intent(in) :: index + this%patch_index_ = index + end subroutine set_patch_index + + integer function patch_index(this) + implicit none + class(fates_hio_interface_type), intent(in) :: this + patch_index = this%patch_index_ + end function patch_index + + ! ======================================================================= + subroutine set_column_index(this, index) + implicit none + class(fates_hio_interface_type), intent(inout) :: this + integer, intent(in) :: index + this%column_index_ = index + end subroutine set_column_index + + integer function column_index(this) + implicit none + class(fates_hio_interface_type), intent(in) :: this + column_index = this%column_index_ + end function column_index + + ! ======================================================================= + subroutine set_levgrnd_index(this, index) + implicit none + class(fates_hio_interface_type), intent(inout) :: this + integer, intent(in) :: index + this%levgrnd_index_ = index + end subroutine set_levgrnd_index + + integer function levgrnd_index(this) + implicit none + class(fates_hio_interface_type), intent(in) :: this + levgrnd_index = this%levgrnd_index_ + end function levgrnd_index + + ! ======================================================================= + subroutine set_levscpf_index(this, index) + implicit none + class(fates_hio_interface_type), intent(inout) :: this + integer, intent(in) :: index + this%levscpf_index_ = index + end subroutine set_levscpf_index + + integer function levscpf_index(this) + implicit none + class(fates_hio_interface_type), intent(in) :: this + levscpf_index = this%levscpf_index_ + end function levscpf_index + + ! ====================================================================================== + + subroutine flush_hvars(this,nc,upfreq_in) + + class(fates_hio_interface_type) :: this + integer,intent(in) :: nc + integer,intent(in) :: upfreq_in + + integer :: ivar + type(fates_history_variable_type),pointer :: hvar + integer :: lb1,ub1,lb2,ub2 + + do ivar=1,ubound(this%hvars,1) + hvar => this%hvars(ivar) + if (hvar%upfreq == upfreq_in) then ! Only flush variables with update on dynamics step + call hvar%Flush(nc, this%dim_bounds, this%dim_kinds) + end if + end do + + end subroutine flush_hvars + + + ! ===================================================================================== + + subroutine set_history_var(this, vname, units, long, use_default, avgflag, vtype, & + hlms, flushval, upfreq, ivar, callstep, index) + + use FatesUtilsMod, only : check_hlm_list + use EDTypesMod, only : cp_hlm_name + + implicit none + + ! arguments + class(fates_hio_interface_type), intent(inout) :: this + character(len=*), intent(in) :: vname + character(len=*), intent(in) :: units + character(len=*), intent(in) :: long + character(len=*), intent(in) :: use_default + character(len=*), intent(in) :: avgflag + character(len=*), intent(in) :: vtype + character(len=*), intent(in) :: hlms + real(r8), intent(in) :: flushval ! IF THE TYPE IS AN INT WE WILL round with NINT + integer, intent(in) :: upfreq + character(len=*), intent(in) :: callstep + integer, intent(inout) :: ivar + integer, intent(inout) :: index ! This is the index for the variable of + ! interest that is associated with an + ! explict name (for fast reference during update) + ! A zero is passed back when the variable is + ! not used + + ! locals + type(fates_history_variable_type), pointer :: hvar + integer :: ub1, lb1, ub2, lb2 ! Bounds for allocating the var + integer :: ityp + + logical :: write_var + + write_var = check_hlm_list(trim(hlms), trim(cp_hlm_name)) + if( write_var ) then + ivar = ivar+1 + index = ivar + + if (trim(callstep) .eq. 'initialize') then + call this%hvars(ivar)%Init(vname, units, long, use_default, & + vtype, avgflag, flushval, upfreq, n_dim_kinds, this%dim_kinds, & + this%dim_bounds) + end if + else + index = 0 + end if + + return + end subroutine set_history_var + + ! ==================================================================================== + + subroutine init_dim_kinds_maps(this) + + ! ---------------------------------------------------------------------------------- + ! This subroutine simply initializes the structures that define the different + ! array and type formats for different IO variables + ! + ! PA_R8 : 1D patch scale 8-byte reals + ! SI_R8 : 1D site scale 8-byte reals + ! + ! The allocation on the structures is not dynamic and should only add up to the + ! number of entries listed here. + ! + ! ---------------------------------------------------------------------------------- + use FatesHistoryDimensionMod, only : patch_r8, patch_ground_r8, patch_class_pft_r8, & + site_r8, site_ground_r8, site_class_pft_r8 + + implicit none + + ! Arguments + class(fates_hio_interface_type), intent(inout) :: this + + + integer :: index + + ! 1d Patch + index = 1 + call this%dim_kinds(index)%Init(patch_r8, 1) + + ! 1d Site + index = index + 1 + call this%dim_kinds(index)%Init(site_r8, 1) + + ! patch x ground + index = index + 1 + call this%dim_kinds(index)%Init(patch_ground_r8, 2) + + ! patch x size-class/pft + index = index + 1 + call this%dim_kinds(index)%Init(patch_class_pft_r8, 2) + + ! site x ground + index = index + 1 + call this%dim_kinds(index)%Init(site_ground_r8, 2) + + ! site x size-class/pft + index = index + 1 + call this%dim_kinds(index)%Init(site_class_pft_r8, 2) + + ! FIXME(bja, 2016-10) assert(index == n_dim_kinds) + end subroutine init_dim_kinds_maps + + ! ======================================================================= subroutine update_history_cbal(this,nc,nsites,sites) use EDtypesMod , only : ed_site_type @@ -730,28 +977,7 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) end subroutine update_history_prod - ! ====================================================================================== - - subroutine flush_hvars(this,nc,upfreq_in) - - class(fates_hio_interface_type) :: this - integer,intent(in) :: nc - integer,intent(in) :: upfreq_in - - integer :: ivar - type(fates_history_variable_type),pointer :: hvar - integer :: lb1,ub1,lb2,ub2 - - do ivar=1,ubound(this%hvars,1) - hvar => this%hvars(ivar) - if (hvar%upfreq == upfreq_in) then ! Only flush variables with update on dynamics step - call hvar%Flush(nc) - end if - end do - - end subroutine flush_hvars - - ! ==================================================================================== + ! ==================================================================================== subroutine define_history_vars(this,callstep,nvar) @@ -781,11 +1007,15 @@ subroutine define_history_vars(this,callstep,nvar) ! If your HLM makes use of, and you want, INTEGER OUTPUT, pass the flushval as ! a real. The applied flush value will use the NINT() intrinsic function ! --------------------------------------------------------------------------------- + + use FatesHistoryDimensionMod, only : patch_r8, patch_ground_r8, patch_class_pft_r8, & + site_r8, site_ground_r8, site_class_pft_r8 + implicit none - class(fates_hio_interface_type) :: this - character(len=*),intent(in) :: callstep ! are we 'count'ing or 'initializ'ing? - integer,optional,intent(out) :: nvar - integer :: ivar + class(fates_hio_interface_type), intent(inout) :: this + character(len=*), intent(in) :: callstep ! are we 'count'ing or 'initializ'ing? + integer, optional, intent(out) :: nvar + integer :: ivar if(.not. (trim(callstep).eq.'count' .or. trim(callstep).eq.'initialize') ) then write(fates_log(),*) 'defining history variables in FATES requires callstep count or initialize' @@ -795,361 +1025,361 @@ subroutine define_history_vars(this,callstep,nvar) ivar=0 ! Site level counting variables - call this%set_history_var(vname='ED_NPATCHES',units='none', & + call this%set_history_var(vname='ED_NPATCHES', units='none', & long='Total number of ED patches per site', use_default='active', & - avgflag='A',vtype='SI_R8',hlms='CLM:ALM',flushval=1.0_r8, upfreq=1, & - ivar=ivar, callstep=callstep,index = ih_npatches_si) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=1.0_r8, upfreq=1, & + ivar=ivar, callstep=callstep, index = ih_npatches_si) - call this%set_history_var(vname='ED_NCOHORTS',units='none', & + call this%set_history_var(vname='ED_NCOHORTS', units='none', & long='Total number of ED cohorts per site', use_default='active', & - avgflag='A',vtype='SI_R8',hlms='CLM:ALM',flushval=1.0_r8, upfreq=1, & - ivar=ivar, callstep=callstep,index = ih_ncohorts_si) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=1.0_r8, upfreq=1, & + ivar=ivar, callstep=callstep, index = ih_ncohorts_si) ! Patch variables - call this%set_history_var(vname='TRIMMING',units='none', & + call this%set_history_var(vname='TRIMMING', units='none', & long='Degree to which canopy expansion is limited by leaf economics', & use_default='active', & - avgflag='A',vtype='PA_R8',hlms='CLM:ALM',flushval=1.0_r8, upfreq=1, & - ivar=ivar, callstep=callstep,index = ih_trimming_pa) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=1.0_r8, upfreq=1, & + ivar=ivar, callstep=callstep, index = ih_trimming_pa) - call this%set_history_var(vname='AREA_PLANT',units='m2', & + call this%set_history_var(vname='AREA_PLANT', units='m2', & long='area occupied by all plants', use_default='active', & - avgflag='A',vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar, callstep=callstep,index = ih_area_plant_pa) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, callstep=callstep, index = ih_area_plant_pa) - call this%set_history_var(vname='AREA_TREES',units='m2', & + call this%set_history_var(vname='AREA_TREES', units='m2', & long='area occupied by woody plants', use_default='active', & - avgflag='A',vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar, callstep=callstep,index = ih_area_treespread_pa) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, callstep=callstep, index = ih_area_treespread_pa) - call this%set_history_var(vname='CANOPY_SPREAD',units='0-1', & + call this%set_history_var(vname='CANOPY_SPREAD', units='0-1', & long='Scaling factor between tree basal area and canopy area', & use_default='active', & - avgflag='A',vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar, callstep=callstep,index = ih_canopy_spread_pa) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, callstep=callstep, index = ih_canopy_spread_pa) - call this%set_history_var(vname='PFTbiomass',units='gC/m2', & + call this%set_history_var(vname='PFTbiomass', units='gC/m2', & long='total PFT level biomass', use_default='active', & - avgflag='A', vtype='PA_GRND_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & + avgflag='A', vtype=patch_ground_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, callstep=callstep, index = ih_biomass_pa_pft ) call this%set_history_var(vname='PFTleafbiomass', units='gC/m2', & long='total PFT level leaf biomass', use_default='active', & - avgflag='A', vtype='PA_GRND_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & + avgflag='A', vtype=patch_ground_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, callstep=callstep, index = ih_leafbiomass_pa_pft ) call this%set_history_var(vname='PFTstorebiomass', units='gC/m2', & long='total PFT level stored biomass', use_default='active', & - avgflag='A', vtype='PA_GRND_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & + avgflag='A', vtype=patch_ground_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, callstep=callstep, index = ih_storebiomass_pa_pft ) call this%set_history_var(vname='PFTnindivs', units='indiv / m2', & long='total PFT level number of individuals', use_default='active', & - avgflag='A', vtype='PA_GRND_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & + avgflag='A', vtype=patch_ground_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, callstep=callstep, index = ih_nindivs_pa_pft ) ! Fire Variables call this%set_history_var(vname='FIRE_NESTEROV_INDEX', units='none', & long='nesterov_fire_danger index', use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar,callstep=callstep, index = ih_nesterov_fire_danger_pa) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, callstep=callstep, index = ih_nesterov_fire_danger_pa) call this%set_history_var(vname='FIRE_ROS', units='m/min', & long='fire rate of spread m/min', use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar,callstep=callstep, index = ih_spitfire_ROS_pa) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, callstep=callstep, index = ih_spitfire_ROS_pa) call this%set_history_var(vname='EFFECT_WSPEED', units='none', & long ='effective windspeed for fire spread', use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar,callstep=callstep, index = ih_effect_wspeed_pa ) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, callstep=callstep, index = ih_effect_wspeed_pa ) call this%set_history_var(vname='FIRE_TFC_ROS', units='none', & long ='total fuel consumed', use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar,callstep=callstep, index = ih_TFC_ROS_pa ) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, callstep=callstep, index = ih_TFC_ROS_pa ) call this%set_history_var(vname='FIRE_INTENSITY', units='kJ/m/s', & long='spitfire fire intensity: kJ/m/s', use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar,callstep=callstep, index = ih_fire_intensity_pa ) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, callstep=callstep, index = ih_fire_intensity_pa ) call this%set_history_var(vname='FIRE_AREA', units='fraction', & long='spitfire fire area:m2', use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar,callstep=callstep, index = ih_fire_area_pa ) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, callstep=callstep, index = ih_fire_area_pa ) call this%set_history_var(vname='SCORCH_HEIGHT', units='m', & long='spitfire fire area:m2', use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar,callstep=callstep, index = ih_scorch_height_pa ) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, callstep=callstep, index = ih_scorch_height_pa ) call this%set_history_var(vname='fire_fuel_mef', units='m', & long='spitfire fuel moisture', use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar,callstep=callstep, index = ih_fire_fuel_mef_pa ) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, callstep=callstep, index = ih_fire_fuel_mef_pa ) call this%set_history_var(vname='fire_fuel_bulkd', units='m', & long='spitfire fuel bulk density', use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar,callstep=callstep, index = ih_fire_fuel_bulkd_pa ) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, callstep=callstep, index = ih_fire_fuel_bulkd_pa ) call this%set_history_var(vname='FIRE_FUEL_EFF_MOIST', units='m', & long='spitfire fuel moisture', use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar,callstep=callstep, index = ih_fire_fuel_eff_moist_pa ) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, callstep=callstep, index = ih_fire_fuel_eff_moist_pa ) call this%set_history_var(vname='fire_fuel_sav', units='m', & long='spitfire fuel surface/volume ', use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar,callstep=callstep, index = ih_fire_fuel_sav_pa ) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, callstep=callstep, index = ih_fire_fuel_sav_pa ) call this%set_history_var(vname='SUM_FUEL', units='gC m-2', & long='total ground fuel related to ros (omits 1000hr fuels)', & use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar,callstep=callstep, index = ih_sum_fuel_pa ) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, callstep=callstep, index = ih_sum_fuel_pa ) ! Litter Variables call this%set_history_var(vname='LITTER_IN', units='gC m-2 s-1', & long='Litter flux in leaves', use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar,callstep=callstep, index = ih_litter_in_pa ) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, callstep=callstep, index = ih_litter_in_pa ) call this%set_history_var(vname='LITTER_OUT', units='gC m-2 s-1', & long='Litter flux out leaves', use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar,callstep=callstep, index = ih_litter_out_pa ) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, callstep=callstep, index = ih_litter_out_pa ) call this%set_history_var(vname='SEED_BANK', units='gC m-2', & long='Total Seed Mass of all PFTs', use_default='active', & - avgflag='A', vtype='SI_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar,callstep=callstep, index = ih_seed_bank_si ) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, callstep=callstep, index = ih_seed_bank_si ) call this%set_history_var(vname='SEEDS_IN', units='gC m-2 s-1', & long='Seed Production Rate', use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar,callstep=callstep, index = ih_seeds_in_pa ) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, callstep=callstep, index = ih_seeds_in_pa ) call this%set_history_var(vname='SEED_GERMINATION', units='gC m-2 s-1', & long='Seed mass converted into new cohorts', use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar,callstep=callstep, index = ih_seed_germination_pa ) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, callstep=callstep, index = ih_seed_germination_pa ) call this%set_history_var(vname='SEED_DECAY', units='gC m-2 s-1', & long='Seed mass decay', use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar,callstep=callstep, index = ih_seed_decay_pa ) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, callstep=callstep, index = ih_seed_decay_pa ) call this%set_history_var(vname='ED_bstore', units='gC m-2', & long='Storage biomass', use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar,callstep=callstep, index = ih_bstore_pa ) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, callstep=callstep, index = ih_bstore_pa ) call this%set_history_var(vname='ED_bdead', units='gC m-2', & long='Dead (structural) biomass (live trees, not CWD)', & use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar,callstep=callstep, index = ih_bdead_pa ) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, callstep=callstep, index = ih_bdead_pa ) call this%set_history_var(vname='ED_balive', units='gC m-2', & long='Live biomass', use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar,callstep=callstep, index = ih_balive_pa ) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, callstep=callstep, index = ih_balive_pa ) call this%set_history_var(vname='ED_bleaf', units='gC m-2', & long='Leaf biomass', use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar,callstep=callstep, index = ih_bleaf_pa ) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, callstep=callstep, index = ih_bleaf_pa ) call this%set_history_var(vname='ED_biomass', units='gC m-2', & long='Total biomass', use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar,callstep=callstep, index = ih_btotal_pa ) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, callstep=callstep, index = ih_btotal_pa ) ! Ecosystem Carbon Fluxes (updated rapidly, upfreq=2) call this%set_history_var(vname='NPP_column', units='gC/m^2/s', & long='net primary production on the site', use_default='active', & - avgflag='A', vtype='SI_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=2, & - ivar=ivar,callstep=callstep, index = ih_npp_si ) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, callstep=callstep, index = ih_npp_si ) call this%set_history_var(vname='GPP', units='gC/m^2/s', & long='gross primary production', use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=2, & - ivar=ivar,callstep=callstep, index = ih_gpp_pa ) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, callstep=callstep, index = ih_gpp_pa ) call this%set_history_var(vname='NPP', units='gC/m^2/s', & long='net primary production', use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=2, & - ivar=ivar,callstep=callstep, index = ih_npp_pa ) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, callstep=callstep, index = ih_npp_pa ) call this%set_history_var(vname='AR', units='gC/m^2/s', & long='autotrophic respiration', use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=2, & - ivar=ivar,callstep=callstep, index = ih_aresp_pa ) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, callstep=callstep, index = ih_aresp_pa ) call this%set_history_var(vname='GROWTH_RESP', units='gC/m^2/s', & long='growth respiration', use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=2, & - ivar=ivar,callstep=callstep, index = ih_growth_resp_pa ) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, callstep=callstep, index = ih_growth_resp_pa ) call this%set_history_var(vname='MAINT_RESP', units='gC/m^2/s', & long='maintenance respiration', use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=2, & - ivar=ivar,callstep=callstep, index = ih_maint_resp_pa ) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, callstep=callstep, index = ih_maint_resp_pa ) ! Carbon Flux (grid dimension x scpf) (THESE ARE DEFAULT INACTIVE!!! ! (BECAUSE THEY TAKE UP SPACE!!! ! =================================================================================== - call this%set_history_var(vname='GPP_SCPF',units='kgC/m2/yr', & + call this%set_history_var(vname='GPP_SCPF', units='kgC/m2/yr', & long='gross primary production', use_default='inactive', & - avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & - upfreq=1, ivar=ivar,callstep=callstep, index = ih_gpp_si_scpf ) + avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, callstep=callstep, index = ih_gpp_si_scpf ) - call this%set_history_var(vname='NPP_SCPF',units='kgC/m2/yr', & + call this%set_history_var(vname='NPP_SCPF', units='kgC/m2/yr', & long='total net primary production', use_default='inactive', & - avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & - upfreq=1, ivar=ivar,callstep=callstep, index = ih_npp_totl_si_scpf ) + avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, callstep=callstep, index = ih_npp_totl_si_scpf ) - call this%set_history_var(vname='NPP_LEAF_SCPF',units='kgC/m2/yr', & + call this%set_history_var(vname='NPP_LEAF_SCPF', units='kgC/m2/yr', & long='NPP flux into leaves', use_default='inactive', & - avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & - upfreq=1, ivar=ivar,callstep=callstep, index = ih_npp_leaf_si_scpf ) + avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, callstep=callstep, index = ih_npp_leaf_si_scpf ) - call this%set_history_var(vname='NPP_SEED_SCPF',units='kgC/m2/yr', & + call this%set_history_var(vname='NPP_SEED_SCPF', units='kgC/m2/yr', & long='NPP flux into seeds', use_default='inactive', & - avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & - upfreq=1, ivar=ivar,callstep=callstep, index = ih_npp_seed_si_scpf ) + avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, callstep=callstep, index = ih_npp_seed_si_scpf ) - call this%set_history_var(vname='NPP_FNRT_SCPF',units='kgC/m2/yr', & + call this%set_history_var(vname='NPP_FNRT_SCPF', units='kgC/m2/yr', & long='NPP flux into fine roots', use_default='inactive', & - avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & - upfreq=1, ivar=ivar,callstep=callstep, index = ih_npp_fnrt_si_scpf ) + avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, callstep=callstep, index = ih_npp_fnrt_si_scpf ) - call this%set_history_var(vname='NPP_BGSW_SCPF',units='kgC/m2/yr', & + call this%set_history_var(vname='NPP_BGSW_SCPF', units='kgC/m2/yr', & long='NPP flux into below-ground sapwood', use_default='inactive', & - avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & - upfreq=1, ivar=ivar,callstep=callstep, index = ih_npp_bgsw_si_scpf ) + avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, callstep=callstep, index = ih_npp_bgsw_si_scpf ) - call this%set_history_var(vname='NPP_BGDW_SCPF',units='kgC/m2/yr', & - long='NPP flux into below-ground deadwood', use_default='inactive',& - avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & - upfreq=1, ivar=ivar,callstep=callstep, index = ih_npp_bgdw_si_scpf ) + call this%set_history_var(vname='NPP_BGDW_SCPF', units='kgC/m2/yr', & + long='NPP flux into below-ground deadwood', use_default='inactive', & + avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, callstep=callstep, index = ih_npp_bgdw_si_scpf ) - call this%set_history_var(vname='NPP_AGSW_SCPF',units='kgC/m2/yr', & + call this%set_history_var(vname='NPP_AGSW_SCPF', units='kgC/m2/yr', & long='NPP flux into above-ground sapwood', use_default='inactive', & - avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & - upfreq=1, ivar=ivar,callstep=callstep, index = ih_npp_agsw_si_scpf ) + avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, callstep=callstep, index = ih_npp_agsw_si_scpf ) call this%set_history_var(vname = 'NPP_AGDW_SCPF', units='kgC/m2/yr', & - long='NPP flux into above-ground deadwood', use_default='inactive',& - avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & - upfreq=1, ivar=ivar,callstep=callstep, index = ih_npp_agdw_si_scpf ) + long='NPP flux into above-ground deadwood', use_default='inactive', & + avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, callstep=callstep, index = ih_npp_agdw_si_scpf ) call this%set_history_var(vname = 'NPP_STOR_SCPF', units='kgC/m2/yr', & long='NPP flux into storage', use_default='inactive', & - avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & - upfreq=1, ivar=ivar,callstep=callstep, index = ih_npp_stor_si_scpf ) + avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, callstep=callstep, index = ih_npp_stor_si_scpf ) call this%set_history_var(vname='DDBH_SCPF', units = 'cm/yr/ha', & - long='diameter growth increment and pft/size',use_default='inactive',& - avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & - upfreq=1, ivar=ivar,callstep=callstep, index = ih_ddbh_si_scpf ) + long='diameter growth increment and pft/size',use_default='inactive', & + avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, callstep=callstep, index = ih_ddbh_si_scpf ) - call this%set_history_var(vname='BA_SCPF',units = 'm2/ha', & + call this%set_history_var(vname='BA_SCPF', units = 'm2/ha', & long='basal area by patch and pft/size', use_default='inactive', & - avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & - upfreq=1, ivar=ivar,callstep=callstep, index = ih_ba_si_scpf ) + avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, callstep=callstep, index = ih_ba_si_scpf ) - call this%set_history_var(vname='NPLANT_SCPF',units = 'N/ha', & + call this%set_history_var(vname='NPLANT_SCPF', units = 'N/ha', & long='stem number density by patch and pft/size', use_default='inactive', & - avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & - upfreq=1, ivar=ivar,callstep=callstep, index = ih_nplant_si_scpf ) + avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, callstep=callstep, index = ih_nplant_si_scpf ) - call this%set_history_var(vname='M1_SCPF',units = 'N/ha/yr', & - long='background mortality count by patch and pft/size', use_default='inactive',& - avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & - upfreq=1, ivar=ivar,callstep=callstep, index = ih_m1_si_scpf ) + call this%set_history_var(vname='M1_SCPF', units = 'N/ha/yr', & + long='background mortality count by patch and pft/size', use_default='inactive', & + avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, callstep=callstep, index = ih_m1_si_scpf ) - call this%set_history_var(vname='M2_SCPF',units = 'N/ha/yr', & - long='hydraulic mortality count by patch and pft/size',use_default='inactive',& - avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & - upfreq=1, ivar=ivar,callstep=callstep, index = ih_m2_si_scpf ) + call this%set_history_var(vname='M2_SCPF', units = 'N/ha/yr', & + long='hydraulic mortality count by patch and pft/size',use_default='inactive', & + avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, callstep=callstep, index = ih_m2_si_scpf ) - call this%set_history_var(vname='M3_SCPF',units = 'N/ha/yr', & - long='carbon starvation mortality count by patch and pft/size',use_default='inactive', & - avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & - upfreq=1, ivar=ivar,callstep=callstep, index = ih_m3_si_scpf ) + call this%set_history_var(vname='M3_SCPF', units = 'N/ha/yr', & + long='carbon starvation mortality count by patch and pft/size', use_default='inactive', & + avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, callstep=callstep, index = ih_m3_si_scpf ) - call this%set_history_var(vname='M4_SCPF',units = 'N/ha/yr', & - long='impact mortality count by patch and pft/size',use_default='inactive',& - avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & - upfreq=1, ivar=ivar,callstep=callstep, index = ih_m4_si_scpf ) + call this%set_history_var(vname='M4_SCPF', units = 'N/ha/yr', & + long='impact mortality count by patch and pft/size',use_default='inactive', & + avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, callstep=callstep, index = ih_m4_si_scpf ) - call this%set_history_var(vname='M5_SCPF',units = 'N/ha/yr', & - long='fire mortality count by patch and pft/size',use_default='inactive',& - avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & - upfreq=1, ivar=ivar,callstep=callstep, index = ih_m5_si_scpf ) + call this%set_history_var(vname='M5_SCPF', units = 'N/ha/yr', & + long='fire mortality count by patch and pft/size',use_default='inactive', & + avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, callstep=callstep, index = ih_m5_si_scpf ) ! CARBON BALANCE VARIABLES THAT DEPEND ON HLM BGC INPUTS call this%set_history_var(vname='NEP', units='gC/m^2/s', & long='net ecosystem production', use_default='active', & - avgflag='A', vtype='SI_R8',hlms='CLM:ALM',flushval=cp_hio_ignore_val, & - upfreq=3, ivar=ivar,callstep=callstep, index = ih_nep_si ) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & + upfreq=3, ivar=ivar, callstep=callstep, index = ih_nep_si ) call this%set_history_var(vname='Fire_Closs', units='gC/m^2/s', & long='ED/SPitfire Carbon loss to atmosphere', use_default='active', & - avgflag='A', vtype='SI_R8',hlms='CLM:ALM',flushval=cp_hio_ignore_val, & - upfreq=3, ivar=ivar,callstep=callstep, index = ih_fire_c_to_atm_si ) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & + upfreq=3, ivar=ivar, callstep=callstep, index = ih_fire_c_to_atm_si ) call this%set_history_var(vname='NBP', units='gC/m^2/s', & long='net biosphere production', use_default='active', & - avgflag='A', vtype='SI_R8',hlms='CLM:ALM',flushval=cp_hio_ignore_val, & - upfreq=3, ivar=ivar,callstep=callstep, index = ih_nbp_si ) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & + upfreq=3, ivar=ivar, callstep=callstep, index = ih_nbp_si ) call this%set_history_var(vname='TOTECOSYSC', units='gC/m^2', & long='total ecosystem carbon', use_default='active', & - avgflag='A', vtype='SI_R8',hlms='CLM:ALM',flushval=cp_hio_ignore_val, & - upfreq=3, ivar=ivar,callstep=callstep, index = ih_totecosysc_si ) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & + upfreq=3, ivar=ivar, callstep=callstep, index = ih_totecosysc_si ) call this%set_history_var(vname='CBALANCE_ERROR_ED', units='gC/m^2/s', & long='total carbon balance error on ED side', use_default='active', & - avgflag='A', vtype='SI_R8',hlms='CLM:ALM',flushval=cp_hio_ignore_val, & - upfreq=3, ivar=ivar,callstep=callstep, index = ih_cbal_err_fates_si ) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & + upfreq=3, ivar=ivar, callstep=callstep, index = ih_cbal_err_fates_si ) call this%set_history_var(vname='CBALANCE_ERROR_BGC', units='gC/m^2/s', & long='total carbon balance error on HLMs BGC side', use_default='active', & - avgflag='A', vtype='SI_R8',hlms='CLM:ALM',flushval=cp_hio_ignore_val, & - upfreq=3, ivar=ivar,callstep=callstep, index = ih_cbal_err_bgc_si ) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & + upfreq=3, ivar=ivar, callstep=callstep, index = ih_cbal_err_bgc_si ) call this%set_history_var(vname='CBALANCE_ERROR_TOTAL', units='gC/m^2/s', & long='total carbon balance error total', use_default='active', & - avgflag='A', vtype='SI_R8',hlms='CLM:ALM',flushval=cp_hio_ignore_val, & - upfreq=3, ivar=ivar,callstep=callstep, index = ih_cbal_err_tot_si ) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & + upfreq=3, ivar=ivar, callstep=callstep, index = ih_cbal_err_tot_si ) call this%set_history_var(vname='BIOMASS_STOCK_COL', units='gC/m^2', & long='total ED biomass carbon at the column level', use_default='active', & - avgflag='A', vtype='SI_R8',hlms='CLM:ALM',flushval=cp_hio_ignore_val, & - upfreq=3, ivar=ivar,callstep=callstep, index = ih_biomass_stock_si ) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & + upfreq=3, ivar=ivar, callstep=callstep, index = ih_biomass_stock_si ) call this%set_history_var(vname='ED_LITTER_STOCK_COL', units='gC/m^2', & long='total ED litter carbon at the column level', use_default='active', & - avgflag='A', vtype='SI_R8',hlms='CLM:ALM',flushval=cp_hio_ignore_val, & - upfreq=3, ivar=ivar,callstep=callstep, index = ih_litter_stock_si ) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & + upfreq=3, ivar=ivar, callstep=callstep, index = ih_litter_stock_si ) call this%set_history_var(vname='CWD_STOCK_COL', units='gC/m^2', & long='total CWD carbon at the column level', use_default='active', & - avgflag='A', vtype='SI_R8',hlms='CLM:ALM',flushval=cp_hio_ignore_val, & - upfreq=3, ivar=ivar,callstep=callstep, index = ih_cwd_stock_si ) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & + upfreq=3, ivar=ivar, callstep=callstep, index = ih_cwd_stock_si ) ! Must be last thing before return @@ -1158,165 +1388,16 @@ subroutine define_history_vars(this,callstep,nvar) return end subroutine define_history_vars - - ! ===================================================================================== - - subroutine set_history_var(this,vname,units,long,use_default,avgflag,vtype,hlms, & - flushval,upfreq,ivar,callstep,index) - - use FatesUtilsMod, only : check_hlm_list - use EDTypesMod, only : cp_hlm_name - - ! arguments - class(fates_hio_interface_type) :: this - character(len=*), intent(in) :: vname - character(len=*), intent(in) :: units - character(len=*), intent(in) :: long - character(len=*), intent(in) :: use_default - character(len=*), intent(in) :: avgflag - character(len=*), intent(in) :: vtype - character(len=*), intent(in) :: hlms - real(r8), intent(in) :: flushval ! IF THE TYPE IS AN INT WE WILL round with NINT - integer, intent(in) :: upfreq - character(len=*), intent(in) :: callstep - integer, intent(inout) :: ivar - integer, intent(inout) :: index ! This is the index for the variable of - ! interest that is associated with an - ! explict name (for fast reference during update) - ! A zero is passed back when the variable is - ! not used - - ! locals - type(fates_history_variable_type), pointer :: hvar - integer :: ub1, lb1, ub2, lb2 ! Bounds for allocating the var - integer :: ityp - - logical :: write_var - - write_var = check_hlm_list(trim(hlms), trim(cp_hlm_name)) - if( write_var ) then - ivar = ivar+1 - index = ivar - - if (trim(callstep) .eq. 'initialize') then - call this%hvars(ivar)%Init(vname, units, long, use_default, & - vtype, avgflag, flushval, upfreq, n_iovar_dk, this%iovar_dk) - end if - else - index = 0 - end if - - return - end subroutine set_history_var - - ! ==================================================================================== - - subroutine init_iovar_dk_maps(this) - - ! ---------------------------------------------------------------------------------- - ! This subroutine simply initializes the structures that define the different - ! array and type formats for different IO variables - ! - ! PA_R8 : 1D patch scale 8-byte reals - ! SI_R8 : 1D site scale 8-byte reals - ! - ! The allocation on the structures is not dynamic and should only add up to the - ! number of entries listed here. - ! - ! ---------------------------------------------------------------------------------- - use FatesHistoryDimensionMod, only : patch_r8, patch_ground_r8, patch_class_pft_r8, & - site_r8, site_ground_r8, site_class_pft_r8 - - implicit none - - ! Arguments - class(fates_hio_interface_type) :: this - - ! Localsi - integer :: index - integer, parameter :: unset_int = -999 - - allocate(this%iovar_dk(n_iovar_dk)) - - ! 1d Patch - index = 1 - call this%iovar_dk(index)%Init(patch_r8, 1) - - ! 1d Site - index = index + 1 - call this%iovar_dk(index)%Init(site_r8, 1) - - ! patch x ground - index = index + 1 - call this%iovar_dk(index)%Init(patch_ground_r8, 2) - - ! patch x size-class/pft - index = index + 1 - call this%iovar_dk(index)%Init(patch_class_pft_r8, 2) - - ! site x ground - index = index + 1 - call this%iovar_dk(index)%Init(site_ground_r8, 2) - - ! site x size-class/pft - index = index + 1 - call this%iovar_dk(index)%Init(site_class_pft_r8, 2) - - ! FIXME(bja, 2016-10) assert(index == n_iovar_dk) - end subroutine init_iovar_dk_maps - - ! =================================================================================== - - subroutine set_dim_ptrs(this,dk_name,idim,dim_target) - - use FatesHistoryVariableType, only : iotype_index - - implicit none - - ! arguments - class(fates_hio_interface_type) :: this - character(len=*),intent(in) :: dk_name - integer,intent(in) :: idim ! dimension index - type(fates_history_dimension_type),target :: dim_target - - - ! local - integer :: ityp - - ityp = iotype_index(trim(dk_name), n_iovar_dk, this%iovar_dk) - - ! First check to see if the dimension is allocated - if(this%iovar_dk(ityp)%ndims dim_target - elseif(idim==2) then - this%iovar_dk(ityp)%dim2_ptr => dim_target - end if - - ! With the map, we can set the dimension size - this%iovar_dk(ityp)%dimsize(idim) = dim_target%upper_bound - dim_target%lower_bound + 1 - - - return - end subroutine set_dim_ptrs - ! ==================================================================================== ! DEPRECATED, TRANSITIONAL OR FUTURE CODE SECTION ! ==================================================================================== - !subroutine set_fates_hio_str(tag,iotype_name,iostr_val) + !subroutine set_fates_hio_str(tag,iotype_name, iostr_val) ! ! Arguments -! character(len=*),intent(in) :: tag -! character(len=*), optional,intent(in) :: iotype_name +! character(len=*), intent(in) :: tag +! character(len=*), optional, intent(in) :: iotype_name ! integer, optional, intent(in) :: iostr_val ! ! local variables @@ -1327,32 +1408,32 @@ end subroutine set_dim_ptrs ! select case (trim(tag)) ! case('flush_to_unset') -! write(*,*) '' -! write(*,*) 'Flushing FATES IO types prior to transfer from host' -! do ityp=1,ubound(iovar_str,1) +! write(*, *) '' +! write(*, *) 'Flushing FATES IO types prior to transfer from host' +! do ityp=1,ubound(iovar_str, 1) ! iovar_str(ityp)%dimsize = unset_int ! iovar_str(ityp)%active = .false. ! end do ! case('check_allset') -! do ityp=1,ubound(iovar_str,1) -! write(*,*) 'Checking to see if ',iovar_str(ityp)%name,' IO communicators were sent to FATES' +! do ityp=1,ubound(iovar_str, 1) +! write(*, *) 'Checking to see if ',iovar_str(ityp)%name, ' IO communicators were sent to FATES' ! if(iovar_str(ityp)%active)then ! if(iovar_str(ityp)%offset .eq. unset_int) then -! write(*,*) 'FATES offset information of IO type:',iovar_str(ityp)%name -! write(*,*) 'was never set' +! write(*, *) 'FATES offset information of IO type:', iovar_str(ityp)%name +! write(*, *) 'was never set' ! ! end_run('MESSAGE') ! end if -! do idim=1,iovar_str(ityp)%ndims +! do idim=1, iovar_str(ityp)%ndims ! if(iovar_str(ityp)%dimsize(idim) .eq. unset_int) then -! write(*,*) 'FATES dimension information of IO type:',iovar_str(ityp)%name -! write(*,*) 'was never set' +! write(*, *) 'FATES dimension information of IO type:', iovar_str(ityp)%name +! write(*, *) 'was never set' ! ! end_run('MESSAGE') ! end if ! end do ! end if ! end do -! write(*,*) 'Checked. All history IO specifications properly sent to FATES.' +! write(*, *) 'Checked. All history IO specifications properly sent to FATES.' ! case default ! ! Must have two arguments if this is not a check or flush @@ -1364,39 +1445,39 @@ end subroutine set_dim_ptrs ! case('offset') ! ityp=iotype_index(trim(iotype_name)) ! iovar_str(ityp)%offset = iostr_val -! write(*,*) 'Transfering offset for IOTYPE',iotype_name,' to FATES' +! write(*, *) 'Transfering offset for IOTYPE',iotype_name, ' to FATES' ! case('dimsize1') ! ityp=iotype_index(trim(iotype_name)) ! iovar_str(ityp)%dimsize(1) = iostr_val -! write(*,*) 'Transfering 1st dimension size for IOTYPE',iotype_name,' to FATES' +! write(*, *) 'Transfering 1st dimension size for IOTYPE',iotype_name, ' to FATES' ! case('dimsize2') ! ityp=iotype_index(trim(iotype_name)) -! if(ubound(iovar_str(ityp)%dimsize,1)==1)then -! write(fates_log(),*) 'Transfering second dimensional bound to unallocated space' -! write(fates_log(),*) 'type:',iotype_name +! if(ubound(iovar_str(ityp)%dimsize, 1)==1)then +! write(fates_log(), *) 'Transfering second dimensional bound to unallocated space' +! write(fates_log(), *) 'type:', iotype_name ! ! end_run ! end if ! iovar_str(ityp)%dimsize(2) = iostr_val -! write(*,*) 'Transfering 2nd dimension size for IOTYPE',iotype_name,' to FATES' +! write(*, *) 'Transfering 2nd dimension size for IOTYPE',iotype_name, ' to FATES' ! case('dimsize3') ! ityp=iotype_index(trim(iotype_name)) -! if(ubound(iovar_str(ityp)%dimsize,1)<3)then -! write(fates_log(),*) 'Transfering third dimensional bound to unallocated space' -! write(fates_log(),*) 'type:',iotype_name +! if(ubound(iovar_str(ityp)%dimsize, 1)<3)then +! write(fates_log(), *) 'Transfering third dimensional bound to unallocated space' +! write(fates_log(), *) 'type:', iotype_name ! ! end_run ! end if ! iovar_str(ityp)%dimsize(3) = iostr_val -! write(*,*) 'Transfering 3rd dimension size for IOTYPE',iotype_name,' to FATES' +! write(*, *) 'Transfering 3rd dimension size for IOTYPE',iotype_name, ' to FATES' ! case default -! write(*,*) 'IO parameter not recognized:',trim(tag) +! write(*, *) 'IO parameter not recognized:', trim(tag) ! ! end_run ! end select ! else -! write(*,*) 'no value was provided for the tag' +! write(*, *) 'no value was provided for the tag' ! end if ! ! end select From 3e1e40f60f293a4e3bca2f8f24bc98017959c18d Mon Sep 17 00:00:00 2001 From: Ben Andre Date: Thu, 20 Oct 2016 11:13:13 -0600 Subject: [PATCH 228/437] Refactor history output Move some history initialization details out of the clm fates interface and into the history module. Convert another pointer into an allocatable. Test: ERS_D_Ld5.f10_f10.ICLM45ED.yellowstone_intel.clm-edTest Test baseline: 44aac42 Test status: pass --- main/HistoryIOMod.F90 | 249 ++++++++++++++++++++++++++---------------- 1 file changed, 156 insertions(+), 93 deletions(-) diff --git a/main/HistoryIOMod.F90 b/main/HistoryIOMod.F90 index aed6e531..a4df876a 100644 --- a/main/HistoryIOMod.F90 +++ b/main/HistoryIOMod.F90 @@ -157,8 +157,8 @@ Module HistoryIOMod type, public :: fates_hio_interface_type ! Instance of the list of history output varialbes - type(fates_history_variable_type), pointer :: hvars(:) - integer :: n_hvars + type(fates_history_variable_type), allocatable :: hvars(:) + integer, private :: num_history_vars_ ! Instanteat one registry of the different dimension/kinds (dk) ! All output variables will have a pointer to one of these dk's @@ -177,19 +177,27 @@ Module HistoryIOMod procedure, public :: Init => InitFatesHistoryOutput procedure, public :: SetThreadBounds => SetHistoryThreadBounds - + procedure, public :: initialize_history_vars + procedure, public :: assemble_valid_output_types + procedure, public :: update_history_dyn procedure, public :: update_history_prod procedure, public :: update_history_cbal - procedure, public :: define_history_vars - procedure, public :: set_history_var - procedure, public :: init_dim_kinds_maps - procedure, public :: set_dim_indicies - procedure, private :: flush_hvars + + ! 'get' methods used by external callers to access private read only data + procedure, public :: num_history_vars procedure, public :: patch_index procedure, public :: column_index procedure, public :: levgrnd_index procedure, public :: levscpf_index + + ! private work functions + procedure, private :: define_history_vars + procedure, private :: set_history_var + procedure, private :: init_dim_kinds_maps + procedure, private :: set_dim_indicies + procedure, private :: flush_hvars + procedure, private :: set_patch_index procedure, private :: set_column_index procedure, private :: set_levgrnd_index @@ -271,6 +279,36 @@ subroutine SetHistoryThreadBounds(this, thread_index, thread_bounds) end subroutine SetHistoryThreadBounds + ! =================================================================================== + subroutine assemble_valid_output_types(this) + + use FatesHistoryDimensionMod, only : patch_r8, patch_ground_r8, patch_class_pft_r8, & + site_r8, site_ground_r8, site_class_pft_r8 + + implicit none + + class(fates_hio_interface_type), intent(inout) :: this + + call this%init_dim_kinds_maps() + + call this%set_dim_indicies(patch_r8, 1, this%patch_index()) + + call this%set_dim_indicies(site_r8, 1, this%column_index()) + + call this%set_dim_indicies(patch_ground_r8, 1, this%patch_index()) + call this%set_dim_indicies(patch_ground_r8, 2, this%levgrnd_index()) + + call this%set_dim_indicies(site_ground_r8, 1, this%column_index()) + call this%set_dim_indicies(site_ground_r8, 2, this%levgrnd_index()) + + call this%set_dim_indicies(patch_class_pft_r8, 1, this%patch_index()) + call this%set_dim_indicies(patch_class_pft_r8, 2, this%levscpf_index()) + + call this%set_dim_indicies(site_class_pft_r8, 1, this%column_index()) + call this%set_dim_indicies(site_class_pft_r8, 2, this%levscpf_index()) + + end subroutine assemble_valid_output_types + ! =================================================================================== subroutine set_dim_indicies(this, dk_name, idim, dim_index) @@ -381,10 +419,11 @@ subroutine flush_hvars(this,nc,upfreq_in) integer :: lb1,ub1,lb2,ub2 do ivar=1,ubound(this%hvars,1) - hvar => this%hvars(ivar) - if (hvar%upfreq == upfreq_in) then ! Only flush variables with update on dynamics step - call hvar%Flush(nc, this%dim_bounds, this%dim_kinds) - end if + associate( hvar => this%hvars(ivar) ) + if (hvar%upfreq == upfreq_in) then ! Only flush variables with update on dynamics step + call hvar%Flush(nc, this%dim_bounds, this%dim_kinds) + end if + end associate end do end subroutine flush_hvars @@ -393,7 +432,7 @@ end subroutine flush_hvars ! ===================================================================================== subroutine set_history_var(this, vname, units, long, use_default, avgflag, vtype, & - hlms, flushval, upfreq, ivar, callstep, index) + hlms, flushval, upfreq, ivar, initialize, index) use FatesUtilsMod, only : check_hlm_list use EDTypesMod, only : cp_hlm_name @@ -411,7 +450,7 @@ subroutine set_history_var(this, vname, units, long, use_default, avgflag, vtype character(len=*), intent(in) :: hlms real(r8), intent(in) :: flushval ! IF THE TYPE IS AN INT WE WILL round with NINT integer, intent(in) :: upfreq - character(len=*), intent(in) :: callstep + logical, intent(in) :: initialize integer, intent(inout) :: ivar integer, intent(inout) :: index ! This is the index for the variable of ! interest that is associated with an @@ -431,7 +470,7 @@ subroutine set_history_var(this, vname, units, long, use_default, avgflag, vtype ivar = ivar+1 index = ivar - if (trim(callstep) .eq. 'initialize') then + if (initialize) then call this%hvars(ivar)%Init(vname, units, long, use_default, & vtype, avgflag, flushval, upfreq, n_dim_kinds, this%dim_kinds, & this%dim_bounds) @@ -977,9 +1016,40 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) end subroutine update_history_prod + ! ==================================================================================== + integer function num_history_vars(this) + + implicit none + + class(fates_hio_interface_type), intent(in) :: this + + num_history_vars = this%num_history_vars_ + + end function num_history_vars + + ! ==================================================================================== + + subroutine initialize_history_vars(this) + + implicit none + + class(fates_hio_interface_type), intent(inout) :: this + + ! Determine how many of the history IO variables registered in FATES + ! are going to be allocated + call this%define_history_vars(initialize_variables=.false.) + + ! Allocate the list of history output variable objects + allocate(this%hvars(this%num_history_vars())) + + ! construct the object that defines all of the IO variables + call this%define_history_vars(initialize_variables=.true.) + + end subroutine initialize_history_vars + ! ==================================================================================== - subroutine define_history_vars(this,callstep,nvar) + subroutine define_history_vars(this, initialize_variables) ! --------------------------------------------------------------------------------- ! @@ -1013,191 +1083,186 @@ subroutine define_history_vars(this,callstep,nvar) implicit none class(fates_hio_interface_type), intent(inout) :: this - character(len=*), intent(in) :: callstep ! are we 'count'ing or 'initializ'ing? - integer, optional, intent(out) :: nvar + logical, intent(in) :: initialize_variables ! are we 'count'ing or 'initializ'ing? + integer :: ivar - if(.not. (trim(callstep).eq.'count' .or. trim(callstep).eq.'initialize') ) then - write(fates_log(),*) 'defining history variables in FATES requires callstep count or initialize' - ! end_run('MESSAGE') - end if - ivar=0 ! Site level counting variables call this%set_history_var(vname='ED_NPATCHES', units='none', & long='Total number of ED patches per site', use_default='active', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=1.0_r8, upfreq=1, & - ivar=ivar, callstep=callstep, index = ih_npatches_si) + ivar=ivar, initialize=initialize_variables, index = ih_npatches_si) call this%set_history_var(vname='ED_NCOHORTS', units='none', & long='Total number of ED cohorts per site', use_default='active', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=1.0_r8, upfreq=1, & - ivar=ivar, callstep=callstep, index = ih_ncohorts_si) + ivar=ivar, initialize=initialize_variables, index = ih_ncohorts_si) ! Patch variables call this%set_history_var(vname='TRIMMING', units='none', & long='Degree to which canopy expansion is limited by leaf economics', & use_default='active', & avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=1.0_r8, upfreq=1, & - ivar=ivar, callstep=callstep, index = ih_trimming_pa) + ivar=ivar, initialize=initialize_variables, index = ih_trimming_pa) call this%set_history_var(vname='AREA_PLANT', units='m2', & long='area occupied by all plants', use_default='active', & avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, callstep=callstep, index = ih_area_plant_pa) + ivar=ivar, initialize=initialize_variables, index = ih_area_plant_pa) call this%set_history_var(vname='AREA_TREES', units='m2', & long='area occupied by woody plants', use_default='active', & avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, callstep=callstep, index = ih_area_treespread_pa) + ivar=ivar, initialize=initialize_variables, index = ih_area_treespread_pa) call this%set_history_var(vname='CANOPY_SPREAD', units='0-1', & long='Scaling factor between tree basal area and canopy area', & use_default='active', & avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, callstep=callstep, index = ih_canopy_spread_pa) + ivar=ivar, initialize=initialize_variables, index = ih_canopy_spread_pa) call this%set_history_var(vname='PFTbiomass', units='gC/m2', & long='total PFT level biomass', use_default='active', & avgflag='A', vtype=patch_ground_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, callstep=callstep, index = ih_biomass_pa_pft ) + ivar=ivar, initialize=initialize_variables, index = ih_biomass_pa_pft ) call this%set_history_var(vname='PFTleafbiomass', units='gC/m2', & long='total PFT level leaf biomass', use_default='active', & avgflag='A', vtype=patch_ground_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, callstep=callstep, index = ih_leafbiomass_pa_pft ) + ivar=ivar, initialize=initialize_variables, index = ih_leafbiomass_pa_pft ) call this%set_history_var(vname='PFTstorebiomass', units='gC/m2', & long='total PFT level stored biomass', use_default='active', & avgflag='A', vtype=patch_ground_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, callstep=callstep, index = ih_storebiomass_pa_pft ) + ivar=ivar, initialize=initialize_variables, index = ih_storebiomass_pa_pft ) call this%set_history_var(vname='PFTnindivs', units='indiv / m2', & long='total PFT level number of individuals', use_default='active', & avgflag='A', vtype=patch_ground_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, callstep=callstep, index = ih_nindivs_pa_pft ) + ivar=ivar, initialize=initialize_variables, index = ih_nindivs_pa_pft ) ! Fire Variables call this%set_history_var(vname='FIRE_NESTEROV_INDEX', units='none', & long='nesterov_fire_danger index', use_default='active', & avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, callstep=callstep, index = ih_nesterov_fire_danger_pa) + ivar=ivar, initialize=initialize_variables, index = ih_nesterov_fire_danger_pa) call this%set_history_var(vname='FIRE_ROS', units='m/min', & long='fire rate of spread m/min', use_default='active', & avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, callstep=callstep, index = ih_spitfire_ROS_pa) + ivar=ivar, initialize=initialize_variables, index = ih_spitfire_ROS_pa) call this%set_history_var(vname='EFFECT_WSPEED', units='none', & long ='effective windspeed for fire spread', use_default='active', & avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, callstep=callstep, index = ih_effect_wspeed_pa ) + ivar=ivar, initialize=initialize_variables, index = ih_effect_wspeed_pa ) call this%set_history_var(vname='FIRE_TFC_ROS', units='none', & long ='total fuel consumed', use_default='active', & avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, callstep=callstep, index = ih_TFC_ROS_pa ) + ivar=ivar, initialize=initialize_variables, index = ih_TFC_ROS_pa ) call this%set_history_var(vname='FIRE_INTENSITY', units='kJ/m/s', & long='spitfire fire intensity: kJ/m/s', use_default='active', & avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, callstep=callstep, index = ih_fire_intensity_pa ) + ivar=ivar, initialize=initialize_variables, index = ih_fire_intensity_pa ) call this%set_history_var(vname='FIRE_AREA', units='fraction', & long='spitfire fire area:m2', use_default='active', & avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, callstep=callstep, index = ih_fire_area_pa ) + ivar=ivar, initialize=initialize_variables, index = ih_fire_area_pa ) call this%set_history_var(vname='SCORCH_HEIGHT', units='m', & long='spitfire fire area:m2', use_default='active', & avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, callstep=callstep, index = ih_scorch_height_pa ) + ivar=ivar, initialize=initialize_variables, index = ih_scorch_height_pa ) call this%set_history_var(vname='fire_fuel_mef', units='m', & long='spitfire fuel moisture', use_default='active', & avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, callstep=callstep, index = ih_fire_fuel_mef_pa ) + ivar=ivar, initialize=initialize_variables, index = ih_fire_fuel_mef_pa ) call this%set_history_var(vname='fire_fuel_bulkd', units='m', & long='spitfire fuel bulk density', use_default='active', & avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, callstep=callstep, index = ih_fire_fuel_bulkd_pa ) + ivar=ivar, initialize=initialize_variables, index = ih_fire_fuel_bulkd_pa ) call this%set_history_var(vname='FIRE_FUEL_EFF_MOIST', units='m', & long='spitfire fuel moisture', use_default='active', & avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, callstep=callstep, index = ih_fire_fuel_eff_moist_pa ) + ivar=ivar, initialize=initialize_variables, index = ih_fire_fuel_eff_moist_pa ) call this%set_history_var(vname='fire_fuel_sav', units='m', & long='spitfire fuel surface/volume ', use_default='active', & avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, callstep=callstep, index = ih_fire_fuel_sav_pa ) + ivar=ivar, initialize=initialize_variables, index = ih_fire_fuel_sav_pa ) call this%set_history_var(vname='SUM_FUEL', units='gC m-2', & long='total ground fuel related to ros (omits 1000hr fuels)', & use_default='active', & avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, callstep=callstep, index = ih_sum_fuel_pa ) + ivar=ivar, initialize=initialize_variables, index = ih_sum_fuel_pa ) ! Litter Variables call this%set_history_var(vname='LITTER_IN', units='gC m-2 s-1', & long='Litter flux in leaves', use_default='active', & avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, callstep=callstep, index = ih_litter_in_pa ) + ivar=ivar, initialize=initialize_variables, index = ih_litter_in_pa ) call this%set_history_var(vname='LITTER_OUT', units='gC m-2 s-1', & long='Litter flux out leaves', use_default='active', & avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, callstep=callstep, index = ih_litter_out_pa ) + ivar=ivar, initialize=initialize_variables, index = ih_litter_out_pa ) call this%set_history_var(vname='SEED_BANK', units='gC m-2', & long='Total Seed Mass of all PFTs', use_default='active', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, callstep=callstep, index = ih_seed_bank_si ) + ivar=ivar, initialize=initialize_variables, index = ih_seed_bank_si ) call this%set_history_var(vname='SEEDS_IN', units='gC m-2 s-1', & long='Seed Production Rate', use_default='active', & avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, callstep=callstep, index = ih_seeds_in_pa ) + ivar=ivar, initialize=initialize_variables, index = ih_seeds_in_pa ) call this%set_history_var(vname='SEED_GERMINATION', units='gC m-2 s-1', & long='Seed mass converted into new cohorts', use_default='active', & avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, callstep=callstep, index = ih_seed_germination_pa ) + ivar=ivar, initialize=initialize_variables, index = ih_seed_germination_pa ) call this%set_history_var(vname='SEED_DECAY', units='gC m-2 s-1', & long='Seed mass decay', use_default='active', & avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, callstep=callstep, index = ih_seed_decay_pa ) + ivar=ivar, initialize=initialize_variables, index = ih_seed_decay_pa ) call this%set_history_var(vname='ED_bstore', units='gC m-2', & long='Storage biomass', use_default='active', & avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, callstep=callstep, index = ih_bstore_pa ) + ivar=ivar, initialize=initialize_variables, index = ih_bstore_pa ) call this%set_history_var(vname='ED_bdead', units='gC m-2', & long='Dead (structural) biomass (live trees, not CWD)', & use_default='active', & avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, callstep=callstep, index = ih_bdead_pa ) + ivar=ivar, initialize=initialize_variables, index = ih_bdead_pa ) call this%set_history_var(vname='ED_balive', units='gC m-2', & long='Live biomass', use_default='active', & avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, callstep=callstep, index = ih_balive_pa ) + ivar=ivar, initialize=initialize_variables, index = ih_balive_pa ) call this%set_history_var(vname='ED_bleaf', units='gC m-2', & long='Leaf biomass', use_default='active', & avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, callstep=callstep, index = ih_bleaf_pa ) + ivar=ivar, initialize=initialize_variables, index = ih_bleaf_pa ) call this%set_history_var(vname='ED_biomass', units='gC m-2', & long='Total biomass', use_default='active', & avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, callstep=callstep, index = ih_btotal_pa ) + ivar=ivar, initialize=initialize_variables, index = ih_btotal_pa ) ! Ecosystem Carbon Fluxes (updated rapidly, upfreq=2) @@ -1205,32 +1270,32 @@ subroutine define_history_vars(this,callstep,nvar) call this%set_history_var(vname='NPP_column', units='gC/m^2/s', & long='net primary production on the site', use_default='active', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, callstep=callstep, index = ih_npp_si ) + ivar=ivar, initialize=initialize_variables, index = ih_npp_si ) call this%set_history_var(vname='GPP', units='gC/m^2/s', & long='gross primary production', use_default='active', & avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, callstep=callstep, index = ih_gpp_pa ) + ivar=ivar, initialize=initialize_variables, index = ih_gpp_pa ) call this%set_history_var(vname='NPP', units='gC/m^2/s', & long='net primary production', use_default='active', & avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, callstep=callstep, index = ih_npp_pa ) + ivar=ivar, initialize=initialize_variables, index = ih_npp_pa ) call this%set_history_var(vname='AR', units='gC/m^2/s', & long='autotrophic respiration', use_default='active', & avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, callstep=callstep, index = ih_aresp_pa ) + ivar=ivar, initialize=initialize_variables, index = ih_aresp_pa ) call this%set_history_var(vname='GROWTH_RESP', units='gC/m^2/s', & long='growth respiration', use_default='active', & avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, callstep=callstep, index = ih_growth_resp_pa ) + ivar=ivar, initialize=initialize_variables, index = ih_growth_resp_pa ) call this%set_history_var(vname='MAINT_RESP', units='gC/m^2/s', & long='maintenance respiration', use_default='active', & avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, callstep=callstep, index = ih_maint_resp_pa ) + ivar=ivar, initialize=initialize_variables, index = ih_maint_resp_pa ) ! Carbon Flux (grid dimension x scpf) (THESE ARE DEFAULT INACTIVE!!! @@ -1240,93 +1305,93 @@ subroutine define_history_vars(this,callstep,nvar) call this%set_history_var(vname='GPP_SCPF', units='kgC/m2/yr', & long='gross primary production', use_default='inactive', & avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, callstep=callstep, index = ih_gpp_si_scpf ) + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_gpp_si_scpf ) call this%set_history_var(vname='NPP_SCPF', units='kgC/m2/yr', & long='total net primary production', use_default='inactive', & avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, callstep=callstep, index = ih_npp_totl_si_scpf ) + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_totl_si_scpf ) call this%set_history_var(vname='NPP_LEAF_SCPF', units='kgC/m2/yr', & long='NPP flux into leaves', use_default='inactive', & avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, callstep=callstep, index = ih_npp_leaf_si_scpf ) + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_leaf_si_scpf ) call this%set_history_var(vname='NPP_SEED_SCPF', units='kgC/m2/yr', & long='NPP flux into seeds', use_default='inactive', & avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, callstep=callstep, index = ih_npp_seed_si_scpf ) + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_seed_si_scpf ) call this%set_history_var(vname='NPP_FNRT_SCPF', units='kgC/m2/yr', & long='NPP flux into fine roots', use_default='inactive', & avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, callstep=callstep, index = ih_npp_fnrt_si_scpf ) + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_fnrt_si_scpf ) call this%set_history_var(vname='NPP_BGSW_SCPF', units='kgC/m2/yr', & long='NPP flux into below-ground sapwood', use_default='inactive', & avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, callstep=callstep, index = ih_npp_bgsw_si_scpf ) + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_bgsw_si_scpf ) call this%set_history_var(vname='NPP_BGDW_SCPF', units='kgC/m2/yr', & long='NPP flux into below-ground deadwood', use_default='inactive', & avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, callstep=callstep, index = ih_npp_bgdw_si_scpf ) + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_bgdw_si_scpf ) call this%set_history_var(vname='NPP_AGSW_SCPF', units='kgC/m2/yr', & long='NPP flux into above-ground sapwood', use_default='inactive', & avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, callstep=callstep, index = ih_npp_agsw_si_scpf ) + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_agsw_si_scpf ) call this%set_history_var(vname = 'NPP_AGDW_SCPF', units='kgC/m2/yr', & long='NPP flux into above-ground deadwood', use_default='inactive', & avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, callstep=callstep, index = ih_npp_agdw_si_scpf ) + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_agdw_si_scpf ) call this%set_history_var(vname = 'NPP_STOR_SCPF', units='kgC/m2/yr', & long='NPP flux into storage', use_default='inactive', & avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, callstep=callstep, index = ih_npp_stor_si_scpf ) + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_stor_si_scpf ) call this%set_history_var(vname='DDBH_SCPF', units = 'cm/yr/ha', & long='diameter growth increment and pft/size',use_default='inactive', & avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, callstep=callstep, index = ih_ddbh_si_scpf ) + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ddbh_si_scpf ) call this%set_history_var(vname='BA_SCPF', units = 'm2/ha', & long='basal area by patch and pft/size', use_default='inactive', & avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, callstep=callstep, index = ih_ba_si_scpf ) + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ba_si_scpf ) call this%set_history_var(vname='NPLANT_SCPF', units = 'N/ha', & long='stem number density by patch and pft/size', use_default='inactive', & avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, callstep=callstep, index = ih_nplant_si_scpf ) + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_si_scpf ) call this%set_history_var(vname='M1_SCPF', units = 'N/ha/yr', & long='background mortality count by patch and pft/size', use_default='inactive', & avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, callstep=callstep, index = ih_m1_si_scpf ) + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m1_si_scpf ) call this%set_history_var(vname='M2_SCPF', units = 'N/ha/yr', & long='hydraulic mortality count by patch and pft/size',use_default='inactive', & avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, callstep=callstep, index = ih_m2_si_scpf ) + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m2_si_scpf ) call this%set_history_var(vname='M3_SCPF', units = 'N/ha/yr', & long='carbon starvation mortality count by patch and pft/size', use_default='inactive', & avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, callstep=callstep, index = ih_m3_si_scpf ) + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m3_si_scpf ) call this%set_history_var(vname='M4_SCPF', units = 'N/ha/yr', & long='impact mortality count by patch and pft/size',use_default='inactive', & avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, callstep=callstep, index = ih_m4_si_scpf ) + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m4_si_scpf ) call this%set_history_var(vname='M5_SCPF', units = 'N/ha/yr', & long='fire mortality count by patch and pft/size',use_default='inactive', & avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, callstep=callstep, index = ih_m5_si_scpf ) + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m5_si_scpf ) ! CARBON BALANCE VARIABLES THAT DEPEND ON HLM BGC INPUTS @@ -1334,58 +1399,56 @@ subroutine define_history_vars(this,callstep,nvar) call this%set_history_var(vname='NEP', units='gC/m^2/s', & long='net ecosystem production', use_default='active', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & - upfreq=3, ivar=ivar, callstep=callstep, index = ih_nep_si ) + upfreq=3, ivar=ivar, initialize=initialize_variables, index = ih_nep_si ) call this%set_history_var(vname='Fire_Closs', units='gC/m^2/s', & long='ED/SPitfire Carbon loss to atmosphere', use_default='active', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & - upfreq=3, ivar=ivar, callstep=callstep, index = ih_fire_c_to_atm_si ) + upfreq=3, ivar=ivar, initialize=initialize_variables, index = ih_fire_c_to_atm_si ) call this%set_history_var(vname='NBP', units='gC/m^2/s', & long='net biosphere production', use_default='active', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & - upfreq=3, ivar=ivar, callstep=callstep, index = ih_nbp_si ) + upfreq=3, ivar=ivar, initialize=initialize_variables, index = ih_nbp_si ) call this%set_history_var(vname='TOTECOSYSC', units='gC/m^2', & long='total ecosystem carbon', use_default='active', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & - upfreq=3, ivar=ivar, callstep=callstep, index = ih_totecosysc_si ) + upfreq=3, ivar=ivar, initialize=initialize_variables, index = ih_totecosysc_si ) call this%set_history_var(vname='CBALANCE_ERROR_ED', units='gC/m^2/s', & long='total carbon balance error on ED side', use_default='active', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & - upfreq=3, ivar=ivar, callstep=callstep, index = ih_cbal_err_fates_si ) + upfreq=3, ivar=ivar, initialize=initialize_variables, index = ih_cbal_err_fates_si ) call this%set_history_var(vname='CBALANCE_ERROR_BGC', units='gC/m^2/s', & long='total carbon balance error on HLMs BGC side', use_default='active', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & - upfreq=3, ivar=ivar, callstep=callstep, index = ih_cbal_err_bgc_si ) + upfreq=3, ivar=ivar, initialize=initialize_variables, index = ih_cbal_err_bgc_si ) call this%set_history_var(vname='CBALANCE_ERROR_TOTAL', units='gC/m^2/s', & long='total carbon balance error total', use_default='active', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & - upfreq=3, ivar=ivar, callstep=callstep, index = ih_cbal_err_tot_si ) + upfreq=3, ivar=ivar, initialize=initialize_variables, index = ih_cbal_err_tot_si ) call this%set_history_var(vname='BIOMASS_STOCK_COL', units='gC/m^2', & long='total ED biomass carbon at the column level', use_default='active', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & - upfreq=3, ivar=ivar, callstep=callstep, index = ih_biomass_stock_si ) + upfreq=3, ivar=ivar, initialize=initialize_variables, index = ih_biomass_stock_si ) call this%set_history_var(vname='ED_LITTER_STOCK_COL', units='gC/m^2', & long='total ED litter carbon at the column level', use_default='active', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & - upfreq=3, ivar=ivar, callstep=callstep, index = ih_litter_stock_si ) + upfreq=3, ivar=ivar, initialize=initialize_variables, index = ih_litter_stock_si ) call this%set_history_var(vname='CWD_STOCK_COL', units='gC/m^2', & long='total CWD carbon at the column level', use_default='active', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & - upfreq=3, ivar=ivar, callstep=callstep, index = ih_cwd_stock_si ) + upfreq=3, ivar=ivar, initialize=initialize_variables, index = ih_cwd_stock_si ) ! Must be last thing before return - if(present(nvar)) nvar = ivar - - return + this%num_history_vars_ = ivar end subroutine define_history_vars From d2c2a75cba0d9cad751b3e5f1c990e31c4a05100 Mon Sep 17 00:00:00 2001 From: Ben Andre Date: Thu, 20 Oct 2016 12:26:12 -0600 Subject: [PATCH 229/437] NAG bugfix: break line that exceeds 132 characters. Test: ERS_D_Ld5.5x5_amazon.ICLM45ED.hobart_nag.clm-edTest Test baseline: none (master didn't compile and run on nag) Test status: pass lease enter the commit message for your changes. Lines starting --- biogeochem/EDCanopyStructureMod.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index a0056056..4a5801ff 100755 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -546,7 +546,8 @@ subroutine canopy_structure( currentSite ) enddo if(((checkarea-currentPatch%area)) > 0.0001)then - write(fates_log(),*) 'problem with canopy area', checkarea,currentPatch%area,checkarea-currentPatch%area,i,z,missing_area + write(fates_log(),*) '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 From 9a9e180e39f2440b36db17d064479dcb38f9cb70 Mon Sep 17 00:00:00 2001 From: Ben Andre Date: Fri, 21 Oct 2016 10:58:22 -0600 Subject: [PATCH 230/437] Rename HistoryIOMod.F90 -> FatesHistoryInterfaceMod.F90 Rename the history interface file to have a consistent name other history related files. no source changes. Test: ERS_D_Ld5.f10_f10.ICLM45ED.yellowstone_intel.clm-edTest Test baseline: 44aac42 Test status: pass --- main/{HistoryIOMod.F90 => FatesHistoryInterfaceMod.F90} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename main/{HistoryIOMod.F90 => FatesHistoryInterfaceMod.F90} (100%) diff --git a/main/HistoryIOMod.F90 b/main/FatesHistoryInterfaceMod.F90 similarity index 100% rename from main/HistoryIOMod.F90 rename to main/FatesHistoryInterfaceMod.F90 From 61ffe7cfa56f04affed7fd068e5a2869231daabc Mon Sep 17 00:00:00 2001 From: Ben Andre Date: Fri, 21 Oct 2016 11:19:39 -0600 Subject: [PATCH 231/437] Source changes renaming the history interface module. Rename the history interface class and corresponding instance. Note: ammending commit, test was not a clean build, may not compile. Test: ERS_D_Ld5.f10_f10.ICLM45ED.yellowstone_intel.clm-edTest Test baseline: 44aac42 Test status: pass --- main/FatesHistoryInterfaceMod.F90 | 50 +++++++++++++++---------------- 1 file changed, 25 insertions(+), 25 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index a4df876a..fd7e6126 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -1,4 +1,4 @@ -Module HistoryIOMod +module FatesHistoryInterfaceMod use FatesConstantsMod, only : r8 => fates_r8 @@ -154,7 +154,7 @@ Module HistoryIOMod end type iovar_map_type - type, public :: fates_hio_interface_type + type, public :: fates_history_interface_type ! Instance of the list of history output varialbes type(fates_history_variable_type), allocatable :: hvars(:) @@ -203,7 +203,7 @@ Module HistoryIOMod procedure, private :: set_levgrnd_index procedure, private :: set_levscpf_index - end type fates_hio_interface_type + end type fates_history_interface_type @@ -217,7 +217,7 @@ subroutine InitFatesHistoryOutput(this, num_threads, fates_bounds) implicit none - class(fates_hio_interface_type), intent(inout) :: this + class(fates_history_interface_type), intent(inout) :: this integer, intent(in) :: num_threads type(fates_bounds_type), intent(in) :: fates_bounds @@ -254,7 +254,7 @@ subroutine SetHistoryThreadBounds(this, thread_index, thread_bounds) implicit none - class(fates_hio_interface_type), intent(inout) :: this + class(fates_history_interface_type), intent(inout) :: this integer, intent(in) :: thread_index type(fates_bounds_type), intent(in) :: thread_bounds @@ -287,7 +287,7 @@ subroutine assemble_valid_output_types(this) implicit none - class(fates_hio_interface_type), intent(inout) :: this + class(fates_history_interface_type), intent(inout) :: this call this%init_dim_kinds_maps() @@ -318,7 +318,7 @@ subroutine set_dim_indicies(this, dk_name, idim, dim_index) implicit none ! arguments - class(fates_hio_interface_type), intent(inout) :: this + class(fates_history_interface_type), intent(inout) :: this character(len=*), intent(in) :: dk_name integer, intent(in) :: idim ! dimension index integer, intent(in) :: dim_index @@ -353,56 +353,56 @@ end subroutine set_dim_indicies ! ======================================================================= subroutine set_patch_index(this, index) implicit none - class(fates_hio_interface_type), intent(inout) :: this + class(fates_history_interface_type), intent(inout) :: this integer, intent(in) :: index this%patch_index_ = index end subroutine set_patch_index integer function patch_index(this) implicit none - class(fates_hio_interface_type), intent(in) :: this + class(fates_history_interface_type), intent(in) :: this patch_index = this%patch_index_ end function patch_index ! ======================================================================= subroutine set_column_index(this, index) implicit none - class(fates_hio_interface_type), intent(inout) :: this + class(fates_history_interface_type), intent(inout) :: this integer, intent(in) :: index this%column_index_ = index end subroutine set_column_index integer function column_index(this) implicit none - class(fates_hio_interface_type), intent(in) :: this + class(fates_history_interface_type), intent(in) :: this column_index = this%column_index_ end function column_index ! ======================================================================= subroutine set_levgrnd_index(this, index) implicit none - class(fates_hio_interface_type), intent(inout) :: this + class(fates_history_interface_type), intent(inout) :: this integer, intent(in) :: index this%levgrnd_index_ = index end subroutine set_levgrnd_index integer function levgrnd_index(this) implicit none - class(fates_hio_interface_type), intent(in) :: this + class(fates_history_interface_type), intent(in) :: this levgrnd_index = this%levgrnd_index_ end function levgrnd_index ! ======================================================================= subroutine set_levscpf_index(this, index) implicit none - class(fates_hio_interface_type), intent(inout) :: this + class(fates_history_interface_type), intent(inout) :: this integer, intent(in) :: index this%levscpf_index_ = index end subroutine set_levscpf_index integer function levscpf_index(this) implicit none - class(fates_hio_interface_type), intent(in) :: this + class(fates_history_interface_type), intent(in) :: this levscpf_index = this%levscpf_index_ end function levscpf_index @@ -410,7 +410,7 @@ end function levscpf_index subroutine flush_hvars(this,nc,upfreq_in) - class(fates_hio_interface_type) :: this + class(fates_history_interface_type) :: this integer,intent(in) :: nc integer,intent(in) :: upfreq_in @@ -440,7 +440,7 @@ subroutine set_history_var(this, vname, units, long, use_default, avgflag, vtype implicit none ! arguments - class(fates_hio_interface_type), intent(inout) :: this + class(fates_history_interface_type), intent(inout) :: this character(len=*), intent(in) :: vname character(len=*), intent(in) :: units character(len=*), intent(in) :: long @@ -503,7 +503,7 @@ subroutine init_dim_kinds_maps(this) implicit none ! Arguments - class(fates_hio_interface_type), intent(inout) :: this + class(fates_history_interface_type), intent(inout) :: this integer :: index @@ -541,7 +541,7 @@ subroutine update_history_cbal(this,nc,nsites,sites) use EDtypesMod , only : ed_site_type ! Arguments - class(fates_hio_interface_type) :: this + class(fates_history_interface_type) :: this integer , intent(in) :: nc ! clump index integer , intent(in) :: nsites type(ed_site_type) , intent(inout), target :: sites(nsites) @@ -609,7 +609,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) use EDParamsMod , only : ED_val_ag_biomass ! Arguments - class(fates_hio_interface_type) :: this + class(fates_history_interface_type) :: this integer , intent(in) :: nc ! clump index integer , intent(in) :: nsites type(ed_site_type) , intent(inout), target :: sites(nsites) @@ -925,7 +925,7 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) ed_patch_type, & AREA ! Arguments - class(fates_hio_interface_type) :: this + class(fates_history_interface_type) :: this integer , intent(in) :: nc ! clump index integer , intent(in) :: nsites type(ed_site_type) , intent(inout), target :: sites(nsites) @@ -1021,7 +1021,7 @@ integer function num_history_vars(this) implicit none - class(fates_hio_interface_type), intent(in) :: this + class(fates_history_interface_type), intent(in) :: this num_history_vars = this%num_history_vars_ @@ -1033,7 +1033,7 @@ subroutine initialize_history_vars(this) implicit none - class(fates_hio_interface_type), intent(inout) :: this + class(fates_history_interface_type), intent(inout) :: this ! Determine how many of the history IO variables registered in FATES ! are going to be allocated @@ -1082,7 +1082,7 @@ subroutine define_history_vars(this, initialize_variables) site_r8, site_ground_r8, site_class_pft_r8 implicit none - class(fates_hio_interface_type), intent(inout) :: this + class(fates_history_interface_type), intent(inout) :: this logical, intent(in) :: initialize_variables ! are we 'count'ing or 'initializ'ing? integer :: ivar @@ -1549,4 +1549,4 @@ end subroutine define_history_vars -end module HistoryIOMod +end module FatesHistoryInterfaceMod From b5c20af051152869c8e48d7d018b248c9264da88 Mon Sep 17 00:00:00 2001 From: Ben Andre Date: Tue, 25 Oct 2016 11:58:10 -0600 Subject: [PATCH 232/437] Code cleanup for history names and whitespace Note: ammend commit, compilation errors with openmp on. Test: ERS_D_Ld5.f10_f10.ICLM45ED.yellowstone_intel.clm-edTest Test baseline: 44aac42 Test status: pass --- main/FatesHistoryDimensionMod.F90 | 12 ++++----- main/FatesHistoryInterfaceMod.F90 | 28 +++++++++---------- main/FatesHistoryVarKindMod.F90 | 28 ++++++++++++++++--- main/FatesHistoryVariableType.F90 | 45 +++++++++---------------------- 4 files changed, 57 insertions(+), 56 deletions(-) diff --git a/main/FatesHistoryDimensionMod.F90 b/main/FatesHistoryDimensionMod.F90 index 143048ee..a287c19a 100644 --- a/main/FatesHistoryDimensionMod.F90 +++ b/main/FatesHistoryDimensionMod.F90 @@ -43,14 +43,14 @@ module FatesHistoryDimensionMod integer, allocatable :: clump_lower_bound(:) ! lower bound of thread's portion of HIO array integer, allocatable :: clump_upper_bound(:) ! upper bound of thread's portion of HIO array contains - procedure, public :: Init => InitHistoryDimensions - procedure, public :: SetThreadBounds => SetHistoryDimensionThreadBounds + procedure, public :: Init + procedure, public :: SetThreadBounds end type fates_history_dimension_type contains ! ===================================================================================== - subroutine InitHistoryDimensions(this, name, num_threads, lower_bound, upper_bound) + subroutine Init(this, name, num_threads, lower_bound, upper_bound) implicit none @@ -71,11 +71,11 @@ subroutine InitHistoryDimensions(this, name, num_threads, lower_bound, upper_bou allocate(this%clump_upper_bound(num_threads)) this%clump_upper_bound(:) = -1 - end subroutine InitHistoryDimensions + end subroutine Init ! ===================================================================================== - subroutine SetHistoryDimensionThreadBounds(this, thread_index, lower_bound, upper_bound) + subroutine SetThreadBounds(this, thread_index, lower_bound, upper_bound) implicit none @@ -87,6 +87,6 @@ subroutine SetHistoryDimensionThreadBounds(this, thread_index, lower_bound, uppe this%clump_lower_bound(thread_index) = lower_bound this%clump_upper_bound(thread_index) = upper_bound - end subroutine SetHistoryDimensionThreadBounds + end subroutine SetThreadBounds end module FatesHistoryDimensionMod diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index fd7e6126..07125e8a 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -129,7 +129,7 @@ module FatesHistoryInterfaceMod ! The number of variable dim/kind types we have defined (static) - integer, parameter :: n_dim_kinds = 6 + integer, parameter :: fates_num_dim_kinds = 6 type, public :: fates_bounds_type integer :: patch_begin @@ -162,7 +162,7 @@ module FatesHistoryInterfaceMod ! Instanteat one registry of the different dimension/kinds (dk) ! All output variables will have a pointer to one of these dk's - type(fates_history_variable_kind_type) :: dim_kinds(n_dim_kinds) + type(fates_history_variable_kind_type) :: dim_kinds(fates_num_dim_kinds) ! This is a structure that explains where FATES patch boundaries ! on each thread point to in the host IO array, this structure is @@ -175,8 +175,8 @@ module FatesHistoryInterfaceMod integer, private :: patch_index_, column_index_, levgrnd_index_, levscpf_index_ contains - procedure, public :: Init => InitFatesHistoryOutput - procedure, public :: SetThreadBounds => SetHistoryThreadBounds + procedure, public :: Init + procedure, public :: SetThreadBounds procedure, public :: initialize_history_vars procedure, public :: assemble_valid_output_types @@ -211,7 +211,7 @@ module FatesHistoryInterfaceMod ! ====================================================================== - subroutine InitFatesHistoryOutput(this, num_threads, fates_bounds) + subroutine Init(this, num_threads, fates_bounds) use FatesHistoryDimensionMod, only : patch, column, levgrnd, levscpf @@ -247,10 +247,10 @@ subroutine InitFatesHistoryOutput(this, num_threads, fates_bounds) ! Allocate the mapping between FATES indices and the IO indices allocate(this%iovar_map(num_threads)) - end subroutine InitFatesHistoryOutput + end subroutine Init ! ====================================================================== - subroutine SetHistoryThreadBounds(this, thread_index, thread_bounds) + subroutine SetThreadBounds(this, thread_index, thread_bounds) implicit none @@ -277,13 +277,13 @@ subroutine SetHistoryThreadBounds(this, thread_index, thread_bounds) call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%pft_class_begin, thread_bounds%pft_class_end) - end subroutine SetHistoryThreadBounds + end subroutine SetThreadBounds ! =================================================================================== subroutine assemble_valid_output_types(this) - use FatesHistoryDimensionMod, only : patch_r8, patch_ground_r8, patch_class_pft_r8, & - site_r8, site_ground_r8, site_class_pft_r8 + use FatesHistoryDimensionMod, only : patch_r8, patch_ground_r8, patch_class_pft_r8 + use FatesHistoryDimensionMod, only : site_r8, site_ground_r8, site_class_pft_r8 implicit none @@ -313,7 +313,7 @@ end subroutine assemble_valid_output_types subroutine set_dim_indicies(this, dk_name, idim, dim_index) - use FatesHistoryVariableType, only : iotype_index + use FatesHistoryVariableKindMod , only : iotype_index implicit none @@ -327,7 +327,7 @@ subroutine set_dim_indicies(this, dk_name, idim, dim_index) ! local integer :: ityp - ityp = iotype_index(trim(dk_name), n_dim_kinds, this%dim_kinds) + ityp = iotype_index(trim(dk_name), fates_num_dim_kinds, this%dim_kinds) ! First check to see if the dimension is allocated if (this%dim_kinds(ityp)%ndims < idim) then @@ -472,7 +472,7 @@ subroutine set_history_var(this, vname, units, long, use_default, avgflag, vtype if (initialize) then call this%hvars(ivar)%Init(vname, units, long, use_default, & - vtype, avgflag, flushval, upfreq, n_dim_kinds, this%dim_kinds, & + vtype, avgflag, flushval, upfreq, fates_num_dim_kinds, this%dim_kinds, & this%dim_bounds) end if else @@ -532,7 +532,7 @@ subroutine init_dim_kinds_maps(this) index = index + 1 call this%dim_kinds(index)%Init(site_class_pft_r8, 2) - ! FIXME(bja, 2016-10) assert(index == n_dim_kinds) + ! FIXME(bja, 2016-10) assert(index == fates_num_dim_kinds) end subroutine init_dim_kinds_maps ! ======================================================================= diff --git a/main/FatesHistoryVarKindMod.F90 b/main/FatesHistoryVarKindMod.F90 index 22ed6c28..fd8bd7a8 100644 --- a/main/FatesHistoryVarKindMod.F90 +++ b/main/FatesHistoryVarKindMod.F90 @@ -1,6 +1,7 @@ module FatesHistoryVariableKindMod use FatesConstantsMod, only : fates_long_string_length + use FatesGlobals, only : fates_log use FatesHistoryDimensionMod, only : fates_history_dimension_type implicit none @@ -21,7 +22,7 @@ module FatesHistoryVariableKindMod contains - procedure, public :: Init => InitVariableKind + procedure, public :: Init procedure, public :: set_active procedure, public :: is_active @@ -32,7 +33,7 @@ module FatesHistoryVariableKindMod contains ! =================================================================================== - subroutine InitVariableKind(this, name, num_dims) + subroutine Init(this, name, num_dims) use FatesConstantsMod, only : fates_unset_int @@ -50,7 +51,7 @@ subroutine InitVariableKind(this, name, num_dims) this%dim1_index = fates_unset_int this%dim2_index = fates_unset_int - end subroutine InitVariableKind + end subroutine Init ! ======================================================================= subroutine set_active(this) @@ -65,5 +66,26 @@ logical function is_active(this) is_active = this%active_ end function is_active + ! ==================================================================================== + + function iotype_index(iotype_name, num_dim_kinds, dim_kinds) result(dk_index) + + ! argument + character(len=*), intent(in) :: iotype_name + integer, intent(in) :: num_dim_kinds + type(fates_history_variable_kind_type), intent(in) :: dim_kinds(:) + + ! local + integer :: dk_index + + do dk_index=1, num_dim_kinds + if (trim(iotype_name) .eq. trim(dim_kinds(dk_index)%name)) then + return + end if + end do + write(fates_log(),*) 'An IOTYPE THAT DOESNT EXIST WAS SPECIFIED' + !end_run + + end function iotype_index end module FatesHistoryVariableKindMod diff --git a/main/FatesHistoryVariableType.F90 b/main/FatesHistoryVariableType.F90 index 54558a54..a2b41f05 100644 --- a/main/FatesHistoryVariableType.F90 +++ b/main/FatesHistoryVariableType.F90 @@ -31,19 +31,21 @@ module FatesHistoryVariableType integer, pointer :: int2d(:,:) integer, pointer :: int3d(:,:,:) contains - procedure, public :: Init => InitHistoryVariableType + procedure, public :: Init procedure, public :: Flush procedure, private :: GetBounds end type fates_history_variable_type contains - subroutine InitHistoryVariableType(this, vname, units, long, use_default, & - vtype, avgflag, flushval, upfreq, n_dim_kinds, dim_kinds, dim_bounds) + subroutine Init(this, vname, units, long, use_default, & + vtype, avgflag, flushval, upfreq, num_dim_kinds, dim_kinds, dim_bounds) use FatesHistoryDimensionMod, only : fates_history_dimension_type - use FatesHistoryDimensionMod, only : patch_r8, patch_ground_r8, patch_class_pft_r8, & - site_r8, site_ground_r8, site_class_pft_r8 + use FatesHistoryDimensionMod, only : patch_r8, patch_ground_r8, patch_class_pft_r8 + use FatesHistoryDimensionMod, only : site_r8, site_ground_r8, site_class_pft_r8 + + use FatesHistoryVariableKindMod, only : iotype_index implicit none @@ -56,7 +58,7 @@ subroutine InitHistoryVariableType(this, vname, units, long, use_default, & character(len=*), intent(in) :: avgflag real(r8), intent(in) :: flushval ! If the type is an int we will round with nint integer, intent(in) :: upfreq - integer, intent(in) :: n_dim_kinds + integer, intent(in) :: num_dim_kinds type(fates_history_dimension_type), intent(in) :: dim_bounds(:) type(fates_history_variable_kind_type), intent(inout) :: dim_kinds(:) @@ -79,7 +81,7 @@ subroutine InitHistoryVariableType(this, vname, units, long, use_default, & nullify(this%int2d) nullify(this%int3d) - dk_index = iotype_index(trim(vtype), n_dim_kinds, dim_kinds) + dk_index = iotype_index(trim(vtype), num_dim_kinds, dim_kinds) this%dim_kinds_index = dk_index call dim_kinds(dk_index)%set_active() @@ -123,7 +125,7 @@ subroutine InitHistoryVariableType(this, vname, units, long, use_default, & ! end_run end select - end subroutine InitHistoryVariableType + end subroutine Init ! ===================================================================================== @@ -179,8 +181,8 @@ end subroutine GetBounds subroutine Flush(this, thread, dim_bounds, dim_kinds) use FatesHistoryDimensionMod, only : fates_history_dimension_type - use FatesHistoryDimensionMod, only : patch_r8, patch_ground_r8, patch_class_pft_r8, & - site_r8, site_ground_r8, site_class_pft_r8, patch_int + use FatesHistoryDimensionMod, only : patch_r8, patch_ground_r8, patch_class_pft_r8 + use FatesHistoryDimensionMod, only : site_r8, site_ground_r8, site_class_pft_r8, patch_int implicit none @@ -216,27 +218,4 @@ subroutine Flush(this, thread, dim_bounds, dim_kinds) end subroutine Flush - ! ==================================================================================== - - function iotype_index(iotype_name, n_dim_kinds, dim_kinds) result(dk_index) - - ! argument - character(len=*), intent(in) :: iotype_name - integer, intent(in) :: n_dim_kinds - type(fates_history_variable_kind_type), intent(in) :: dim_kinds(:) - - ! local - integer :: dk_index - - do dk_index=1, n_dim_kinds - if (trim(iotype_name) .eq. trim(dim_kinds(dk_index)%name)) then - return - end if - end do - write(fates_log(),*) 'An IOTYPE THAT DOESNT EXIST WAS SPECIFIED' - !end_run - - end function iotype_index - - end module FatesHistoryVariableType From a481ece4bb1afa0cf987a1b97176fb71c1bf2752 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 27 Oct 2016 15:56:34 -0700 Subject: [PATCH 233/437] Various syntactical fixes including: making rgas more explicit in its name, adding _r8 to local constants, adding an unset integer to global constants, removing some text that explained a constant. --- biogeochem/EDCohortDynamicsMod.F90 | 22 +++++---- biogeophys/EDPhotosynthesisMod.F90 | 76 +++++++++++++++--------------- main/FatesConstantsMod.F90 | 18 ++++++- 3 files changed, 66 insertions(+), 50 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 8f4ebd11..cdca9ec6 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -293,6 +293,8 @@ subroutine nan_cohort(cc_p) ! ! !USES: use shr_infnan_mod, only : nan => shr_infnan_nan, assignment(=) + use FatesConstantsMod, only : fates_unset_int + ! ! !ARGUMENTS type (ed_cohort_type), intent(inout), target :: cc_p @@ -314,13 +316,13 @@ subroutine nan_cohort(cc_p) 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%size_class = 999 ! size class index - currentCohort%size_by_pft_class = 999 ! size by pft classification index + currentCohort%pft = fates_unset_int ! pft number + currentCohort%indexnumber = fates_unset_int ! unique number for each cohort. (within clump?) + currentCohort%canopy_layer = fates_unset_int ! canopy status of cohort (1 = canopy, 2 = understorey, etc.) + currentCohort%NV = fates_unset_int ! Number of leaf layers: - + currentCohort%status_coh = fates_unset_int ! growth status of plant (2 = leaves on , 1 = leaves off) + currentCohort%size_class = fates_unset_int ! size class index + currentCohort%size_by_pft_class = fates_unset_int ! size by pft classification index currentCohort%n = nan ! number of individuals in cohort per 'area' (10000m2 default) currentCohort%dbh = nan ! 'diameter at breast height' in cm @@ -1136,8 +1138,8 @@ end function count_cohorts subroutine size_and_type_class_index(dbh,pft,size_class,size_by_pft_class) - use EDTypesMod, only: sclass_ed, & - nlevsclass_ed + use EDTypesMod, only: sclass_ed + use EDTypesMod, only: nlevsclass_ed ! Arguments real(r8),intent(in) :: dbh @@ -1145,7 +1147,7 @@ subroutine size_and_type_class_index(dbh,pft,size_class,size_by_pft_class) integer,intent(out) :: size_class integer,intent(out) :: size_by_pft_class - size_class = count(dbh-sclass_ed.ge.0.0) + size_class = count(dbh-sclass_ed.ge.0.0_r8) size_by_pft_class = (pft-1)*nlevsclass_ed+size_class diff --git a/biogeophys/EDPhotosynthesisMod.F90 b/biogeophys/EDPhotosynthesisMod.F90 index 5e9c2ee3..a9e6cf50 100644 --- a/biogeophys/EDPhotosynthesisMod.F90 +++ b/biogeophys/EDPhotosynthesisMod.F90 @@ -45,50 +45,49 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) ! READS ARE REFACTORED (RGK 10-13-2016) use pftconMod , only : pftcon ! THIS WILL BE DEPRECATED WHEN PARAMETER ! READS ARE REFACTORED (RGK 10-13-2016) - use EDParamsMod , only : ED_val_grperc, & - ED_val_ag_biomass + use EDParamsMod , only : ED_val_grperc + use EDParamsMod , only : ED_val_ag_biomass use EDSharedParamsMod , only : EDParamsShareInst - use EDTypesMod , only : numpft_ed, & - dinc_ed, & - ed_patch_type, & - ed_cohort_type, & - ed_site_type, & - numpft_ed, & - numpatchespercol, & - cp_numlevsoil, & - cp_nlevcan, & - cp_nclmax + use EDTypesMod , only : numpft_ed + use EDTypesMod , only : dinc_ed + use EDTypesMod , only : ed_patch_type + use EDTypesMod , only : ed_cohort_type + use EDTypesMod , only : ed_site_type + use EDTypesMod , only : numpft_ed + use EDTypesMod , only : numpatchespercol + use EDTypesMod , only : cp_numlevsoil + use EDTypesMod , only : cp_nlevcan + use EDTypesMod , only : cp_nclmax use EDEcophysContype , only : EDecophyscon - use FatesInterfaceMod , only : bc_in_type, & - bc_out_type + + use FatesInterfaceMod , only : bc_in_type + use FatesInterfaceMod , only : bc_out_type - use EDCanopyStructureMod,only: calc_areaindex + use EDCanopyStructureMod, only : calc_areaindex - use FatesConstantsMod, only : umolC_to_kgC, & ! micromole conversion to kgC - g_per_kg, & ! number of grams per kg - mg_per_g, & ! number of miligrams per g - sec_per_min, & ! seconds per minute (60!) - rgas, & ! universal gas constant - - tfrz => t_water_freeze_k_1atm ! Freezing point of water at 1 atmosphere + use FatesConstantsMod, only : umolC_to_kgC + use FatesConstantsMod, only : g_per_kg + use FatesConstantsMod, only : mg_per_g + use FatesConstantsMod, only : sec_per_min + use FatesConstantsMod, only : umol_per_mmol + use FatesConstantsMod, only : rgas => rgas_J_K_kmol + use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm - ! ! !ARGUMENTS: + ! ----------------------------------------------------------------------------------- integer,intent(in) :: nsites type(ed_site_type),intent(inout),target :: sites(nsites) type(bc_in_type),intent(in) :: bc_in(nsites) type(bc_out_type),intent(inout) :: bc_out(nsites) real(r8),intent(in) :: dtime - ! - ! !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. logical :: DEBUG = .false. @@ -237,8 +236,8 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) ! First guess on ratio between intracellular co2 and the atmosphere ! an iterator converges on actual - real(r8),parameter :: init_a2l_co2_c3 = 0.7 - real(r8),parameter :: init_a2l_co2_c4 = 0.4 + real(r8),parameter :: init_a2l_co2_c3 = 0.7_r8 + real(r8),parameter :: init_a2l_co2_c4 = 0.4_r8 associate( & @@ -1012,7 +1011,7 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) end if bc_out(s)%rssun_pa(ifp) = rscanopy bc_out(s)%rssha_pa(ifp) = rscanopy - bc_out(s)%gccanopy_pa(ifp) = 1.0_r8/rscanopy*cf/1000.0 !convert into umol m-2 s-1 then mmol m-2 s-1. + bc_out(s)%gccanopy_pa(ifp) = 1.0_r8/rscanopy*cf/umol_per_mmol !convert into umol m-2 s-1 then mmol m-2 s-1. end if currentPatch => currentPatch%younger @@ -1037,8 +1036,8 @@ function ft1_f(tl, ha) result(ans) ! 7/23/16: Copied over from CLM by Ryan Knox ! !!USES - use FatesConstantsMod, only : rgas, & ! universal gas constant - tfrz => t_water_freeze_k_1atm ! Freezing point of water at 1 atm + use FatesConstantsMod, only : rgas => rgas_J_K_kmol + use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm ! ! !ARGUMENTS: real(r8), intent(in) :: tl ! leaf temperature in photosynthesis temperature function (K) @@ -1064,8 +1063,9 @@ function fth_f(tl,hd,se,scaleFactor) result(ans) ! Jinyun Tang separated it out from Photosynthesis, Feb. 07/2013 ! 7/23/16: Copied over from CLM by Ryan Knox ! - use FatesConstantsMod, only : rgas, & ! universal gas constant - tfrz => t_water_freeze_k_1atm ! Freezing point of water at 1 atm + use FatesConstantsMod, only : rgas => rgas_J_K_kmol + use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm + ! ! !ARGUMENTS: real(r8), intent(in) :: tl ! leaf temperature in photosynthesis temperature function (K) @@ -1094,8 +1094,9 @@ function fth25_f(hd,se)result(ans) ! 7/23/16: Copied over from CLM by Ryan Knox ! !!USES - use FatesConstantsMod, only : rgas, & ! universal gas constant - tfrz => t_water_freeze_k_1atm ! Freezing point of water at 1 atm + + use FatesConstantsMod, only : rgas => rgas_J_K_kmol + use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm ! ! !ARGUMENTS: @@ -1127,7 +1128,6 @@ subroutine quadratic_f (a, b, c, r1, r2) ! 7/23/16: Copied over from CLM by Ryan Knox ! ! !USES: - implicit none ! ! !ARGUMENTS: real(r8), intent(in) :: a,b,c ! Terms for quadratic equation diff --git a/main/FatesConstantsMod.F90 b/main/FatesConstantsMod.F90 index 8a9d6938..824d1ab2 100644 --- a/main/FatesConstantsMod.F90 +++ b/main/FatesConstantsMod.F90 @@ -15,6 +15,10 @@ module FatesConstantsMod integer, parameter :: fates_long_string_length = 199 + ! Unset and various other 'special' values + integer, parameter :: fates_unset_int = -9999 + + ! Unit conversion constants: ! Conversion factor umols of Carbon -> kg of Carbon (1 mol = 12g) @@ -27,14 +31,24 @@ module FatesConstantsMod ! Conversion factor: miligrams per grams real(fates_r8), parameter :: mg_per_g = 1000.0_fates_r8 + ! Conversion factor: micromoles per milimole + real(fates_r8), parameter :: umol_per_mmol = 1000.0_fates_r8 + + ! Conversion factor: milimoles per mole + real(fates_r8), parameter :: mmol_per_mol = 1000.0_fates_r8 + + ! Conversion factor: micromoles per mole + real(fates_r8), parameter :: umol_per_mol = 1.0E6_fates_r8 + + ! Conversion: secons per minute real(fates_r8), parameter :: sec_per_min = 60.0_fates_r8 ! Physical constants - ! universal gas constant [J/K/kmole] - real(fates_r8), parameter :: rgas = 8314.4598_fates_r8 + ! universal gas constant [J/K/kmol] + real(fates_r8), parameter :: rgas_J_K_kmol = 8314.4598_fates_r8 ! freezing point of water at 1 atm (K) real(fates_r8), parameter :: t_water_freeze_k_1atm = 273.15_fates_r8 From edf670046adbf90fbeadd289c119e19f9dae118c Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 31 Oct 2016 17:58:09 -0700 Subject: [PATCH 234/437] Fixed the logic on a warning statement in create cohort. The logic was tripping true for all restart initialization cases and producing false positive warnings. I changed the logic to only trip in cases where the arguments passed into the routine signaled something was unusual, and in that case to kill the run instead of simply report. --- biogeochem/EDCohortDynamicsMod.F90 | 72 +++++++++++++++++------------- 1 file changed, 41 insertions(+), 31 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 1d87f95f..1ed42734 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -4,8 +4,10 @@ module EDCohortDynamicsMod ! Cohort stuctures in ED. ! ! !USES: - use shr_kind_mod , only : r8 => shr_kind_r8; - use clm_varctl , only : iulog + use abortutils , only : endrun + use FatesGlobals , only : fates_log + use FatesConstantsMod , only : r8 => fates_r8 + use shr_log_mod , only : errMsg => shr_log_errMsg use pftconMod , only : pftcon use EDEcophysContype , only : EDecophyscon use EDGrowthFunctionsMod , only : c_area, tree_lai @@ -32,6 +34,9 @@ module EDCohortDynamicsMod logical, parameter :: DEBUG = .false. ! local debug flag + character(len=*), parameter, private :: sourcefile = & + __FILE__ + ! 10/30/09: Created by Rosie Fisher !-------------------------------------------------------------------------------------! @@ -95,13 +100,18 @@ subroutine create_cohort(patchptr, pft, nn, hite, dbh, & call size_and_type_class_index(new_cohort%dbh,new_cohort%pft, & new_cohort%size_class,new_cohort%size_by_pft_class) - if ( DEBUG ) write(iulog,*) 'EDCohortDyn I ',bstore + if ( DEBUG ) write(fates_log(),*) 'EDCohortDyn I ',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', & + ! This routine may be called during restarts, and at this point in the call sequence + ! the actual cohort data is unknown, as this is really only used for allocation + ! In these cases, testing if things like biomass are reasonable is pre-mature + ! However, in this part of the code, we will pass in nominal values for size, number and type + + if (new_cohort%dbh <= 0.0_r8 .or. new_cohort%n == 0._r8 .or. new_cohort%pft == 0 ) then + write(fates_log(),*) 'ED: something is zero in create_cohort', & new_cohort%indexnumber,new_cohort%dbh,new_cohort%n, & - new_cohort%pft,new_cohort%canopy_trim,new_cohort%balive + new_cohort%pft + call endrun(msg=errMsg(sourcefile, __LINE__)) endif if (new_cohort%siteptr%status==2 .and. pftcon%season_decid(pft) == 1) then @@ -274,12 +284,12 @@ subroutine allocate_live_biomass(cc_p,mode) endif if (abs(currentcohort%balive -currentcohort%bl- currentcohort%br - currentcohort%bsw)>1e-12) then - write(iulog,*) 'issue with carbon allocation in create_cohort,allocate_live_biomass',& + write(fates_log(),*) 'issue with carbon allocation in create_cohort,allocate_live_biomass',& 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 - write(iulog,*) 'pft',ft,pftcon%evergreen(ft),pftcon%season_decid(ft),leaves_off_switch + write(fates_log(),*) 'actual vs predicted balive',ideal_balive,currentcohort%balive ,ratio_balive,leaf_frac + write(fates_log(),*) 'leaf,root,stem',currentcohort%bl,currentcohort%br,currentcohort%bsw + write(fates_log(),*) 'pft',ft,pftcon%evergreen(ft),pftcon%season_decid(ft),leaves_off_switch endif currentCohort%b = currentCohort%bdead + currentCohort%balive @@ -496,7 +506,7 @@ subroutine terminate_cohorts( patchptr ) if (currentcohort%n < min_n_safemath) then terminate = 1 if ( DEBUG ) then - write(iulog,*) 'terminating cohorts 0',currentCohort%n/currentPatch%area,currentCohort%dbh + write(fates_log(),*) 'terminating cohorts 0',currentCohort%n/currentPatch%area,currentCohort%dbh endif endif @@ -510,7 +520,7 @@ subroutine terminate_cohorts( patchptr ) terminate = 1 if ( DEBUG ) then - write(iulog,*) 'terminating cohorts 1',currentCohort%n/currentPatch%area,currentCohort%dbh + write(fates_log(),*) 'terminating cohorts 1',currentCohort%n/currentPatch%area,currentCohort%dbh endif endif @@ -518,7 +528,7 @@ subroutine terminate_cohorts( patchptr ) if (currentCohort%canopy_layer > cp_nclmax ) then terminate = 1 if ( DEBUG ) then - write(iulog,*) 'terminating cohorts 2', currentCohort%canopy_layer + write(fates_log(),*) 'terminating cohorts 2', currentCohort%canopy_layer endif endif @@ -526,7 +536,7 @@ subroutine terminate_cohorts( patchptr ) if (currentCohort%balive < 1e-10_r8 .or. currentCohort%bstore < 1e-10_r8) then terminate = 1 if ( DEBUG ) then - write(iulog,*) 'terminating cohorts 3', currentCohort%balive,currentCohort%bstore + write(fates_log(),*) 'terminating cohorts 3', currentCohort%balive,currentCohort%bstore endif endif @@ -534,7 +544,7 @@ subroutine terminate_cohorts( patchptr ) if (currentCohort%balive+currentCohort%bdead+currentCohort%bstore < 0._r8) then terminate = 1 if ( DEBUG ) then - write(iulog,*) 'terminating cohorts 4', currentCohort%balive, & + write(fates_log(),*) 'terminating cohorts 4', currentCohort%balive, & currentCohort%bstore, currentCohort%bdead, & currentCohort%balive+currentCohort%bdead+& currentCohort%bstore, currentCohort%n @@ -667,11 +677,11 @@ subroutine fuse_cohorts(patchptr) currentCohort%balive = (currentCohort%n*currentCohort%balive + nextc%n*nextc%balive)/newn currentCohort%bdead = (currentCohort%n*currentCohort%bdead + nextc%n*nextc%bdead)/newn - if ( DEBUG ) write(iulog,*) 'EDcohortDyn I ',currentCohort%bstore + if ( DEBUG ) write(fates_log(),*) 'EDcohortDyn I ',currentCohort%bstore currentCohort%bstore = (currentCohort%n*currentCohort%bstore + nextc%n*nextc%bstore)/newn - if ( DEBUG ) write(iulog,*) 'EDcohortDyn II ',currentCohort%bstore + if ( DEBUG ) write(fates_log(),*) 'EDcohortDyn II ',currentCohort%bstore 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 @@ -689,10 +699,10 @@ subroutine fuse_cohorts(patchptr) currentCohort%bsw = (currentCohort%n*currentCohort%bsw + nextc%n*nextc%bsw)/newn currentCohort%bl = (currentCohort%n*currentCohort%bl + nextc%n*nextc%bl)/newn - if ( DEBUG ) write(iulog,*) 'EDcohortDyn 569 ',currentCohort%br - if ( DEBUG ) write(iulog,*) 'EDcohortDyn 570 ',currentCohort%n - if ( DEBUG ) write(iulog,*) 'EDcohortDyn 571 ',nextc%br - if ( DEBUG ) write(iulog,*) 'EDcohortDyn 572 ',nextc%n + if ( DEBUG ) write(fates_log(),*) 'EDcohortDyn 569 ',currentCohort%br + if ( DEBUG ) write(fates_log(),*) 'EDcohortDyn 570 ',currentCohort%n + if ( DEBUG ) write(fates_log(),*) 'EDcohortDyn 571 ',nextc%br + if ( DEBUG ) write(fates_log(),*) 'EDcohortDyn 572 ',nextc%n currentCohort%br = (currentCohort%n*currentCohort%br + nextc%n*nextc%br)/newn currentCohort%hite = (currentCohort%n*currentCohort%hite + nextc%n*nextc%hite)/newn @@ -700,14 +710,14 @@ subroutine fuse_cohorts(patchptr) currentCohort%gpp_acc = (currentCohort%n*currentCohort%gpp_acc + nextc%n*nextc%gpp_acc)/newn - if ( DEBUG ) write(iulog,*) 'EDcohortDyn III ',currentCohort%npp_acc - if ( DEBUG ) write(iulog,*) 'EDcohortDyn IV ',currentCohort%resp_acc + if ( DEBUG ) write(fates_log(),*) 'EDcohortDyn III ',currentCohort%npp_acc + if ( DEBUG ) write(fates_log(),*) 'EDcohortDyn IV ',currentCohort%resp_acc 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 - if ( DEBUG ) write(iulog,*) 'EDcohortDyn V ',currentCohort%npp_acc - if ( DEBUG ) write(iulog,*) 'EDcohortDyn VI ',currentCohort%resp_acc + if ( DEBUG ) write(fates_log(),*) 'EDcohortDyn V ',currentCohort%npp_acc + if ( DEBUG ) write(fates_log(),*) 'EDcohortDyn VI ',currentCohort%resp_acc currentCohort%resp_acc_hold = (currentCohort%n*currentCohort%resp_acc_hold + nextc%n*nextc%resp_acc_hold)/newn currentCohort%npp_acc_hold = (currentCohort%n*currentCohort%npp_acc_hold + nextc%n*nextc%npp_acc_hold)/newn @@ -791,7 +801,7 @@ subroutine fuse_cohorts(patchptr) !---------------------------------------------------------------------! dynamic_fusion_tolerance = dynamic_fusion_tolerance * 1.1_r8 - write(iulog,*) 'maxcohorts exceeded',dynamic_fusion_tolerance + write(fates_log(),*) 'maxcohorts exceeded',dynamic_fusion_tolerance else iterate = 0 @@ -1024,8 +1034,8 @@ subroutine copy_cohort( currentCohort,copyc ) n%npp_acc_hold = o%npp_acc_hold n%npp_tstep = o%npp_tstep - if ( DEBUG ) write(iulog,*) 'EDcohortDyn Ia ',o%npp_acc - if ( DEBUG ) write(iulog,*) 'EDcohortDyn Ib ',o%resp_acc + if ( DEBUG ) write(fates_log(),*) 'EDcohortDyn Ia ',o%npp_acc + if ( DEBUG ) write(fates_log(),*) 'EDcohortDyn Ib ',o%resp_acc n%npp_acc_hold = o%npp_acc_hold n%resp_tstep = o%resp_tstep @@ -1080,7 +1090,7 @@ subroutine copy_cohort( currentCohort,copyc ) n%dbdeaddt = o%dbdeaddt n%dbstoredt = o%dbstoredt - if ( DEBUG ) write(iulog,*) 'EDCohortDyn dpstoredt ',o%dbstoredt + if ( DEBUG ) write(fates_log(),*) 'EDCohortDyn dpstoredt ',o%dbstoredt n%storage_flux = o%storage_flux @@ -1129,7 +1139,7 @@ function count_cohorts( currentPatch ) result ( backcount ) enddo if (backcount /= currentPatch%countcohorts) then - write(iulog,*) 'problem with linked list, not symmetrical' + write(fates_log(),*) 'problem with linked list, not symmetrical' endif end function count_cohorts From 0dd05d11b801d60ee15c90b4a077f0bd7cb6b3c3 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 2 Nov 2016 15:30:06 -0700 Subject: [PATCH 235/437] Moved more print statements that were reporting when not in debug mode. --- biogeochem/EDCanopyStructureMod.F90 | 11 ++++++----- main/EDRestVectorMod.F90 | 4 +++- 2 files changed, 9 insertions(+), 6 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index da85a093..85ece117 100755 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -994,8 +994,6 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) layer_bottom_hite = currentCohort%hite-(((iv+1)/currentCohort%NV) * currentCohort%hite * & EDecophyscon%crown(currentCohort%pft)) ! pftcon%vertical_canopy_frac(ft)) - write(fates_log(), *) 'calc snow 2', snow_depth_si , frac_sno_eff_si - fraction_exposed =1.0_r8 currentPatch%tlai_profile(L,ft,iv) = currentPatch%tlai_profile(L,ft,iv)+ dinc_ed * fleaf * & @@ -1013,9 +1011,12 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) currentPatch%layer_height_profile(L,ft,iv) = currentPatch%layer_height_profile(L,ft,iv) + (dinc_ed * fleaf * & currentCohort%c_area/currentPatch%total_canopy_area *(layer_top_hite+layer_bottom_hite)/2.0_r8) !average height of layer. - write(fates_log(), *) 'LHP', currentPatch%layer_height_profile(L,ft,iv) - if ( DEBUG ) write(fates_log(), *) 'EDCLMLink 1246 ', currentPatch%elai_profile(1,ft,iv) - + if ( DEBUG ) then + write(fates_log(), *) 'calc snow 2', snow_depth_si , frac_sno_eff_si + write(fates_log(), *) 'LHP', currentPatch%layer_height_profile(L,ft,iv) + write(fates_log(), *) 'EDCLMLink 1246 ', currentPatch%elai_profile(1,ft,iv) + end if + end do !Bottom layer diff --git a/main/EDRestVectorMod.F90 b/main/EDRestVectorMod.F90 index 5fbcb72c..b1678bb0 100755 --- a/main/EDRestVectorMod.F90 +++ b/main/EDRestVectorMod.F90 @@ -2030,7 +2030,9 @@ subroutine createPatchCohortStructure( this, bounds, nsites, sites, fcolumn ) ! item it needs, not the entire cohort...refactor temp_cohort%dbh = Dbh(temp_cohort) + 0.0001_r8*ft - write(iulog,*) 'EDRestVectorMod.F90::createPatchCohortStructure call create_cohort ' + if (this%DEBUG) then + write(iulog,*) 'EDRestVectorMod.F90::createPatchCohortStructure call create_cohort ' + end if call create_cohort(newp, ft, temp_cohort%n, temp_cohort%hite, temp_cohort%dbh, & temp_cohort%balive, temp_cohort%bdead, temp_cohort%bstore, & From 09f3f1168c6a94c93f35de4e840ec30926fe2349 Mon Sep 17 00:00:00 2001 From: Ben Andre Date: Wed, 2 Nov 2016 15:54:31 -0600 Subject: [PATCH 236/437] Fix typo and naming issue found during code review. Testing: Test: SMS_D_Ld5.f10_f10.ICLM45ED.yellowstone_intel.clm-edTest Test baseline: 53bbb9d Test status: pass Test suite: ed - yellowstone gnu, intel, pgi Test baseline: 53bbb9d Test status: all tests pass Test suite: ed - hobart nag Test baseline: none, previous master did not run under nag. Test status: all tests pass Test suite: clm_shorts - yellowstone gnu, intel, pgi Test baseline: clm4_5_12_r195 Test status: all tests pass --- main/FatesHistoryDimensionMod.F90 | 4 +- main/FatesHistoryInterfaceMod.F90 | 92 +++++++++++++++---------------- main/FatesHistoryVariableType.F90 | 16 +++--- 3 files changed, 56 insertions(+), 56 deletions(-) diff --git a/main/FatesHistoryDimensionMod.F90 b/main/FatesHistoryDimensionMod.F90 index a287c19a..d980f840 100644 --- a/main/FatesHistoryDimensionMod.F90 +++ b/main/FatesHistoryDimensionMod.F90 @@ -7,10 +7,10 @@ module FatesHistoryDimensionMod ! FIXME(bja, 2016-10) do these need to be strings, or can they be integer enumerations? character(*), parameter :: patch_r8 = 'PA_R8' character(*), parameter :: patch_ground_r8 = 'PA_GRND_R8' - character(*), parameter :: patch_class_pft_r8 = 'PA_SCPF_R8' + character(*), parameter :: patch_size_pft_r8 = 'PA_SCPF_R8' character(*), parameter :: site_r8 = 'SI_R8' character(*), parameter :: site_ground_r8 = 'SI_GRND_R8' - character(*), parameter :: site_class_pft_r8 = 'SI_SCPF_R8' + character(*), parameter :: site_size_pft_r8 = 'SI_SCPF_R8' character(*), parameter :: patch_int = 'PA_INT' integer, parameter :: fates_num_dimension_types = 4 diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index b8a94638..77aace9d 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -202,7 +202,7 @@ module FatesHistoryInterfaceMod procedure, private :: define_history_vars procedure, private :: set_history_var procedure, private :: init_dim_kinds_maps - procedure, private :: set_dim_indicies + procedure, private :: set_dim_indices procedure, private :: flush_hvars procedure, private :: set_patch_index @@ -289,8 +289,8 @@ end subroutine SetThreadBounds ! =================================================================================== subroutine assemble_valid_output_types(this) - use FatesHistoryDimensionMod, only : patch_r8, patch_ground_r8, patch_class_pft_r8 - use FatesHistoryDimensionMod, only : site_r8, site_ground_r8, site_class_pft_r8 + use FatesHistoryDimensionMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 + use FatesHistoryDimensionMod, only : site_r8, site_ground_r8, site_size_pft_r8 implicit none @@ -298,27 +298,27 @@ subroutine assemble_valid_output_types(this) call this%init_dim_kinds_maps() - call this%set_dim_indicies(patch_r8, 1, this%patch_index()) + call this%set_dim_indices(patch_r8, 1, this%patch_index()) - call this%set_dim_indicies(site_r8, 1, this%column_index()) + call this%set_dim_indices(site_r8, 1, this%column_index()) - call this%set_dim_indicies(patch_ground_r8, 1, this%patch_index()) - call this%set_dim_indicies(patch_ground_r8, 2, this%levgrnd_index()) + call this%set_dim_indices(patch_ground_r8, 1, this%patch_index()) + call this%set_dim_indices(patch_ground_r8, 2, this%levgrnd_index()) - call this%set_dim_indicies(site_ground_r8, 1, this%column_index()) - call this%set_dim_indicies(site_ground_r8, 2, this%levgrnd_index()) + call this%set_dim_indices(site_ground_r8, 1, this%column_index()) + call this%set_dim_indices(site_ground_r8, 2, this%levgrnd_index()) - call this%set_dim_indicies(patch_class_pft_r8, 1, this%patch_index()) - call this%set_dim_indicies(patch_class_pft_r8, 2, this%levscpf_index()) + call this%set_dim_indices(patch_size_pft_r8, 1, this%patch_index()) + call this%set_dim_indices(patch_size_pft_r8, 2, this%levscpf_index()) - call this%set_dim_indicies(site_class_pft_r8, 1, this%column_index()) - call this%set_dim_indicies(site_class_pft_r8, 2, this%levscpf_index()) + call this%set_dim_indices(site_size_pft_r8, 1, this%column_index()) + call this%set_dim_indices(site_size_pft_r8, 2, this%levscpf_index()) end subroutine assemble_valid_output_types ! =================================================================================== - subroutine set_dim_indicies(this, dk_name, idim, dim_index) + subroutine set_dim_indices(this, dk_name, idim, dim_index) use FatesHistoryVariableKindMod , only : iotype_index @@ -355,7 +355,7 @@ subroutine set_dim_indicies(this, dk_name, idim, dim_index) this%dim_kinds(ityp)%dimsize(idim) = this%dim_bounds(dim_index)%upper_bound - & this%dim_bounds(dim_index)%lower_bound + 1 - end subroutine set_dim_indicies + end subroutine set_dim_indices ! ======================================================================= subroutine set_patch_index(this, index) @@ -504,8 +504,8 @@ subroutine init_dim_kinds_maps(this) ! number of entries listed here. ! ! ---------------------------------------------------------------------------------- - use FatesHistoryDimensionMod, only : patch_r8, patch_ground_r8, patch_class_pft_r8, & - site_r8, site_ground_r8, site_class_pft_r8 + use FatesHistoryDimensionMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8, & + site_r8, site_ground_r8, site_size_pft_r8 implicit none @@ -529,7 +529,7 @@ subroutine init_dim_kinds_maps(this) ! patch x size-class/pft index = index + 1 - call this%dim_kinds(index)%Init(patch_class_pft_r8, 2) + call this%dim_kinds(index)%Init(patch_size_pft_r8, 2) ! site x ground index = index + 1 @@ -537,7 +537,7 @@ subroutine init_dim_kinds_maps(this) ! site x size-class/pft index = index + 1 - call this%dim_kinds(index)%Init(site_class_pft_r8, 2) + call this%dim_kinds(index)%Init(site_size_pft_r8, 2) ! FIXME(bja, 2016-10) assert(index == fates_num_dim_kinds) end subroutine init_dim_kinds_maps @@ -1128,8 +1128,8 @@ subroutine define_history_vars(this, initialize_variables) ! a real. The applied flush value will use the NINT() intrinsic function ! --------------------------------------------------------------------------------- - use FatesHistoryDimensionMod, only : patch_r8, patch_ground_r8, patch_class_pft_r8, & - site_r8, site_ground_r8, site_class_pft_r8 + use FatesHistoryDimensionMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8, & + site_r8, site_ground_r8, site_size_pft_r8 implicit none class(fates_history_interface_type), intent(inout) :: this @@ -1354,130 +1354,130 @@ subroutine define_history_vars(this, initialize_variables) call this%set_history_var(vname='GPP_SCPF', units='kgC/m2/yr', & long='gross primary production', use_default='inactive', & - avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_gpp_si_scpf ) call this%set_history_var(vname='NPP_SCPF', units='kgC/m2/yr', & long='total net primary production', use_default='inactive', & - avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_totl_si_scpf ) call this%set_history_var(vname='NPP_LEAF_SCPF', units='kgC/m2/yr', & long='NPP flux into leaves', use_default='inactive', & - avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_leaf_si_scpf ) call this%set_history_var(vname='NPP_SEED_SCPF', units='kgC/m2/yr', & long='NPP flux into seeds', use_default='inactive', & - avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_seed_si_scpf ) call this%set_history_var(vname='NPP_FNRT_SCPF', units='kgC/m2/yr', & long='NPP flux into fine roots', use_default='inactive', & - avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_fnrt_si_scpf ) call this%set_history_var(vname='NPP_BGSW_SCPF', units='kgC/m2/yr', & long='NPP flux into below-ground sapwood', use_default='inactive', & - avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_bgsw_si_scpf ) call this%set_history_var(vname='NPP_BGDW_SCPF', units='kgC/m2/yr', & long='NPP flux into below-ground deadwood', use_default='inactive', & - avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_bgdw_si_scpf ) call this%set_history_var(vname='NPP_AGSW_SCPF', units='kgC/m2/yr', & long='NPP flux into above-ground sapwood', use_default='inactive', & - avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_agsw_si_scpf ) call this%set_history_var(vname = 'NPP_AGDW_SCPF', units='kgC/m2/yr', & long='NPP flux into above-ground deadwood', use_default='inactive', & - avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_agdw_si_scpf ) call this%set_history_var(vname = 'NPP_STOR_SCPF', units='kgC/m2/yr', & long='NPP flux into storage', use_default='inactive', & - avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_stor_si_scpf ) call this%set_history_var(vname='DDBH_SCPF', units = 'cm/yr/ha', & long='diameter growth increment and pft/size',use_default='inactive', & - avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ddbh_si_scpf ) call this%set_history_var(vname='BA_SCPF', units = 'm2/ha', & long='basal area by patch and pft/size', use_default='inactive', & - avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ba_si_scpf ) call this%set_history_var(vname='NPLANT_SCPF', units = 'N/ha', & long='stem number density by patch and pft/size', use_default='inactive', & - avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_si_scpf ) call this%set_history_var(vname='M1_SCPF', units = 'N/ha/yr', & long='background mortality count by patch and pft/size', use_default='inactive', & - avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m1_si_scpf ) call this%set_history_var(vname='M2_SCPF', units = 'N/ha/yr', & long='hydraulic mortality count by patch and pft/size',use_default='inactive', & - avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m2_si_scpf ) call this%set_history_var(vname='M3_SCPF', units = 'N/ha/yr', & long='carbon starvation mortality count by patch and pft/size', use_default='inactive', & - avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m3_si_scpf ) call this%set_history_var(vname='M4_SCPF', units = 'N/ha/yr', & long='impact mortality count by patch and pft/size',use_default='inactive', & - avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m4_si_scpf ) call this%set_history_var(vname='M5_SCPF', units = 'N/ha/yr', & long='fire mortality count by patch and pft/size',use_default='inactive', & - avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m5_si_scpf ) ! Size structured diagnostics that require rapid updates (upfreq=2) call this%set_history_var(vname='AR_SCPF',units = 'kgC/m2/yr', & long='total autotrophic respiration per m2 per year',use_default='inactive',& - avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_ar_si_scpf ) call this%set_history_var(vname='AR_GROW_SCPF',units = 'kgC/m2/yr', & long='growth autotrophic respiration per m2 per year',use_default='inactive',& - avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_ar_grow_si_scpf ) call this%set_history_var(vname='AR_MAINT_SCPF',units = 'kgC/m2/yr', & long='maintenance autotrophic respiration per m2 per year',use_default='inactive',& - avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_ar_maint_si_scpf ) call this%set_history_var(vname='AR_DARKM_SCPF',units = 'kgC/m2/yr', & long='dark portion of maintenance autotrophic respiration per m2 per year',use_default='inactive',& - avgflag='A', vtype=site_class_pft_r8,hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8,hlms='CLM:ALM', flushval=0.0_r8, & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_ar_darkm_si_scpf ) call this%set_history_var(vname='AR_AGSAPM_SCPF',units = 'kgC/m2/yr', & long='above-ground sapwood maintenance autotrophic respiration per m2 per year',use_default='inactive',& - avgflag='A', vtype=site_class_pft_r8,hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8,hlms='CLM:ALM', flushval=0.0_r8, & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_ar_agsapm_si_scpf ) call this%set_history_var(vname='AR_CROOTM_SCPF',units = 'kgC/m2/yr', & long='below-ground sapwood maintenance autotrophic respiration per m2 per year',use_default='inactive',& - avgflag='A', vtype=site_class_pft_r8,hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8,hlms='CLM:ALM', flushval=0.0_r8, & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_ar_crootm_si_scpf ) call this%set_history_var(vname='AR_FROOTM_SCPF',units = 'kgC/m2/yr', & long='fine root maintenance autotrophic respiration per m2 per year',use_default='inactive',& - avgflag='A', vtype=site_class_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_ar_frootm_si_scpf ) diff --git a/main/FatesHistoryVariableType.F90 b/main/FatesHistoryVariableType.F90 index a2b41f05..21895043 100644 --- a/main/FatesHistoryVariableType.F90 +++ b/main/FatesHistoryVariableType.F90 @@ -42,8 +42,8 @@ subroutine Init(this, vname, units, long, use_default, & vtype, avgflag, flushval, upfreq, num_dim_kinds, dim_kinds, dim_bounds) use FatesHistoryDimensionMod, only : fates_history_dimension_type - use FatesHistoryDimensionMod, only : patch_r8, patch_ground_r8, patch_class_pft_r8 - use FatesHistoryDimensionMod, only : site_r8, site_ground_r8, site_class_pft_r8 + use FatesHistoryDimensionMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 + use FatesHistoryDimensionMod, only : site_r8, site_ground_r8, site_size_pft_r8 use FatesHistoryVariableKindMod, only : iotype_index @@ -106,7 +106,7 @@ subroutine Init(this, vname, units, long, use_default, & allocate(this%r82d(lb1:ub1, lb2:ub2)) this%r82d(:,:) = flushval - case(patch_class_pft_r8) + case(patch_size_pft_r8) allocate(this%r82d(lb1:ub1, lb2:ub2)) this%r82d(:,:) = flushval @@ -114,7 +114,7 @@ subroutine Init(this, vname, units, long, use_default, & allocate(this%r82d(lb1:ub1, lb2:ub2)) this%r82d(:,:) = flushval - case(site_class_pft_r8) + case(site_size_pft_r8) allocate(this%r82d(lb1:ub1, lb2:ub2)) this%r82d(:,:) = flushval @@ -181,8 +181,8 @@ end subroutine GetBounds subroutine Flush(this, thread, dim_bounds, dim_kinds) use FatesHistoryDimensionMod, only : fates_history_dimension_type - use FatesHistoryDimensionMod, only : patch_r8, patch_ground_r8, patch_class_pft_r8 - use FatesHistoryDimensionMod, only : site_r8, site_ground_r8, site_class_pft_r8, patch_int + use FatesHistoryDimensionMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 + use FatesHistoryDimensionMod, only : site_r8, site_ground_r8, site_size_pft_r8, patch_int implicit none @@ -202,11 +202,11 @@ subroutine Flush(this, thread, dim_bounds, dim_kinds) this%r81d(lb1:ub1) = this%flushval case(patch_ground_r8) this%r82d(lb1:ub1, lb2:ub2) = this%flushval - case(patch_class_pft_r8) + case(patch_size_pft_r8) this%r82d(lb1:ub1, lb2:ub2) = this%flushval case(site_ground_r8) this%r82d(lb1:ub1, lb2:ub2) = this%flushval - case(site_class_pft_r8) + case(site_size_pft_r8) this%r82d(lb1:ub1, lb2:ub2) = this%flushval case(patch_int) this%int1d(lb1:ub1) = nint(this%flushval) From 65ef98405273d54509310a6d974d4c84bc8387a8 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Sun, 13 Nov 2016 15:14:06 -0700 Subject: [PATCH 237/437] Intial re-factoring of restarts to have object like variable, dimension and variable-kinds like history output has. This pass has not performed any checking, nor has it evaluated the call sequence or implemented updating or setting the array spaces. --- main/FatesHistoryInterfaceMod.F90 | 59 +++++++++---------- main/FatesHistoryVariableType.F90 | 32 +++++----- ...ensionMod.F90 => FatesIODimensionsMod.F90} | 38 +++++++----- ...KindMod.F90 => FatesIOVariableKindMod.F90} | 32 +++++++--- 4 files changed, 88 insertions(+), 73 deletions(-) rename main/{FatesHistoryDimensionMod.F90 => FatesIODimensionsMod.F90} (75%) rename main/{FatesHistoryVarKindMod.F90 => FatesIOVariableKindMod.F90} (66%) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 77aace9d..ec8c9813 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -5,10 +5,9 @@ module FatesHistoryInterfaceMod use FatesConstantsMod, only : fates_avg_flag_length, fates_short_string_length, fates_long_string_length use FatesGlobals , only : fates_log - use FatesHistoryDimensionMod, only : fates_history_dimension_type, fates_num_dimension_types - use FatesHistoryVariableKindMod, only : fates_history_variable_kind_type + use FatesIODimensionsMod, only : fates_io_dimension_type + use FatesIOVariableKindMod, only : fates_io_variable_kind_type use FatesHistoryVariableType, only : fates_history_variable_type - use EDTypesMod , only : cp_hio_ignore_val ! FIXME(bja, 2016-10) need to remove CLM dependancy @@ -135,19 +134,11 @@ module FatesHistoryInterfaceMod integer, private :: ih_ar_crootm_si_scpf integer, private :: ih_ar_frootm_si_scpf + ! The number of variable dim/kind types we have defined (static) - integer, parameter :: fates_num_dim_kinds = 6 - - type, public :: fates_bounds_type - integer :: patch_begin - integer :: patch_end - integer :: column_begin - integer :: column_end - integer :: ground_begin - integer :: ground_end - integer :: pft_class_begin - integer :: pft_class_end - end type fates_bounds_type + integer, parameter :: fates_history_num_dimensions = 4 + integer, parameter :: fates_history_num_dim_kinds = 6 + ! This structure is allocated by thread, and must be calculated after the FATES @@ -169,13 +160,13 @@ module FatesHistoryInterfaceMod ! Instanteat one registry of the different dimension/kinds (dk) ! All output variables will have a pointer to one of these dk's - type(fates_history_variable_kind_type) :: dim_kinds(fates_num_dim_kinds) + type(fates_io_variable_kind_type) :: dim_kinds(fates_history_num_dim_kinds) ! This is a structure that explains where FATES patch boundaries ! on each thread point to in the host IO array, this structure is ! allocated by number of threads. This could be dynamically ! allocated, but is unlikely to change...? - type(fates_history_dimension_type) :: dim_bounds(fates_num_dimension_types) + type(fates_io_dimension_type) :: dim_bounds(fates_history_num_dimensions) type(iovar_map_type), pointer :: iovar_map(:) @@ -185,7 +176,7 @@ module FatesHistoryInterfaceMod procedure, public :: Init procedure, public :: SetThreadBounds procedure, public :: initialize_history_vars - procedure, public :: assemble_valid_output_types + procedure, public :: assemble_history_output_types procedure, public :: update_history_dyn procedure, public :: update_history_prod @@ -220,7 +211,8 @@ module FatesHistoryInterfaceMod subroutine Init(this, num_threads, fates_bounds) - use FatesHistoryDimensionMod, only : patch, column, levgrnd, levscpf + use FatesIODimensionsMod, only : patch, column, levgrnd, levscpf + use FatesIODimensionsMod, only : fates_bounds_type implicit none @@ -259,6 +251,8 @@ end subroutine Init ! ====================================================================== subroutine SetThreadBounds(this, thread_index, thread_bounds) + use FatesIODimensionsMod, only : fates_bounds_type + implicit none class(fates_history_interface_type), intent(inout) :: this @@ -287,10 +281,10 @@ subroutine SetThreadBounds(this, thread_index, thread_bounds) end subroutine SetThreadBounds ! =================================================================================== - subroutine assemble_valid_output_types(this) + subroutine assemble_history_output_types(this) - use FatesHistoryDimensionMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 - use FatesHistoryDimensionMod, only : site_r8, site_ground_r8, site_size_pft_r8 + use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 + use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8 implicit none @@ -314,13 +308,13 @@ subroutine assemble_valid_output_types(this) call this%set_dim_indices(site_size_pft_r8, 1, this%column_index()) call this%set_dim_indices(site_size_pft_r8, 2, this%levscpf_index()) - end subroutine assemble_valid_output_types + end subroutine assemble_history_output_types ! =================================================================================== subroutine set_dim_indices(this, dk_name, idim, dim_index) - use FatesHistoryVariableKindMod , only : iotype_index + use FatesIOVariableKindMod , only : iotype_index implicit none @@ -334,7 +328,7 @@ subroutine set_dim_indices(this, dk_name, idim, dim_index) ! local integer :: ityp - ityp = iotype_index(trim(dk_name), fates_num_dim_kinds, this%dim_kinds) + ityp = iotype_index(trim(dk_name), fates_history_num_dim_kinds, this%dim_kinds) ! First check to see if the dimension is allocated if (this%dim_kinds(ityp)%ndims < idim) then @@ -479,7 +473,7 @@ subroutine set_history_var(this, vname, units, long, use_default, avgflag, vtype if (initialize) then call this%hvars(ivar)%Init(vname, units, long, use_default, & - vtype, avgflag, flushval, upfreq, fates_num_dim_kinds, this%dim_kinds, & + vtype, avgflag, flushval, upfreq, fates_history_num_dim_kinds, this%dim_kinds, & this%dim_bounds) end if else @@ -504,8 +498,8 @@ subroutine init_dim_kinds_maps(this) ! number of entries listed here. ! ! ---------------------------------------------------------------------------------- - use FatesHistoryDimensionMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8, & - site_r8, site_ground_r8, site_size_pft_r8 + use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 + use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8 implicit none @@ -539,7 +533,7 @@ subroutine init_dim_kinds_maps(this) index = index + 1 call this%dim_kinds(index)%Init(site_size_pft_r8, 2) - ! FIXME(bja, 2016-10) assert(index == fates_num_dim_kinds) + ! FIXME(bja, 2016-10) assert(index == fates_history_num_dim_kinds) end subroutine init_dim_kinds_maps ! ======================================================================= @@ -548,7 +542,7 @@ subroutine update_history_cbal(this,nc,nsites,sites) use EDtypesMod , only : ed_site_type ! Arguments - class(fates_history_interface_type) :: this + class(fates_history_interface_type) :: this integer , intent(in) :: nc ! clump index integer , intent(in) :: nsites type(ed_site_type) , intent(inout), target :: sites(nsites) @@ -1128,8 +1122,8 @@ subroutine define_history_vars(this, initialize_variables) ! a real. The applied flush value will use the NINT() intrinsic function ! --------------------------------------------------------------------------------- - use FatesHistoryDimensionMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8, & - site_r8, site_ground_r8, site_size_pft_r8 + use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 + use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8 implicit none class(fates_history_interface_type), intent(inout) :: this @@ -1539,6 +1533,7 @@ subroutine define_history_vars(this, initialize_variables) end subroutine define_history_vars + ! ==================================================================================== ! DEPRECATED, TRANSITIONAL OR FUTURE CODE SECTION ! ==================================================================================== diff --git a/main/FatesHistoryVariableType.F90 b/main/FatesHistoryVariableType.F90 index 21895043..44d64586 100644 --- a/main/FatesHistoryVariableType.F90 +++ b/main/FatesHistoryVariableType.F90 @@ -2,7 +2,7 @@ module FatesHistoryVariableType use FatesConstantsMod, only : r8 => fates_r8 use FatesGlobals, only : fates_log - use FatesHistoryVariableKindMod, only : fates_history_variable_kind_type + use FatesIOVariableKindMod, only : fates_io_variable_kind_type implicit none @@ -41,11 +41,11 @@ module FatesHistoryVariableType subroutine Init(this, vname, units, long, use_default, & vtype, avgflag, flushval, upfreq, num_dim_kinds, dim_kinds, dim_bounds) - use FatesHistoryDimensionMod, only : fates_history_dimension_type - use FatesHistoryDimensionMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 - use FatesHistoryDimensionMod, only : site_r8, site_ground_r8, site_size_pft_r8 + use FatesIODimensionsMod, only : fates_io_dimension_type - use FatesHistoryVariableKindMod, only : iotype_index + use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 + use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8 + use FatesIOVariableKindMod, only : iotype_index implicit none @@ -59,8 +59,8 @@ subroutine Init(this, vname, units, long, use_default, & real(r8), intent(in) :: flushval ! If the type is an int we will round with nint integer, intent(in) :: upfreq integer, intent(in) :: num_dim_kinds - type(fates_history_dimension_type), intent(in) :: dim_bounds(:) - type(fates_history_variable_kind_type), intent(inout) :: dim_kinds(:) + type(fates_io_dimension_type), intent(in) :: dim_bounds(:) + type(fates_io_variable_kind_type), intent(inout) :: dim_kinds(:) integer :: dk_index integer :: lb1, ub1, lb2, ub2 @@ -131,14 +131,14 @@ end subroutine Init subroutine GetBounds(this, thread, dim_bounds, dim_kinds, lb1, ub1, lb2, ub2) - use FatesHistoryDimensionMod, only : fates_history_dimension_type + use FatesIODimensionsMod, only : fates_io_dimension_type implicit none class(fates_history_variable_type), intent(inout) :: this integer, intent(in) :: thread - class(fates_history_dimension_type), intent(in) :: dim_bounds(:) - type(fates_history_variable_kind_type), intent(in) :: dim_kinds(:) + class(fates_io_dimension_type), intent(in) :: dim_bounds(:) + type(fates_io_variable_kind_type), intent(in) :: dim_kinds(:) integer, intent(out) :: lb1 integer, intent(out) :: ub1 integer, intent(out) :: lb2 @@ -178,18 +178,18 @@ subroutine GetBounds(this, thread, dim_bounds, dim_kinds, lb1, ub1, lb2, ub2) end subroutine GetBounds - subroutine Flush(this, thread, dim_bounds, dim_kinds) + subroutine Flush(this, thread, dim_bounds, dim_kinds) - use FatesHistoryDimensionMod, only : fates_history_dimension_type - use FatesHistoryDimensionMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 - use FatesHistoryDimensionMod, only : site_r8, site_ground_r8, site_size_pft_r8, patch_int + use FatesIODimensionsMod, only : fates_io_dimension_type + use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 + use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8, patch_int implicit none class(fates_history_variable_type), intent(inout) :: this integer, intent(in) :: thread - type(fates_history_dimension_type), intent(in) :: dim_bounds(:) - type(fates_history_variable_kind_type), intent(in) :: dim_kinds(:) + type(fates_io_dimension_type), intent(in) :: dim_bounds(:) + type(fates_io_variable_kind_type), intent(in) :: dim_kinds(:) integer :: lb1, ub1, lb2, ub2 diff --git a/main/FatesHistoryDimensionMod.F90 b/main/FatesIODimensionsMod.F90 similarity index 75% rename from main/FatesHistoryDimensionMod.F90 rename to main/FatesIODimensionsMod.F90 index d980f840..2267f0c9 100644 --- a/main/FatesHistoryDimensionMod.F90 +++ b/main/FatesIODimensionsMod.F90 @@ -1,19 +1,10 @@ -module FatesHistoryDimensionMod +module FatesIODimensionsMod use FatesConstantsMod, only : fates_short_string_length implicit none - ! FIXME(bja, 2016-10) do these need to be strings, or can they be integer enumerations? - character(*), parameter :: patch_r8 = 'PA_R8' - character(*), parameter :: patch_ground_r8 = 'PA_GRND_R8' - character(*), parameter :: patch_size_pft_r8 = 'PA_SCPF_R8' - character(*), parameter :: site_r8 = 'SI_R8' - character(*), parameter :: site_ground_r8 = 'SI_GRND_R8' - character(*), parameter :: site_size_pft_r8 = 'SI_SCPF_R8' - character(*), parameter :: patch_int = 'PA_INT' - - integer, parameter :: fates_num_dimension_types = 4 + character(*), parameter :: cohort = 'cohort' character(*), parameter :: patch = 'patch' character(*), parameter :: column = 'column' character(*), parameter :: levgrnd = 'levgrnd' @@ -34,9 +25,24 @@ module FatesHistoryDimensionMod ! number of size-class x pft dimension + type, public :: fates_bounds_type + integer :: patch_begin + integer :: patch_end + integer :: cohort_begin + integer :: cohort_end + integer :: column_begin + integer :: column_end + integer :: ground_begin + integer :: ground_end + integer :: pft_class_begin + integer :: pft_class_end + end type fates_bounds_type + + + ! This structure is not allocated by thread, but the upper and lower boundaries ! of the dimension for each thread is saved in the clump_ entry - type fates_history_dimension_type + type fates_io_dimension_type character(len=fates_short_string_length) :: name integer :: lower_bound integer :: upper_bound @@ -45,7 +51,7 @@ module FatesHistoryDimensionMod contains procedure, public :: Init procedure, public :: SetThreadBounds - end type fates_history_dimension_type + end type fates_io_dimension_type contains @@ -55,7 +61,7 @@ subroutine Init(this, name, num_threads, lower_bound, upper_bound) implicit none ! arguments - class(fates_history_dimension_type), intent(inout) :: this + class(fates_io_dimension_type), intent(inout) :: this character(len=*), intent(in) :: name integer, intent(in) :: num_threads integer, intent(in) :: lower_bound @@ -79,7 +85,7 @@ subroutine SetThreadBounds(this, thread_index, lower_bound, upper_bound) implicit none - class(fates_history_dimension_type), intent(inout) :: this + class(fates_io_dimension_type), intent(inout) :: this integer, intent(in) :: thread_index integer, intent(in) :: lower_bound integer, intent(in) :: upper_bound @@ -89,4 +95,4 @@ subroutine SetThreadBounds(this, thread_index, lower_bound, upper_bound) end subroutine SetThreadBounds -end module FatesHistoryDimensionMod +end module FatesIODimensionsMod diff --git a/main/FatesHistoryVarKindMod.F90 b/main/FatesIOVariableKindMod.F90 similarity index 66% rename from main/FatesHistoryVarKindMod.F90 rename to main/FatesIOVariableKindMod.F90 index fd8bd7a8..343d3b43 100644 --- a/main/FatesHistoryVarKindMod.F90 +++ b/main/FatesIOVariableKindMod.F90 @@ -1,18 +1,32 @@ -module FatesHistoryVariableKindMod +module FatesIOVariableKindMod use FatesConstantsMod, only : fates_long_string_length use FatesGlobals, only : fates_log - use FatesHistoryDimensionMod, only : fates_history_dimension_type + use FatesIODimensionsMod, only : fates_io_dimension_type implicit none + ! FIXME(bja, 2016-10) do these need to be strings, or can they be integer enumerations? + ! FIXME(rgk, 2016-11) these should probably be moved to varkindmod? + + character(*), parameter :: patch_r8 = 'PA_R8' + character(*), parameter :: patch_ground_r8 = 'PA_GRND_R8' + character(*), parameter :: patch_size_pft_r8 = 'PA_SCPF_R8' + character(*), parameter :: site_r8 = 'SI_R8' + character(*), parameter :: site_int = 'SI_INT' + character(*), parameter :: site_ground_r8 = 'SI_GRND_R8' + character(*), parameter :: site_size_pft_r8 = 'SI_SCPF_R8' + character(*), parameter :: patch_int = 'PA_INT' + character(*), parameter :: cohort_r8 = 'CO_R8' + character(*), parameter :: cohort_int = 'CO_INT' + ! NOTE(RGK, 2016) %active is not used yet. Was intended as a check on the HLM->FATES ! control parameter passing to ensure all active dimension types received all ! dimensioning specifications from the host, but we currently arent using those ! passing functions.. ! This structure is not multi-threaded - type fates_history_variable_kind_type + type fates_io_variable_kind_type character(len=fates_long_string_length) :: name ! String labelling this IO type integer :: ndims ! number of dimensions in this IO type integer, allocatable :: dimsize(:) ! The size of each dimension @@ -26,7 +40,7 @@ module FatesHistoryVariableKindMod procedure, public :: set_active procedure, public :: is_active - end type fates_history_variable_kind_type + end type fates_io_variable_kind_type @@ -39,7 +53,7 @@ subroutine Init(this, name, num_dims) implicit none - class(fates_history_variable_kind_type), intent(inout) :: this + class(fates_io_variable_kind_type), intent(inout) :: this character(*), intent(in) :: name integer, intent(in) :: num_dims @@ -56,13 +70,13 @@ end subroutine Init ! ======================================================================= subroutine set_active(this) implicit none - class(fates_history_variable_kind_type), intent(inout) :: this + class(fates_io_variable_kind_type), intent(inout) :: this this%active_ = .true. end subroutine set_active logical function is_active(this) implicit none - class(fates_history_variable_kind_type), intent(in) :: this + class(fates_io_variable_kind_type), intent(in) :: this is_active = this%active_ end function is_active @@ -73,7 +87,7 @@ function iotype_index(iotype_name, num_dim_kinds, dim_kinds) result(dk_index) ! argument character(len=*), intent(in) :: iotype_name integer, intent(in) :: num_dim_kinds - type(fates_history_variable_kind_type), intent(in) :: dim_kinds(:) + type(fates_io_variable_kind_type), intent(in) :: dim_kinds(:) ! local integer :: dk_index @@ -88,4 +102,4 @@ function iotype_index(iotype_name, num_dim_kinds, dim_kinds) result(dk_index) end function iotype_index -end module FatesHistoryVariableKindMod +end module FatesIOVariableKindMod From d054d3bfb347d9f0fde560d48b7475597527c4ce Mon Sep 17 00:00:00 2001 From: Rosie Fisher Date: Mon, 14 Nov 2016 13:50:12 -0700 Subject: [PATCH 238/437] Changes to namelist defaults to turn spitfire off --- biogeochem/EDCanopyStructureMod.F90 | 30 +- biogeochem/EDCohortDynamicsMod.F90 | 57 +- biogeophys/EDPhotosynthesisMod.F90 | 357 ++-- main/EDTypesMod.F90 | 22 +- main/FatesConstantsMod.F90 | 41 + main/FatesHistoryDimensionMod.F90 | 92 + ...IOMod.F90 => FatesHistoryInterfaceMod.F90} | 1510 +++++++++-------- main/FatesHistoryVarKindMod.F90 | 91 + main/FatesHistoryVariableType.F90 | 221 +++ 9 files changed, 1478 insertions(+), 943 deletions(-) create mode 100644 main/FatesHistoryDimensionMod.F90 rename main/{HistoryIOMod.F90 => FatesHistoryInterfaceMod.F90} (53%) create mode 100644 main/FatesHistoryVarKindMod.F90 create mode 100644 main/FatesHistoryVariableType.F90 diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index a0056056..5ce6d663 100755 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -546,7 +546,8 @@ subroutine canopy_structure( currentSite ) enddo if(((checkarea-currentPatch%area)) > 0.0001)then - write(fates_log(),*) 'problem with canopy area', checkarea,currentPatch%area,checkarea-currentPatch%area,i,z,missing_area + write(fates_log(),*) '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 @@ -658,6 +659,7 @@ subroutine canopy_summarization( nsites, sites, bc_in ) use FatesInterfaceMod , only : bc_in_type use EDPatchDynamicsMod , only : set_patchno + use EDCohortDynamicsMod , only : size_and_type_class_index use EDGrowthFunctionsMod , only : tree_lai, c_area use EDEcophysConType , only : EDecophyscon use EDtypesMod , only : area @@ -675,7 +677,6 @@ subroutine canopy_summarization( nsites, sites, bc_in ) integer :: ft ! plant functional type integer :: ifp integer :: patchn ! identification number for each patch. - real(r8) :: coarse_wood_frac real(r8) :: canopy_leaf_area ! total amount of leaf area in the vegetated area. m2. !---------------------------------------------------------------------- @@ -710,26 +711,13 @@ subroutine canopy_summarization( nsites, sites, bc_in ) do while(associated(currentCohort)) ft = currentCohort%pft - currentCohort%livestemn = currentCohort%bsw / pftcon%leafcn(currentCohort%pft) - - currentCohort%livecrootn = 0.0_r8 - - if (pftcon%woody(ft) == 1) then - coarse_wood_frac = 0.5_r8 - else - coarse_wood_frac = 0.0_r8 - end if - - if ( DEBUG ) then - write(fates_log(),*) 'canopy_summarization 724 ',currentCohort%livecrootn - write(fates_log(),*) 'canopy_summarization 725 ',currentCohort%br - write(fates_log(),*) 'canopy_summarization 726 ',coarse_wood_frac - write(fates_log(),*) 'canopy_summarization 727 ',pftcon%leafcn(ft) - endif - - currentCohort%livecrootn = currentCohort%br * coarse_wood_frac / pftcon%leafcn(ft) + - if ( DEBUG ) write(fates_log(),*) 'canopy_summarization 732 ',currentCohort%livecrootn + ! Update the cohort's index within the size bin classes + ! Update the cohort's index within the SCPF classification system + call size_and_type_class_index(currentCohort%dbh,currentCohort%pft, & + currentCohort%size_class,currentCohort%size_by_pft_class) + currentCohort%b = currentCohort%balive+currentCohort%bdead+currentCohort%bstore currentCohort%treelai = tree_lai(currentCohort) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index fca32709..cdca9ec6 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -27,7 +27,7 @@ module EDCohortDynamicsMod public :: sort_cohorts public :: copy_cohort public :: count_cohorts -! public :: countCohorts + public :: size_and_type_class_index public :: allocate_live_biomass logical, parameter :: DEBUG = .false. ! local debug flag @@ -92,6 +92,9 @@ subroutine create_cohort(patchptr, pft, nn, hite, dbh, & new_cohort%balive = balive new_cohort%bstore = bstore + call size_and_type_class_index(new_cohort%dbh,new_cohort%pft, & + new_cohort%size_class,new_cohort%size_by_pft_class) + if ( DEBUG ) write(iulog,*) 'EDCohortDyn I ',bstore if (new_cohort%dbh <= 0.0_r8 .or. new_cohort%n == 0._r8 .or. new_cohort%pft == 0 & @@ -290,6 +293,8 @@ subroutine nan_cohort(cc_p) ! ! !USES: use shr_infnan_mod, only : nan => shr_infnan_nan, assignment(=) + use FatesConstantsMod, only : fates_unset_int + ! ! !ARGUMENTS type (ed_cohort_type), intent(inout), target :: cc_p @@ -311,11 +316,13 @@ subroutine nan_cohort(cc_p) 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%pft = fates_unset_int ! pft number + currentCohort%indexnumber = fates_unset_int ! unique number for each cohort. (within clump?) + currentCohort%canopy_layer = fates_unset_int ! canopy status of cohort (1 = canopy, 2 = understorey, etc.) + currentCohort%NV = fates_unset_int ! Number of leaf layers: - + currentCohort%status_coh = fates_unset_int ! growth status of plant (2 = leaves on , 1 = leaves off) + currentCohort%size_class = fates_unset_int ! size class index + currentCohort%size_by_pft_class = fates_unset_int ! size by pft classification index currentCohort%n = nan ! number of individuals in cohort per 'area' (10000m2 default) currentCohort%dbh = nan ! 'diameter at breast height' in cm @@ -361,7 +368,7 @@ subroutine nan_cohort(cc_p) !RESPIRATION - currentCohort%rd = nan + currentCohort%rdark = 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 @@ -381,11 +388,6 @@ subroutine nan_cohort(cc_p) 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 @@ -423,7 +425,7 @@ subroutine zero_cohort(cc_p) currentCohort%NV = 0 currentCohort%status_coh = 0 - currentCohort%rd = 0._r8 + currentCohort%rdark = 0._r8 currentCohort%resp_m = 0._r8 currentCohort%resp_g = 0._r8 currentCohort%livestem_mr = 0._r8 @@ -1040,18 +1042,13 @@ subroutine copy_cohort( currentCohort,copyc ) n%npp_store = o%npp_store !RESPIRATION - n%rd = o%rd + n%rdark = o%rdark 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 @@ -1137,6 +1134,28 @@ function count_cohorts( currentPatch ) result ( backcount ) end function count_cohorts + ! ===================================================================================== + + subroutine size_and_type_class_index(dbh,pft,size_class,size_by_pft_class) + + use EDTypesMod, only: sclass_ed + use EDTypesMod, only: nlevsclass_ed + + ! Arguments + real(r8),intent(in) :: dbh + integer,intent(in) :: pft + integer,intent(out) :: size_class + integer,intent(out) :: size_by_pft_class + + size_class = count(dbh-sclass_ed.ge.0.0_r8) + + size_by_pft_class = (pft-1)*nlevsclass_ed+size_class + + return + end subroutine size_and_type_class_index + + + !-------------------------------------------------------------------------------------! ! function countCohorts( bounds, ed_allsites_inst ) result ( totNumCohorts ) ! diff --git a/biogeophys/EDPhotosynthesisMod.F90 b/biogeophys/EDPhotosynthesisMod.F90 index aecc4710..a9e6cf50 100644 --- a/biogeophys/EDPhotosynthesisMod.F90 +++ b/biogeophys/EDPhotosynthesisMod.F90 @@ -9,14 +9,14 @@ module EDPhotosynthesisMod ! ! !USES: ! - use shr_kind_mod , only : r8 => shr_kind_r8 - use shr_log_mod , only : errMsg => shr_log_errMsg - use abortutils , only : endrun - use clm_varctl , only : iulog + + use abortutils, only : endrun + use FatesGlobals, only : fates_log + use FatesConstantsMod, only : r8 => fates_r8 + use shr_log_mod , only : errMsg => shr_log_errMsg + implicit none private - ! - ! PUBLIC MEMBER FUNCTIONS: @@ -39,38 +39,55 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) ! 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 clm_varcon , only : rgas, tfrz, namep - use clm_varpar , only : nlevsoi, mxpft - use clm_varctl , only : iulog - use pftconMod , only : pftcon + use clm_varpar , only : mxpft ! THIS WILL BE DEPRECATED WHEN PARAMETER + ! READS ARE REFACTORED (RGK 10-13-2016) + use pftconMod , only : pftcon ! THIS WILL BE DEPRECATED WHEN PARAMETER + ! READS ARE REFACTORED (RGK 10-13-2016) use EDParamsMod , only : ED_val_grperc + use EDParamsMod , only : ED_val_ag_biomass 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 + use EDTypesMod , only : numpft_ed + use EDTypesMod , only : dinc_ed + use EDTypesMod , only : ed_patch_type + use EDTypesMod , only : ed_cohort_type + use EDTypesMod , only : ed_site_type + use EDTypesMod , only : numpft_ed + use EDTypesMod , only : numpatchespercol + use EDTypesMod , only : cp_numlevsoil + use EDTypesMod , only : cp_nlevcan + use EDTypesMod , only : cp_nclmax + use EDEcophysContype , only : EDecophyscon - use FatesInterfaceMod , only : bc_in_type,bc_out_type - use EDtypesMod , only : numpatchespercol, cp_nlevcan, cp_nclmax - use EDCanopyStructureMod,only: calc_areaindex - ! + use FatesInterfaceMod , only : bc_in_type + use FatesInterfaceMod , only : bc_out_type + + use EDCanopyStructureMod, only : calc_areaindex + + use FatesConstantsMod, only : umolC_to_kgC + use FatesConstantsMod, only : g_per_kg + use FatesConstantsMod, only : mg_per_g + use FatesConstantsMod, only : sec_per_min + use FatesConstantsMod, only : umol_per_mmol + use FatesConstantsMod, only : rgas => rgas_J_K_kmol + use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm + ! !ARGUMENTS: + ! ----------------------------------------------------------------------------------- integer,intent(in) :: nsites type(ed_site_type),intent(inout),target :: sites(nsites) type(bc_in_type),intent(in) :: bc_in(nsites) type(bc_out_type),intent(inout) :: bc_out(nsites) real(r8),intent(in) :: dtime - ! - ! !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. logical :: DEBUG = .false. @@ -84,8 +101,8 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) real(r8) :: lmr_z(cp_nclmax,mxpft,cp_nlevcan) ! initial slope of CO2 response curve (C4 plants) real(r8) :: rs_z(cp_nclmax,mxpft,cp_nlevcan) ! stomatal resistance s/m real(r8) :: gs_z(cp_nclmax,mxpft,cp_nlevcan) ! stomatal conductance m/s - - real(r8) :: ci(cp_nclmax,mxpft,cp_nlevcan) ! intracellular leaf CO2 (Pa) + + real(r8) :: ci ! intracellular leaf CO2 (Pa) real(r8) :: lnc(mxpft) ! leaf N concentration (gN leaf/m^2) real(r8) :: kc( numpatchespercol ) ! Michaelis-Menten constant for CO2 (Pa) @@ -148,7 +165,7 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) integer :: c,CL,f,s,iv,j,ps,ft,ifp ! 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) @@ -180,7 +197,6 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) real(r8) :: an(cp_nclmax,mxpft,cp_nlevcan) ! net leaf photosynthesis (umol CO2/m**2/s) real(r8) :: an_av(cp_nclmax,mxpft,cp_nlevcan) ! 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 @@ -188,15 +204,41 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) 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 real(r8) :: rscanopy real(r8) :: elai + + real(r8) :: live_stem_n ! Live stem (above-ground sapwood) nitrogen content (kgN/plant) + real(r8) :: live_croot_n ! Live coarse root (below-ground sapwood) nitrogen content (kgN/plant) + real(r8) :: froot_n ! Fine root nitrogen content (kgN/plant) + + ! Parameters + ! ----------------------------------------------------------------------- + ! Base maintenance respiration rate for plant tissues base_mr_20 + ! 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 + ! (gC/gN/s) + ! ------------------------------------------------------------------------ + + real(r8),parameter :: base_mr_20 = 2.525e-6_r8 + + ! maximum stomatal resistance [s/m] + real(r8),parameter :: rsmax0 = 2.e4_r8 + + ! First guess on ratio between intracellular co2 and the atmosphere + ! an iterator converges on actual + real(r8),parameter :: init_a2l_co2_c3 = 0.7_r8 + real(r8),parameter :: init_a2l_co2_c4 = 0.4_r8 + associate( & c3psn => pftcon%c3psn , & ! photosynthetic pathway: 0. = c4, 1. = c3 @@ -205,11 +247,9 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) woody => pftcon%woody , & ! Is vegetation woody or not? fnitr => pftcon%fnitr , & ! foliage nitrogen limitation factor (-) leafcn => pftcon%leafcn , & ! leaf C:N (gC/gN) + frootcn => pftcon%frootcn , & ! froot C:N (gc/gN) bb_slope => EDecophyscon%BB_slope ) ! slope of BB relationship - ! 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 @@ -226,7 +266,7 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) 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 + act25 = act25 * mg_per_g / sec_per_min ! Activation energy, from: ! Bernacchi et al (2001) Plant, Cell and Environment 24:253-259 @@ -371,14 +411,6 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) end if bbb(FT) = max (bbbopt(ps)*currentPatch%btran_ft(FT), 1._r8) - ! THIS CALL APPEARS TO BE REDUNDANT WITH LINE 650 (RGK) - if (nint(c3psn(FT)) == 1)then - ci(:,FT,:) = 0.7_r8 * bc_in(s)%cair_pa(ifp) - else - ci(:,FT,:) = 0.4_r8 * bc_in(s)%cair_pa(ifp) - end if - - ! Leaf nitrogen concentration at the top of the canopy (g N leaf / m**2 leaf) lnc(FT) = 1._r8 / (slatop(FT) * leafcn(FT)) @@ -390,7 +422,7 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) ! 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) = (2.59_r8 - 0.035_r8*min(max((t10(p)-tfrzc),11._r8),35._r8)) * vcmax25top(FT) jmax25top(FT) = 1.67_r8 * vcmax25top(FT) tpu25top(FT) = 0.167_r8 * vcmax25top(FT) @@ -409,13 +441,6 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) ! 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 @@ -423,7 +448,7 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) ! 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 + lmr25top(FT) = lmr25top(FT) * lnc(FT) / (umolC_to_kgC * g_per_kg) end do !FT @@ -435,7 +460,7 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) 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, & + write(fates_log(),*) '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,cp_nclmax currentPatch%present(CL,FT) = 1 @@ -520,10 +545,9 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) ! Leaf-level photosynthesis and stomatal conductance !==============================================================================! - rsmax0 = 2.e4_r8 - ! Leaf boundary layer conductance, umol/m**2/s + ! THESE HARD CODED CONVERSIONS NEED TO BE CALLED FROM GLOBAL CONSTANTS (RGK 10-13-2016) cf = bc_in(s)%forc_pbot/(rgas*1.e-3_r8*bc_in(s)%tgcm_pa(ifp))*1.e06_r8 gb = 1._r8/bc_in(s)%rb_pa(ifp) gb_mol = gb * cf @@ -542,7 +566,7 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) 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 ( DEBUG ) write(iulog,*) 'EDphoto 581 ',currentPatch%ed_parsun_z(CL,ft,iv) + if ( DEBUG ) write(fates_log(),*) 'EDphoto 581 ',currentPatch%ed_parsun_z(CL,ft,iv) if (currentPatch%ed_parsun_z(CL,FT,iv) <= 0._r8) then ! night time ac = 0._r8 @@ -557,12 +581,12 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) else ! day time !is there leaf area? - (NV can be larger than 0 with only stem area if deciduous) - if ( DEBUG ) write(iulog,*) 'EDphot 594 ',currentPatch%ed_laisun_z(CL,ft,iv) - if ( DEBUG ) write(iulog,*) 'EDphot 595 ',currentPatch%ed_laisha_z(CL,ft,iv) + if ( DEBUG ) write(fates_log(),*) 'EDphot 594 ',currentPatch%ed_laisun_z(CL,ft,iv) + if ( DEBUG ) write(fates_log(),*) 'EDphot 595 ',currentPatch%ed_laisha_z(CL,ft,iv) if(currentPatch%ed_laisun_z(CL,ft,iv)+currentPatch%ed_laisha_z(cl,ft,iv) > 0._r8)then - if ( DEBUG ) write(iulog,*) '600 in laisun, laisha loop ' + if ( DEBUG ) write(fates_log(),*) '600 in laisun, laisha loop ' !Loop aroun shaded and unshaded leaves currentPatch%psn_z(CL,ft,iv) = 0._r8 ! psn is accumulated across sun and shaded leaves. @@ -605,9 +629,9 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) ! THIS CALL APPEARS TO BE REDUNDANT WITH LINE 423 (RGK) if (nint(c3psn(FT)) == 1)then - ci(cl,ft,iv) = 0.7_r8 * bc_in(s)%cair_pa(ifp) + ci = init_a2l_co2_c3 * bc_in(s)%cair_pa(ifp) else - ci(cl,ft,iv) = 0.4_r8 * bc_in(s)%cair_pa(ifp) + ci = init_a2l_co2_c4 * bc_in(s)%cair_pa(ifp) end if niter = 0 @@ -617,15 +641,15 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) niter = niter + 1 ! Save old ci - ciold = ci(cl,ft,iv) + ciold = ci ! 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(ifp), 0._r8) / (ci(cl,ft,iv)+kc(ifp)* & + ac = vcmax_z(cl,ft,iv) * max(ci-co2_cp(ifp), 0._r8) / (ci+kc(ifp)* & (1._r8+bc_in(s)%oair_pa(ifp)/ko(ifp))) ! C3: RuBP-limited photosynthesis - aj = je * max(ci(cl,ft,iv)-co2_cp(ifp), 0._r8) / (4._r8*ci(cl,ft,iv)+8._r8*co2_cp(ifp)) + aj = je * max(ci-co2_cp(ifp), 0._r8) / (4._r8*ci+8._r8*co2_cp(ifp)) ! C3: Product-limited photosynthesis ap = 3._r8 * tpu_z(cl,ft,iv) else @@ -649,7 +673,7 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) end if ! C4: PEP carboxylase-limited (CO2-limited) - ap = kp_z(cl,ft,iv) * max(ci(cl,ft,iv), 0._r8) / bc_in(s)%forc_pbot + ap = kp_z(cl,ft,iv) * max(ci, 0._r8) / bc_in(s)%forc_pbot end if ! Gross photosynthesis smoothing calculations. First co-limit ac and aj. Then co-limit ap aquad = theta_cj(ps) @@ -683,14 +707,14 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) gs_mol = max(r1,r2) ! Derive new estimate for ci - ci(cl,ft,iv) = bc_in(s)%cair_pa(ifp) - an(cl,ft,iv) * bc_in(s)%forc_pbot * & + ci = bc_in(s)%cair_pa(ifp) - an(cl,ft,iv) * bc_in(s)%forc_pbot * & (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)/bc_in(s)%forc_pbot*1.e06_r8 <= 2.e-06_r8) .or. niter == 5) then + if ((abs(ci-ciold)/bc_in(s)%forc_pbot*1.e06_r8 <= 2.e-06_r8) .or. niter == 5) then exitloop = 1 end if end do !iteration loop @@ -703,14 +727,14 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) ! Final estimates for cs and ci (needed for early exit of ci iteration when an < 0) cs = bc_in(s)%cair_pa(ifp) - 1.4_r8/gb_mol * an(cl,ft,iv) * bc_in(s)%forc_pbot cs = max(cs,1.e-06_r8) - ci(cl,ft,iv) = bc_in(s)%cair_pa(ifp) - & + ci = bc_in(s)%cair_pa(ifp) - & an(cl,ft,iv) * bc_in(s)%forc_pbot * (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 - if ( DEBUG ) write(iulog,*) 'EDPhoto 737 ', currentPatch%psn_z(cl,ft,iv) - if ( DEBUG ) write(iulog,*) 'EDPhoto 738 ', ag(cl,ft,iv) - if ( DEBUG ) write(iulog,*) 'EDPhoto 739 ', currentPatch%f_sun(cl,ft,iv) + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 737 ', currentPatch%psn_z(cl,ft,iv) + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 738 ', ag(cl,ft,iv) + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 739 ', currentPatch%f_sun(cl,ft,iv) !accumulate total photosynthesis umol/m2 ground/s-1. weight per unit sun and sha leaves. if(sunsha == 1)then !sunlit @@ -733,15 +757,15 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) end if - if ( DEBUG ) write(iulog,*) 'EDPhoto 758 ', currentPatch%psn_z(cl,ft,iv) - if ( DEBUG ) write(iulog,*) 'EDPhoto 759 ', ag(cl,ft,iv) - if ( DEBUG ) write(iulog,*) 'EDPhoto 760 ', currentPatch%f_sun(cl,ft,iv) + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 758 ', currentPatch%psn_z(cl,ft,iv) + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 759 ', ag(cl,ft,iv) + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 760 ', currentPatch%f_sun(cl,ft,iv) ! Make sure iterative solution is correct if (gs_mol < 0._r8) then - write (iulog,*)'Negative stomatal conductance:' - write (iulog,*)'ifp,iv,gs_mol= ',ifp,iv,gs_mol - call endrun(msg=errmsg(sourcefile, __LINE__)) + write (fates_log(),*)'Negative stomatal conductance:' + write (fates_log(),*)'ifp,iv,gs_mol= ',ifp,iv,gs_mol + call endrun(msg=errMsg(sourcefile, __LINE__)) end if ! Compare with Ball-Berry model: gs_mol = m * an * hs/cs p + b @@ -749,8 +773,8 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) gs_mol_err = bb_slope(ft)*max(an(cl,ft,iv), 0._r8)*hs/cs*bc_in(s)%forc_pbot + 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 + write (fates_log(),*) 'CF: Ball-Berry error check - stomatal conductance error:' + write (fates_log(),*) gs_mol, gs_mol_err end if enddo !sunsha loop @@ -787,7 +811,7 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) currentCohort%npp_tstep = 0.0_r8 currentCohort%resp_tstep = 0.0_r8 currentCohort%gpp_tstep = 0.0_r8 - currentCohort%rd = 0.0_r8 + currentCohort%rdark = 0.0_r8 currentCohort%resp_m = 0.0_r8 ! Select canopy layer and PFT. @@ -798,34 +822,34 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) !------------------------------------------------------------------------------ ! Convert from umolC/m2leaf/s to umolC/indiv/s ( x canopy area x 1m2 leaf area). tree_area = currentCohort%c_area/currentCohort%n - if ( DEBUG ) write(iulog,*) 'EDPhoto 816 ', currentCohort%gpp_tstep - if ( DEBUG ) write(iulog,*) 'EDPhoto 817 ', currentPatch%psn_z(cl,ft,1:currentCohort%nv-1) - if ( DEBUG ) write(iulog,*) 'EDPhoto 818 ', cl - if ( DEBUG ) write(iulog,*) 'EDPhoto 819 ', ft - if ( DEBUG ) write(iulog,*) 'EDPhoto 820 ', currentCohort%nv - if ( DEBUG ) write(iulog,*) 'EDPhoto 821 ', currentPatch%elai_profile(cl,ft,1:currentCohort%nv-1) + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 816 ', currentCohort%gpp_tstep + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 817 ', currentPatch%psn_z(cl,ft,1:currentCohort%nv-1) + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 818 ', cl + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 819 ', ft + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 820 ', currentCohort%nv + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 821 ', currentPatch%elai_profile(cl,ft,1:currentCohort%nv-1) if (currentCohort%nv > 1) then !is there canopy, and are the leaves on? currentCohort%gpp_tstep = 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) * & + currentCohort%rdark = 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)+bc_in(s)%rb_pa(ifp)))) * tree_area - currentCohort%ts_net_uptake(1:currentCohort%nv) = an_av(cl,ft,1:currentCohort%nv) * 12E-9 * dtime + currentCohort%ts_net_uptake(1:currentCohort%nv) = an_av(cl,ft,1:currentCohort%nv) * umolC_to_kgC * dtime else currentCohort%gpp_tstep = 0.0_r8 - currentCohort%rd = 0.0_r8 + currentCohort%rdark = 0.0_r8 currentCohort%gscan = 0.0_r8 currentCohort%ts_net_uptake(:) = 0.0_r8 end if - if ( DEBUG ) write(iulog,*) 'EDPhoto 832 ', currentCohort%gpp_tstep + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 832 ', currentCohort%gpp_tstep laifrac = (currentCohort%treelai+currentCohort%treesai)-(currentCohort%nv-1)*dinc_ed @@ -833,104 +857,112 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) currentCohort%gscan = currentCohort%gscan+gs_cohort if ( DEBUG ) then - write(iulog,*) 'EDPhoto 868 ', currentCohort%gpp_tstep - write(iulog,*) 'EDPhoto 869 ', currentPatch%psn_z(cl,ft,currentCohort%nv) - write(iulog,*) 'EDPhoto 870 ', currentPatch%elai_profile(cl,ft,currentCohort%nv) - write(iulog,*) 'EDPhoto 871 ', laifrac - write(iulog,*) 'EDPhoto 872 ', tree_area - write(iulog,*) 'EDPhoto 873 ', currentCohort%nv, cl, ft + write(fates_log(),*) 'EDPhoto 868 ', currentCohort%gpp_tstep + write(fates_log(),*) 'EDPhoto 869 ', currentPatch%psn_z(cl,ft,currentCohort%nv) + write(fates_log(),*) 'EDPhoto 870 ', currentPatch%elai_profile(cl,ft,currentCohort%nv) + write(fates_log(),*) 'EDPhoto 871 ', laifrac + write(fates_log(),*) 'EDPhoto 872 ', tree_area + write(fates_log(),*) 'EDPhoto 873 ', currentCohort%nv, cl, ft endif currentCohort%gpp_tstep = currentCohort%gpp_tstep + currentPatch%psn_z(cl,ft,currentCohort%nv) * & currentPatch%elai_profile(cl,ft,currentCohort%nv) * laifrac * tree_area - if ( DEBUG ) write(iulog,*) 'EDPhoto 843 ', currentCohort%rd + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 843 ', currentCohort%rdark - currentCohort%rd = currentCohort%rd + lmr_z(cl,ft,currentCohort%nv) * & - currentPatch%elai_profile(cl,ft,currentCohort%nv) * laifrac * tree_area - !------------------------------------------------------------------------------ - ! 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) - !------------------------------------------------------------------------------ + currentCohort%rdark = currentCohort%rdark + lmr_z(cl,ft,currentCohort%nv) * & + currentPatch%elai_profile(cl,ft,currentCohort%nv) * laifrac * tree_area - br = 2.525e-6_r8 + ! Convert dark respiration from umol/plant/s to kgC/plant/s + currentCohort%rdark = currentCohort%rdark * umolC_to_kgC 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 ( DEBUG ) write(iulog,*) 'EDPhoto 874 ', currentCohort%livecroot_mr - if ( DEBUG ) write(iulog,*) 'EDPhoto 875 ', currentCohort%livecrootn + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! THIS CALCULATION SHOULD BE MOVED TO THE ALLOMETRY MODULE (RGK 10-8-2016) + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + currentCohort%bsw = EDecophyscon%sapwood_ratio(currentCohort%pft) * & + currentCohort%hite * (currentCohort%balive + currentCohort%laimemory)*leaf_frac - if (woody(FT) == 1) then - tc = q10**((bc_in(s)%t_veg_pa(ifp)-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) + ! Calculate the amount of nitrogen in the above and below ground + ! stem and root pools, used for maint resp + ! We are using the fine-root C:N ratio as an approximation for + ! the sapwood pools. + ! Units are in (kgN/plant) + ! ------------------------------------------------------------------ + live_stem_n = ED_val_ag_biomass * currentCohort%bsw / & + frootcn(currentCohort%pft) + live_croot_n = (1.0_r8-ED_val_ag_biomass) * currentCohort%bsw / & + frootcn(currentCohort%pft) + froot_n = currentCohort%br / frootcn(currentCohort%pft) + + + !------------------------------------------------------------------------------ + ! 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. + !------------------------------------------------------------------------------ - !convert from gC /indiv/s-1 to kgC/indiv/s-1 - ! TODO: CHANGE THAT 1000 to 1000.0_r8 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - currentCohort%livestem_mr = currentCohort%livestem_mr /1000 - currentCohort%livecroot_mr = currentCohort%livecroot_mr /1000 + ! Live stem MR (kgC/plant/s) (above ground sapwood) + ! ------------------------------------------------------------------ + if (woody(ft) == 1) then + tc = q10**((bc_in(s)%t_veg_pa(ifp)-tfrz - 20.0_r8)/10.0_r8) + ! kgC/s = kgN * kgC/kgN/s + currentCohort%livestem_mr = live_stem_n * base_mr_20 * tc 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. + ! Fine Root MR (kgC/plant/s) + ! ------------------------------------------------------------------ currentCohort%froot_mr = 0._r8 - - do j = 1,nlevsoi + do j = 1,cp_numlevsoil tcsoi = q10**((bc_in(s)%t_soisno_gl(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 + currentCohort%froot_mr = currentCohort%froot_mr + & + froot_n * base_mr_20 * tcsoi * currentPatch%rootfr_ft(ft,j) enddo - ! 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 + ! Coarse Root MR (kgC/plant/s) (below ground sapwood) + ! ------------------------------------------------------------------ + if (woody(ft) == 1) then + currentCohort%livecroot_mr = 0._r8 + do j = 1,cp_numlevsoil + ! Soil temperature used to adjust base rate of MR + tcsoi = q10**((bc_in(s)%t_soisno_gl(j)-tfrz - 20.0_r8)/10.0_r8) + currentCohort%livecroot_mr = currentCohort%livecroot_mr + & + live_croot_n * base_mr_20 * tcsoi * & + currentPatch%rootfr_ft(ft,j) + enddo + else + currentCohort%livecroot_mr = 0._r8 + end if - if ( DEBUG ) write(iulog,*) 'EDPhoto 904 ', currentCohort%resp_m - if ( DEBUG ) write(iulog,*) 'EDPhoto 905 ', currentCohort%rd - if ( DEBUG ) write(iulog,*) 'EDPhoto 906 ', currentCohort%livestem_mr - if ( DEBUG ) write(iulog,*) 'EDPhoto 907 ', currentCohort%livecroot_mr - if ( DEBUG ) write(iulog,*) 'EDPhoto 908 ', currentCohort%froot_mr + ! convert gpp from umol/indiv/s-1 to kgC/indiv/s-1 = X * 12 *10-6 * 10-3 - currentCohort%gpp_tstep = currentCohort%gpp_tstep * 12.0E-9 + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 904 ', currentCohort%resp_m + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 905 ', currentCohort%rdark + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 906 ', currentCohort%livestem_mr + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 907 ', currentCohort%livecroot_mr + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 908 ', currentCohort%froot_mr + + currentCohort%gpp_tstep = currentCohort%gpp_tstep * umolC_to_kgC ! 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 + currentCohort%resp_m = currentCohort%resp_m + currentCohort%rdark ! convert from kgC/indiv/s to kgC/indiv/timestep currentCohort%resp_m = currentCohort%resp_m * dtime currentCohort%gpp_tstep = currentCohort%gpp_tstep * dtime - if ( DEBUG ) write(iulog,*) 'EDPhoto 911 ', currentCohort%gpp_tstep - if ( DEBUG ) write(iulog,*) 'EDPhoto 912 ', currentCohort%resp_tstep - if ( DEBUG ) write(iulog,*) 'EDPhoto 913 ', currentCohort%resp_m + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 911 ', currentCohort%gpp_tstep + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 912 ', currentCohort%resp_tstep + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 913 ', currentCohort%resp_m - currentCohort%resp_g = ED_val_grperc(1) * (max(0._r8,currentCohort%gpp_tstep - currentCohort%resp_m)) + currentCohort%resp_g = ED_val_grperc(ft) * (max(0._r8,currentCohort%gpp_tstep - currentCohort%resp_m)) currentCohort%resp_tstep = currentCohort%resp_m + currentCohort%resp_g ! kgC/indiv/ts currentCohort%npp_tstep = currentCohort%gpp_tstep - currentCohort%resp_tstep ! kgC/indiv/ts @@ -949,7 +981,7 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) 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 + write(fates_log(),*) 'CF: pft 0 or n 0',currentCohort%pft,currentCohort%n,currentCohort%indexnumber currentCohort%gpp_tstep = 0._r8 currentCohort%resp_m = 0._r8 currentCohort%gscan = 0._r8 @@ -979,7 +1011,7 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) end if bc_out(s)%rssun_pa(ifp) = rscanopy bc_out(s)%rssha_pa(ifp) = rscanopy - bc_out(s)%gccanopy_pa(ifp) = 1.0_r8/rscanopy*cf/1000 !convert into umol m02 s-1 then mmol m-2 s-1. + bc_out(s)%gccanopy_pa(ifp) = 1.0_r8/rscanopy*cf/umol_per_mmol !convert into umol m-2 s-1 then mmol m-2 s-1. end if currentPatch => currentPatch%younger @@ -1004,7 +1036,8 @@ function ft1_f(tl, ha) result(ans) ! 7/23/16: Copied over from CLM by Ryan Knox ! !!USES - use clm_varcon , only : rgas, tfrz + use FatesConstantsMod, only : rgas => rgas_J_K_kmol + use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm ! ! !ARGUMENTS: real(r8), intent(in) :: tl ! leaf temperature in photosynthesis temperature function (K) @@ -1030,7 +1063,9 @@ function fth_f(tl,hd,se,scaleFactor) result(ans) ! Jinyun Tang separated it out from Photosynthesis, Feb. 07/2013 ! 7/23/16: Copied over from CLM by Ryan Knox ! - use clm_varcon , only : rgas, tfrz + use FatesConstantsMod, only : rgas => rgas_J_K_kmol + use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm + ! ! !ARGUMENTS: real(r8), intent(in) :: tl ! leaf temperature in photosynthesis temperature function (K) @@ -1058,8 +1093,11 @@ function fth25_f(hd,se)result(ans) ! Jinyun Tang separated it out from Photosynthesis, Feb. 07/2013 ! 7/23/16: Copied over from CLM by Ryan Knox ! - !!USES - use clm_varcon , only : rgas, tfrz + !!USES + + use FatesConstantsMod, only : rgas => rgas_J_K_kmol + use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm + ! ! !ARGUMENTS: real(r8), intent(in) :: hd ! deactivation energy in photosynthesis temperature function (J/mol) @@ -1090,7 +1128,6 @@ subroutine quadratic_f (a, b, c, r1, r2) ! 7/23/16: Copied over from CLM by Ryan Knox ! ! !USES: - implicit none ! ! !ARGUMENTS: real(r8), intent(in) :: a,b,c ! Terms for quadratic equation @@ -1101,8 +1138,8 @@ subroutine quadratic_f (a, b, c, r1, r2) !------------------------------------------------------------------------------ if (a == 0._r8) then - write (iulog,*) 'Quadratic solution error: a = ',a - call endrun(msg=errmsg(sourcefile, __LINE__)) + write (fates_log(),*) 'Quadratic solution error: a = ',a + call endrun(msg=errMsg(sourcefile, __LINE__)) end if if (b >= 0._r8) then diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 9f64aefa..d02891cb 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -189,6 +189,14 @@ module EDTypesMod real(r8) :: treesai ! stem area index of tree (total stem area (m2) / canopy area (m2) logical :: isnew ! flag to signify a new cohort, new cohorts have not experienced ! npp or mortality and should therefore not be fused or averaged + integer :: size_class ! An index that indicates which diameter size bin the cohort currently resides in + ! this is used for history output. We maintain this in the main cohort memory + ! because we don't want to continually re-calculate the cohort's position when + ! performing size diagnostics at high-frequency calls + integer :: size_by_pft_class ! An index that indicates the cohorts position of the joint size-class x functional + ! type classification. We also maintain this in the main cohort memory + ! because we don't want to continually re-calculate the cohort's position when + ! performing size diagnostics at high-frequency calls ! CARBON FLUXES real(r8) :: gpp ! GPP: kgC/indiv/year @@ -212,11 +220,13 @@ module EDTypesMod real(r8) :: year_net_uptake(cp_nlevcan) ! Net uptake of leaf layers: kgC/m2/year ! RESPIRATION COMPONENTS - real(r8) :: rd ! Dark respiration: umol/indiv/s + real(r8) :: rdark ! Dark respiration: kgC/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 + ! (Above ground) + real(r8) :: livecroot_mr ! Live stem maintenance respiration: kgC/indiv/s + ! (below ground) real(r8) :: froot_mr ! Live fine root maintenance respiration: kgC/indiv/s ! ALLOCATION @@ -239,9 +249,11 @@ module EDTypesMod real(r8) :: fmort ! fire mortality n/year ! 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 + ! ---------------------------------------------------------------------------------- + ! Nitrogen pools are not prognostic in the current implementation. + ! They are diagnosed during photosynthesis using a simple C2N parameter. Local values + ! used in that routine. + ! ---------------------------------------------------------------------------------- ! GROWTH DERIVIATIVES real(r8) :: dndt ! time derivative of cohort size : n/year diff --git a/main/FatesConstantsMod.F90 b/main/FatesConstantsMod.F90 index 244f6f65..3df36d6b 100644 --- a/main/FatesConstantsMod.F90 +++ b/main/FatesConstantsMod.F90 @@ -14,4 +14,45 @@ module FatesConstantsMod integer, parameter :: fates_short_string_length = 32 integer, parameter :: fates_long_string_length = 199 + ! Unset and various other 'special' values + integer, parameter :: fates_unset_int = -9999 + + ! Unit conversion constants: + + ! Conversion factor umols of Carbon -> kg of Carbon (1 mol = 12g) + ! We do not use umolC_per_kg because it is a non-terminating decimal + real(fates_r8), parameter :: umolC_to_kgC = 12.0E-9_fates_r8 + + ! Conversion factor: grams per kilograms + real(fates_r8), parameter :: g_per_kg = 1000.0_fates_r8 + + ! Conversion factor: miligrams per grams + real(fates_r8), parameter :: mg_per_g = 1000.0_fates_r8 + + ! Conversion factor: micromoles per milimole + real(fates_r8), parameter :: umol_per_mmol = 1000.0_fates_r8 + + ! Conversion factor: milimoles per mole + real(fates_r8), parameter :: mmol_per_mol = 1000.0_fates_r8 + + ! Conversion factor: micromoles per mole + real(fates_r8), parameter :: umol_per_mol = 1.0E6_fates_r8 + + + ! Conversion: secons per minute + real(fates_r8), parameter :: sec_per_min = 60.0_fates_r8 + + + ! Physical constants + + ! universal gas constant [J/K/kmol] + real(fates_r8), parameter :: rgas_J_K_kmol = 8314.4598_fates_r8 + + ! freezing point of water at 1 atm (K) + real(fates_r8), parameter :: t_water_freeze_k_1atm = 273.15_fates_r8 + + ! freezing point of water at triple point (K) + real(fates_r8), parameter :: t_water_freeze_k_triple = 273.16_fates_r8 + + end module FatesConstantsMod diff --git a/main/FatesHistoryDimensionMod.F90 b/main/FatesHistoryDimensionMod.F90 new file mode 100644 index 00000000..d980f840 --- /dev/null +++ b/main/FatesHistoryDimensionMod.F90 @@ -0,0 +1,92 @@ +module FatesHistoryDimensionMod + + use FatesConstantsMod, only : fates_short_string_length + + implicit none + + ! FIXME(bja, 2016-10) do these need to be strings, or can they be integer enumerations? + character(*), parameter :: patch_r8 = 'PA_R8' + character(*), parameter :: patch_ground_r8 = 'PA_GRND_R8' + character(*), parameter :: patch_size_pft_r8 = 'PA_SCPF_R8' + character(*), parameter :: site_r8 = 'SI_R8' + character(*), parameter :: site_ground_r8 = 'SI_GRND_R8' + character(*), parameter :: site_size_pft_r8 = 'SI_SCPF_R8' + character(*), parameter :: patch_int = 'PA_INT' + + integer, parameter :: fates_num_dimension_types = 4 + character(*), parameter :: patch = 'patch' + character(*), parameter :: column = 'column' + character(*), parameter :: levgrnd = 'levgrnd' + character(*), parameter :: levscpf = 'levscpf' + + ! patch = This is a structure that records where FATES patch boundaries + ! on each thread point to in the host IO array, this structure + ! is allocated by number of threads + + ! column = This is a structure that records where FATES column boundaries + ! on each thread point to in the host IO array, this structure + ! is allocated by number of threads + + ! ground = This is a structure that records the boundaries for the + ! ground level (includes rock) dimension + + ! levscpf = This is a structure that records the boundaries for the + ! number of size-class x pft dimension + + + ! This structure is not allocated by thread, but the upper and lower boundaries + ! of the dimension for each thread is saved in the clump_ entry + type fates_history_dimension_type + character(len=fates_short_string_length) :: name + integer :: lower_bound + integer :: upper_bound + integer, allocatable :: clump_lower_bound(:) ! lower bound of thread's portion of HIO array + integer, allocatable :: clump_upper_bound(:) ! upper bound of thread's portion of HIO array + contains + procedure, public :: Init + procedure, public :: SetThreadBounds + end type fates_history_dimension_type + +contains + + ! ===================================================================================== + subroutine Init(this, name, num_threads, lower_bound, upper_bound) + + implicit none + + ! arguments + class(fates_history_dimension_type), intent(inout) :: this + character(len=*), intent(in) :: name + integer, intent(in) :: num_threads + integer, intent(in) :: lower_bound + integer, intent(in) :: upper_bound + + this%name = trim(name) + this%lower_bound = lower_bound + this%upper_bound = upper_bound + + allocate(this%clump_lower_bound(num_threads)) + this%clump_lower_bound(:) = -1 + + allocate(this%clump_upper_bound(num_threads)) + this%clump_upper_bound(:) = -1 + + end subroutine Init + + ! ===================================================================================== + + subroutine SetThreadBounds(this, thread_index, lower_bound, upper_bound) + + implicit none + + class(fates_history_dimension_type), intent(inout) :: this + integer, intent(in) :: thread_index + integer, intent(in) :: lower_bound + integer, intent(in) :: upper_bound + + this%clump_lower_bound(thread_index) = lower_bound + this%clump_upper_bound(thread_index) = upper_bound + + end subroutine SetThreadBounds + +end module FatesHistoryDimensionMod diff --git a/main/HistoryIOMod.F90 b/main/FatesHistoryInterfaceMod.F90 similarity index 53% rename from main/HistoryIOMod.F90 rename to main/FatesHistoryInterfaceMod.F90 index b21edabe..77aace9d 100644 --- a/main/HistoryIOMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -1,10 +1,17 @@ -Module HistoryIOMod +module FatesHistoryInterfaceMod use FatesConstantsMod, only : r8 => fates_r8 use FatesConstantsMod, only : fates_avg_flag_length, fates_short_string_length, fates_long_string_length use FatesGlobals , only : fates_log + + use FatesHistoryDimensionMod, only : fates_history_dimension_type, fates_num_dimension_types + use FatesHistoryVariableKindMod, only : fates_history_variable_kind_type + use FatesHistoryVariableType, only : fates_history_variable_type + use EDTypesMod , only : cp_hio_ignore_val + + ! FIXME(bja, 2016-10) need to remove CLM dependancy use pftconMod , only : pftcon implicit none @@ -120,21 +127,27 @@ Module HistoryIOMod integer, private :: ih_m4_si_scpf integer, private :: ih_m5_si_scpf + integer, private :: ih_ar_si_scpf + integer, private :: ih_ar_grow_si_scpf + integer, private :: ih_ar_maint_si_scpf + integer, private :: ih_ar_darkm_si_scpf + integer, private :: ih_ar_agsapm_si_scpf + integer, private :: ih_ar_crootm_si_scpf + integer, private :: ih_ar_frootm_si_scpf ! The number of variable dim/kind types we have defined (static) - integer, parameter :: n_iovar_dk = 6 - - - ! This structure is not allocated by thread, but the upper and lower boundaries - ! of the dimension for each thread is saved in the clump_ entry - type iovar_dim_type - character(fates_short_string_length) :: name ! This should match the name of the dimension - integer :: lb ! lower bound - integer :: ub ! upper bound - integer,allocatable :: clump_lb(:) ! lower bound of thread's portion of HIO array - integer,allocatable :: clump_ub(:) ! upper bound of thread's portion of HIO array - end type iovar_dim_type - + integer, parameter :: fates_num_dim_kinds = 6 + + type, public :: fates_bounds_type + integer :: patch_begin + integer :: patch_end + integer :: column_begin + integer :: column_end + integer :: ground_begin + integer :: ground_end + integer :: pft_class_begin + integer :: pft_class_end + end type fates_bounds_type ! This structure is allocated by thread, and must be calculated after the FATES @@ -148,105 +161,394 @@ Module HistoryIOMod end type iovar_map_type - - ! This structure is not multi-threaded - type iovar_dimkind_type - character(fates_short_string_length) :: name ! String labelling this IO type - integer :: ndims ! number of dimensions in this IO type - integer, allocatable :: dimsize(:) ! The size of each dimension - logical :: active - type(iovar_dim_type), pointer :: dim1_ptr - type(iovar_dim_type), pointer :: dim2_ptr - end type iovar_dimkind_type - - - - ! This type is instanteated in the HLM-FATES interface (clmfates_interfaceMod.F90) - type iovar_def_type - character(len=fates_short_string_length) :: vname - character(len=fates_short_string_length) :: units - character(len=fates_long_string_length) :: long - character(len=fates_short_string_length) :: use_default ! States whether a variable should be turned - ! on the output files by default (active/inactive) - ! It is a good idea to set inactive for very large - ! or infrequently used output datasets - character(len=fates_short_string_length) :: vtype - character(len=fates_avg_flag_length) :: avgflag - integer :: upfreq ! Update frequency (this is for checks and flushing) - ! 1 = dynamics "dyn" (daily) - ! 2 = production "prod" (prob model tstep) - real(r8) :: flushval - type(iovar_dimkind_type),pointer :: iovar_dk_ptr - ! Pointers (only one of these is allocated per variable) - real(r8), pointer :: r81d(:) - real(r8), pointer :: r82d(:,:) - real(r8), pointer :: r83d(:,:,:) - integer, pointer :: int1d(:) - integer, pointer :: int2d(:,:) - integer, pointer :: int3d(:,:,:) - end type iovar_def_type - - - type, public :: fates_hio_interface_type + type, public :: fates_history_interface_type ! Instance of the list of history output varialbes - type(iovar_def_type), pointer :: hvars(:) - integer :: n_hvars + type(fates_history_variable_type), allocatable :: hvars(:) + integer, private :: num_history_vars_ ! Instanteat one registry of the different dimension/kinds (dk) ! All output variables will have a pointer to one of these dk's - type(iovar_dimkind_type), pointer :: iovar_dk(:) + type(fates_history_variable_kind_type) :: dim_kinds(fates_num_dim_kinds) ! This is a structure that explains where FATES patch boundaries - ! on each thread point to in the host IO array, this structure - ! is allocated by number of threads - type(iovar_dim_type) :: iopa_dim + ! on each thread point to in the host IO array, this structure is + ! allocated by number of threads. This could be dynamically + ! allocated, but is unlikely to change...? + type(fates_history_dimension_type) :: dim_bounds(fates_num_dimension_types) - ! This is a structure that explains where FATES patch boundaries - ! on each thread point to in the host IO array, this structure - ! is allocated by number of threads - type(iovar_dim_type) :: iosi_dim - - ! This is a structure that contains the boundaries for the - ! ground level (includes rock) dimension - type(iovar_dim_type) :: iogrnd_dim - - ! This is a structure that contains the boundaries for the - ! number of size-class x pft dimension - type(iovar_dim_type) :: ioscpf_dim - - type(iovar_map_type), pointer :: iovar_map(:) - + + integer, private :: patch_index_, column_index_, levgrnd_index_, levscpf_index_ contains + procedure, public :: Init + procedure, public :: SetThreadBounds + procedure, public :: initialize_history_vars + procedure, public :: assemble_valid_output_types + procedure, public :: update_history_dyn procedure, public :: update_history_prod procedure, public :: update_history_cbal - procedure, public :: define_history_vars - procedure, public :: set_history_var - procedure, public :: init_iovar_dk_maps - procedure, public :: iotype_index - procedure, public :: set_dim_ptrs - procedure, public :: get_hvar_bounds - procedure, public :: dim_init - procedure, public :: set_dim_thread_bounds + + ! 'get' methods used by external callers to access private read only data + procedure, public :: num_history_vars + procedure, public :: patch_index + procedure, public :: column_index + procedure, public :: levgrnd_index + procedure, public :: levscpf_index + + ! private work functions + procedure, private :: define_history_vars + procedure, private :: set_history_var + procedure, private :: init_dim_kinds_maps + procedure, private :: set_dim_indices procedure, private :: flush_hvars - end type fates_hio_interface_type + procedure, private :: set_patch_index + procedure, private :: set_column_index + procedure, private :: set_levgrnd_index + procedure, private :: set_levscpf_index + + end type fates_history_interface_type contains - ! =================================================================================== + ! ====================================================================== + + subroutine Init(this, num_threads, fates_bounds) + + use FatesHistoryDimensionMod, only : patch, column, levgrnd, levscpf + + implicit none + + class(fates_history_interface_type), intent(inout) :: this + integer, intent(in) :: num_threads + type(fates_bounds_type), intent(in) :: fates_bounds + + integer :: dim_count = 0 + + dim_count = dim_count + 1 + call this%set_patch_index(dim_count) + call this%dim_bounds(dim_count)%Init(patch, num_threads, & + fates_bounds%patch_begin, fates_bounds%patch_end) + + dim_count = dim_count + 1 + call this%set_column_index(dim_count) + call this%dim_bounds(dim_count)%Init(column, num_threads, & + fates_bounds%column_begin, fates_bounds%column_end) + + dim_count = dim_count + 1 + call this%set_levgrnd_index(dim_count) + call this%dim_bounds(dim_count)%Init(levgrnd, num_threads, & + fates_bounds%ground_begin, fates_bounds%ground_end) + + dim_count = dim_count + 1 + call this%set_levscpf_index(dim_count) + call this%dim_bounds(dim_count)%Init(levscpf, num_threads, & + fates_bounds%pft_class_begin, fates_bounds%pft_class_end) + ! FIXME(bja, 2016-10) assert(dim_count == FatesHistorydimensionmod::num_dimension_types) + + ! Allocate the mapping between FATES indices and the IO indices + allocate(this%iovar_map(num_threads)) + + end subroutine Init + + ! ====================================================================== + subroutine SetThreadBounds(this, thread_index, thread_bounds) + + implicit none + + class(fates_history_interface_type), intent(inout) :: this + + integer, intent(in) :: thread_index + type(fates_bounds_type), intent(in) :: thread_bounds + + integer :: index + + index = this%patch_index() + call this%dim_bounds(index)%SetThreadBounds(thread_index, & + thread_bounds%patch_begin, thread_bounds%patch_end) + + index = this%column_index() + call this%dim_bounds(index)%SetThreadBounds(thread_index, & + thread_bounds%column_begin, thread_bounds%column_end) + + index = this%levgrnd_index() + call this%dim_bounds(index)%SetThreadBounds(thread_index, & + thread_bounds%ground_begin, thread_bounds%ground_end) + + index = this%levscpf_index() + call this%dim_bounds(index)%SetThreadBounds(thread_index, & + thread_bounds%pft_class_begin, thread_bounds%pft_class_end) + + end subroutine SetThreadBounds - subroutine update_history_cbal(this,nc,nsites,sites) + ! =================================================================================== + subroutine assemble_valid_output_types(this) + + use FatesHistoryDimensionMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 + use FatesHistoryDimensionMod, only : site_r8, site_ground_r8, site_size_pft_r8 + + implicit none + + class(fates_history_interface_type), intent(inout) :: this + + call this%init_dim_kinds_maps() + + call this%set_dim_indices(patch_r8, 1, this%patch_index()) + + call this%set_dim_indices(site_r8, 1, this%column_index()) + + call this%set_dim_indices(patch_ground_r8, 1, this%patch_index()) + call this%set_dim_indices(patch_ground_r8, 2, this%levgrnd_index()) + + call this%set_dim_indices(site_ground_r8, 1, this%column_index()) + call this%set_dim_indices(site_ground_r8, 2, this%levgrnd_index()) + + call this%set_dim_indices(patch_size_pft_r8, 1, this%patch_index()) + call this%set_dim_indices(patch_size_pft_r8, 2, this%levscpf_index()) + + call this%set_dim_indices(site_size_pft_r8, 1, this%column_index()) + call this%set_dim_indices(site_size_pft_r8, 2, this%levscpf_index()) + + end subroutine assemble_valid_output_types + + ! =================================================================================== + + subroutine set_dim_indices(this, dk_name, idim, dim_index) + + use FatesHistoryVariableKindMod , only : iotype_index + + implicit none + + ! arguments + class(fates_history_interface_type), intent(inout) :: this + character(len=*), intent(in) :: dk_name + integer, intent(in) :: idim ! dimension index + integer, intent(in) :: dim_index + + + ! local + integer :: ityp + + ityp = iotype_index(trim(dk_name), fates_num_dim_kinds, this%dim_kinds) + + ! First check to see if the dimension is allocated + if (this%dim_kinds(ityp)%ndims < idim) then + write(fates_log(), *) 'Trying to define dimension size to a dim-type structure' + write(fates_log(), *) 'but the dimension index does not exist' + write(fates_log(), *) 'type: ',dk_name,' ndims: ',this%dim_kinds(ityp)%ndims,' input dim:',idim + stop + !end_run + end if + + if (idim == 1) then + this%dim_kinds(ityp)%dim1_index = dim_index + else if (idim == 2) then + this%dim_kinds(ityp)%dim2_index = dim_index + end if + + ! With the map, we can set the dimension size + this%dim_kinds(ityp)%dimsize(idim) = this%dim_bounds(dim_index)%upper_bound - & + this%dim_bounds(dim_index)%lower_bound + 1 + + end subroutine set_dim_indices + + ! ======================================================================= + subroutine set_patch_index(this, index) + implicit none + class(fates_history_interface_type), intent(inout) :: this + integer, intent(in) :: index + this%patch_index_ = index + end subroutine set_patch_index + + integer function patch_index(this) + implicit none + class(fates_history_interface_type), intent(in) :: this + patch_index = this%patch_index_ + end function patch_index + + ! ======================================================================= + subroutine set_column_index(this, index) + implicit none + class(fates_history_interface_type), intent(inout) :: this + integer, intent(in) :: index + this%column_index_ = index + end subroutine set_column_index + + integer function column_index(this) + implicit none + class(fates_history_interface_type), intent(in) :: this + column_index = this%column_index_ + end function column_index + + ! ======================================================================= + subroutine set_levgrnd_index(this, index) + implicit none + class(fates_history_interface_type), intent(inout) :: this + integer, intent(in) :: index + this%levgrnd_index_ = index + end subroutine set_levgrnd_index + + integer function levgrnd_index(this) + implicit none + class(fates_history_interface_type), intent(in) :: this + levgrnd_index = this%levgrnd_index_ + end function levgrnd_index + + ! ======================================================================= + subroutine set_levscpf_index(this, index) + implicit none + class(fates_history_interface_type), intent(inout) :: this + integer, intent(in) :: index + this%levscpf_index_ = index + end subroutine set_levscpf_index + + integer function levscpf_index(this) + implicit none + class(fates_history_interface_type), intent(in) :: this + levscpf_index = this%levscpf_index_ + end function levscpf_index + + ! ====================================================================================== + + subroutine flush_hvars(this,nc,upfreq_in) + + class(fates_history_interface_type) :: this + integer,intent(in) :: nc + integer,intent(in) :: upfreq_in + + integer :: ivar + type(fates_history_variable_type),pointer :: hvar + integer :: lb1,ub1,lb2,ub2 + + do ivar=1,ubound(this%hvars,1) + associate( hvar => this%hvars(ivar) ) + if (hvar%upfreq == upfreq_in) then ! Only flush variables with update on dynamics step + call hvar%Flush(nc, this%dim_bounds, this%dim_kinds) + end if + end associate + end do + + end subroutine flush_hvars + + + ! ===================================================================================== + + subroutine set_history_var(this, vname, units, long, use_default, avgflag, vtype, & + hlms, flushval, upfreq, ivar, initialize, index) + + use FatesUtilsMod, only : check_hlm_list + use EDTypesMod, only : cp_hlm_name + + implicit none + + ! arguments + class(fates_history_interface_type), intent(inout) :: this + character(len=*), intent(in) :: vname + character(len=*), intent(in) :: units + character(len=*), intent(in) :: long + character(len=*), intent(in) :: use_default + character(len=*), intent(in) :: avgflag + character(len=*), intent(in) :: vtype + character(len=*), intent(in) :: hlms + real(r8), intent(in) :: flushval ! IF THE TYPE IS AN INT WE WILL round with NINT + integer, intent(in) :: upfreq + logical, intent(in) :: initialize + integer, intent(inout) :: ivar + integer, intent(inout) :: index ! This is the index for the variable of + ! interest that is associated with an + ! explict name (for fast reference during update) + ! A zero is passed back when the variable is + ! not used + + ! locals + type(fates_history_variable_type), pointer :: hvar + integer :: ub1, lb1, ub2, lb2 ! Bounds for allocating the var + integer :: ityp + + logical :: write_var + + write_var = check_hlm_list(trim(hlms), trim(cp_hlm_name)) + if( write_var ) then + ivar = ivar+1 + index = ivar + + if (initialize) then + call this%hvars(ivar)%Init(vname, units, long, use_default, & + vtype, avgflag, flushval, upfreq, fates_num_dim_kinds, this%dim_kinds, & + this%dim_bounds) + end if + else + index = 0 + end if + + return + end subroutine set_history_var + + ! ==================================================================================== + + subroutine init_dim_kinds_maps(this) + + ! ---------------------------------------------------------------------------------- + ! This subroutine simply initializes the structures that define the different + ! array and type formats for different IO variables + ! + ! PA_R8 : 1D patch scale 8-byte reals + ! SI_R8 : 1D site scale 8-byte reals + ! + ! The allocation on the structures is not dynamic and should only add up to the + ! number of entries listed here. + ! + ! ---------------------------------------------------------------------------------- + use FatesHistoryDimensionMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8, & + site_r8, site_ground_r8, site_size_pft_r8 + + implicit none + + ! Arguments + class(fates_history_interface_type), intent(inout) :: this + + + integer :: index + + ! 1d Patch + index = 1 + call this%dim_kinds(index)%Init(patch_r8, 1) + + ! 1d Site + index = index + 1 + call this%dim_kinds(index)%Init(site_r8, 1) + + ! patch x ground + index = index + 1 + call this%dim_kinds(index)%Init(patch_ground_r8, 2) + + ! patch x size-class/pft + index = index + 1 + call this%dim_kinds(index)%Init(patch_size_pft_r8, 2) + + ! site x ground + index = index + 1 + call this%dim_kinds(index)%Init(site_ground_r8, 2) + + ! site x size-class/pft + index = index + 1 + call this%dim_kinds(index)%Init(site_size_pft_r8, 2) + + ! FIXME(bja, 2016-10) assert(index == fates_num_dim_kinds) + end subroutine init_dim_kinds_maps + + ! ======================================================================= + subroutine update_history_cbal(this,nc,nsites,sites) use EDtypesMod , only : ed_site_type ! Arguments - class(fates_hio_interface_type) :: this + class(fates_history_interface_type) :: this integer , intent(in) :: nc ! clump index integer , intent(in) :: nsites type(ed_site_type) , intent(inout), target :: sites(nsites) @@ -314,7 +616,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) use EDParamsMod , only : ED_val_ag_biomass ! Arguments - class(fates_hio_interface_type) :: this + class(fates_history_interface_type) :: this integer , intent(in) :: nc ! clump index integer , intent(in) :: nsites type(ed_site_type) , intent(inout), target :: sites(nsites) @@ -329,15 +631,13 @@ subroutine update_history_dyn(this,nc,nsites,sites) integer :: lb1,ub1,lb2,ub2 ! IO array bounds for the calling thread integer :: ivar ! index of IO variable object vector integer :: ft ! functional type index - integer :: scpf ! index of the size-class x pft bin - integer :: sc ! index of the size-class bin real(r8) :: n_density ! individual of cohort per m2. real(r8) :: n_perm2 ! individuals per m2 for the whole column real(r8) :: patch_scaling_scalar ! ratio of canopy to patch area for counteracting patch scaling real(r8) :: dbh ! diameter ("at breast height") - type(iovar_def_type),pointer :: hvar + type(fates_history_variable_type),pointer :: hvar type(ed_patch_type),pointer :: cpatch type(ed_cohort_type),pointer :: ccohort @@ -490,75 +790,76 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! ------------------------------------------------------------------------ dbh = ccohort%dbh !-0.5*(1./365.25)*ccohort%ddbhdt - sc = count(dbh-sclass_ed.ge.0.0) - scpf = (ft-1)*nlevsclass_ed+sc ! Flux Variables (cohorts must had experienced a day before any of these values ! have any meaning, otherwise they are just inialization values if( .not.(ccohort%isnew) ) then - hio_gpp_si_scpf(io_si,scpf) = hio_gpp_si_scpf(io_si,scpf) + & - n_perm2*ccohort%gpp ! [kgC/m2/yr] - hio_npp_totl_si_scpf(io_si,scpf) = hio_npp_totl_si_scpf(io_si,scpf) + & - ccohort%npp*n_perm2 - hio_npp_leaf_si_scpf(io_si,scpf) = hio_npp_leaf_si_scpf(io_si,scpf) + & - ccohort%npp_leaf*n_perm2 - hio_npp_fnrt_si_scpf(io_si,scpf) = hio_npp_fnrt_si_scpf(io_si,scpf) + & - ccohort%npp_froot*n_perm2 - hio_npp_bgsw_si_scpf(io_si,scpf) = hio_npp_bgsw_si_scpf(io_si,scpf) + & - ccohort%npp_bsw*(1._r8-ED_val_ag_biomass)*n_perm2 - hio_npp_agsw_si_scpf(io_si,scpf) = hio_npp_agsw_si_scpf(io_si,scpf) + & - ccohort%npp_bsw*ED_val_ag_biomass*n_perm2 - hio_npp_bgdw_si_scpf(io_si,scpf) = hio_npp_bgdw_si_scpf(io_si,scpf) + & - ccohort%npp_bdead*(1._r8-ED_val_ag_biomass)*n_perm2 - hio_npp_agdw_si_scpf(io_si,scpf) = hio_npp_agdw_si_scpf(io_si,scpf) + & - ccohort%npp_bdead*ED_val_ag_biomass*n_perm2 - hio_npp_seed_si_scpf(io_si,scpf) = hio_npp_seed_si_scpf(io_si,scpf) + & - ccohort%npp_bseed*n_perm2 - hio_npp_stor_si_scpf(io_si,scpf) = hio_npp_stor_si_scpf(io_si,scpf) + & - ccohort%npp_store*n_perm2 - - if( abs(ccohort%npp-(ccohort%npp_leaf+ccohort%npp_froot+ & - ccohort%npp_bsw+ccohort%npp_bdead+ & - ccohort%npp_bseed+ccohort%npp_store))>1.e-9) then - write(fates_log(),*) 'NPP Partitions are not balancing' - write(fates_log(),*) 'Fractional Error: ', & - abs(ccohort%npp-(ccohort%npp_leaf+ccohort%npp_froot+ & - ccohort%npp_bsw+ccohort%npp_bdead+ & - ccohort%npp_bseed+ccohort%npp_store))/ccohort%npp - write(fates_log(),*) 'Terms: ',ccohort%npp,ccohort%npp_leaf,ccohort%npp_froot, & - ccohort%npp_bsw,ccohort%npp_bdead, & - ccohort%npp_bseed,ccohort%npp_store - write(fates_log(),*) ' NPP components during FATES-HLM linking does not balance ' - stop ! we need termination control for FATES!!! - ! call endrun(msg=errMsg(__FILE__, __LINE__)) - end if + associate( scpf => ccohort%size_by_pft_class ) + + hio_gpp_si_scpf(io_si,scpf) = hio_gpp_si_scpf(io_si,scpf) + & + n_perm2*ccohort%gpp ! [kgC/m2/yr] + hio_npp_totl_si_scpf(io_si,scpf) = hio_npp_totl_si_scpf(io_si,scpf) + & + ccohort%npp*n_perm2 + hio_npp_leaf_si_scpf(io_si,scpf) = hio_npp_leaf_si_scpf(io_si,scpf) + & + ccohort%npp_leaf*n_perm2 + hio_npp_fnrt_si_scpf(io_si,scpf) = hio_npp_fnrt_si_scpf(io_si,scpf) + & + ccohort%npp_froot*n_perm2 + hio_npp_bgsw_si_scpf(io_si,scpf) = hio_npp_bgsw_si_scpf(io_si,scpf) + & + ccohort%npp_bsw*(1._r8-ED_val_ag_biomass)*n_perm2 + hio_npp_agsw_si_scpf(io_si,scpf) = hio_npp_agsw_si_scpf(io_si,scpf) + & + ccohort%npp_bsw*ED_val_ag_biomass*n_perm2 + hio_npp_bgdw_si_scpf(io_si,scpf) = hio_npp_bgdw_si_scpf(io_si,scpf) + & + ccohort%npp_bdead*(1._r8-ED_val_ag_biomass)*n_perm2 + hio_npp_agdw_si_scpf(io_si,scpf) = hio_npp_agdw_si_scpf(io_si,scpf) + & + ccohort%npp_bdead*ED_val_ag_biomass*n_perm2 + hio_npp_seed_si_scpf(io_si,scpf) = hio_npp_seed_si_scpf(io_si,scpf) + & + ccohort%npp_bseed*n_perm2 + hio_npp_stor_si_scpf(io_si,scpf) = hio_npp_stor_si_scpf(io_si,scpf) + & + ccohort%npp_store*n_perm2 + + if( abs(ccohort%npp-(ccohort%npp_leaf+ccohort%npp_froot+ & + ccohort%npp_bsw+ccohort%npp_bdead+ & + ccohort%npp_bseed+ccohort%npp_store))>1.e-9) then + write(fates_log(),*) 'NPP Partitions are not balancing' + write(fates_log(),*) 'Fractional Error: ', & + abs(ccohort%npp-(ccohort%npp_leaf+ccohort%npp_froot+ & + ccohort%npp_bsw+ccohort%npp_bdead+ & + ccohort%npp_bseed+ccohort%npp_store))/ccohort%npp + write(fates_log(),*) 'Terms: ',ccohort%npp,ccohort%npp_leaf,ccohort%npp_froot, & + ccohort%npp_bsw,ccohort%npp_bdead, & + ccohort%npp_bseed,ccohort%npp_store + write(fates_log(),*) ' NPP components during FATES-HLM linking does not balance ' + stop ! we need termination control for FATES!!! + ! call endrun(msg=errMsg(__FILE__, __LINE__)) + end if - ! Woody State Variables (basal area and number density and mortality) - if (pftcon%woody(ft) == 1) then - - hio_m1_si_scpf(io_si,scpf) = hio_m1_si_scpf(io_si,scpf) + ccohort%bmort*n_perm2*AREA - hio_m2_si_scpf(io_si,scpf) = hio_m2_si_scpf(io_si,scpf) + ccohort%hmort*n_perm2*AREA - hio_m3_si_scpf(io_si,scpf) = hio_m3_si_scpf(io_si,scpf) + ccohort%cmort*n_perm2*AREA - hio_m4_si_scpf(io_si,scpf) = hio_m4_si_scpf(io_si,scpf) + ccohort%imort*n_perm2*AREA - hio_m5_si_scpf(io_si,scpf) = hio_m5_si_scpf(io_si,scpf) + ccohort%fmort*n_perm2*AREA - - ! basal area [m2/ha] - hio_ba_si_scpf(io_si,scpf) = hio_ba_si_scpf(io_si,scpf) + & - 0.25_r8*3.14159_r8*((dbh/100.0_r8)**2.0_r8)*n_perm2*AREA - - ! number density [/ha] - hio_nplant_si_scpf(io_si,scpf) = hio_nplant_si_scpf(io_si,scpf) + AREA*n_perm2 - - ! Growth Incrments must have NaN check and woody check - if(ccohort%ddbhdt == ccohort%ddbhdt) then - hio_ddbh_si_scpf(io_si,scpf) = hio_ddbh_si_scpf(io_si,scpf) + & - ccohort%ddbhdt*n_perm2*AREA - else - hio_ddbh_si_scpf(io_si,scpf) = -999.9 - end if - end if - + ! Woody State Variables (basal area and number density and mortality) + if (pftcon%woody(ft) == 1) then + + hio_m1_si_scpf(io_si,scpf) = hio_m1_si_scpf(io_si,scpf) + ccohort%bmort*n_perm2*AREA + hio_m2_si_scpf(io_si,scpf) = hio_m2_si_scpf(io_si,scpf) + ccohort%hmort*n_perm2*AREA + hio_m3_si_scpf(io_si,scpf) = hio_m3_si_scpf(io_si,scpf) + ccohort%cmort*n_perm2*AREA + hio_m4_si_scpf(io_si,scpf) = hio_m4_si_scpf(io_si,scpf) + ccohort%imort*n_perm2*AREA + hio_m5_si_scpf(io_si,scpf) = hio_m5_si_scpf(io_si,scpf) + ccohort%fmort*n_perm2*AREA + + ! basal area [m2/ha] + hio_ba_si_scpf(io_si,scpf) = hio_ba_si_scpf(io_si,scpf) + & + 0.25_r8*3.14159_r8*((dbh/100.0_r8)**2.0_r8)*n_perm2*AREA + + ! number density [/ha] + hio_nplant_si_scpf(io_si,scpf) = hio_nplant_si_scpf(io_si,scpf) + AREA*n_perm2 + + ! Growth Incrments must have NaN check and woody check + if(ccohort%ddbhdt == ccohort%ddbhdt) then + hio_ddbh_si_scpf(io_si,scpf) = hio_ddbh_si_scpf(io_si,scpf) + & + ccohort%ddbhdt*n_perm2*AREA + else + hio_ddbh_si_scpf(io_si,scpf) = -999.9 + end if + end if + + end associate end if ccohort => ccohort%taller @@ -628,9 +929,11 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) use EDtypesMod , only : ed_site_type, & ed_cohort_type, & ed_patch_type, & - AREA + AREA, & + sclass_ed, & + nlevsclass_ed ! Arguments - class(fates_hio_interface_type) :: this + class(fates_history_interface_type) :: this integer , intent(in) :: nc ! clump index integer , intent(in) :: nsites type(ed_site_type) , intent(inout), target :: sites(nsites) @@ -645,11 +948,11 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) integer :: io_soipa integer :: lb1,ub1,lb2,ub2 ! IO array bounds for the calling thread integer :: ivar ! index of IO variable object vector - + integer :: ft ! functional type index real(r8) :: n_density ! individual of cohort per m2. real(r8) :: n_perm2 ! individuals per m2 for the whole column - type(iovar_def_type),pointer :: hvar + type(fates_history_variable_type),pointer :: hvar type(ed_patch_type),pointer :: cpatch type(ed_cohort_type),pointer :: ccohort @@ -661,7 +964,15 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) hio_aresp_pa => this%hvars(ih_aresp_pa)%r81d, & hio_maint_resp_pa => this%hvars(ih_maint_resp_pa)%r81d, & hio_growth_resp_pa => this%hvars(ih_growth_resp_pa)%r81d, & - hio_npp_si => this%hvars(ih_npp_si)%r81d ) + hio_npp_si => this%hvars(ih_npp_si)%r81d, & + hio_ar_si_scpf => this%hvars(ih_ar_si_scpf)%r82d, & + hio_ar_grow_si_scpf => this%hvars(ih_ar_grow_si_scpf)%r82d, & + hio_ar_maint_si_scpf => this%hvars(ih_ar_maint_si_scpf)%r82d, & + hio_ar_agsapm_si_scpf => this%hvars(ih_ar_agsapm_si_scpf)%r82d, & + hio_ar_darkm_si_scpf => this%hvars(ih_ar_darkm_si_scpf)%r82d, & + hio_ar_crootm_si_scpf => this%hvars(ih_ar_crootm_si_scpf)%r82d, & + hio_ar_frootm_si_scpf => this%hvars(ih_ar_frootm_si_scpf)%r82d ) + ! Flush the relevant history variables call this%flush_hvars(nc,upfreq_in=2) @@ -691,7 +1002,10 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) endif if ( .not. ccohort%isnew ) then - + + ! Calculate index for the scpf class + associate( scpf => ccohort%size_by_pft_class ) + ! scale up cohort fluxes to their patches hio_npp_pa(io_pa) = hio_npp_pa(io_pa) + & ccohort%npp_tstep * 1.e3_r8 * n_density / dt_tstep @@ -707,6 +1021,37 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) ! map ed cohort-level npp fluxes to clm column fluxes hio_npp_si(io_si) = hio_npp_si(io_si) + ccohort%npp_tstep * n_perm2 * 1.e3_r8 /dt_tstep + + ! Total AR (kgC/m2/yr) = (kgC/plant/step) / (s/step) * (plant/m2) * (s/yr) + hio_ar_si_scpf(io_si,scpf) = hio_ar_si_scpf(io_si,scpf) + & + (ccohort%resp_tstep/dt_tstep) * n_perm2 * daysecs * yeardays + + ! Growth AR (kgC/m2/yr) + hio_ar_grow_si_scpf(io_si,scpf) = hio_ar_grow_si_scpf(io_si,scpf) + & + (ccohort%resp_g/dt_tstep) * n_perm2 * daysecs * yeardays + + ! Maint AR (kgC/m2/yr) + hio_ar_maint_si_scpf(io_si,scpf) = hio_ar_maint_si_scpf(io_si,scpf) + & + (ccohort%resp_m/dt_tstep) * n_perm2 * daysecs * yeardays + + ! Maintenance AR partition variables are stored as rates (kgC/plant/s) + ! (kgC/m2/yr) = (kgC/plant/s) * (plant/m2) * (s/yr) + hio_ar_agsapm_si_scpf(io_si,scpf) = hio_ar_agsapm_si_scpf(io_si,scpf) + & + ccohort%livestem_mr * n_perm2 * daysecs * yeardays + + ! (kgC/m2/yr) = (kgC/plant/s) * (plant/m2) * (s/yr) + hio_ar_darkm_si_scpf(io_si,scpf) = hio_ar_darkm_si_scpf(io_si,scpf) + & + ccohort%rdark * n_perm2 * daysecs * yeardays + + ! (kgC/m2/yr) = (kgC/plant/s) * (plant/m2) * (s/yr) + hio_ar_crootm_si_scpf(io_si,scpf) = hio_ar_crootm_si_scpf(io_si,scpf) + & + ccohort%livecroot_mr * n_perm2 * daysecs * yeardays + + ! (kgC/m2/yr) = (kgC/plant/s) * (plant/m2) * (s/yr) + hio_ar_frootm_si_scpf(io_si,scpf) = hio_ar_frootm_si_scpf(io_si,scpf) + & + ccohort%froot_mr * n_perm2 * daysecs * yeardays + + end associate endif ccohort => ccohort%taller @@ -721,51 +1066,40 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) end subroutine update_history_prod - ! ====================================================================================== + ! ==================================================================================== + integer function num_history_vars(this) - subroutine flush_hvars(this,nc,upfreq_in) - - class(fates_hio_interface_type) :: this - integer,intent(in) :: nc - integer,intent(in) :: upfreq_in + implicit none - integer :: ivar - type(iovar_def_type),pointer :: hvar - integer :: lb1,ub1,lb2,ub2 + class(fates_history_interface_type), intent(in) :: this + num_history_vars = this%num_history_vars_ + + end function num_history_vars + + ! ==================================================================================== + + subroutine initialize_history_vars(this) - do ivar=1,ubound(this%hvars,1) - hvar => this%hvars(ivar) - if (hvar%upfreq==upfreq_in) then ! Only flush variables with update on dynamics step - call this%get_hvar_bounds(hvar,nc,lb1,ub1,lb2,ub2) - select case(trim(hvar%iovar_dk_ptr%name)) - case('PA_R8') - hvar%r81d(lb1:ub1) = hvar%flushval - case('SI_R8') - hvar%r81d(lb1:ub1) = hvar%flushval - case('PA_GRND_R8') - hvar%r82d(lb1:ub1,lb2:ub2) = hvar%flushval - case('PA_SCPF_R8') - hvar%r82d(lb1:ub1,lb2:ub2) = hvar%flushval - case('SI_GRND_R8') - hvar%r82d(lb1:ub1,lb2:ub2) = hvar%flushval - case('SI_SCPF_R8') - hvar%r82d(lb1:ub1,lb2:ub2) = hvar%flushval - case('PA_INT') - hvar%int1d(lb1:ub1) = nint(hvar%flushval) - case default - write(fates_log(),*) 'iotyp undefined while flushing history variables' - stop - !end_run - end select - end if - end do - - end subroutine flush_hvars + implicit none + + class(fates_history_interface_type), intent(inout) :: this - ! ==================================================================================== + ! Determine how many of the history IO variables registered in FATES + ! are going to be allocated + call this%define_history_vars(initialize_variables=.false.) + + ! Allocate the list of history output variable objects + allocate(this%hvars(this%num_history_vars())) + + ! construct the object that defines all of the IO variables + call this%define_history_vars(initialize_variables=.true.) + + end subroutine initialize_history_vars + + ! ==================================================================================== - subroutine define_history_vars(this,callstep,nvar) + subroutine define_history_vars(this, initialize_variables) ! --------------------------------------------------------------------------------- ! @@ -793,727 +1127,427 @@ subroutine define_history_vars(this,callstep,nvar) ! If your HLM makes use of, and you want, INTEGER OUTPUT, pass the flushval as ! a real. The applied flush value will use the NINT() intrinsic function ! --------------------------------------------------------------------------------- + + use FatesHistoryDimensionMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8, & + site_r8, site_ground_r8, site_size_pft_r8 + implicit none - class(fates_hio_interface_type) :: this - character(len=*),intent(in) :: callstep ! are we 'count'ing or 'initializ'ing? - integer,optional,intent(out) :: nvar - integer :: ivar - - if(.not. (trim(callstep).eq.'count' .or. trim(callstep).eq.'initialize') ) then - write(fates_log(),*) 'defining history variables in FATES requires callstep count or initialize' - ! end_run('MESSAGE') - end if + class(fates_history_interface_type), intent(inout) :: this + logical, intent(in) :: initialize_variables ! are we 'count'ing or 'initializ'ing? + + integer :: ivar ivar=0 ! Site level counting variables - call this%set_history_var(vname='ED_NPATCHES',units='none', & + call this%set_history_var(vname='ED_NPATCHES', units='none', & long='Total number of ED patches per site', use_default='active', & - avgflag='A',vtype='SI_R8',hlms='CLM:ALM',flushval=1.0_r8, upfreq=1, & - ivar=ivar, callstep=callstep,index = ih_npatches_si) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=1.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_npatches_si) - call this%set_history_var(vname='ED_NCOHORTS',units='none', & + call this%set_history_var(vname='ED_NCOHORTS', units='none', & long='Total number of ED cohorts per site', use_default='active', & - avgflag='A',vtype='SI_R8',hlms='CLM:ALM',flushval=1.0_r8, upfreq=1, & - ivar=ivar, callstep=callstep,index = ih_ncohorts_si) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=1.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_ncohorts_si) ! Patch variables - call this%set_history_var(vname='TRIMMING',units='none', & + call this%set_history_var(vname='TRIMMING', units='none', & long='Degree to which canopy expansion is limited by leaf economics', & use_default='active', & - avgflag='A',vtype='PA_R8',hlms='CLM:ALM',flushval=1.0_r8, upfreq=1, & - ivar=ivar, callstep=callstep,index = ih_trimming_pa) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=1.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_trimming_pa) - call this%set_history_var(vname='AREA_PLANT',units='m2', & + call this%set_history_var(vname='AREA_PLANT', units='m2', & long='area occupied by all plants', use_default='active', & - avgflag='A',vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar, callstep=callstep,index = ih_area_plant_pa) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_area_plant_pa) - call this%set_history_var(vname='AREA_TREES',units='m2', & + call this%set_history_var(vname='AREA_TREES', units='m2', & long='area occupied by woody plants', use_default='active', & - avgflag='A',vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar, callstep=callstep,index = ih_area_treespread_pa) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_area_treespread_pa) - call this%set_history_var(vname='CANOPY_SPREAD',units='0-1', & + call this%set_history_var(vname='CANOPY_SPREAD', units='0-1', & long='Scaling factor between tree basal area and canopy area', & use_default='active', & - avgflag='A',vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar, callstep=callstep,index = ih_canopy_spread_pa) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_canopy_spread_pa) - call this%set_history_var(vname='PFTbiomass',units='gC/m2', & + call this%set_history_var(vname='PFTbiomass', units='gC/m2', & long='total PFT level biomass', use_default='active', & - avgflag='A', vtype='PA_GRND_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar, callstep=callstep, index = ih_biomass_pa_pft ) + avgflag='A', vtype=patch_ground_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_biomass_pa_pft ) call this%set_history_var(vname='PFTleafbiomass', units='gC/m2', & long='total PFT level leaf biomass', use_default='active', & - avgflag='A', vtype='PA_GRND_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar, callstep=callstep, index = ih_leafbiomass_pa_pft ) + avgflag='A', vtype=patch_ground_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_leafbiomass_pa_pft ) call this%set_history_var(vname='PFTstorebiomass', units='gC/m2', & long='total PFT level stored biomass', use_default='active', & - avgflag='A', vtype='PA_GRND_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar, callstep=callstep, index = ih_storebiomass_pa_pft ) + avgflag='A', vtype=patch_ground_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_storebiomass_pa_pft ) call this%set_history_var(vname='PFTnindivs', units='indiv / m2', & long='total PFT level number of individuals', use_default='active', & - avgflag='A', vtype='PA_GRND_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar, callstep=callstep, index = ih_nindivs_pa_pft ) + avgflag='A', vtype=patch_ground_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_nindivs_pa_pft ) ! Fire Variables call this%set_history_var(vname='FIRE_NESTEROV_INDEX', units='none', & long='nesterov_fire_danger index', use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar,callstep=callstep, index = ih_nesterov_fire_danger_pa) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_nesterov_fire_danger_pa) call this%set_history_var(vname='FIRE_ROS', units='m/min', & long='fire rate of spread m/min', use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar,callstep=callstep, index = ih_spitfire_ROS_pa) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_spitfire_ROS_pa) call this%set_history_var(vname='EFFECT_WSPEED', units='none', & long ='effective windspeed for fire spread', use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar,callstep=callstep, index = ih_effect_wspeed_pa ) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_effect_wspeed_pa ) call this%set_history_var(vname='FIRE_TFC_ROS', units='none', & long ='total fuel consumed', use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar,callstep=callstep, index = ih_TFC_ROS_pa ) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_TFC_ROS_pa ) call this%set_history_var(vname='FIRE_INTENSITY', units='kJ/m/s', & long='spitfire fire intensity: kJ/m/s', use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar,callstep=callstep, index = ih_fire_intensity_pa ) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_fire_intensity_pa ) call this%set_history_var(vname='FIRE_AREA', units='fraction', & long='spitfire fire area:m2', use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar,callstep=callstep, index = ih_fire_area_pa ) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_fire_area_pa ) call this%set_history_var(vname='SCORCH_HEIGHT', units='m', & long='spitfire fire area:m2', use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar,callstep=callstep, index = ih_scorch_height_pa ) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_scorch_height_pa ) call this%set_history_var(vname='fire_fuel_mef', units='m', & long='spitfire fuel moisture', use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar,callstep=callstep, index = ih_fire_fuel_mef_pa ) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_fire_fuel_mef_pa ) call this%set_history_var(vname='fire_fuel_bulkd', units='m', & long='spitfire fuel bulk density', use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar,callstep=callstep, index = ih_fire_fuel_bulkd_pa ) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_fire_fuel_bulkd_pa ) call this%set_history_var(vname='FIRE_FUEL_EFF_MOIST', units='m', & long='spitfire fuel moisture', use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar,callstep=callstep, index = ih_fire_fuel_eff_moist_pa ) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_fire_fuel_eff_moist_pa ) call this%set_history_var(vname='fire_fuel_sav', units='m', & long='spitfire fuel surface/volume ', use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar,callstep=callstep, index = ih_fire_fuel_sav_pa ) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_fire_fuel_sav_pa ) call this%set_history_var(vname='SUM_FUEL', units='gC m-2', & long='total ground fuel related to ros (omits 1000hr fuels)', & use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar,callstep=callstep, index = ih_sum_fuel_pa ) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_sum_fuel_pa ) ! Litter Variables call this%set_history_var(vname='LITTER_IN', units='gC m-2 s-1', & long='Litter flux in leaves', use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar,callstep=callstep, index = ih_litter_in_pa ) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_litter_in_pa ) call this%set_history_var(vname='LITTER_OUT', units='gC m-2 s-1', & long='Litter flux out leaves', use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar,callstep=callstep, index = ih_litter_out_pa ) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_litter_out_pa ) call this%set_history_var(vname='SEED_BANK', units='gC m-2', & long='Total Seed Mass of all PFTs', use_default='active', & - avgflag='A', vtype='SI_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar,callstep=callstep, index = ih_seed_bank_si ) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_seed_bank_si ) call this%set_history_var(vname='SEEDS_IN', units='gC m-2 s-1', & long='Seed Production Rate', use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar,callstep=callstep, index = ih_seeds_in_pa ) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_seeds_in_pa ) call this%set_history_var(vname='SEED_GERMINATION', units='gC m-2 s-1', & long='Seed mass converted into new cohorts', use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar,callstep=callstep, index = ih_seed_germination_pa ) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_seed_germination_pa ) call this%set_history_var(vname='SEED_DECAY', units='gC m-2 s-1', & long='Seed mass decay', use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar,callstep=callstep, index = ih_seed_decay_pa ) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_seed_decay_pa ) call this%set_history_var(vname='ED_bstore', units='gC m-2', & long='Storage biomass', use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar,callstep=callstep, index = ih_bstore_pa ) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_bstore_pa ) call this%set_history_var(vname='ED_bdead', units='gC m-2', & long='Dead (structural) biomass (live trees, not CWD)', & use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar,callstep=callstep, index = ih_bdead_pa ) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_bdead_pa ) call this%set_history_var(vname='ED_balive', units='gC m-2', & long='Live biomass', use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar,callstep=callstep, index = ih_balive_pa ) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_balive_pa ) call this%set_history_var(vname='ED_bleaf', units='gC m-2', & long='Leaf biomass', use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar,callstep=callstep, index = ih_bleaf_pa ) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_bleaf_pa ) call this%set_history_var(vname='ED_biomass', units='gC m-2', & long='Total biomass', use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=1, & - ivar=ivar,callstep=callstep, index = ih_btotal_pa ) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_btotal_pa ) ! Ecosystem Carbon Fluxes (updated rapidly, upfreq=2) call this%set_history_var(vname='NPP_column', units='gC/m^2/s', & long='net primary production on the site', use_default='active', & - avgflag='A', vtype='SI_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=2, & - ivar=ivar,callstep=callstep, index = ih_npp_si ) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_npp_si ) call this%set_history_var(vname='GPP', units='gC/m^2/s', & long='gross primary production', use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=2, & - ivar=ivar,callstep=callstep, index = ih_gpp_pa ) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_gpp_pa ) call this%set_history_var(vname='NPP', units='gC/m^2/s', & long='net primary production', use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=2, & - ivar=ivar,callstep=callstep, index = ih_npp_pa ) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_npp_pa ) call this%set_history_var(vname='AR', units='gC/m^2/s', & long='autotrophic respiration', use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=2, & - ivar=ivar,callstep=callstep, index = ih_aresp_pa ) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_aresp_pa ) call this%set_history_var(vname='GROWTH_RESP', units='gC/m^2/s', & long='growth respiration', use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=2, & - ivar=ivar,callstep=callstep, index = ih_growth_resp_pa ) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_growth_resp_pa ) call this%set_history_var(vname='MAINT_RESP', units='gC/m^2/s', & long='maintenance respiration', use_default='active', & - avgflag='A', vtype='PA_R8',hlms='CLM:ALM',flushval=0.0_r8, upfreq=2, & - ivar=ivar,callstep=callstep, index = ih_maint_resp_pa ) + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_maint_resp_pa ) ! Carbon Flux (grid dimension x scpf) (THESE ARE DEFAULT INACTIVE!!! ! (BECAUSE THEY TAKE UP SPACE!!! ! =================================================================================== - call this%set_history_var(vname='GPP_SCPF',units='kgC/m2/yr', & + call this%set_history_var(vname='GPP_SCPF', units='kgC/m2/yr', & long='gross primary production', use_default='inactive', & - avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & - upfreq=1, ivar=ivar,callstep=callstep, index = ih_gpp_si_scpf ) + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_gpp_si_scpf ) - call this%set_history_var(vname='NPP_SCPF',units='kgC/m2/yr', & + call this%set_history_var(vname='NPP_SCPF', units='kgC/m2/yr', & long='total net primary production', use_default='inactive', & - avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & - upfreq=1, ivar=ivar,callstep=callstep, index = ih_npp_totl_si_scpf ) + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_totl_si_scpf ) - call this%set_history_var(vname='NPP_LEAF_SCPF',units='kgC/m2/yr', & + call this%set_history_var(vname='NPP_LEAF_SCPF', units='kgC/m2/yr', & long='NPP flux into leaves', use_default='inactive', & - avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & - upfreq=1, ivar=ivar,callstep=callstep, index = ih_npp_leaf_si_scpf ) + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_leaf_si_scpf ) - call this%set_history_var(vname='NPP_SEED_SCPF',units='kgC/m2/yr', & + call this%set_history_var(vname='NPP_SEED_SCPF', units='kgC/m2/yr', & long='NPP flux into seeds', use_default='inactive', & - avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & - upfreq=1, ivar=ivar,callstep=callstep, index = ih_npp_seed_si_scpf ) + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_seed_si_scpf ) - call this%set_history_var(vname='NPP_FNRT_SCPF',units='kgC/m2/yr', & + call this%set_history_var(vname='NPP_FNRT_SCPF', units='kgC/m2/yr', & long='NPP flux into fine roots', use_default='inactive', & - avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & - upfreq=1, ivar=ivar,callstep=callstep, index = ih_npp_fnrt_si_scpf ) + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_fnrt_si_scpf ) - call this%set_history_var(vname='NPP_BGSW_SCPF',units='kgC/m2/yr', & + call this%set_history_var(vname='NPP_BGSW_SCPF', units='kgC/m2/yr', & long='NPP flux into below-ground sapwood', use_default='inactive', & - avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & - upfreq=1, ivar=ivar,callstep=callstep, index = ih_npp_bgsw_si_scpf ) + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_bgsw_si_scpf ) - call this%set_history_var(vname='NPP_BGDW_SCPF',units='kgC/m2/yr', & - long='NPP flux into below-ground deadwood', use_default='inactive',& - avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & - upfreq=1, ivar=ivar,callstep=callstep, index = ih_npp_bgdw_si_scpf ) + call this%set_history_var(vname='NPP_BGDW_SCPF', units='kgC/m2/yr', & + long='NPP flux into below-ground deadwood', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_bgdw_si_scpf ) - call this%set_history_var(vname='NPP_AGSW_SCPF',units='kgC/m2/yr', & + call this%set_history_var(vname='NPP_AGSW_SCPF', units='kgC/m2/yr', & long='NPP flux into above-ground sapwood', use_default='inactive', & - avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & - upfreq=1, ivar=ivar,callstep=callstep, index = ih_npp_agsw_si_scpf ) + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_agsw_si_scpf ) call this%set_history_var(vname = 'NPP_AGDW_SCPF', units='kgC/m2/yr', & - long='NPP flux into above-ground deadwood', use_default='inactive',& - avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & - upfreq=1, ivar=ivar,callstep=callstep, index = ih_npp_agdw_si_scpf ) + long='NPP flux into above-ground deadwood', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_agdw_si_scpf ) call this%set_history_var(vname = 'NPP_STOR_SCPF', units='kgC/m2/yr', & long='NPP flux into storage', use_default='inactive', & - avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & - upfreq=1, ivar=ivar,callstep=callstep, index = ih_npp_stor_si_scpf ) + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_stor_si_scpf ) call this%set_history_var(vname='DDBH_SCPF', units = 'cm/yr/ha', & - long='diameter growth increment and pft/size',use_default='inactive',& - avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & - upfreq=1, ivar=ivar,callstep=callstep, index = ih_ddbh_si_scpf ) + long='diameter growth increment and pft/size',use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ddbh_si_scpf ) - call this%set_history_var(vname='BA_SCPF',units = 'm2/ha', & + call this%set_history_var(vname='BA_SCPF', units = 'm2/ha', & long='basal area by patch and pft/size', use_default='inactive', & - avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & - upfreq=1, ivar=ivar,callstep=callstep, index = ih_ba_si_scpf ) + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ba_si_scpf ) - call this%set_history_var(vname='NPLANT_SCPF',units = 'N/ha', & + call this%set_history_var(vname='NPLANT_SCPF', units = 'N/ha', & long='stem number density by patch and pft/size', use_default='inactive', & - avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & - upfreq=1, ivar=ivar,callstep=callstep, index = ih_nplant_si_scpf ) + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_si_scpf ) - call this%set_history_var(vname='M1_SCPF',units = 'N/ha/yr', & - long='background mortality count by patch and pft/size', use_default='inactive',& - avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & - upfreq=1, ivar=ivar,callstep=callstep, index = ih_m1_si_scpf ) + call this%set_history_var(vname='M1_SCPF', units = 'N/ha/yr', & + long='background mortality count by patch and pft/size', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m1_si_scpf ) - call this%set_history_var(vname='M2_SCPF',units = 'N/ha/yr', & - long='hydraulic mortality count by patch and pft/size',use_default='inactive',& - avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & - upfreq=1, ivar=ivar,callstep=callstep, index = ih_m2_si_scpf ) - - call this%set_history_var(vname='M3_SCPF',units = 'N/ha/yr', & - long='carbon starvation mortality count by patch and pft/size',use_default='inactive', & - avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & - upfreq=1, ivar=ivar,callstep=callstep, index = ih_m3_si_scpf ) - - call this%set_history_var(vname='M4_SCPF',units = 'N/ha/yr', & - long='impact mortality count by patch and pft/size',use_default='inactive',& - avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & - upfreq=1, ivar=ivar,callstep=callstep, index = ih_m4_si_scpf ) + call this%set_history_var(vname='M2_SCPF', units = 'N/ha/yr', & + long='hydraulic mortality count by patch and pft/size',use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m2_si_scpf ) + + call this%set_history_var(vname='M3_SCPF', units = 'N/ha/yr', & + long='carbon starvation mortality count by patch and pft/size', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m3_si_scpf ) + + call this%set_history_var(vname='M4_SCPF', units = 'N/ha/yr', & + long='impact mortality count by patch and pft/size',use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m4_si_scpf ) + + call this%set_history_var(vname='M5_SCPF', units = 'N/ha/yr', & + long='fire mortality count by patch and pft/size',use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m5_si_scpf ) + + ! Size structured diagnostics that require rapid updates (upfreq=2) + + call this%set_history_var(vname='AR_SCPF',units = 'kgC/m2/yr', & + long='total autotrophic respiration per m2 per year',use_default='inactive',& + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_ar_si_scpf ) + + call this%set_history_var(vname='AR_GROW_SCPF',units = 'kgC/m2/yr', & + long='growth autotrophic respiration per m2 per year',use_default='inactive',& + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_ar_grow_si_scpf ) + + call this%set_history_var(vname='AR_MAINT_SCPF',units = 'kgC/m2/yr', & + long='maintenance autotrophic respiration per m2 per year',use_default='inactive',& + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_ar_maint_si_scpf ) + + call this%set_history_var(vname='AR_DARKM_SCPF',units = 'kgC/m2/yr', & + long='dark portion of maintenance autotrophic respiration per m2 per year',use_default='inactive',& + avgflag='A', vtype=site_size_pft_r8,hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_ar_darkm_si_scpf ) + + call this%set_history_var(vname='AR_AGSAPM_SCPF',units = 'kgC/m2/yr', & + long='above-ground sapwood maintenance autotrophic respiration per m2 per year',use_default='inactive',& + avgflag='A', vtype=site_size_pft_r8,hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_ar_agsapm_si_scpf ) + + call this%set_history_var(vname='AR_CROOTM_SCPF',units = 'kgC/m2/yr', & + long='below-ground sapwood maintenance autotrophic respiration per m2 per year',use_default='inactive',& + avgflag='A', vtype=site_size_pft_r8,hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_ar_crootm_si_scpf ) - call this%set_history_var(vname='M5_SCPF',units = 'N/ha/yr', & - long='fire mortality count by patch and pft/size',use_default='inactive',& - avgflag='A', vtype='SI_SCPF_R8',hlms='CLM:ALM',flushval=0.0_r8, & - upfreq=1, ivar=ivar,callstep=callstep, index = ih_m5_si_scpf ) + call this%set_history_var(vname='AR_FROOTM_SCPF',units = 'kgC/m2/yr', & + long='fine root maintenance autotrophic respiration per m2 per year',use_default='inactive',& + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_ar_frootm_si_scpf ) ! CARBON BALANCE VARIABLES THAT DEPEND ON HLM BGC INPUTS call this%set_history_var(vname='NEP', units='gC/m^2/s', & long='net ecosystem production', use_default='active', & - avgflag='A', vtype='SI_R8',hlms='CLM:ALM',flushval=cp_hio_ignore_val, & - upfreq=3, ivar=ivar,callstep=callstep, index = ih_nep_si ) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & + upfreq=3, ivar=ivar, initialize=initialize_variables, index = ih_nep_si ) call this%set_history_var(vname='Fire_Closs', units='gC/m^2/s', & long='ED/SPitfire Carbon loss to atmosphere', use_default='active', & - avgflag='A', vtype='SI_R8',hlms='CLM:ALM',flushval=cp_hio_ignore_val, & - upfreq=3, ivar=ivar,callstep=callstep, index = ih_fire_c_to_atm_si ) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & + upfreq=3, ivar=ivar, initialize=initialize_variables, index = ih_fire_c_to_atm_si ) call this%set_history_var(vname='NBP', units='gC/m^2/s', & long='net biosphere production', use_default='active', & - avgflag='A', vtype='SI_R8',hlms='CLM:ALM',flushval=cp_hio_ignore_val, & - upfreq=3, ivar=ivar,callstep=callstep, index = ih_nbp_si ) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & + upfreq=3, ivar=ivar, initialize=initialize_variables, index = ih_nbp_si ) call this%set_history_var(vname='TOTECOSYSC', units='gC/m^2', & long='total ecosystem carbon', use_default='active', & - avgflag='A', vtype='SI_R8',hlms='CLM:ALM',flushval=cp_hio_ignore_val, & - upfreq=3, ivar=ivar,callstep=callstep, index = ih_totecosysc_si ) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & + upfreq=3, ivar=ivar, initialize=initialize_variables, index = ih_totecosysc_si ) call this%set_history_var(vname='CBALANCE_ERROR_ED', units='gC/m^2/s', & long='total carbon balance error on ED side', use_default='active', & - avgflag='A', vtype='SI_R8',hlms='CLM:ALM',flushval=cp_hio_ignore_val, & - upfreq=3, ivar=ivar,callstep=callstep, index = ih_cbal_err_fates_si ) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & + upfreq=3, ivar=ivar, initialize=initialize_variables, index = ih_cbal_err_fates_si ) call this%set_history_var(vname='CBALANCE_ERROR_BGC', units='gC/m^2/s', & long='total carbon balance error on HLMs BGC side', use_default='active', & - avgflag='A', vtype='SI_R8',hlms='CLM:ALM',flushval=cp_hio_ignore_val, & - upfreq=3, ivar=ivar,callstep=callstep, index = ih_cbal_err_bgc_si ) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & + upfreq=3, ivar=ivar, initialize=initialize_variables, index = ih_cbal_err_bgc_si ) call this%set_history_var(vname='CBALANCE_ERROR_TOTAL', units='gC/m^2/s', & long='total carbon balance error total', use_default='active', & - avgflag='A', vtype='SI_R8',hlms='CLM:ALM',flushval=cp_hio_ignore_val, & - upfreq=3, ivar=ivar,callstep=callstep, index = ih_cbal_err_tot_si ) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & + upfreq=3, ivar=ivar, initialize=initialize_variables, index = ih_cbal_err_tot_si ) call this%set_history_var(vname='BIOMASS_STOCK_COL', units='gC/m^2', & long='total ED biomass carbon at the column level', use_default='active', & - avgflag='A', vtype='SI_R8',hlms='CLM:ALM',flushval=cp_hio_ignore_val, & - upfreq=3, ivar=ivar,callstep=callstep, index = ih_biomass_stock_si ) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & + upfreq=3, ivar=ivar, initialize=initialize_variables, index = ih_biomass_stock_si ) call this%set_history_var(vname='ED_LITTER_STOCK_COL', units='gC/m^2', & long='total ED litter carbon at the column level', use_default='active', & - avgflag='A', vtype='SI_R8',hlms='CLM:ALM',flushval=cp_hio_ignore_val, & - upfreq=3, ivar=ivar,callstep=callstep, index = ih_litter_stock_si ) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & + upfreq=3, ivar=ivar, initialize=initialize_variables, index = ih_litter_stock_si ) call this%set_history_var(vname='CWD_STOCK_COL', units='gC/m^2', & long='total CWD carbon at the column level', use_default='active', & - avgflag='A', vtype='SI_R8',hlms='CLM:ALM',flushval=cp_hio_ignore_val, & - upfreq=3, ivar=ivar,callstep=callstep, index = ih_cwd_stock_si ) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & + upfreq=3, ivar=ivar, initialize=initialize_variables, index = ih_cwd_stock_si ) ! Must be last thing before return - if(present(nvar)) nvar = ivar - - return + this%num_history_vars_ = ivar end subroutine define_history_vars - - ! ===================================================================================== - - subroutine set_history_var(this,vname,units,long,use_default,avgflag,vtype,hlms, & - flushval,upfreq,ivar,callstep,index) - - - use FatesUtilsMod, only : check_hlm_list - use EDTypesMod, only : cp_hlm_name - - ! arguments - class(fates_hio_interface_type) :: this - character(len=*),intent(in) :: vname - character(len=*),intent(in) :: units - character(len=*),intent(in) :: long - character(len=*),intent(in) :: use_default - character(len=*),intent(in) :: avgflag - character(len=*),intent(in) :: vtype - character(len=*),intent(in) :: hlms - real(r8),intent(in) :: flushval ! IF THE TYPE IS AN INT WE WILL round with NINT - integer,intent(in) :: upfreq - character(len=*),intent(in) :: callstep - integer, intent(inout) :: ivar - integer, intent(inout) :: index ! This is the index for the variable of - ! interest that is associated with an - ! explict name (for fast reference during update) - ! A zero is passed back when the variable is - ! not used - - ! locals - type(iovar_def_type),pointer :: hvar - integer :: ub1,lb1,ub2,lb2 ! Bounds for allocating the var - integer :: ityp - - if( check_hlm_list(trim(hlms),trim(cp_hlm_name)) ) then - - ivar = ivar+1 - index = ivar - - if(trim(callstep).eq.'initialize')then - - hvar => this%hvars(ivar) - hvar%vname = vname - hvar%units = units - hvar%long = long - hvar%use_default = use_default - hvar%vtype = vtype - hvar%avgflag = avgflag - hvar%flushval = flushval - hvar%upfreq = upfreq - ityp=this%iotype_index(trim(vtype)) - hvar%iovar_dk_ptr => this%iovar_dk(ityp) - this%iovar_dk(ityp)%active = .true. - - nullify(hvar%r81d) - nullify(hvar%r82d) - nullify(hvar%r83d) - nullify(hvar%int1d) - nullify(hvar%int2d) - nullify(hvar%int3d) - - call this%get_hvar_bounds(hvar,0,lb1,ub1,lb2,ub2) - - ! currently, all array spaces are flushed each time - ! the update is called. The flush here on the initialization - ! may be redundant, but will prevent issues in the future - ! if we have host models where not all threads are updating - ! the HIO array spaces. (RGK:09-2016) - - select case(trim(vtype)) - case('PA_R8') - allocate(hvar%r81d(lb1:ub1));hvar%r81d(:)=flushval - case('SI_R8') - allocate(hvar%r81d(lb1:ub1));hvar%r81d(:)=flushval - case('PA_GRND_R8') - allocate(hvar%r82d(lb1:ub1,lb2:ub2));hvar%r82d(:,:)=flushval - case('PA_SCPF_R8') - allocate(hvar%r82d(lb1:ub1,lb2:ub2));hvar%r82d(:,:)=flushval - case('SI_GRND_R8') - allocate(hvar%r82d(lb1:ub1,lb2:ub2));hvar%r82d(:,:)=flushval - case('SI_SCPF_R8') - allocate(hvar%r82d(lb1:ub1,lb2:ub2));hvar%r82d(:,:)=flushval - case default - write(fates_log(),*) 'Incompatible vtype passed to set_history_var' - write(fates_log(),*) 'vtype = ',trim(vtype),' ?' - stop - ! end_run - end select - - end if - else - - index = 0 - end if - - return - end subroutine set_history_var - - ! ===================================================================================== - - subroutine get_hvar_bounds(this,hvar,thread,lb1,ub1,lb2,ub2) - - class(fates_hio_interface_type) :: this - type(iovar_def_type),target,intent(in) :: hvar - integer,intent(in) :: thread - integer,intent(out) :: lb1 - integer,intent(out) :: ub1 - integer,intent(out) :: lb2 - integer,intent(out) :: ub2 - - ! local - integer :: ndims - - lb1 = 0 - ub1 = 0 - lb2 = 0 - ub2 = 0 - - ndims = hvar%iovar_dk_ptr%ndims - - ! The thread = 0 case is the boundaries for the whole proc/node - if (thread==0) then - lb1 = hvar%iovar_dk_ptr%dim1_ptr%lb - ub1 = hvar%iovar_dk_ptr%dim1_ptr%ub - if(ndims>1)then - lb2 = hvar%iovar_dk_ptr%dim2_ptr%lb - ub2 = hvar%iovar_dk_ptr%dim2_ptr%ub - end if - else - lb1 = hvar%iovar_dk_ptr%dim1_ptr%clump_lb(thread) - ub1 = hvar%iovar_dk_ptr%dim1_ptr%clump_ub(thread) - if(ndims>1)then - lb2 = hvar%iovar_dk_ptr%dim2_ptr%clump_lb(thread) - ub2 = hvar%iovar_dk_ptr%dim2_ptr%clump_ub(thread) - end if - end if - - return - end subroutine get_hvar_bounds - - - ! ==================================================================================== - - subroutine init_iovar_dk_maps(this) - - ! ---------------------------------------------------------------------------------- - ! This subroutine simply initializes the structures that define the different - ! array and type formats for different IO variables - ! - ! PA_R8 : 1D patch scale 8-byte reals - ! SI_R8 : 1D site scale 8-byte reals - ! - ! The allocation on the structures is not dynamic and should only add up to the - ! number of entries listed here. - ! - ! note (RGK) %active is not used yet. Was intended as a check on the HLM->FATES - ! control parameter passing to ensure all active dimension types received all - ! dimensioning specifications from the host, but we currently arent using those - ! passing functions.. - ! ---------------------------------------------------------------------------------- - - ! Arguments - class(fates_hio_interface_type) :: this - - ! Locals - integer :: ityp - integer, parameter :: unset_int = -999 - - allocate(this%iovar_dk(n_iovar_dk)) - - ! 1d Patch - ityp = 1 - this%iovar_dk(ityp)%name = 'PA_R8' - this%iovar_dk(ityp)%ndims = 1 - allocate(this%iovar_dk(ityp)%dimsize(this%iovar_dk(ityp)%ndims)) - this%iovar_dk(ityp)%dimsize(:) = unset_int - this%iovar_dk(ityp)%active = .false. - nullify(this%iovar_dk(ityp)%dim1_ptr) - nullify(this%iovar_dk(ityp)%dim2_ptr) - - ! 1d Site - ityp = 2 - this%iovar_dk(ityp)%name = 'SI_R8' - this%iovar_dk(ityp)%ndims = 1 - allocate(this%iovar_dk(ityp)%dimsize(this%iovar_dk(ityp)%ndims)) - this%iovar_dk(ityp)%dimsize(:) = unset_int - this%iovar_dk(ityp)%active = .false. - nullify(this%iovar_dk(ityp)%dim1_ptr) - nullify(this%iovar_dk(ityp)%dim2_ptr) - - ! patch x ground - ityp = 3 - this%iovar_dk(ityp)%name = 'PA_GRND_R8' - this%iovar_dk(ityp)%ndims = 2 - allocate(this%iovar_dk(ityp)%dimsize(this%iovar_dk(ityp)%ndims)) - this%iovar_dk(ityp)%dimsize(:) = unset_int - this%iovar_dk(ityp)%active = .false. - nullify(this%iovar_dk(ityp)%dim1_ptr) - nullify(this%iovar_dk(ityp)%dim2_ptr) - - ! patch x size-class/pft - ityp = 4 - this%iovar_dk(ityp)%name = 'PA_SCPF_R8' - this%iovar_dk(ityp)%ndims = 2 - allocate(this%iovar_dk(ityp)%dimsize(this%iovar_dk(ityp)%ndims)) - this%iovar_dk(ityp)%dimsize(:) = unset_int - this%iovar_dk(ityp)%active = .false. - nullify(this%iovar_dk(ityp)%dim1_ptr) - nullify(this%iovar_dk(ityp)%dim2_ptr) - - ! site x ground - ityp = 5 - this%iovar_dk(ityp)%name = 'SI_GRND_R8' - this%iovar_dk(ityp)%ndims = 2 - allocate(this%iovar_dk(ityp)%dimsize(this%iovar_dk(ityp)%ndims)) - this%iovar_dk(ityp)%dimsize(:) = unset_int - this%iovar_dk(ityp)%active = .false. - nullify(this%iovar_dk(ityp)%dim1_ptr) - nullify(this%iovar_dk(ityp)%dim2_ptr) - - ! site x size-class/pft - ityp = 6 - this%iovar_dk(ityp)%name = 'SI_SCPF_R8' - this%iovar_dk(ityp)%ndims = 2 - allocate(this%iovar_dk(ityp)%dimsize(this%iovar_dk(ityp)%ndims)) - this%iovar_dk(ityp)%dimsize(:) = unset_int - this%iovar_dk(ityp)%active = .false. - nullify(this%iovar_dk(ityp)%dim1_ptr) - nullify(this%iovar_dk(ityp)%dim2_ptr) - - - - - - - return - end subroutine init_iovar_dk_maps - - ! =================================================================================== - - subroutine set_dim_ptrs(this,dk_name,idim,dim_target) - - ! arguments - class(fates_hio_interface_type) :: this - character(len=*),intent(in) :: dk_name - integer,intent(in) :: idim ! dimension index - type(iovar_dim_type),target :: dim_target - - - ! local - integer :: ityp - - ityp = this%iotype_index(trim(dk_name)) - - ! First check to see if the dimension is allocated - if(this%iovar_dk(ityp)%ndims dim_target - elseif(idim==2) then - this%iovar_dk(ityp)%dim2_ptr => dim_target - end if - - ! With the map, we can set the dimension size - this%iovar_dk(ityp)%dimsize(idim) = dim_target%ub - dim_target%lb + 1 - - - return - end subroutine set_dim_ptrs - - ! ==================================================================================== - - function iotype_index(this,iotype_name) result(ityp) - - ! argument - class(fates_hio_interface_type) :: this - character(len=*),intent(in) :: iotype_name - - ! local - integer :: ityp - - do ityp=1,n_iovar_dk - if(trim(iotype_name).eq.trim(this%iovar_dk(ityp)%name))then - return - end if - end do - write(fates_log(),*) 'An IOTYPE THAT DOESNT EXIST WAS SPECIFIED' - !end_run - - end function iotype_index - - ! ===================================================================================== - - subroutine dim_init(this,iovar_dim,dim_name,nthreads,lb_in,ub_in) - - ! arguments - class(fates_hio_interface_type) :: this - type(iovar_dim_type),target :: iovar_dim - character(len=*),intent(in) :: dim_name - integer,intent(in) :: nthreads - integer,intent(in) :: lb_in - integer,intent(in) :: ub_in - - allocate(iovar_dim%clump_lb(nthreads)) - allocate(iovar_dim%clump_ub(nthreads)) - - iovar_dim%name = trim(dim_name) - iovar_dim%lb = lb_in - iovar_dim%ub = ub_in - - return - end subroutine dim_init - - ! ===================================================================================== - - subroutine set_dim_thread_bounds(this,iovar_dim,nc,lb_in,ub_in) - - class(fates_hio_interface_type) :: this - type(iovar_dim_type),target :: iovar_dim - integer,intent(in) :: nc ! Thread index - integer,intent(in) :: lb_in - integer,intent(in) :: ub_in - - iovar_dim%clump_lb(nc) = lb_in - iovar_dim%clump_ub(nc) = ub_in - - return - end subroutine set_dim_thread_bounds ! ==================================================================================== ! DEPRECATED, TRANSITIONAL OR FUTURE CODE SECTION ! ==================================================================================== - !subroutine set_fates_hio_str(tag,iotype_name,iostr_val) + !subroutine set_fates_hio_str(tag,iotype_name, iostr_val) ! ! Arguments -! character(len=*),intent(in) :: tag -! character(len=*), optional,intent(in) :: iotype_name +! character(len=*), intent(in) :: tag +! character(len=*), optional, intent(in) :: iotype_name ! integer, optional, intent(in) :: iostr_val ! ! local variables @@ -1524,32 +1558,32 @@ end subroutine set_dim_thread_bounds ! select case (trim(tag)) ! case('flush_to_unset') -! write(*,*) '' -! write(*,*) 'Flushing FATES IO types prior to transfer from host' -! do ityp=1,ubound(iovar_str,1) +! write(*, *) '' +! write(*, *) 'Flushing FATES IO types prior to transfer from host' +! do ityp=1,ubound(iovar_str, 1) ! iovar_str(ityp)%dimsize = unset_int ! iovar_str(ityp)%active = .false. ! end do ! case('check_allset') -! do ityp=1,ubound(iovar_str,1) -! write(*,*) 'Checking to see if ',iovar_str(ityp)%name,' IO communicators were sent to FATES' +! do ityp=1,ubound(iovar_str, 1) +! write(*, *) 'Checking to see if ',iovar_str(ityp)%name, ' IO communicators were sent to FATES' ! if(iovar_str(ityp)%active)then ! if(iovar_str(ityp)%offset .eq. unset_int) then -! write(*,*) 'FATES offset information of IO type:',iovar_str(ityp)%name -! write(*,*) 'was never set' +! write(*, *) 'FATES offset information of IO type:', iovar_str(ityp)%name +! write(*, *) 'was never set' ! ! end_run('MESSAGE') ! end if -! do idim=1,iovar_str(ityp)%ndims +! do idim=1, iovar_str(ityp)%ndims ! if(iovar_str(ityp)%dimsize(idim) .eq. unset_int) then -! write(*,*) 'FATES dimension information of IO type:',iovar_str(ityp)%name -! write(*,*) 'was never set' +! write(*, *) 'FATES dimension information of IO type:', iovar_str(ityp)%name +! write(*, *) 'was never set' ! ! end_run('MESSAGE') ! end if ! end do ! end if ! end do -! write(*,*) 'Checked. All history IO specifications properly sent to FATES.' +! write(*, *) 'Checked. All history IO specifications properly sent to FATES.' ! case default ! ! Must have two arguments if this is not a check or flush @@ -1561,39 +1595,39 @@ end subroutine set_dim_thread_bounds ! case('offset') ! ityp=iotype_index(trim(iotype_name)) ! iovar_str(ityp)%offset = iostr_val -! write(*,*) 'Transfering offset for IOTYPE',iotype_name,' to FATES' +! write(*, *) 'Transfering offset for IOTYPE',iotype_name, ' to FATES' ! case('dimsize1') ! ityp=iotype_index(trim(iotype_name)) ! iovar_str(ityp)%dimsize(1) = iostr_val -! write(*,*) 'Transfering 1st dimension size for IOTYPE',iotype_name,' to FATES' +! write(*, *) 'Transfering 1st dimension size for IOTYPE',iotype_name, ' to FATES' ! case('dimsize2') ! ityp=iotype_index(trim(iotype_name)) -! if(ubound(iovar_str(ityp)%dimsize,1)==1)then -! write(fates_log(),*) 'Transfering second dimensional bound to unallocated space' -! write(fates_log(),*) 'type:',iotype_name +! if(ubound(iovar_str(ityp)%dimsize, 1)==1)then +! write(fates_log(), *) 'Transfering second dimensional bound to unallocated space' +! write(fates_log(), *) 'type:', iotype_name ! ! end_run ! end if ! iovar_str(ityp)%dimsize(2) = iostr_val -! write(*,*) 'Transfering 2nd dimension size for IOTYPE',iotype_name,' to FATES' +! write(*, *) 'Transfering 2nd dimension size for IOTYPE',iotype_name, ' to FATES' ! case('dimsize3') ! ityp=iotype_index(trim(iotype_name)) -! if(ubound(iovar_str(ityp)%dimsize,1)<3)then -! write(fates_log(),*) 'Transfering third dimensional bound to unallocated space' -! write(fates_log(),*) 'type:',iotype_name +! if(ubound(iovar_str(ityp)%dimsize, 1)<3)then +! write(fates_log(), *) 'Transfering third dimensional bound to unallocated space' +! write(fates_log(), *) 'type:', iotype_name ! ! end_run ! end if ! iovar_str(ityp)%dimsize(3) = iostr_val -! write(*,*) 'Transfering 3rd dimension size for IOTYPE',iotype_name,' to FATES' +! write(*, *) 'Transfering 3rd dimension size for IOTYPE',iotype_name, ' to FATES' ! case default -! write(*,*) 'IO parameter not recognized:',trim(tag) +! write(*, *) 'IO parameter not recognized:', trim(tag) ! ! end_run ! end select ! else -! write(*,*) 'no value was provided for the tag' +! write(*, *) 'no value was provided for the tag' ! end if ! ! end select @@ -1602,4 +1636,4 @@ end subroutine set_dim_thread_bounds -end module HistoryIOMod +end module FatesHistoryInterfaceMod diff --git a/main/FatesHistoryVarKindMod.F90 b/main/FatesHistoryVarKindMod.F90 new file mode 100644 index 00000000..fd8bd7a8 --- /dev/null +++ b/main/FatesHistoryVarKindMod.F90 @@ -0,0 +1,91 @@ +module FatesHistoryVariableKindMod + + use FatesConstantsMod, only : fates_long_string_length + use FatesGlobals, only : fates_log + use FatesHistoryDimensionMod, only : fates_history_dimension_type + + implicit none + + ! NOTE(RGK, 2016) %active is not used yet. Was intended as a check on the HLM->FATES + ! control parameter passing to ensure all active dimension types received all + ! dimensioning specifications from the host, but we currently arent using those + ! passing functions.. + + ! This structure is not multi-threaded + type fates_history_variable_kind_type + character(len=fates_long_string_length) :: name ! String labelling this IO type + integer :: ndims ! number of dimensions in this IO type + integer, allocatable :: dimsize(:) ! The size of each dimension + logical, private :: active_ + integer :: dim1_index + integer :: dim2_index + + contains + + procedure, public :: Init + procedure, public :: set_active + procedure, public :: is_active + + end type fates_history_variable_kind_type + + + +contains + + ! =================================================================================== + subroutine Init(this, name, num_dims) + + use FatesConstantsMod, only : fates_unset_int + + implicit none + + class(fates_history_variable_kind_type), intent(inout) :: this + character(*), intent(in) :: name + integer, intent(in) :: num_dims + + this%name = trim(name) + this%ndims = num_dims + allocate(this%dimsize(this%ndims)) + this%dimsize(:) = fates_unset_int + this%active_ = .false. + this%dim1_index = fates_unset_int + this%dim2_index = fates_unset_int + + end subroutine Init + + ! ======================================================================= + subroutine set_active(this) + implicit none + class(fates_history_variable_kind_type), intent(inout) :: this + this%active_ = .true. + end subroutine set_active + + logical function is_active(this) + implicit none + class(fates_history_variable_kind_type), intent(in) :: this + is_active = this%active_ + end function is_active + + ! ==================================================================================== + + function iotype_index(iotype_name, num_dim_kinds, dim_kinds) result(dk_index) + + ! argument + character(len=*), intent(in) :: iotype_name + integer, intent(in) :: num_dim_kinds + type(fates_history_variable_kind_type), intent(in) :: dim_kinds(:) + + ! local + integer :: dk_index + + do dk_index=1, num_dim_kinds + if (trim(iotype_name) .eq. trim(dim_kinds(dk_index)%name)) then + return + end if + end do + write(fates_log(),*) 'An IOTYPE THAT DOESNT EXIST WAS SPECIFIED' + !end_run + + end function iotype_index + +end module FatesHistoryVariableKindMod diff --git a/main/FatesHistoryVariableType.F90 b/main/FatesHistoryVariableType.F90 new file mode 100644 index 00000000..21895043 --- /dev/null +++ b/main/FatesHistoryVariableType.F90 @@ -0,0 +1,221 @@ +module FatesHistoryVariableType + + use FatesConstantsMod, only : r8 => fates_r8 + use FatesGlobals, only : fates_log + use FatesHistoryVariableKindMod, only : fates_history_variable_kind_type + + implicit none + + ! This type is instanteated in the HLM-FATES interface (clmfates_interfaceMod.F90) + + type fates_history_variable_type + character(len=32) :: vname + character(len=24) :: units + character(len=128) :: long + character(len=24) :: use_default ! States whether a variable should be turned + ! on the output files by default (active/inactive) + ! It is a good idea to set inactive for very large + ! or infrequently used output datasets + character(len=24) :: vtype + character(len=1) :: avgflag + integer :: upfreq ! Update frequency (this is for checks and flushing) + ! 1 = dynamics "dyn" (daily) + ! 2 = production "prod" (prob model tstep) + real(r8) :: flushval + integer :: dim_kinds_index + ! Pointers (only one of these is allocated per variable) + real(r8), pointer :: r81d(:) + real(r8), pointer :: r82d(:,:) + real(r8), pointer :: r83d(:,:,:) + integer, pointer :: int1d(:) + integer, pointer :: int2d(:,:) + integer, pointer :: int3d(:,:,:) + contains + procedure, public :: Init + procedure, public :: Flush + procedure, private :: GetBounds + end type fates_history_variable_type + +contains + + subroutine Init(this, vname, units, long, use_default, & + vtype, avgflag, flushval, upfreq, num_dim_kinds, dim_kinds, dim_bounds) + + use FatesHistoryDimensionMod, only : fates_history_dimension_type + use FatesHistoryDimensionMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 + use FatesHistoryDimensionMod, only : site_r8, site_ground_r8, site_size_pft_r8 + + use FatesHistoryVariableKindMod, only : iotype_index + + implicit none + + class(fates_history_variable_type), intent(inout) :: this + character(len=*), intent(in) :: vname + character(len=*), intent(in) :: units + character(len=*), intent(in) :: long + character(len=*), intent(in) :: use_default + character(len=*), intent(in) :: vtype + character(len=*), intent(in) :: avgflag + real(r8), intent(in) :: flushval ! If the type is an int we will round with nint + integer, intent(in) :: upfreq + integer, intent(in) :: num_dim_kinds + type(fates_history_dimension_type), intent(in) :: dim_bounds(:) + type(fates_history_variable_kind_type), intent(inout) :: dim_kinds(:) + + integer :: dk_index + integer :: lb1, ub1, lb2, ub2 + + this%vname = vname + this%units = units + this%long = long + this%use_default = use_default + this%vtype = vtype + this%avgflag = avgflag + this%flushval = flushval + this%upfreq = upfreq + + nullify(this%r81d) + nullify(this%r82d) + nullify(this%r83d) + nullify(this%int1d) + nullify(this%int2d) + nullify(this%int3d) + + dk_index = iotype_index(trim(vtype), num_dim_kinds, dim_kinds) + this%dim_kinds_index = dk_index + call dim_kinds(dk_index)%set_active() + + call this%GetBounds(0, dim_bounds, dim_kinds, lb1, ub1, lb2, ub2) + + ! NOTE(rgk, 2016-09) currently, all array spaces are flushed each + ! time the update is called. The flush here on the initialization + ! may be redundant, but will prevent issues in the future if we + ! have host models where not all threads are updating the HHistory + ! array spaces. + + select case(trim(vtype)) + case(patch_r8) + allocate(this%r81d(lb1:ub1)) + this%r81d(:) = flushval + + case(site_r8) + allocate(this%r81d(lb1:ub1)) + this%r81d(:) = flushval + + case(patch_ground_r8) + allocate(this%r82d(lb1:ub1, lb2:ub2)) + this%r82d(:,:) = flushval + + case(patch_size_pft_r8) + allocate(this%r82d(lb1:ub1, lb2:ub2)) + this%r82d(:,:) = flushval + + case(site_ground_r8) + allocate(this%r82d(lb1:ub1, lb2:ub2)) + this%r82d(:,:) = flushval + + case(site_size_pft_r8) + allocate(this%r82d(lb1:ub1, lb2:ub2)) + this%r82d(:,:) = flushval + + case default + write(fates_log(),*) 'Incompatible vtype passed to set_history_var' + write(fates_log(),*) 'vtype = ',trim(vtype),' ?' + stop + ! end_run + end select + + end subroutine Init + + ! ===================================================================================== + + subroutine GetBounds(this, thread, dim_bounds, dim_kinds, lb1, ub1, lb2, ub2) + + use FatesHistoryDimensionMod, only : fates_history_dimension_type + + implicit none + + class(fates_history_variable_type), intent(inout) :: this + integer, intent(in) :: thread + class(fates_history_dimension_type), intent(in) :: dim_bounds(:) + type(fates_history_variable_kind_type), intent(in) :: dim_kinds(:) + integer, intent(out) :: lb1 + integer, intent(out) :: ub1 + integer, intent(out) :: lb2 + integer, intent(out) :: ub2 + + ! local + integer :: ndims + integer :: d_index + + lb1 = 0 + ub1 = 0 + lb2 = 0 + ub2 = 0 + + ndims = dim_kinds(this%dim_kinds_index)%ndims + + ! The thread = 0 case is the boundaries for the whole proc/node + if (thread==0) then + d_index = dim_kinds(this%dim_kinds_index)%dim1_index + lb1 = dim_bounds(d_index)%lower_bound + ub1 = dim_bounds(d_index)%upper_bound + if(ndims>1)then + d_index = dim_kinds(this%dim_kinds_index)%dim2_index + lb2 = dim_bounds(d_index)%lower_bound + ub2 = dim_bounds(d_index)%upper_bound + end if + else + d_index = dim_kinds(this%dim_kinds_index)%dim1_index + lb1 = dim_bounds(d_index)%clump_lower_bound(thread) + ub1 = dim_bounds(d_index)%clump_upper_bound(thread) + if(ndims>1)then + d_index = dim_kinds(this%dim_kinds_index)%dim2_index + lb2 = dim_bounds(d_index)%clump_lower_bound(thread) + ub2 = dim_bounds(d_index)%clump_upper_bound(thread) + end if + end if + + end subroutine GetBounds + + subroutine Flush(this, thread, dim_bounds, dim_kinds) + + use FatesHistoryDimensionMod, only : fates_history_dimension_type + use FatesHistoryDimensionMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 + use FatesHistoryDimensionMod, only : site_r8, site_ground_r8, site_size_pft_r8, patch_int + + implicit none + + class(fates_history_variable_type), intent(inout) :: this + integer, intent(in) :: thread + type(fates_history_dimension_type), intent(in) :: dim_bounds(:) + type(fates_history_variable_kind_type), intent(in) :: dim_kinds(:) + + integer :: lb1, ub1, lb2, ub2 + + call this%GetBounds(thread, dim_bounds, dim_kinds, lb1, ub1, lb2, ub2) + + select case(trim(dim_kinds(this%dim_kinds_index)%name)) + case(patch_r8) + this%r81d(lb1:ub1) = this%flushval + case(site_r8) + this%r81d(lb1:ub1) = this%flushval + case(patch_ground_r8) + this%r82d(lb1:ub1, lb2:ub2) = this%flushval + case(patch_size_pft_r8) + this%r82d(lb1:ub1, lb2:ub2) = this%flushval + case(site_ground_r8) + this%r82d(lb1:ub1, lb2:ub2) = this%flushval + case(site_size_pft_r8) + this%r82d(lb1:ub1, lb2:ub2) = this%flushval + case(patch_int) + this%int1d(lb1:ub1) = nint(this%flushval) + case default + write(fates_log(),*) 'fates history variable type undefined while flushing history variables' + stop + !end_run + end select + + end subroutine Flush + +end module FatesHistoryVariableType From d6654f3c5c67c6f681ef514e28902e9adaf2b570 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 16 Nov 2016 14:29:18 -0800 Subject: [PATCH 239/437] Forgot to add the new files to vc. --- main/FatesRestartInterfaceMod.F90 | 1765 +++++++++++++++++++++++++++++ main/FatesRestartVariableType.F90 | 201 ++++ 2 files changed, 1966 insertions(+) create mode 100644 main/FatesRestartInterfaceMod.F90 create mode 100644 main/FatesRestartVariableType.F90 diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 new file mode 100644 index 00000000..42504d11 --- /dev/null +++ b/main/FatesRestartInterfaceMod.F90 @@ -0,0 +1,1765 @@ +module FatesRestartInterfaceMod + + + use FatesConstantsMod , only : r8 => fates_r8 + use FatesConstantsMod , only : fates_avg_flag_length + use FatesConstantsMod , only : fates_short_string_length + use FatesConstantsMod , only : fates_long_string_length + use FatesGlobals , only : fates_log + + use FatesIODimensionsMod, only : fates_io_dimension_type + use FatesIOVariableKindMod, only : fates_io_variable_kind_type + use FatesRestartVariableMod, only : fates_restart_variable_type + + ! TO BE REMOVED WHEN ERROR HANDLINE IS ADDED (rgk 11-2016) + use shr_log_mod , only : errMsg => shr_log_errMsg + use abortutils , only : endrun + + implicit none + + ! ------------------------------------------------------------ + ! A note on variable naming conventions. + ! Many variables in this restart IO portion of the code will + ! follow the conventions: + ! + ! __ + ! + ! For instance we use an index for restart variable "ir_" + ! to point the object that contains the number of patches per + ! site "npatch" and this value is relevant to all sites "si" + ! thus: ir_npatch_si + ! + ! We also use associations to the data arrays of restart IO + ! variables "rio", for example the leaf litter "leaf_litter" + ! is retrieved for every patch and every functional type "paft" + ! thus: ir_leaf_litter_paft + ! + ! si: site dimension + ! pa: patch dimension + ! co: cohort dimension + ! ft: functional type dimension + ! cl: canopy layer dimension (upper, lower, etc) + ! ls: layer sublayer dimension (fine discretization of upper,lower) + ! wm: the number of memory slots for water (currently 10) + ! ------------------------------------------------------------- + + + ! Indices to the restart variable object + integer, private :: ir_npatch_si + integer, private :: ir_oldstock_si + integer, private :: ir_cd_status_si + integer, private :: ir_dd_status_si + integer, private :: ir_nchill_days_si + integer, private :: ir_leafondate_si + integer, private :: ir_leafoffdate_si + integer, private :: ir_dleafondate_si + integer, private :: ir_dleafoffdate_si + integer, private :: ir_acc_ni_si + integer, private :: ir_gdd_si + integer, private :: ir_nep_timeintegrated_si + integer, private :: ir_npp_timeintegrated_si + integer, private :: ir_hr_timeintegrated_si + integer, private :: ir_cbal_error_fates_si + integer, private :: ir_cbal_error_bgc_si + integer, private :: ir_cbal_error_total_si + integer, private :: ir_totecosysc_old_si + integer, private :: ir_totfatesc_old_si + integer, private :: ir_totbgcc_old_si + integer, private :: ir_fates_to_bgc_this_ts_si + integer, private :: ir_fates_to_bgc_last_ts_si + integer, private :: ir_seedrainflux_si + integer, private :: ir_ncohort_pa + integer, private :: ir_balive_co + integer, private :: ir_bdead_co + integer, private :: ir_bleaf_co + integer, private :: ir_broot_co + integer, private :: ir_bstore_co + integer, private :: ir_canopy_layer_co + integer, private :: ir_canopy_trim_co + integer, private :: ir_dbh_co + integer, private :: ir_height_co + integer, private :: ir_laimemory_co + integer, private :: ir_leaf_md_co + integer, private :: ir_root_md_co + integer, private :: ir_nplant_co + integer, private :: ir_gpp_acc_co + integer, private :: ir_npp_acc_co + integer, private :: ir_gpp_co + integer, private :: ir_npp_co + integer, private :: ir_npp_leaf_co + integer, private :: ir_npp_froot_co + integer, private :: ir_npp_sw_co + integer, private :: ir_npp_dead_co + integer, private :: ir_npp_seed_co + integer, private :: ir_npp_store_co + integer, private :: ir_bmort_co + integer, private :: ir_hmort_co + integer, private :: ir_cmort_co + integer, private :: ir_imort_co + integer, private :: ir_fmort_co + integer, private :: ir_ddbhdt_co + integer, private :: ir_resp_tstep_co + integer, private :: ir_pft_co + integer, private :: ir_status_co + integer, private :: ir_isnew_co + integer, private :: ir_cwd_ag_pacw + integer, private :: ir_cwd_bg_pacw + integer, private :: ir_leaf_litter_paft + integer, private :: ir_root_litter_paft + integer, private :: ir_leaf_litter_in_paft + integer, private :: ir_root_litter_in_paft + integer, private :: ir_seed_bank_co + integer, private :: ir_spread_pacl + integer, private :: ir_livegrass_pa + integer, private :: ir_age_pa + integer, private :: ir_area_pa + integer, private :: ir_fsun_paclftls + integer, private :: ir_fabd_sun_paclftls + integer, private :: ir_fabi_sun_paclftls + integer, private :: ir_fabd_sha_paclftls + integer, private :: ir_fabi_sha_paclftls + integer, private :: ir_watermem_siwm + + ! The number of variable dim/kind types we have defined (static) + integer, parameter :: fates_restart_num_dimensions = 2 + integer, parameter :: fates_restart_num_dim_kinds = 4 + + ! integer constants for storing logical data + integer, parameter :: old_cohort = 0 + integer, parameter :: new_cohort = 1 + + ! Local debug flag + logical, parameter :: DEBUG=.false. + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + + ! This structure is allocated by thread, and must be calculated after the FATES + ! sites are allocated, and their mapping to the HLM is identified. This structure + ! is not combined with iovar_bounds, because that one is multi-instanced. This + ! structure is used more during the update phase, wherease _bounds is used + ! more for things like flushing + type restart_map_type + integer, allocatable :: site_index(:) ! maps site indexes to the HIO site position + integer, allocatable :: patch1_index(:) ! maps site index to the HIO patch 1st position + integer, allocatable :: cohort1_index(:) ! maps site index to the HIO cohort 1st position + end type restart_map_type + + + + type, public :: fates_restart_interface_type + + type(fates_restart_variable_type),allocatable :: rvars(:) + integer,private :: num_restart_vars_ + + ! Instanteate one registry of the different dimension/kinds (dk) + ! All output variables will have a pointer to one of these dk's + type(fates_io_variable_kind_type) :: dim_kinds(fates_restart_num_dim_kinds) + + ! This is a structure that explains where FATES patch boundaries + ! on each thread point to in the host IO array, this structure is + ! allocated by number of threads. This could be dynamically + ! allocated, but is unlikely to change...? + ! Note: history io also instanteates fates_io_dimension_type + type(fates_io_dimension_type) :: dim_bounds(fates_restart_num_dimensions) + + type(restart_map_type), pointer :: restart_map(:) + + integer, private :: cohort_index_, column_index_ + + contains + + procedure, public :: Init + procedure, public :: SetThreadBoundsEach + procedure, public :: assemble_restart_output_types + procedure, public :: initialize_restart_vars + procedure, public :: num_restart_vars + procedure, public :: column_index + procedure, public :: cohort_index + procedure, public :: set_restart_vectors + procedure, public :: create_patchcohort_structure + procedure, public :: get_restart_vectors + ! private work functions + procedure, private :: init_dim_kinds_maps + procedure, private :: set_dim_indices +! procedure, private :: set_patch_index (not currently used rgk 11-2016) + procedure, private :: set_cohort_index + procedure, private :: set_column_index + procedure, private :: flushzero_rvars + + procedure, private :: define_restart_vars + procedure, private :: set_restart_var + + + + end type fates_restart_interface_type + + + + +contains + + ! ===================================================================================== + + subroutine Init(this, num_threads, fates_bounds) + + use FatesIODimensionsMod, only : fates_bounds_type, column, cohort + + implicit none + + class(fates_restart_interface_type), intent(inout) :: this + integer, intent(in) :: num_threads + type(fates_bounds_type), intent(in) :: fates_bounds + + integer :: dim_count = 0 + + dim_count = dim_count + 1 + call this%set_cohort_index(dim_count) + call this%dim_bounds(dim_count)%Init(cohort, num_threads, & + fates_bounds%cohort_begin, fates_bounds%cohort_end) + + dim_count = dim_count + 1 + call this%set_column_index(dim_count) + call this%dim_bounds(dim_count)%Init(column, num_threads, & + fates_bounds%column_begin, fates_bounds%column_end) + + ! FIXME(bja, 2016-10) assert(dim_count == FatesIOdimensionsmod::num_dimension_types) + + ! Allocate the mapping between FATES indices and the IO indices + allocate(this%restart_map(num_threads)) + + end subroutine Init + + ! ====================================================================== + + subroutine SetThreadBoundsEach(this, thread_index, thread_bounds) + + use FatesIODimensionsMod, only : fates_bounds_type + + implicit none + + class(fates_restart_interface_type), intent(inout) :: this + + integer, intent(in) :: thread_index + type(fates_bounds_type), intent(in) :: thread_bounds + + integer :: index + + index = this%cohort_index() + call this%dim_bounds(index)%SetThreadBounds(thread_index, & + thread_bounds%cohort_begin, thread_bounds%cohort_end) + + index = this%column_index() + call this%dim_bounds(index)%SetThreadBounds(thread_index, & + thread_bounds%column_begin, thread_bounds%column_end) + + end subroutine SetThreadBoundsEach + + ! =================================================================================== + + subroutine assemble_restart_output_types(this) + + use FatesIOVariableKindMod, only : site_r8, site_int, cohort_r8, cohort_int + + implicit none + + class(fates_restart_interface_type), intent(inout) :: this + + call this%init_dim_kinds_maps() + + call this%set_dim_indices(cohort_r8, 1, this%cohort_index()) + call this%set_dim_indices(cohort_int, 1, this%cohort_index()) + + call this%set_dim_indices(site_r8, 1, this%column_index()) + call this%set_dim_indices(site_int, 1, this%column_index()) + + end subroutine assemble_restart_output_types + + ! =================================================================================== + + subroutine set_dim_indices(this, dk_name, idim, dim_index) + + use FatesIOVariableKindMod , only : iotype_index + + implicit none + + ! arguments + class(fates_restart_interface_type), intent(inout) :: this + character(len=*), intent(in) :: dk_name + integer, intent(in) :: idim ! dimension index + integer, intent(in) :: dim_index + + + ! local + integer :: ityp + + ityp = iotype_index(trim(dk_name), fates_restart_num_dim_kinds, this%dim_kinds) + + ! First check to see if the dimension is allocated + if (this%dim_kinds(ityp)%ndims < idim) then + write(fates_log(), *) 'Trying to define dimension size to a dim-type structure' + write(fates_log(), *) 'but the dimension index does not exist' + write(fates_log(), *) 'type: ',dk_name,' ndims: ',this%dim_kinds(ityp)%ndims,' input dim:',idim + stop + !end_run + end if + + if (idim == 1) then + this%dim_kinds(ityp)%dim1_index = dim_index + else if (idim == 2) then + this%dim_kinds(ityp)%dim2_index = dim_index + end if + + ! With the map, we can set the dimension size + this%dim_kinds(ityp)%dimsize(idim) = this%dim_bounds(dim_index)%upper_bound - & + this%dim_bounds(dim_index)%lower_bound + 1 + + end subroutine set_dim_indices + + + ! ======================================================================= + + subroutine set_cohort_index(this, index) + implicit none + class(fates_restart_interface_type), intent(inout) :: this + integer, intent(in) :: index + this%cohort_index_ = index + end subroutine set_cohort_index + + integer function cohort_index(this) + implicit none + class(fates_restart_interface_type), intent(in) :: this + cohort_index = this%cohort_index_ + end function cohort_index + + ! ======================================================================= + + subroutine set_column_index(this, index) + implicit none + class(fates_restart_interface_type), intent(inout) :: this + integer, intent(in) :: index + this%column_index_ = index + end subroutine set_column_index + + integer function column_index(this) + implicit none + class(fates_restart_interface_type), intent(in) :: this + column_index = this%column_index_ + end function column_index + + + subroutine init_dim_kinds_maps(this) + + ! ---------------------------------------------------------------------------------- + ! This subroutine simply initializes the structures that define the different + ! array and type formats for different IO variables + ! + ! CO_R8 : 1D cohort scale 8-byte reals + ! SI_R8 : 1D site scale 8-byte reals + ! CO_INT : 1D cohort scale integers + ! SI_INT : 1D site scale integers + ! + ! The allocation on the structures is not dynamic and should only add up to the + ! number of entries listed here. + ! + ! ---------------------------------------------------------------------------------- + use FatesIOVariableKindMod, only : site_r8, site_int, cohort_r8, cohort_int + + implicit none + + ! Arguments + class(fates_restart_interface_type), intent(inout) :: this + + integer :: index + + ! 1d cohort r8 + index = 1 + call this%dim_kinds(index)%Init(cohort_r8, 1) + + ! 1d Site r8 + index = index + 1 + call this%dim_kinds(index)%Init(site_r8, 1) + + ! cohort int + index = index + 1 + call this%dim_kinds(index)%Init(cohort_int, 1) + + ! site int + index = index + 1 + call this%dim_kinds(index)%Init(site_int, 1) + + ! FIXME(bja, 2016-10) assert(index == fates_num_dim_kinds) + end subroutine init_dim_kinds_maps + + + ! ==================================================================================== + integer function num_restart_vars(this) + + implicit none + + class(fates_restart_interface_type), intent(in) :: this + + num_restart_vars = this%num_restart_vars_ + + end function num_restart_vars + + ! ==================================================================================== + + subroutine initialize_restart_vars(this) + + implicit none + + class(fates_restart_interface_type), intent(inout) :: this + + ! Determine how many of the restart IO variables registered in FATES + ! are going to be allocated + call this%define_restart_vars(initialize_variables=.false.) + + ! Allocate the list of restart output variable objects + allocate(this%rvars(this%num_restart_vars())) + + ! construct the object that defines all of the IO variables + call this%define_restart_vars(initialize_variables=.true.) + + end subroutine initialize_restart_vars + + ! ====================================================================================== + + subroutine flushzero_rvars(this,nc) + + class(fates_restart_interface_type) :: this + integer,intent(in) :: nc + + integer :: ivar + type(fates_restart_variable_type),pointer :: rvar + integer :: lb1,ub1,lb2,ub2 + + do ivar=1,ubound(this%rvars,1) + associate( rvar => this%rvars(ivar) ) + call rvar%FlushZero(nc, this%dim_bounds, this%dim_kinds) + end associate + end do + + end subroutine flushzero_rvars + + + + ! ==================================================================================== + + subroutine define_restart_vars(this, initialize_variables) + + ! --------------------------------------------------------------------------------- + ! + ! REGISTRY OF HISTORY OUTPUT VARIABLES + ! + ! This subroutine is called in two contexts, either in count mode or inialize mode + ! In count mode, we just walk through the list of registerred variables, compare + ! if the variable of interest list the current host model and add it to the count + ! if true. This count is used just to allocate the variable space. After this + ! has been done, we go through the list a second time populating a memory structure. + ! This phase is the "initialize" phase. These two phases are differntiated by the + ! string "callstep", which should be either "count" or "initialize". + ! + ! Note 1 there are different ways you can flush or initialize the output fields. + ! If you flush to a native type, (such as zero), the entire slab which covers + ! indices which may not be relevant to FATES, are flushed to this value. So + ! in that case, lakes and crops that are not controlled by FATES will zero'd + ! and when values are scaled up to the land-grid, the zero's for non FATES will + ! be included. This is good and correct if nothing is there. + ! + ! But, what if crops exist in the host model and occupy a fraction of the land-surface + ! shared with natural vegetation? In that case, you want to flush your arrays + ! with a value that the HLM treats as "do not average" + ! + ! If your HLM makes use of, and you want, INTEGER OUTPUT, pass the flushval as + ! a real. The applied flush value will use the NINT() intrinsic function + ! --------------------------------------------------------------------------------- + + use FatesIOVariableKindMod, only : site_r8, site_int, cohort_int, cohort_r8 + implicit none + + class(fates_restart_interface_type), intent(inout) :: this + logical, intent(in) :: initialize_variables ! are we 'count'ing or 'initializ'ing? + + integer :: ivar + + ivar=0 + + ! Site level counting variables + call this%set_restart_var(vname='ed_io_numPatchesPerCol', vtype=site_int, & + long_name='Total number of ED patches per column', units='none', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_npatch_si ) + + call this%set_restart_var(vname='ed_old_stock', vtype=site_r8, & + long_name='ed cohort - old_stock', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_oldstock_si ) + + call this%set_restart_var(vname='ed_cd_status', vtype=site_r8, & + long_name='ed cold dec status', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_cd_status_si ) + + call this%set_restart_var(vname='ed_dd_status', vtype=site_r8, & + long_name='ed drought dec status', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_dd_status_si ) + + call this%set_restart_var(vname='ed_chilling_days', vtype=site_r8, & + long_name='ed chilling day counter', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_nchill_days_si ) + + call this%set_restart_var(vname='ed_leafondate', vtype=site_r8, & + long_name='ed leafondate', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_leafondate_si ) + + call this%set_restart_var(vname='ed_leafoffdate', vtype=site_r8, & + long_name='ed leafoffdate', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_leafoffdate_si ) + + call this%set_restart_var(vname='ed_dleafondate', vtype=site_r8, & + long_name='ed dleafondate', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_dleafondate_si ) + + call this%set_restart_var(vname='ed_dleafoffdate', vtype=site_r8, & + long_name='ed dleafoffdate', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_dleafoffdate_si ) + + call this%set_restart_var(vname='ed_acc_NI', vtype=site_r8, & + long_name='ed nesterov index', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_acc_ni_si ) + + call this%set_restart_var(vname='ed_gdd_site', vtype=site_r8, & + long_name='ed GDD site', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_gdd_si ) + + call this%set_restart_var(vname='nep_timeintegrated_col', vtype=site_r8, & + long_name='NA', units='NA', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_nep_timeintegrated_si ) + + call this%set_restart_var(vname='npp_timeintegrated_col', vtype=site_r8, & + long_name='NA', units='NA', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_npp_timeintegrated_si ) + + call this%set_restart_var(vname='hr_timeintegrated_col', vtype=site_r8, & + long_name='NA', units='NA', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hr_timeintegrated_si ) + + call this%set_restart_var(vname='cbalance_error_ed_col', vtype=site_r8, & + long_name='NA', units='NA', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_cbal_error_fates_si ) + + call this%set_restart_var(vname='cbalance_error_bgc_col', vtype=site_r8, & + long_name='NA', units='NA', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_cbal_error_bgc_si ) + + call this%set_restart_var(vname='cbalance_error_total_col', vtype=site_r8, & + long_name='NA', units='NA', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_cbal_error_total_si ) + + call this%set_restart_var(vname='totecosysc_old_col', vtype=site_r8, & + long_name='NA', units='NA', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_totecosysc_old_si ) + + call this%set_restart_var(vname='totedc_old_col', vtype=site_r8, & + long_name='NA', units='NA', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_totfatesc_old_si ) + + call this%set_restart_var(vname='totbgcc_old_col', vtype=site_r8, & + long_name='NA', units='NA', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_totbgcc_old_si ) + + call this%set_restart_var(vname='ed_to_bgc_this_edts_col', vtype=site_r8, & + long_name='NA', units='NA', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fates_to_bgc_this_ts_si ) + + call this%set_restart_var(vname='ed_to_bgc_last_edts_col', vtype=site_r8, & + long_name='NA', units='NA', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fates_to_bgc_last_ts_si ) + + call this%set_restart_var(vname='seed_rain_flux_col', vtype=site_r8, & + long_name='NA', units='NA', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_seedrainflux_si ) + + ! + ! cohort level vars + ! + + ! This variable may be confusing, because it is a patch level variables + ! but it is using the cohort IO vector to hold data + call this%set_restart_var(vname='ed_io_cohortsPerPatch', vtype=cohort_int, & + long_name='cohorts per patch, indexed by numPatchesPerCol', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_ncohort_pa ) + + call this%set_restart_var(vname='ed_balive', vtype=cohort_r8, & + long_name='ed cohort ed_balive', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_balive_co ) + + call this%set_restart_var(vname='ed_bdead', vtype=cohort_r8, & + long_name='ed cohort - bdead', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_bdead_co ) + + call this%set_restart_var(vname='ed_bl', vtype=cohort_r8, & + long_name='ed cohort - bl', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_bleaf_co ) + + call this%set_restart_var(vname='ed_br', vtype=cohort_r8, & + long_name='ed cohort - br', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_broot_co ) + + call this%set_restart_var(vname='ed_bstore', vtype=cohort_r8, & + long_name='ed cohort - bstore', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_bstore_co ) + + call this%set_restart_var(vname='ed_canopy_layer', vtype=cohort_r8, & + long_name='ed cohort - canopy_layer', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_canopy_layer_co ) + + call this%set_restart_var(vname='ed_canopy_trim', vtype=cohort_r8, & + long_name='ed cohort - canopy_trim', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_canopy_trim_co ) + + call this%set_restart_var(vname='ed_dbh', vtype=cohort_r8, & + long_name='ed cohort - dbh', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_dbh_co ) + + call this%set_restart_var(vname='ed_hite', vtype=cohort_r8, & + long_name='ed cohort - hite', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_height_co ) + + call this%set_restart_var(vname='ed_laimemory', vtype=cohort_r8, & + long_name='ed cohort - laimemory', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_laimemory_co ) + + call this%set_restart_var(vname='ed_leaf_md', vtype=cohort_r8, & + long_name='ed cohort - leaf_md', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_leaf_md_co ) + + call this%set_restart_var(vname='ed_root_md', vtype=cohort_r8, & + long_name='ed cohort - root_md', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_root_md_co ) + + call this%set_restart_var(vname='ed_n', vtype=cohort_r8, & + long_name='ed cohort - n', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_nplant_co ) + + call this%set_restart_var(vname='ed_gpp_acc', vtype=cohort_r8, & + long_name='ed cohort - gpp_acc', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_gpp_acc_co ) + + call this%set_restart_var(vname='ed_npp_acc', vtype=cohort_r8, & + long_name='ed cohort - npp_acc', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_npp_acc_co ) + + call this%set_restart_var(vname='ed_gpp', vtype=cohort_r8, & + long_name='ed cohort - gpp', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_gpp_co ) + + call this%set_restart_var(vname='ed_npp', vtype=cohort_r8, & + long_name='ed cohort - npp', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_npp_co ) + + call this%set_restart_var(vname='ed_npp_leaf', vtype=cohort_r8, & + long_name='ed cohort - npp_leaf', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_npp_leaf_co ) + + call this%set_restart_var(vname='ed_npp_froot', vtype=cohort_r8, & + long_name='ed cohort - npp_froot', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_npp_froot_co ) + + call this%set_restart_var(vname='ed_npp_sw', vtype=cohort_r8, & + long_name='ed cohort - npp_sw', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_npp_sw_co ) + + call this%set_restart_var(vname='ed_npp_bdead', vtype=cohort_r8, & + long_name='ed cohort - npp_bdead', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_npp_dead_co ) + + call this%set_restart_var(vname='ed_npp_bseed', vtype=cohort_r8, & + long_name='ed cohort - npp_bseed', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_npp_seed_co ) + + call this%set_restart_var(vname='ed_npp_store', vtype=cohort_r8, & + long_name='ed cohort - npp_store', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_npp_store_co ) + + call this%set_restart_var(vname='ed_bmort', vtype=cohort_r8, & + long_name='ed cohort - bmort', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_bmort_co ) + + call this%set_restart_var(vname='ed_hmort', vtype=cohort_r8, & + long_name='ed cohort - hmort', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hmort_co ) + + call this%set_restart_var(vname='ed_cmort', vtype=cohort_r8, & + long_name='ed cohort - cmort', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_cmort_co ) + + call this%set_restart_var(vname='ed_imort', vtype=cohort_r8, & + long_name='ed cohort - imort', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_imort_co ) + + call this%set_restart_var(vname='ed_fmort', vtype=cohort_r8, & + long_name='ed cohort - fmort', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fmort_co ) + + call this%set_restart_var(vname='ed_ddbhdt', vtype=cohort_r8, & + long_name='ed cohort - ddbhdt', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_ddbhdt_co ) + + call this%set_restart_var(vname='ed_resp_tstep', vtype=cohort_r8, & + long_name='ed cohort - resp_tstep', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_resp_tstep_co ) + + call this%set_restart_var(vname='ed_pft', vtype=cohort_int, & + long_name='ed cohort - pft', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_pft_co ) + + call this%set_restart_var(vname='ed_status_coh', vtype=cohort_int, & + long_name='ed cohort - status_coh', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_status_co ) + + call this%set_restart_var(vname='ed_isnew', vtype=cohort_int, & + long_name='ed cohort - isnew', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_isnew_co ) + + ! + ! patch level vars + ! + + call this%set_restart_var(vname='ed_cwd_ag', vtype=cohort_r8, & + long_name='ed patch - cwd_ag', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_cwd_ag_pacw ) + + call this%set_restart_var(vname='ed_cwd_bg', vtype=cohort_r8, & + long_name='ed patch - cwd_bg', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_cwd_bg_pacw ) + + call this%set_restart_var(vname='ed_leaf_litter', vtype=cohort_r8, & + long_name='fates: leaf litter by patch x pft', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_leaf_litter_paft ) + + call this%set_restart_var(vname='ed_root_litter', vtype=cohort_r8, & + long_name='ed patch - root_litter', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_root_litter_paft ) + + call this%set_restart_var(vname='ed_leaf_litter_in', vtype=cohort_r8, & + long_name='ed patch - leaf_litter_in', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_leaf_litter_in_paft ) + + call this%set_restart_var(vname='ed_root_litter_in', vtype=cohort_r8, & + long_name='ed patch - root_litter_in', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_root_litter_in_paft ) + + ! TODO: THIS SAYS SITE BUT USES COHORT LEVEL, INVESTIGATE (RGK) + call this%set_restart_var(vname='ed_seed_bank', vtype=cohort_r8, & + long_name='ed site? - seed_bank', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_seed_bank_co ) + + call this%set_restart_var(vname='ed_spread', vtype=cohort_r8, & + long_name='ed patch - spread', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_spread_pacl ) + + call this%set_restart_var(vname='ed_livegrass', vtype=cohort_r8, & + long_name='ed patch - livegrass', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_livegrass_pa ) + + call this%set_restart_var(vname='ed_age', vtype=cohort_r8, & + long_name='ed patch - age', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_age_pa ) + + call this%set_restart_var(vname='ed_area', vtype=cohort_r8, & + long_name='ed patch - area', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_area_pa ) + + ! These dimensions are pa "patch" cl "canopy layer" ft "functional type" ls "layer sublevel" + call this%set_restart_var(vname='ed_f_sun', vtype=cohort_r8, & + long_name='ed patch - f_sun', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fsun_paclftls ) + + call this%set_restart_var(vname='ed_fabd_sun_z', vtype=cohort_r8, & + long_name='ed patch - fabd_sun_z', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fabd_sun_paclftls ) + + call this%set_restart_var(vname='ed_fabi_sun_z', vtype=cohort_r8, & + long_name='ed patch - fabi_sun_z', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fabi_sun_paclftls ) + + call this%set_restart_var(vname='ed_fabd_sha_z', vtype=cohort_r8, & + long_name='ed patch - fabd_sha_z', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fabd_sha_paclftls ) + + call this%set_restart_var(vname='ed_fabi_sha_z', vtype=cohort_r8, & + long_name='ed patch - fabi_sha_z', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fabi_sha_paclftls ) + + ! + ! site x time level vars + ! + + call this%set_restart_var(vname='ed_water_memory', vtype=cohort_r8, & + long_name='ed cohort - water_memory', units='unitless', & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_watermem_siwm ) + + + ! Must be last thing before return + this%num_restart_vars_ = ivar + + end subroutine define_restart_vars + + + ! ===================================================================================== + + subroutine set_restart_var(this,vname,vtype,long_name,units,hlms,initialize,ivar,index) + + use FatesUtilsMod, only : check_hlm_list + use EDTypesMod, only : cp_hlm_name + + ! arguments + class(fates_restart_interface_type) :: this + character(len=*),intent(in) :: vname + character(len=*),intent(in) :: vtype + character(len=*),intent(in) :: units + character(len=*),intent(in) :: long_name + character(len=*),intent(in) :: hlms + logical, intent(in) :: initialize + integer, intent(inout) :: ivar + integer, intent(inout) :: index ! This is the index for the variable of + ! interest that is associated with an + ! explict name (for fast reference during update) + ! A zero is passed back when the variable is + ! not used + + + type(fates_restart_variable_type),pointer :: rvar + integer :: ub1,lb1,ub2,lb2 ! Bounds for allocating the var + integer :: ityp + + logical :: use_var + + use_var = check_hlm_list(trim(hlms), trim(cp_hlm_name)) + + + if( use_var ) then + + ivar = ivar+1 + index = ivar + + if( initialize )then + + call this%rvars(ivar)%Init(vname, units, long_name, vtype, & + fates_restart_num_dim_kinds, this%dim_kinds, this%dim_bounds) + + end if + else + + index = 0 + end if + + return + end subroutine set_restart_var + + ! ===================================================================================== + + subroutine set_restart_vectors(this,nc,nsites,sites) + + use EDTypesMod, only : cp_nclmax + use EDTypesMod, only : cp_nlevcan + use EDTypesMod, only : numCohortsPerPatch + use EDTypesMod, only : numpft_ed + use EDTypesMod, only : ed_site_type + use EDTypesMod, only : ed_cohort_type + use EDTypesMod, only : ed_patch_type + use EDTypesMod, only : cohorts_per_col + use EDTypesMod, only : ncwd + use EDTypesMod, only : numWaterMem + + ! Arguments + class(fates_restart_interface_type) :: this + integer , intent(in) :: nc ! clump index + integer , intent(in) :: nsites + type(ed_site_type) , intent(inout), target :: sites(nsites) + + ! Locals + integer :: s ! The local site index + integer :: io_si ! The site index of the IO array + integer :: io_co + integer :: incrementOffset + integer :: countCohort + integer :: countPft + integer :: countNcwd + integer :: countNclmax + integer :: countWaterMem + integer :: countSunZ + integer :: numCohorts + integer :: numPatches + + integer :: ivar ! index of IO variable object vector + integer :: ft ! functional type index + integer :: scpf ! index of the size-class x pft bin + integer :: sc ! index of the size-class bin + integer :: totalcohorts ! total cohort count + integer :: k,j,i ! indices to the radiation matrix + + real(r8) :: n_density ! individual of cohort per m2. + real(r8) :: n_perm2 ! individuals per m2 for the whole column + real(r8) :: patch_scaling_scalar ! ratio of canopy to patch area for + ! counteracting patch scaling + real(r8) :: dbh ! diameter ("at breast height") + + type(fates_restart_variable_type) :: rvar + type(ed_patch_type),pointer :: cpatch + type(ed_cohort_type),pointer :: ccohort + + + associate( rio_npatch_si => this%rvars(ir_npatch_si)%int1d, & + rio_old_stock_si => this%rvars(ir_oldstock_si)%r81d, & + rio_cd_status_si => this%rvars(ir_cd_status_si)%r81d, & + rio_dd_status_si => this%rvars(ir_dd_status_si)%r81d, & + rio_nchill_days_si => this%rvars(ir_nchill_days_si)%r81d, & + rio_leafondate_si => this%rvars(ir_leafondate_si)%r81d, & + rio_leafoffdate_si => this%rvars(ir_leafoffdate_si)%r81d, & + rio_dleafondate_si => this%rvars(ir_dleafondate_si)%r81d, & + rio_dleafoffdate_si => this%rvars(ir_dleafoffdate_si)%r81d, & + rio_acc_ni_si => this%rvars(ir_acc_ni_si)%r81d, & + rio_gdd_si => this%rvars(ir_gdd_si)%r81d, & + rio_nep_timeintegrated_si => this%rvars(ir_nep_timeintegrated_si)%r81d, & + rio_npp_timeintegrated_si => this%rvars(ir_npp_timeintegrated_si)%r81d, & + rio_hr_timeintegrated_si => this%rvars(ir_hr_timeintegrated_si)%r81d, & + rio_cbal_err_fates_si => this%rvars(ir_cbal_error_fates_si)%r81d, & + rio_cbal_err_bgc_si => this%rvars(ir_cbal_error_bgc_si)%r81d, & + rio_cbal_err_tot_si => this%rvars(ir_cbal_error_total_si)%r81d, & + rio_totecosysc_old_si => this%rvars(ir_totecosysc_old_si)%r81d, & + rio_totfatesc_old_si => this%rvars(ir_totfatesc_old_si)%r81d, & + rio_totbgcc_old_si => this%rvars(ir_totbgcc_old_si)%r81d, & + rio_fates_to_bgc_this_ts_si => this%rvars(ir_fates_to_bgc_this_ts_si)%r81d, & + rio_fates_to_bgc_last_ts_si => this%rvars(ir_fates_to_bgc_last_ts_si)%r81d, & + rio_seedrainflux_si => this%rvars(ir_seedrainflux_si)%r81d, & + rio_ncohort_pa => this%rvars(ir_ncohort_pa)%int1d, & + rio_balive_co => this%rvars(ir_balive_co)%r81d, & + rio_bdead_co => this%rvars(ir_bdead_co)%r81d, & + rio_bleaf_co => this%rvars(ir_bleaf_co)%r81d, & + rio_broot_co => this%rvars(ir_broot_co)%r81d, & + rio_bstore_co => this%rvars(ir_bstore_co)%r81d, & + rio_canopy_layer_co => this%rvars(ir_canopy_layer_co)%r81d, & + rio_canopy_trim_co => this%rvars(ir_canopy_trim_co)%r81d, & + rio_dbh_co => this%rvars(ir_dbh_co)%r81d, & + rio_height_co => this%rvars(ir_height_co)%r81d, & + rio_laimemory_co => this%rvars(ir_laimemory_co)%r81d, & + rio_leaf_md_co => this%rvars(ir_leaf_md_co)%r81d, & + rio_root_md_co => this%rvars(ir_root_md_co)%r81d, & + rio_nplant_co => this%rvars(ir_nplant_co)%r81d, & + rio_gpp_acc_co => this%rvars(ir_gpp_acc_co)%r81d, & + rio_npp_acc_co => this%rvars(ir_npp_acc_co)%r81d, & + rio_gpp_co => this%rvars(ir_gpp_co)%r81d, & + rio_npp_co => this%rvars(ir_npp_co)%r81d, & + rio_npp_leaf_co => this%rvars(ir_npp_leaf_co)%r81d, & + rio_npp_froot_co => this%rvars(ir_npp_froot_co)%r81d, & + rio_npp_sw_co => this%rvars(ir_npp_sw_co)%r81d, & + rio_npp_dead_co => this%rvars(ir_npp_dead_co)%r81d, & + rio_npp_seed_co => this%rvars(ir_npp_seed_co)%r81d, & + rio_npp_store_co => this%rvars(ir_npp_store_co)%r81d, & + rio_bmort_co => this%rvars(ir_bmort_co)%r81d, & + rio_hmort_co => this%rvars(ir_hmort_co)%r81d, & + rio_cmort_co => this%rvars(ir_cmort_co)%r81d, & + rio_imort_co => this%rvars(ir_imort_co)%r81d, & + rio_fmort_co => this%rvars(ir_fmort_co)%r81d, & + rio_ddbhdt_co => this%rvars(ir_ddbhdt_co)%r81d, & + rio_resp_tstep_co => this%rvars(ir_resp_tstep_co)%r81d, & + rio_pft_co => this%rvars(ir_pft_co)%int1d, & + rio_status_co => this%rvars(ir_status_co)%int1d, & + rio_isnew_co => this%rvars(ir_isnew_co)%int1d, & + rio_cwd_ag_pacw => this%rvars(ir_cwd_ag_pacw)%r81d, & + rio_cwd_bg_pacw => this%rvars(ir_cwd_bg_pacw)%r81d, & + rio_leaf_litter_paft => this%rvars(ir_leaf_litter_paft)%r81d, & + rio_root_litter_paft => this%rvars(ir_root_litter_paft)%r81d, & + rio_leaf_litter_in_paft => this%rvars(ir_leaf_litter_in_paft)%r81d, & + rio_root_litter_in_paft => this%rvars(ir_root_litter_in_paft)%r81d, & + rio_seed_bank_co => this%rvars(ir_seed_bank_co)%r81d, & + rio_spread_pacl => this%rvars(ir_spread_pacl)%r81d, & + rio_livegrass_pa => this%rvars(ir_livegrass_pa)%r81d, & + rio_age_pa => this%rvars(ir_age_pa)%r81d, & + rio_area_pa => this%rvars(ir_area_pa)%r81d, & + rio_fsun_paclftls => this%rvars(ir_fsun_paclftls)%r81d, & + rio_fabd_sun_z_paclftls => this%rvars(ir_fabd_sun_paclftls)%r81d, & + rio_fabi_sun_z_paclftls => this%rvars(ir_fabi_sun_paclftls)%r81d, & + rio_fabd_sha_z_paclftls => this%rvars(ir_fabd_sha_paclftls)%r81d, & + rio_fabi_sha_z_paclftls => this%rvars(ir_fabi_sha_paclftls)%r81d, & + rio_watermem_siwm => this%rvars(ir_watermem_siwm)%r81d ) + + totalCohorts = 0 + + ! --------------------------------------------------------------------------------- + ! Flush arrays to values defined by %flushval (see registry entry in + ! subroutine define_history_vars() + ! --------------------------------------------------------------------------------- + call this%flushzero_rvars(nc) + + do s = 1,nsites + + ! Calculate the offsets + ! fcolumn is the global column index of the current site. + ! For the first site, if that site aligns with the first column index + ! in the clump, than the offset should be be equal to begCohort + + io_si = this%restart_map(nc)%site_index(s) + io_co = this%restart_map(nc)%cohort1_index(s) + + incrementOffset = io_co + countCohort = io_co + countPft = io_co + countNcwd = io_co + countNclmax = io_co + countWaterMem = io_co + countSunZ = io_co + + ! write seed_bank info(site-level, but PFT-resolved) + do i = 1,numpft_ed + rio_seed_bank_co(incrementOffset+i-1) = sites(s)%seed_bank(i) + end do + + cpatch => sites(s)%oldest_patch + + ! new column, reset num patches + numPatches = 0 + + do while(associated(cpatch)) + + ! found patch, increment + numPatches = numPatches + 1 + + ccohort => cpatch%shortest + + ! new patch, reset num cohorts + numCohorts = 0 + + do while(associated(ccohort)) + + ! found cohort, increment + numCohorts = numCohorts + 1 + totalCohorts = totalCohorts + 1 + + if ( DEBUG ) then + write(fates_log(),*) 'CLTV countCohort ', countCohort + write(fates_log(),*) 'CLTV lowerbound ', lbound(rio_npp_acc_co,1) + write(fates_log(),*) 'CLTV upperbound ', ubound(rio_npp_acc_co,1) + endif + + rio_balive_co(countCohort) = ccohort%balive + rio_bdead_co(countCohort) = ccohort%bdead + rio_bleaf_co(countCohort) = ccohort%bl + rio_broot_co(countCohort) = ccohort%br + rio_bstore_co(countCohort) = ccohort%bstore + rio_canopy_layer_co(countCohort) = ccohort%canopy_layer + rio_canopy_trim_co(countCohort) = ccohort%canopy_trim + rio_dbh_co(countCohort) = ccohort%dbh + rio_height_co(countCohort) = ccohort%hite + rio_laimemory_co(countCohort) = ccohort%laimemory + rio_leaf_md_co(countCohort) = ccohort%leaf_md + rio_root_md_co(countCohort) = ccohort%root_md + rio_nplant_co(countCohort) = ccohort%n + rio_gpp_acc_co(countCohort) = ccohort%gpp_acc + rio_npp_acc_co(countCohort) = ccohort%npp_acc + rio_gpp_co(countCohort) = ccohort%gpp + rio_npp_co(countCohort) = ccohort%npp + rio_npp_leaf_co(countCohort) = ccohort%npp_leaf + rio_npp_froot_co(countCohort) = ccohort%npp_froot + rio_npp_sw_co(countCohort) = ccohort%npp_bsw + rio_npp_dead_co(countCohort) = ccohort%npp_bdead + rio_npp_seed_co(countCohort) = ccohort%npp_bseed + rio_npp_store_co(countCohort) = ccohort%npp_store + rio_bmort_co(countCohort) = ccohort%bmort + rio_hmort_co(countCohort) = ccohort%hmort + rio_cmort_co(countCohort) = ccohort%cmort + rio_imort_co(countCohort) = ccohort%imort + rio_fmort_co(countCohort) = ccohort%fmort + rio_ddbhdt_co(countCohort) = ccohort%ddbhdt + rio_resp_tstep_co(countCohort) = ccohort%resp_tstep + rio_pft_co(countCohort) = ccohort%pft + rio_status_co(countCohort) = ccohort%status_coh + if ( ccohort%isnew ) then + rio_isnew_co(countCohort) = new_cohort + else + rio_isnew_co(countCohort) = old_cohort + endif + + if ( DEBUG ) then + write(fates_log(),*) 'CLTV offsetNumCohorts II ',countCohort, & + numCohorts + endif + + countCohort = countCohort + 1 + + ccohort => ccohort%taller + + enddo ! ccohort do while + + ! + ! deal with patch level fields here + ! + rio_livegrass_pa(incrementOffset) = cpatch%livegrass + rio_age_pa(incrementOffset) = cpatch%age + rio_area_pa(incrementOffset) = cpatch%area + + ! set cohorts per patch for IO + rio_ncohort_pa( incrementOffset ) = numCohorts + + if ( DEBUG ) then + write(fates_log(),*) 'offsetNumCohorts III ' & + ,countCohort,cohorts_per_col, numCohorts + 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 + rio_leaf_litter_paft(countPft) = cpatch%leaf_litter(i) + rio_root_litter_paft(countPft) = cpatch%root_litter(i) + rio_leaf_litter_in_paft(countPft) = cpatch%leaf_litter_in(i) + rio_root_litter_in_paft(countPft) = cpatch%root_litter_in(i) + countPft = countPft + 1 + end do + + do i = 1,ncwd ! ncwd currently 4 + rio_cwd_ag_pacw(countNcwd) = cpatch%cwd_ag(i) + rio_cwd_bg_pacw(countNcwd) = cpatch%cwd_bg(i) + countNcwd = countNcwd + 1 + end do + + do i = 1,cp_nclmax ! cp_nclmax currently 2 + rio_spread_pacl(countNclmax) = cpatch%spread(i) + countNclmax = countNclmax + 1 + end do + + if ( DEBUG ) write(fates_log(),*) 'CLTV countSunZ 1 ',countSunZ + + if ( DEBUG ) write(fates_log(),*) 'CLTV 1186 ',cp_nlevcan,numpft_ed,cp_nclmax + + do k = 1,cp_nlevcan ! cp_nlevcan currently 40 + do j = 1,numpft_ed ! numpft_ed currently 2 + do i = 1,cp_nclmax ! cp_nclmax currently 2 + rio_fsun_paclftls(countSunZ) = cpatch%f_sun(i,j,k) + rio_fabd_sun_z_paclftls(countSunZ) = cpatch%fabd_sun_z(i,j,k) + rio_fabi_sun_z_paclftls(countSunZ) = cpatch%fabi_sun_z(i,j,k) + rio_fabd_sha_z_paclftls(countSunZ) = cpatch%fabd_sha_z(i,j,k) + rio_fabi_sha_z_paclftls(countSunZ) = cpatch%fabi_sha_z(i,j,k) + countSunZ = countSunZ + 1 + end do + end do + end do + + if ( DEBUG ) write(fates_log(),*) 'CLTV countSunZ 2 ',countSunZ + + incrementOffset = incrementOffset + numCohortsPerPatch + + ! reset counters so that they are all advanced evenly. Currently + ! the offset is 10, the max of numpft_ed, ncwd, cp_nclmax, + ! countWaterMem and the number of allowed cohorts per patch + countPft = incrementOffset + countNcwd = incrementOffset + countNclmax = incrementOffset + countCohort = incrementOffset + countSunZ = incrementOffset + + if ( DEBUG ) then + write(fates_log(),*) 'CLTV incrementOffset ', incrementOffset + write(fates_log(),*) 'CLTV cohorts_per_col ', cohorts_per_col + write(fates_log(),*) 'CLTV numCohort ', numCohorts + write(fates_log(),*) 'CLTV totalCohorts ', totalCohorts + end if + + cpatch => cpatch%younger + + enddo ! cpatch do while + + rio_old_stock_si(io_si) = sites(s)%old_stock + rio_cd_status_si(io_si) = sites(s)%status + rio_dd_status_si(io_si) = sites(s)%dstatus + rio_nchill_days_si(io_si) = sites(s)%ncd + rio_leafondate_si(io_si) = sites(s)%leafondate + rio_leafoffdate_si(io_si) = sites(s)%leafoffdate + rio_dleafondate_si(io_si) = sites(s)%dleafondate + rio_dleafoffdate_si(io_si) = sites(s)%dleafoffdate + rio_acc_ni_si(io_si) = sites(s)%acc_NI + rio_gdd_si(io_si) = sites(s)%ED_GDD_site + + ! Carbon Balance and Checks + rio_nep_timeintegrated_si(io_si) = sites(s)%nep_timeintegrated + rio_npp_timeintegrated_si(io_si) = sites(s)%npp_timeintegrated + rio_hr_timeintegrated_si(io_si) = sites(s)%hr_timeintegrated + rio_totecosysc_old_si(io_si) = sites(s)%totecosysc_old + rio_totfatesc_old_si(io_si) = sites(s)%totfatesc_old + rio_totbgcc_old_si(io_si) = sites(s)%totbgcc_old + rio_cbal_err_fates_si(io_si) = sites(s)%cbal_err_fates + rio_cbal_err_bgc_si(io_si) = sites(s)%cbal_err_bgc + rio_cbal_err_tot_si(io_si) = sites(s)%cbal_err_tot + rio_fates_to_bgc_this_ts_si(io_si) = sites(s)%fates_to_bgc_this_ts + rio_fates_to_bgc_last_ts_si(io_si) = sites(s)%fates_to_bgc_last_ts + rio_seedrainflux_si(io_si) = sites(s)%tot_seed_rain_flux + + ! set numpatches for this column + rio_npatch_si(io_si) = numPatches + + do i = 1,numWaterMem ! numWaterMem currently 10 + rio_watermem_siwm( countWaterMem ) = sites(s)%water_memory(i) + countWaterMem = countWaterMem + 1 + end do + + enddo + + if ( DEBUG ) then + write(fates_log(),*) 'CLTV total cohorts ',totalCohorts + end if + + return + end associate + end subroutine set_restart_vectors + + ! ==================================================================================== + + subroutine create_patchcohort_structure(this, nc, nsites, sites ) + + ! ---------------------------------------------------------------------------------- + ! This subroutine takes a peak at the restart file to determine how to allocate + ! memory for the state structure, and then makes those allocations. This + ! subroutine is called prior to the transfer of the restart vectors into the + ! linked-list state structure. + ! --------------------------------------------------------------------------------- + use EDTypesMod, only : ed_site_type + use EDTypesMod, only : ed_cohort_type + use EDTypesMod, only : ed_patch_type + use EDTypesMod, only : ncwd + use EDTypesMod, only : cp_nlevcan + use EDTypesMod, only : cp_nclmax + use EDTypesMod, only : numCohortsPerPatch + use EDTypesMod, only : numpft_ed + use EDTypesMod, only : area + 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 pftconMod, only : pftcon + + ! !ARGUMENTS: + class(fates_restart_interface_type) , intent(inout) :: this + integer , intent(in) :: nc + integer , intent(in) :: nsites + type(ed_site_type) , intent(inout), target :: sites(nsites) + + ! local variables + + type(ed_patch_type) , pointer :: newp + type(ed_cohort_type), allocatable :: temp_cohort + real(r8) :: cwd_ag_local(ncwd) + real(r8) :: cwd_bg_local(ncwd) + real(r8) :: spread_local(cp_nclmax) + real(r8) :: leaf_litter_local(numpft_ed) + real(r8) :: root_litter_local(numpft_ed) + real(r8) :: patch_age + integer :: cohortstatus + integer :: s ! site index + integer :: patchIdx ! local patch index, 1: + integer :: io_si ! global site index in IO vector + integer :: io_co ! global cohort index in IO vector + integer :: fto + integer :: ft + + ! Dummy arguments used for calling create patch, these will be overwritten before + ! run-time. Just used now for allocation. + 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(:) = ED_val_maxspread + patch_age = 0.0_r8 + + ! ---------------------------------------------------------------------------------- + ! We really only need the counts for the number of patches per site + ! and the number of cohorts per patch. These values tell us how much + ! space to allocate. + ! ---------------------------------------------------------------------------------- + + associate( rio_npatch_si => this%rvars(ir_npatch_si)%int1d , & + rio_ncohort_pa => this%rvars(ir_ncohort_pa)%int1d ) + + do s = 1,nsites + + io_si = this%restart_map(nc)%site_index(s) + io_co = this%restart_map(nc)%cohort1_index(s) + + call zero_site( sites(s) ) + + ! + ! set a few items that are necessary on restart for ED but not on the + ! restart file + ! + + sites(s)%ncd = 0.0_r8 + + if ( rio_npatch_si(io_si)<0 .or. rio_npatch_si(io_si) > 10000 ) then + write(fates_log(),*) 'a column was expected to contain a valid number of patches' + write(fates_log(),*) '0 is a valid number, but this column seems uninitialized',rio_npatch_si(io_si) + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + ! Initialize the site pointers to null + sites(s)%youngest_patch => null() + sites(s)%oldest_patch => null() + + do patchIdx = 1,rio_npatch_si(io_si) + + if ( DEBUG ) then + write(fates_log(),*) 'create patch ',patchIdx + write(fates_log(),*) 'patchIdx 1-numCohorts : ', rio_ncohort_pa( io_co ) + end if + + ! create patch + allocate(newp) + + ! make new patch + call create_patch(sites(s), newp, patch_age, area, & + spread_local, cwd_ag_local, cwd_bg_local, & + leaf_litter_local, root_litter_local) + + newp%siteptr => sites(s) + + ! give this patch a unique patch number + newp%patchno = patchIdx + + do fto = 1, rio_ncohort_pa( io_co ) + + 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 + + if (DEBUG) then + write(fates_log(),*) 'EDRestVectorMod.F90::createPatchCohortStructure call create_cohort ' + end if + + 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 ( DEBUG ) write(fates_log(),*) 'patchIdx = 1 ',patchIdx + + sites(s)%youngest_patch => newp + sites(s)%oldest_patch => newp + sites(s)%youngest_patch%younger => null() + sites(s)%youngest_patch%older => null() + sites(s)%oldest_patch%younger => null() + sites(s)%oldest_patch%older => null() + + else if (patchIdx == 2) then ! add second patch to list + + if ( DEBUG ) write(fates_log(),*) 'patchIdx = 2 ',patchIdx + + sites(s)%youngest_patch => newp + sites(s)%youngest_patch%younger => null() + sites(s)%youngest_patch%older => sites(s)%oldest_patch + sites(s)%oldest_patch%younger => sites(s)%youngest_patch + sites(s)%oldest_patch%older => null() + + else ! more than 2 patches, insert patch into youngest slot + + if ( DEBUG ) write(fates_log(),*) 'patchIdx > 2 ',patchIdx + + newp%older => sites(s)%youngest_patch + sites(s)%youngest_patch%younger => newp + newp%younger => null() + sites(s)%youngest_patch => newp + + endif + + io_co = io_co + numCohortsPerPatch + + enddo ! ends loop over patchIdx + + enddo ! ends loop over s + + end associate + end subroutine create_patchcohort_structure + + ! ==================================================================================== + + subroutine get_restart_vectors(this, nc, nsites, sites) + + use EDTypesMod, only : ed_site_type + use EDTypesMod, only : ed_cohort_type + use EDTypesMod, only : ed_patch_type + use EDTypesMod, only : numpft_ed + use EDTypesMod, only : ncwd + use EDTypesMod, only : cp_nlevcan + use EDTypesMod, only : cp_nclmax + use EDTypesMod, only : numCohortsPerPatch + use EDTypesMod, only : cohorts_per_col + use EDTypesMod, only : numWaterMem + + ! !ARGUMENTS: + class(fates_restart_interface_type) , intent(inout) :: this + integer , intent(in) :: nc + integer , intent(in) :: nsites + type(ed_site_type) , intent(inout), target :: sites(nsites) + + + ! locals + ! ---------------------------------------------------------------------------------- + ! LL pointers + type(ed_patch_type),pointer :: cpatch ! current patch + type(ed_cohort_type),pointer :: ccohort ! current cohort + + ! loop indices + integer :: s, i, j, k + + ! ---------------------------------------------------------------------------------- + ! The following group of integers indicate the positional index (idx) + ! of variables at different scales inside the I/O arrays (io) + ! Keep in mind that many of these variables have a composite dimension + ! at the patch scale. To hold this memory, we borrow the cohort + ! vector. Thus the head of each array points to the first cohort + ! of each patch. "io_idx_co_1st" + ! ---------------------------------------------------------------------------------- + integer :: io_idx_si ! site index + integer :: io_idx_co_1st ! 1st cohort of each patch + integer :: io_idx_co ! cohort index + integer :: io_idx_pa_pft ! each pft within each patch (pa_pft) + integer :: io_idx_pa_cwd ! each cwd class within each patch (pa_cwd) + integer :: io_idx_pa_cl ! each canopy layer class within each patch (pa_cl) + integer :: io_idx_pa_sunz ! index for the combined dimensions for radiation + integer :: io_idx_si_wmem ! each water memory class within each site + + ! Some counters (for checking mostly) + integer :: totalcohorts ! total cohort count on this thread (diagnostic) + integer :: patchespersite ! number of patches per site + integer :: cohortsperpatch ! number of cohorts per patch + + + + associate( rio_npatch_si => this%rvars(ir_npatch_si)%int1d, & + rio_old_stock_si => this%rvars(ir_oldstock_si)%r81d, & + rio_cd_status_si => this%rvars(ir_cd_status_si)%r81d, & + rio_dd_status_si => this%rvars(ir_dd_status_si)%r81d, & + rio_nchill_days_si => this%rvars(ir_nchill_days_si)%r81d, & + rio_leafondate_si => this%rvars(ir_leafondate_si)%r81d, & + rio_leafoffdate_si => this%rvars(ir_leafoffdate_si)%r81d, & + rio_dleafondate_si => this%rvars(ir_dleafondate_si)%r81d, & + rio_dleafoffdate_si => this%rvars(ir_dleafoffdate_si)%r81d, & + rio_acc_ni_si => this%rvars(ir_acc_ni_si)%r81d, & + rio_gdd_si => this%rvars(ir_gdd_si)%r81d, & + rio_nep_timeintegrated_si => this%rvars(ir_nep_timeintegrated_si)%r81d, & + rio_npp_timeintegrated_si => this%rvars(ir_npp_timeintegrated_si)%r81d, & + rio_hr_timeintegrated_si => this%rvars(ir_hr_timeintegrated_si)%r81d, & + rio_cbal_err_fates_si => this%rvars(ir_cbal_error_fates_si)%r81d, & + rio_cbal_err_bgc_si => this%rvars(ir_cbal_error_bgc_si)%r81d, & + rio_cbal_err_tot_si => this%rvars(ir_cbal_error_total_si)%r81d, & + rio_totecosysc_old_si => this%rvars(ir_totecosysc_old_si)%r81d, & + rio_totfatesc_old_si => this%rvars(ir_totfatesc_old_si)%r81d, & + rio_totbgcc_old_si => this%rvars(ir_totbgcc_old_si)%r81d, & + rio_fates_to_bgc_this_ts_si => this%rvars(ir_fates_to_bgc_this_ts_si)%r81d, & + rio_fates_to_bgc_last_ts_si => this%rvars(ir_fates_to_bgc_last_ts_si)%r81d, & + rio_seedrainflux_si => this%rvars(ir_seedrainflux_si)%r81d, & + rio_ncohort_pa => this%rvars(ir_ncohort_pa)%int1d, & + rio_balive_co => this%rvars(ir_balive_co)%r81d, & + rio_bdead_co => this%rvars(ir_bdead_co)%r81d, & + rio_bleaf_co => this%rvars(ir_bleaf_co)%r81d, & + rio_broot_co => this%rvars(ir_broot_co)%r81d, & + rio_bstore_co => this%rvars(ir_bstore_co)%r81d, & + rio_canopy_layer_co => this%rvars(ir_canopy_layer_co)%r81d, & + rio_canopy_trim_co => this%rvars(ir_canopy_trim_co)%r81d, & + rio_dbh_co => this%rvars(ir_dbh_co)%r81d, & + rio_height_co => this%rvars(ir_height_co)%r81d, & + rio_laimemory_co => this%rvars(ir_laimemory_co)%r81d, & + rio_leaf_md_co => this%rvars(ir_leaf_md_co)%r81d, & + rio_root_md_co => this%rvars(ir_root_md_co)%r81d, & + rio_nplant_co => this%rvars(ir_nplant_co)%r81d, & + rio_gpp_acc_co => this%rvars(ir_gpp_acc_co)%r81d, & + rio_npp_acc_co => this%rvars(ir_npp_acc_co)%r81d, & + rio_gpp_co => this%rvars(ir_gpp_co)%r81d, & + rio_npp_co => this%rvars(ir_npp_co)%r81d, & + rio_npp_leaf_co => this%rvars(ir_npp_leaf_co)%r81d, & + rio_npp_froot_co => this%rvars(ir_npp_froot_co)%r81d, & + rio_npp_sw_co => this%rvars(ir_npp_sw_co)%r81d, & + rio_npp_dead_co => this%rvars(ir_npp_dead_co)%r81d, & + rio_npp_seed_co => this%rvars(ir_npp_seed_co)%r81d, & + rio_npp_store_co => this%rvars(ir_npp_store_co)%r81d, & + rio_bmort_co => this%rvars(ir_bmort_co)%r81d, & + rio_hmort_co => this%rvars(ir_hmort_co)%r81d, & + rio_cmort_co => this%rvars(ir_cmort_co)%r81d, & + rio_imort_co => this%rvars(ir_imort_co)%r81d, & + rio_fmort_co => this%rvars(ir_fmort_co)%r81d, & + rio_ddbhdt_co => this%rvars(ir_ddbhdt_co)%r81d, & + rio_resp_tstep_co => this%rvars(ir_resp_tstep_co)%r81d, & + rio_pft_co => this%rvars(ir_pft_co)%int1d, & + rio_status_co => this%rvars(ir_status_co)%int1d, & + rio_isnew_co => this%rvars(ir_isnew_co)%int1d, & + rio_cwd_ag_pacw => this%rvars(ir_cwd_ag_pacw)%r81d, & + rio_cwd_bg_pacw => this%rvars(ir_cwd_bg_pacw)%r81d, & + rio_leaf_litter_paft => this%rvars(ir_leaf_litter_paft)%r81d, & + rio_root_litter_paft => this%rvars(ir_root_litter_paft)%r81d, & + rio_leaf_litter_in_paft => this%rvars(ir_leaf_litter_in_paft)%r81d, & + rio_root_litter_in_paft => this%rvars(ir_root_litter_in_paft)%r81d, & + rio_seed_bank_co => this%rvars(ir_seed_bank_co)%r81d, & + rio_spread_pacl => this%rvars(ir_spread_pacl)%r81d, & + rio_livegrass_pa => this%rvars(ir_livegrass_pa)%r81d, & + rio_age_pa => this%rvars(ir_age_pa)%r81d, & + rio_area_pa => this%rvars(ir_area_pa)%r81d, & + rio_fsun_paclftls => this%rvars(ir_fsun_paclftls)%r81d, & + rio_fabd_sun_z_paclftls => this%rvars(ir_fabd_sun_paclftls)%r81d, & + rio_fabi_sun_z_paclftls => this%rvars(ir_fabi_sun_paclftls)%r81d, & + rio_fabd_sha_z_paclftls => this%rvars(ir_fabd_sha_paclftls)%r81d, & + rio_fabi_sha_z_paclftls => this%rvars(ir_fabi_sha_paclftls)%r81d, & + rio_watermem_siwm => this%rvars(ir_watermem_siwm)%r81d ) + + totalcohorts = 0 + + do s = 1,nsites + + io_idx_si = this%restart_map(nc)%site_index(s) + io_idx_co_1st = this%restart_map(nc)%cohort1_index(s) + + io_idx_co = io_idx_co_1st + io_idx_pa_pft = io_idx_co_1st + io_idx_pa_cwd = io_idx_co_1st + io_idx_pa_cl = io_idx_co_1st + io_idx_pa_sunz = io_idx_co_1st + io_idx_si_wmem = io_idx_co_1st + + ! read seed_bank info(site-level, but PFT-resolved) + do i = 1,numpft_ed + rio_seed_bank_co(io_idx_co_1st+i-1) = sites(s)%seed_bank(i) + enddo + + ! Perform a check on the number of patches per site + patchespersite = 0 + + cpatch => sites(s)%oldest_patch + do while(associated(cpatch)) + + patchespersite = patchespersite + 1 + + ccohort => cpatch%shortest + + ! new patch, reset num cohorts + cohortsperpatch = 0 + + do while(associated(ccohort)) + + ! found cohort, increment + cohortsperpatch = cohortsperpatch + 1 + totalcohorts = totalcohorts + 1 + + if ( DEBUG ) then + write(fates_log(),*) 'CVTL io_idx_co ',io_idx_co + endif + + ccohort%balive = rio_balive_co(io_idx_co) + ccohort%bdead = rio_bdead_co(io_idx_co) + ccohort%bl = rio_bleaf_co(io_idx_co) + ccohort%br = rio_broot_co(io_idx_co) + ccohort%bstore = rio_bstore_co(io_idx_co) + ccohort%canopy_layer = rio_canopy_layer_co(io_idx_co) + ccohort%canopy_trim = rio_canopy_trim_co(io_idx_co) + ccohort%dbh = rio_dbh_co(io_idx_co) + ccohort%hite = rio_height_co(io_idx_co) + ccohort%laimemory = rio_laimemory_co(io_idx_co) + ccohort%leaf_md = rio_leaf_md_co(io_idx_co) + ccohort%root_md = rio_root_md_co(io_idx_co) + ccohort%n = rio_nplant_co(io_idx_co) + ccohort%gpp_acc = rio_gpp_acc_co(io_idx_co) + ccohort%npp_acc = rio_npp_acc_co(io_idx_co) + ccohort%gpp = rio_gpp_co(io_idx_co) + ccohort%npp = rio_npp_co(io_idx_co) + ccohort%npp_leaf = rio_npp_leaf_co(io_idx_co) + ccohort%npp_froot = rio_npp_froot_co(io_idx_co) + ccohort%npp_bsw = rio_npp_sw_co(io_idx_co) + ccohort%npp_bdead = rio_npp_dead_co(io_idx_co) + ccohort%npp_bseed = rio_npp_seed_co(io_idx_co) + ccohort%npp_store = rio_npp_store_co(io_idx_co) + ccohort%bmort = rio_bmort_co(io_idx_co) + ccohort%hmort = rio_hmort_co(io_idx_co) + ccohort%cmort = rio_cmort_co(io_idx_co) + ccohort%imort = rio_imort_co(io_idx_co) + ccohort%fmort = rio_fmort_co(io_idx_co) + ccohort%ddbhdt = rio_ddbhdt_co(io_idx_co) + ccohort%resp_tstep = rio_resp_tstep_co(io_idx_co) + ccohort%pft = rio_pft_co(io_idx_co) + ccohort%status_coh = rio_status_co(io_idx_co) + ccohort%isnew = ( rio_isnew_co(io_idx_co) .eq. new_cohort ) + + io_idx_co = io_idx_co + 1 + + ccohort => ccohort%taller + + enddo ! current cohort do while + + if(cohortsperpatch .ne. rio_ncohort_pa(io_idx_co_1st)) then + write(fates_log(),*) 'Number of cohorts per patch during retrieval' + write(fates_log(),*) 'does not match allocation' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + + ! FIX(SPM,032414) move to init if you can...or make a new init function + cpatch%leaf_litter(:) = 0.0_r8 + cpatch%root_litter(:) = 0.0_r8 + cpatch%leaf_litter_in(:) = 0.0_r8 + cpatch%root_litter_in(:) = 0.0_r8 + cpatch%spread(:) = 0.0_r8 + + ! + ! deal with patch level fields here + ! + cpatch%livegrass = rio_livegrass_pa(io_idx_co_1st) + cpatch%age = rio_age_pa(io_idx_co_1st) + cpatch%area = rio_area_pa(io_idx_co_1st) + + ! set cohorts per patch for IO + + if ( DEBUG ) then + write(fates_log(),*) 'CVTL III ' & + ,io_idx_co,cohorts_per_col, cohortsperpatch + 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 + cpatch%leaf_litter(i) = rio_leaf_litter_paft(io_idx_pa_pft) + cpatch%root_litter(i) = rio_root_litter_paft(io_idx_pa_pft) + cpatch%leaf_litter_in(i) = rio_leaf_litter_in_paft(io_idx_pa_pft) + cpatch%root_litter_in(i) = rio_root_litter_in_paft(io_idx_pa_pft) + io_idx_pa_pft = io_idx_pa_pft + 1 + enddo + + do i = 1,ncwd ! ncwd currently 4 + cpatch%cwd_ag(i) = rio_cwd_ag_pacw(io_idx_pa_cwd) + cpatch%cwd_bg(i) = rio_cwd_bg_pacw(io_idx_pa_cwd) + io_idx_pa_cwd = io_idx_pa_cwd + 1 + enddo + + do i = 1,cp_nclmax ! cp_nclmax currently 2 + cpatch%spread(i) = rio_spread_pacl(io_idx_pa_cl) + io_idx_pa_cl = io_idx_pa_cl + 1 + enddo + + if ( DEBUG ) write(fates_log(),*) 'CVTL io_idx_pa_sunz 1 ',io_idx_pa_sunz + + do k = 1,cp_nlevcan ! cp_nlevcan currently 40 + do j = 1,numpft_ed ! numpft_ed currently 2 + do i = 1,cp_nclmax ! cp_nclmax currently 2 + cpatch%f_sun(i,j,k) = rio_fsun_paclftls(io_idx_pa_sunz) + cpatch%fabd_sun_z(i,j,k) = rio_fabd_sun_z_paclftls(io_idx_pa_sunz) + cpatch%fabi_sun_z(i,j,k) = rio_fabi_sun_z_paclftls(io_idx_pa_sunz) + cpatch%fabd_sha_z(i,j,k) = rio_fabd_sha_z_paclftls(io_idx_pa_sunz) + cpatch%fabi_sha_z(i,j,k) = rio_fabi_sha_z_paclftls(io_idx_pa_sunz) + io_idx_pa_sunz = io_idx_pa_sunz + 1 + end do + end do + end do + + if ( DEBUG ) write(fates_log(),*) 'CVTL io_idx_pa_sunz 2 ',io_idx_pa_sunz + + ! Now increment the position of the first cohort to that of the next + ! patch + + io_idx_co_1st = io_idx_co_1st + numcohortsPerPatch + + ! and the number of allowed cohorts per patch (currently 200) + io_idx_pa_pft = io_idx_co_1st + io_idx_pa_cwd = io_idx_co_1st + io_idx_pa_cl = io_idx_co_1st + io_idx_co = io_idx_co_1st + io_idx_pa_sunz = io_idx_co_1st + + if ( DEBUG ) then + write(fates_log(),*) 'CVTL io_idx_co_1st ', io_idx_co_1st + write(fates_log(),*) 'CVTL cohorts_per_col ', cohorts_per_col + write(fates_log(),*) 'CVTL cohortsperpatch ', cohortsperpatch + write(fates_log(),*) 'CVTL totalCohorts ', totalCohorts + end if + + cpatch => cpatch%younger + + enddo ! patch do while + + if(patchespersite .ne. rio_npatch_si(io_idx_si)) then + write(fates_log(),*) 'Number of patches per site during retrieval does not match allocation' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + + do i = 1,numWaterMem + sites(s)%water_memory(i) = rio_watermem_siwm( io_idx_si_wmem ) + io_idx_si_wmem = io_idx_si_wmem + 1 + end do + + sites(s)%old_stock = rio_old_stock_si(io_idx_si) + sites(s)%status = rio_cd_status_si(io_idx_si) + sites(s)%dstatus = rio_dd_status_si(io_idx_si) + sites(s)%ncd = rio_nchill_days_si(io_idx_si) + sites(s)%leafondate = rio_leafondate_si(io_idx_si) + sites(s)%leafoffdate = rio_leafoffdate_si(io_idx_si) + sites(s)%dleafondate = rio_dleafondate_si(io_idx_si) + sites(s)%dleafoffdate = rio_dleafoffdate_si(io_idx_si) + sites(s)%acc_NI = rio_acc_ni_si(io_idx_si) + sites(s)%ED_GDD_site = rio_gdd_si(io_idx_si) + + ! Carbon Balance and Checks + sites(s)%nep_timeintegrated = rio_nep_timeintegrated_si(io_idx_si) + sites(s)%npp_timeintegrated = rio_npp_timeintegrated_si(io_idx_si) + sites(s)%hr_timeintegrated = rio_hr_timeintegrated_si(io_idx_si) + sites(s)%totecosysc_old = rio_totecosysc_old_si(io_idx_si) + sites(s)%totfatesc_old = rio_totfatesc_old_si(io_idx_si) + sites(s)%totbgcc_old = rio_totbgcc_old_si(io_idx_si) + sites(s)%cbal_err_fates = rio_cbal_err_fates_si(io_idx_si) + sites(s)%cbal_err_bgc = rio_cbal_err_bgc_si(io_idx_si) + sites(s)%cbal_err_tot = rio_cbal_err_tot_si(io_idx_si) + sites(s)%fates_to_bgc_this_ts = rio_fates_to_bgc_this_ts_si(io_idx_si) + sites(s)%fates_to_bgc_last_ts = rio_fates_to_bgc_last_ts_si(io_idx_si) + sites(s)%tot_seed_rain_flux = rio_seedrainflux_si(io_idx_si) + + end do + + if ( DEBUG ) then + write(fates_log(),*) 'CVTL total cohorts ',totalCohorts + end if + + end associate + end subroutine get_restart_vectors + + end module FatesRestartInterfaceMod diff --git a/main/FatesRestartVariableType.F90 b/main/FatesRestartVariableType.F90 new file mode 100644 index 00000000..17b58fa3 --- /dev/null +++ b/main/FatesRestartVariableType.F90 @@ -0,0 +1,201 @@ +module FatesRestartVariableMod + + use FatesConstantsMod, only : r8 => fates_r8 + use FatesGlobals, only : fates_log + use FatesIOVariableKindMod, only : fates_io_variable_kind_type + + implicit none + + ! This type is instanteated in the HLM-FATES interface (clmfates_interfaceMod.F90) + + type fates_restart_variable_type + character(len=32) :: vname + character(len=24) :: units + character(len=128) :: long + character(len=24) :: vtype + real(r8) :: flushval ! DONT THINK THIS IS NEEDED IN RESTARTS + ! RESTARTS HAVE A MAPPING TABLE AND + ! THERE IS NO AVERAGING AND NO NEED TO + ! INDICATE NON-INCLUDED ARRAY SPACES + ! KEEPING FOR NOW (RGK-11-2016) + integer :: dim_kinds_index + ! Pointers (only one of these is allocated per variable) + real(r8), pointer :: r81d(:) + integer, pointer :: int1d(:) + contains + procedure, public :: Init + procedure, public :: FlushZero + procedure, private :: GetBounds + end type fates_restart_variable_type + +contains + + subroutine Init(this, vname, units, long, vtype, num_dim_kinds, dim_kinds, dim_bounds) + + use FatesIODimensionsMod, only : fates_io_dimension_type + use FatesIOVariableKindMod, only : patch_r8, site_r8, cohort_r8 + use FatesIOVariableKindMod, only : patch_int, site_int, cohort_int + use FatesIOVariableKindMod, only : iotype_index + + implicit none + + class(fates_restart_variable_type), intent(inout) :: this + character(len=*), intent(in) :: vname + character(len=*), intent(in) :: units + character(len=*), intent(in) :: long + character(len=*), intent(in) :: vtype + integer, intent(in) :: num_dim_kinds + type(fates_io_dimension_type), intent(in) :: dim_bounds(:) + type(fates_io_variable_kind_type), intent(inout) :: dim_kinds(:) + + integer :: dk_index + integer :: lb1, ub1, lb2, ub2 + + this%vname = vname + this%units = units + this%long = long + this%vtype = vtype + + nullify(this%r81d) + nullify(this%int1d) + + dk_index = iotype_index(trim(vtype), num_dim_kinds, dim_kinds) + this%dim_kinds_index = dk_index + call dim_kinds(dk_index)%set_active() + + call this%GetBounds(0, dim_bounds, dim_kinds, lb1, ub1, lb2, ub2) + + ! NOTE(rgk, 2016-09) currently, all array spaces are flushed each + ! time the update is called. The flush here on the initialization + ! may be redundant, but will prevent issues in the future if we + ! have host models where not all threads are updating the HHistory + ! array spaces. + + select case(trim(vtype)) + + case(cohort_r8) + allocate(this%r81d(lb1:ub1)) + this%r81d(:) = 0.0_r8 + + case(patch_r8) + allocate(this%r81d(lb1:ub1)) + this%r81d(:) = 0.0_r8 + + case(site_r8) + allocate(this%r81d(lb1:ub1)) + this%r81d(:) = 0.0_r8 + + case(cohort_int) + allocate(this%int1d(lb1:ub1)) + this%int1d(:) = 0 + + case(patch_int) + allocate(this%int1d(lb1:ub1)) + this%int1d(:) = 0 + + case(site_int) + allocate(this%int1d(lb1:ub1)) + this%int1d(:) = 0 + + case default + write(fates_log(),*) 'Incompatible vtype passed to set_restart_var' + write(fates_log(),*) 'vtype = ',trim(vtype),' ?' + stop + ! end_run + end select + + end subroutine Init + + ! ===================================================================================== + + subroutine GetBounds(this, thread, dim_bounds, dim_kinds, lb1, ub1, lb2, ub2) + + use FatesIODimensionsMod, only : fates_io_dimension_type + + implicit none + + class(fates_restart_variable_type), intent(inout) :: this + integer, intent(in) :: thread + class(fates_io_dimension_type), intent(in) :: dim_bounds(:) + type(fates_io_variable_kind_type), intent(in) :: dim_kinds(:) + integer, intent(out) :: lb1 + integer, intent(out) :: ub1 + integer, intent(out) :: lb2 + integer, intent(out) :: ub2 + + ! local + integer :: ndims + integer :: d_index + + lb1 = 0 + ub1 = 0 + lb2 = 0 + ub2 = 0 + + ndims = dim_kinds(this%dim_kinds_index)%ndims + + ! The thread = 0 case is the boundaries for the whole proc/node + if (thread==0) then + d_index = dim_kinds(this%dim_kinds_index)%dim1_index + lb1 = dim_bounds(d_index)%lower_bound + ub1 = dim_bounds(d_index)%upper_bound + if(ndims>1)then + d_index = dim_kinds(this%dim_kinds_index)%dim2_index + lb2 = dim_bounds(d_index)%lower_bound + ub2 = dim_bounds(d_index)%upper_bound + end if + else + d_index = dim_kinds(this%dim_kinds_index)%dim1_index + lb1 = dim_bounds(d_index)%clump_lower_bound(thread) + ub1 = dim_bounds(d_index)%clump_upper_bound(thread) + if(ndims>1)then + d_index = dim_kinds(this%dim_kinds_index)%dim2_index + lb2 = dim_bounds(d_index)%clump_lower_bound(thread) + ub2 = dim_bounds(d_index)%clump_upper_bound(thread) + end if + end if + + end subroutine GetBounds + + ! ==================================================================================== + + subroutine FlushZero(this, thread, dim_bounds, dim_kinds) + + use FatesIODimensionsMod, only : fates_io_dimension_type + use FatesIOVariableKindMod, only : patch_r8, site_r8, cohort_r8 + use FatesIOVariableKindMod, only : patch_int, site_int, cohort_int + + implicit none + + class(fates_restart_variable_type), intent(inout) :: this + integer, intent(in) :: thread + type(fates_io_dimension_type), intent(in) :: dim_bounds(:) + type(fates_io_variable_kind_type), intent(in) :: dim_kinds(:) + + integer :: lb1, ub1, lb2, ub2 + + call this%GetBounds(thread, dim_bounds, dim_kinds, lb1, ub1, lb2, ub2) + + select case(trim(dim_kinds(this%dim_kinds_index)%name)) + case(patch_r8) + this%r81d(lb1:ub1) = 0.0_r8 + case(site_r8) + this%r81d(lb1:ub1) = 0.0_r8 + case(cohort_r8) + this%r81d(lb1:ub1) = 0.0_r8 + case(patch_int) + this%int1d(lb1:ub1) = 0 + case(site_int) + this%int1d(lb1:ub1) = 0 + case(cohort_int) + this%int1d(lb1:ub1) = 0 + + case default + write(fates_log(),*) 'fates history variable type undefined while flushing history variables' + stop + !end_run + end select + + end subroutine FlushZero + +end module FatesRestartVariableMod From e3760b29172ccc0520c02a322c769f20ae3fde2d Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 17 Nov 2016 14:02:35 -0800 Subject: [PATCH 240/437] Some commenting and documentation. Removed a nann-ing of lat and lon in zero site. --- main/EDInitMod.F90 | 4 ++-- main/FatesIODimensionsMod.F90 | 4 ++-- main/FatesRestartInterfaceMod.F90 | 16 ++++++---------- 3 files changed, 10 insertions(+), 14 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 18a52c16..00fa835c 100755 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -55,8 +55,8 @@ subroutine zero_site( site_in ) site_in%youngest_patch => null() ! pointer to yngest patch at the site ! INDICES - site_in%lat = nan - site_in%lon = nan +! site_in%lat = nan +! site_in%lon = nan ! DISTURBANCE site_in%disturbance_rate = 0._r8 ! site level disturbance rates from mortality and fire. diff --git a/main/FatesIODimensionsMod.F90 b/main/FatesIODimensionsMod.F90 index 2267f0c9..84c082e7 100644 --- a/main/FatesIODimensionsMod.F90 +++ b/main/FatesIODimensionsMod.F90 @@ -30,8 +30,8 @@ module FatesIODimensionsMod integer :: patch_end integer :: cohort_begin integer :: cohort_end - integer :: column_begin - integer :: column_end + integer :: column_begin ! FATES does not have a "column" type + integer :: column_end ! we call this a "site" (rgk 11-2016) integer :: ground_begin integer :: ground_end integer :: pft_class_begin diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 42504d11..ba7683e1 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -32,7 +32,7 @@ module FatesRestartInterfaceMod ! We also use associations to the data arrays of restart IO ! variables "rio", for example the leaf litter "leaf_litter" ! is retrieved for every patch and every functional type "paft" - ! thus: ir_leaf_litter_paft + ! thus: rio_leaf_litter_paft ! ! si: site dimension ! pa: patch dimension @@ -84,8 +84,8 @@ module FatesRestartInterfaceMod integer, private :: ir_nplant_co integer, private :: ir_gpp_acc_co integer, private :: ir_npp_acc_co - integer, private :: ir_gpp_co - integer, private :: ir_npp_co + integer, private :: ir_gpp_co ! IS THIS VARIABLE NECESSARY? ... (RGK 11-2016) + integer, private :: ir_npp_co ! IS THIS VARIABLE NECESSARY? ... (RGK 11-2016) integer, private :: ir_npp_leaf_co integer, private :: ir_npp_froot_co integer, private :: ir_npp_sw_co @@ -121,8 +121,8 @@ module FatesRestartInterfaceMod integer, private :: ir_watermem_siwm ! The number of variable dim/kind types we have defined (static) - integer, parameter :: fates_restart_num_dimensions = 2 - integer, parameter :: fates_restart_num_dim_kinds = 4 + integer, parameter :: fates_restart_num_dimensions = 2 !(cohort,column) + integer, parameter :: fates_restart_num_dim_kinds = 4 !(cohort-int,cohort-r8,site-int,site-r8) ! integer constants for storing logical data integer, parameter :: old_cohort = 0 @@ -141,7 +141,7 @@ module FatesRestartInterfaceMod ! more for things like flushing type restart_map_type integer, allocatable :: site_index(:) ! maps site indexes to the HIO site position - integer, allocatable :: patch1_index(:) ! maps site index to the HIO patch 1st position +! integer, allocatable :: patch1_index(:) ! maps site index to the HIO patch 1st position integer, allocatable :: cohort1_index(:) ! maps site index to the HIO cohort 1st position end type restart_map_type @@ -182,15 +182,11 @@ module FatesRestartInterfaceMod ! private work functions procedure, private :: init_dim_kinds_maps procedure, private :: set_dim_indices -! procedure, private :: set_patch_index (not currently used rgk 11-2016) procedure, private :: set_cohort_index procedure, private :: set_column_index procedure, private :: flushzero_rvars - procedure, private :: define_restart_vars procedure, private :: set_restart_var - - end type fates_restart_interface_type From dfb7d4c54ee772b3545bfec46deeeea73503cb0e Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 17 Nov 2016 15:14:19 -0800 Subject: [PATCH 241/437] Updated some variable names and tried to make naming conventions consistent across subroutines. This mostly addressed how global indexing in the restart files was named. --- biogeochem/EDCohortDynamicsMod.F90 | 4 +- biogeochem/EDPatchDynamicsMod.F90 | 4 +- biogeophys/EDPhotosynthesisMod.F90 | 8 +- biogeophys/EDSurfaceAlbedoMod.F90 | 14 +- main/EDInitMod.F90 | 4 - main/EDRestVectorMod.F90 | 8 +- main/EDTypesMod.F90 | 4 +- main/FatesInterfaceMod.F90 | 78 +++---- main/FatesRestartInterfaceMod.F90 | 344 ++++++++++++++--------------- 9 files changed, 227 insertions(+), 241 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index cdca9ec6..5fc649bb 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -11,7 +11,7 @@ module EDCohortDynamicsMod use EDGrowthFunctionsMod , only : c_area, tree_lai use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type use EDTypesMod , only : fusetol, cp_nclmax - use EDtypesMod , only : ncwd, numcohortsperpatch, udata + use EDtypesMod , only : ncwd, maxcohortsperpatch, udata use EDtypesMod , only : sclass_ed,nlevsclass_ed,AREA use EDtypesMod , only : min_npm2, min_nppatch, min_n_safemath ! @@ -616,7 +616,7 @@ subroutine fuse_cohorts(patchptr) iterate = 1 fusion_took_place = 0 currentPatch => patchptr - maxcohorts = numCohortsPerPatch + maxcohorts = maxCohortsPerPatch !---------------------------------------------------------------------! ! Keep doing this until nocohorts <= maxcohorts ! diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index c7cf190d..5fae1a78 100755 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -9,7 +9,7 @@ module EDPatchDynamicsMod 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, numPatchesPerCol + use EDtypesMod , only : ncwd, n_dbh_bins, ntol, numpft_ed, area, dbhmax, maxPatchesPerCol use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type, udata use EDTypesMod , only : min_patch_area, cp_numlevgrnd, cp_numSWb ! @@ -1018,7 +1018,7 @@ subroutine fuse_patches( csite ) !--------------------------------------------------------------------- !maxpatch = 4 - maxpatch = numPatchesPerCol + maxpatch = maxPatchesPerCol currentSite => csite diff --git a/biogeophys/EDPhotosynthesisMod.F90 b/biogeophys/EDPhotosynthesisMod.F90 index a9e6cf50..7e55aee9 100644 --- a/biogeophys/EDPhotosynthesisMod.F90 +++ b/biogeophys/EDPhotosynthesisMod.F90 @@ -54,7 +54,7 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) use EDTypesMod , only : ed_cohort_type use EDTypesMod , only : ed_site_type use EDTypesMod , only : numpft_ed - use EDTypesMod , only : numpatchespercol + use EDTypesMod , only : maxpatchespercol use EDTypesMod , only : cp_numlevsoil use EDTypesMod , only : cp_nlevcan use EDTypesMod , only : cp_nclmax @@ -105,9 +105,9 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) real(r8) :: ci ! intracellular leaf CO2 (Pa) real(r8) :: lnc(mxpft) ! leaf N concentration (gN leaf/m^2) - real(r8) :: kc( numpatchespercol ) ! Michaelis-Menten constant for CO2 (Pa) - real(r8) :: ko( numpatchespercol ) ! Michaelis-Menten constant for O2 (Pa) - real(r8) :: co2_cp( numpatchespercol ) ! CO2 compensation point (Pa) + real(r8) :: kc( maxpatchespercol ) ! Michaelis-Menten constant for CO2 (Pa) + real(r8) :: ko( maxpatchespercol ) ! Michaelis-Menten constant for O2 (Pa) + real(r8) :: co2_cp( maxpatchespercol ) ! CO2 compensation point (Pa) ! --------------------------------------------------------------- ! TO-DO: bbbopt is slated to be transferred to the parameter file diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index c4bdd45d..5180c0f8 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -12,7 +12,7 @@ module EDSurfaceRadiationMod use EDtypesMod , only : ed_patch_type, ed_site_type use EDtypesMod , only : numpft_ed - use EDtypesMod , only : numPatchesPerCol + use EDtypesMod , only : maxPatchesPerCol use shr_kind_mod , only : r8 => shr_kind_r8 use shr_log_mod , only : errMsg => shr_log_errMsg use FatesInterfaceMod , only : bc_in_type, & @@ -74,8 +74,8 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) real(r8) :: k_dir(numpft_ed) ! Direct beam extinction coefficient real(r8) :: tr_dir_z(cp_nclmax,numpft_ed,cp_nlevcan) ! Exponential transmittance of direct beam radiation through a single layer real(r8) :: tr_dif_z(cp_nclmax,numpft_ed,cp_nlevcan) ! Exponential transmittance of diffuse radiation through a single layer - real(r8) :: forc_dir(numPatchesPerCol,cp_maxSWb) - real(r8) :: forc_dif(numPatchesPerCol,cp_maxSWb) + real(r8) :: forc_dir(maxPatchesPerCol,cp_maxSWb) + real(r8) :: forc_dif(maxPatchesPerCol,cp_maxSWb) real(r8) :: weighted_dir_tr(cp_nclmax) real(r8) :: weighted_fsun(cp_nclmax) real(r8) :: weighted_dif_ratio(cp_nclmax,cp_maxSWb) @@ -93,8 +93,8 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) real(r8) :: abs_rad(cp_maxSWb) !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(numPatchesPerCol,numpft_ed) ! Radiation transmitted to the soil surface. - real(r8) :: phi2b(numPatchesPerCol,numpft_ed) + real(r8) :: phi1b(maxPatchesPerCol,numpft_ed) ! Radiation transmitted to the soil surface. + real(r8) :: phi2b(maxPatchesPerCol,numpft_ed) real(r8) :: laisum ! cumulative lai+sai for canopy layer (at middle of layer) real(r8) :: angle @@ -107,8 +107,8 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) integer :: fp,iv,s ! array indices integer :: ib ! waveband number real(r8) :: cosz ! 0.001 <= coszen <= 1.000 - real(r8) :: chil(numPatchesPerCol) ! -0.4 <= xl <= 0.6 - real(r8) :: gdir(numPatchesPerCol) ! leaf projection in solar direction (0 to 1) + real(r8) :: chil(maxPatchesPerCol) ! -0.4 <= xl <= 0.6 + real(r8) :: gdir(maxPatchesPerCol) ! leaf projection in solar direction (0 to 1) !----------------------------------------------------------------------- diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 00fa835c..e8830e41 100755 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -54,10 +54,6 @@ subroutine zero_site( site_in ) site_in%oldest_patch => null() ! pointer to oldest patch at the site site_in%youngest_patch => null() ! pointer to yngest patch at the site - ! INDICES -! site_in%lat = nan -! site_in%lon = nan - ! DISTURBANCE site_in%disturbance_rate = 0._r8 ! site level disturbance rates from mortality and fire. site_in%dist_type = 0 ! disturbance dist_type id. diff --git a/main/EDRestVectorMod.F90 b/main/EDRestVectorMod.F90 index f655c1be..b7a94fa2 100755 --- a/main/EDRestVectorMod.F90 +++ b/main/EDRestVectorMod.F90 @@ -9,7 +9,7 @@ module EDRestVectorMod use spmdMod , only : masterproc use decompMod , only : bounds_type use pftconMod , only : pftcon - use EDTypesMod , only : area, cohorts_per_col, numpft_ed, numWaterMem, cp_nclmax, numCohortsPerPatch + use EDTypesMod , only : area, cohorts_per_col, numpft_ed, numWaterMem, cp_nclmax, maxCohortsPerPatch use EDTypesMod , only : ncwd, invalidValue, cp_nlevcan use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type use abortutils , only : endrun @@ -1833,7 +1833,7 @@ subroutine convertCohortListToVector( this, bounds, nsites, sites, fcolumn ) if (this%DEBUG) write(iulog,*) 'CLTV countSunZ 2 ',countSunZ - incrementOffset = incrementOffset + numCohortsPerPatch + incrementOffset = incrementOffset + maxCohortsPerPatch ! reset counters so that they are all advanced evenly. Currently ! the offset is 10, the max of numpft_ed, ncwd, cp_nclmax, @@ -2076,7 +2076,7 @@ subroutine createPatchCohortStructure( this, bounds, nsites, sites, fcolumn ) endif - currIdx = currIdx + numCohortsPerPatch + currIdx = currIdx + maxCohortsPerPatch enddo ! ends loop over patchIdx @@ -2271,7 +2271,7 @@ subroutine convertCohortVectorToList( this, bounds, nsites, sites, fcolumn ) if (this%DEBUG) write(iulog,*) 'CVTL countSunZ 2 ',countSunZ - incrementOffset = incrementOffset + numCohortsPerPatch + incrementOffset = incrementOffset + maxCohortsPerPatch ! and the number of allowed cohorts per patch (currently 200) countPft = incrementOffset diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index d02891cb..35fdb699 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -24,8 +24,8 @@ module EDTypesMod ! for setting number of patches per gridcell and number of cohorts per patch ! for I/O and converting to a vector - integer, parameter :: numPatchesPerCol = 10 ! - integer, parameter :: numCohortsPerPatch = 160 ! + integer, parameter :: maxPatchesPerCol = 10 ! + integer, parameter :: maxCohortsPerPatch = 160 ! integer, parameter :: cohorts_per_col = 1600 ! This is the max number of individual items one can store per ! each grid cell and effects the striding in the ED restart diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 356951bc..9be0bfa8 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -16,7 +16,7 @@ module FatesInterfaceMod ! ------------------------------------------------------------------------------------ use EDtypesMod , only : ed_site_type, & - numPatchesPerCol, & + maxPatchesPerCol, & cp_nclmax, & cp_numSWb, & cp_numlevgrnd, & @@ -346,8 +346,8 @@ subroutine allocate_bcin(bc_in) ! Allocate input boundaries ! Radiation - allocate(bc_in%solad_parb(numPatchesPerCol,cp_numSWb)) - allocate(bc_in%solai_parb(numPatchesPerCol,cp_numSWb)) + allocate(bc_in%solad_parb(maxPatchesPerCol,cp_numSWb)) + allocate(bc_in%solai_parb(maxPatchesPerCol,cp_numSWb)) ! Hydrology allocate(bc_in%smp_gl(cp_numlevgrnd)) @@ -357,20 +357,20 @@ subroutine allocate_bcin(bc_in) allocate(bc_in%h2o_liqvol_gl(cp_numlevgrnd)) ! Photosynthesis - allocate(bc_in%filter_photo_pa(numPatchesPerCol)) - allocate(bc_in%dayl_factor_pa(numPatchesPerCol)) - allocate(bc_in%esat_tv_pa(numPatchesPerCol)) - allocate(bc_in%eair_pa(numPatchesPerCol)) - allocate(bc_in%oair_pa(numPatchesPerCol)) - allocate(bc_in%cair_pa(numPatchesPerCol)) - allocate(bc_in%rb_pa(numPatchesPerCol)) - allocate(bc_in%t_veg_pa(numPatchesPerCol)) - allocate(bc_in%tgcm_pa(numPatchesPerCol)) + allocate(bc_in%filter_photo_pa(maxPatchesPerCol)) + allocate(bc_in%dayl_factor_pa(maxPatchesPerCol)) + allocate(bc_in%esat_tv_pa(maxPatchesPerCol)) + allocate(bc_in%eair_pa(maxPatchesPerCol)) + allocate(bc_in%oair_pa(maxPatchesPerCol)) + allocate(bc_in%cair_pa(maxPatchesPerCol)) + allocate(bc_in%rb_pa(maxPatchesPerCol)) + allocate(bc_in%t_veg_pa(maxPatchesPerCol)) + allocate(bc_in%tgcm_pa(maxPatchesPerCol)) allocate(bc_in%t_soisno_gl(cp_numlevgrnd)) ! Canopy Radiation - allocate(bc_in%filter_vegzen_pa(numPatchesPerCol)) - allocate(bc_in%coszen_pa(numPatchesPerCol)) + allocate(bc_in%filter_vegzen_pa(maxPatchesPerCol)) + allocate(bc_in%coszen_pa(maxPatchesPerCol)) allocate(bc_in%albgr_dir_rb(cp_numSWb)) allocate(bc_in%albgr_dif_rb(cp_numSWb)) @@ -394,30 +394,30 @@ subroutine allocate_bcout(bc_out) ! Radiation - allocate(bc_out%fsun_pa(numPatchesPerCol)) - allocate(bc_out%laisun_pa(numPatchesPerCol)) - allocate(bc_out%laisha_pa(numPatchesPerCol)) + allocate(bc_out%fsun_pa(maxPatchesPerCol)) + allocate(bc_out%laisun_pa(maxPatchesPerCol)) + allocate(bc_out%laisha_pa(maxPatchesPerCol)) ! Hydrology allocate(bc_out%active_suction_gl(cp_numlevgrnd)) - allocate(bc_out%rootr_pagl(numPatchesPerCol,cp_numlevgrnd)) - allocate(bc_out%btran_pa(numPatchesPerCol)) + allocate(bc_out%rootr_pagl(maxPatchesPerCol,cp_numlevgrnd)) + allocate(bc_out%btran_pa(maxPatchesPerCol)) ! Photosynthesis - allocate(bc_out%rssun_pa(numPatchesPerCol)) - allocate(bc_out%rssha_pa(numPatchesPerCol)) - allocate(bc_out%gccanopy_pa(numPatchesPerCol)) - allocate(bc_out%lmrcanopy_pa(numPatchesPerCol)) - allocate(bc_out%psncanopy_pa(numPatchesPerCol)) + allocate(bc_out%rssun_pa(maxPatchesPerCol)) + allocate(bc_out%rssha_pa(maxPatchesPerCol)) + allocate(bc_out%gccanopy_pa(maxPatchesPerCol)) + allocate(bc_out%lmrcanopy_pa(maxPatchesPerCol)) + allocate(bc_out%psncanopy_pa(maxPatchesPerCol)) ! Canopy Radiation - allocate(bc_out%albd_parb(numPatchesPerCol,cp_numSWb)) - allocate(bc_out%albi_parb(numPatchesPerCol,cp_numSWb)) - allocate(bc_out%fabd_parb(numPatchesPerCol,cp_numSWb)) - allocate(bc_out%fabi_parb(numPatchesPerCol,cp_numSWb)) - allocate(bc_out%ftdd_parb(numPatchesPerCol,cp_numSWb)) - allocate(bc_out%ftid_parb(numPatchesPerCol,cp_numSWb)) - allocate(bc_out%ftii_parb(numPatchesPerCol,cp_numSWb)) + allocate(bc_out%albd_parb(maxPatchesPerCol,cp_numSWb)) + allocate(bc_out%albi_parb(maxPatchesPerCol,cp_numSWb)) + allocate(bc_out%fabd_parb(maxPatchesPerCol,cp_numSWb)) + allocate(bc_out%fabi_parb(maxPatchesPerCol,cp_numSWb)) + allocate(bc_out%ftdd_parb(maxPatchesPerCol,cp_numSWb)) + allocate(bc_out%ftid_parb(maxPatchesPerCol,cp_numSWb)) + allocate(bc_out%ftii_parb(maxPatchesPerCol,cp_numSWb)) ! biogeochemistry allocate(bc_out%FATES_c_to_litr_lab_c_col(cp_numlevdecomp_full)) @@ -425,14 +425,14 @@ subroutine allocate_bcout(bc_out) allocate(bc_out%FATES_c_to_litr_lig_c_col(cp_numlevdecomp_full)) ! Canopy Structure - allocate(bc_out%elai_pa(numPatchesPerCol)) - allocate(bc_out%esai_pa(numPatchesPerCol)) - allocate(bc_out%tlai_pa(numPatchesPerCol)) - allocate(bc_out%tsai_pa(numPatchesPerCol)) - allocate(bc_out%htop_pa(numPatchesPerCol)) - allocate(bc_out%hbot_pa(numPatchesPerCol)) - allocate(bc_out%canopy_fraction_pa(numPatchesPerCol)) - allocate(bc_out%frac_veg_nosno_alb_pa(numPatchesPerCol)) + allocate(bc_out%elai_pa(maxPatchesPerCol)) + allocate(bc_out%esai_pa(maxPatchesPerCol)) + allocate(bc_out%tlai_pa(maxPatchesPerCol)) + allocate(bc_out%tsai_pa(maxPatchesPerCol)) + allocate(bc_out%htop_pa(maxPatchesPerCol)) + allocate(bc_out%hbot_pa(maxPatchesPerCol)) + allocate(bc_out%canopy_fraction_pa(maxPatchesPerCol)) + allocate(bc_out%frac_veg_nosno_alb_pa(maxPatchesPerCol)) return diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index ba7683e1..dee2cbb1 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -343,6 +343,7 @@ integer function column_index(this) column_index = this%column_index_ end function column_index + ! ======================================================================= subroutine init_dim_kinds_maps(this) @@ -388,7 +389,8 @@ subroutine init_dim_kinds_maps(this) end subroutine init_dim_kinds_maps - ! ==================================================================================== + ! ==================================================================================== + integer function num_restart_vars(this) implicit none @@ -446,29 +448,16 @@ subroutine define_restart_vars(this, initialize_variables) ! --------------------------------------------------------------------------------- ! - ! REGISTRY OF HISTORY OUTPUT VARIABLES - ! - ! This subroutine is called in two contexts, either in count mode or inialize mode - ! In count mode, we just walk through the list of registerred variables, compare - ! if the variable of interest list the current host model and add it to the count - ! if true. This count is used just to allocate the variable space. After this - ! has been done, we go through the list a second time populating a memory structure. - ! This phase is the "initialize" phase. These two phases are differntiated by the - ! string "callstep", which should be either "count" or "initialize". + ! REGISTRY OF RESTART OUTPUT VARIABLES ! - ! Note 1 there are different ways you can flush or initialize the output fields. - ! If you flush to a native type, (such as zero), the entire slab which covers - ! indices which may not be relevant to FATES, are flushed to this value. So - ! in that case, lakes and crops that are not controlled by FATES will zero'd - ! and when values are scaled up to the land-grid, the zero's for non FATES will - ! be included. This is good and correct if nothing is there. + ! Please add any restart variables to this registry. This registry will handle + ! all variables that can make use of 1D column dimensioned or 1D cohort dimensioned + ! variables. Note that restarts are only using 1D vectors in ALM and CLM. If you + ! have a multi-dimensional variable that is below the cohort scale, then pack + ! that variable into a cohort-sized output array by giving it a vtype "cohort_r8" + ! or "cohort_int". ! - ! But, what if crops exist in the host model and occupy a fraction of the land-surface - ! shared with natural vegetation? In that case, you want to flush your arrays - ! with a value that the HLM treats as "do not average" - ! - ! If your HLM makes use of, and you want, INTEGER OUTPUT, pass the flushval as - ! a real. The applied flush value will use the NINT() intrinsic function + ! Unlike history variables, restarts flush to zero. ! --------------------------------------------------------------------------------- use FatesIOVariableKindMod, only : site_r8, site_int, cohort_int, cohort_r8 @@ -858,7 +847,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) use EDTypesMod, only : cp_nclmax use EDTypesMod, only : cp_nlevcan - use EDTypesMod, only : numCohortsPerPatch + use EDTypesMod, only : maxCohortsPerPatch use EDTypesMod, only : numpft_ed use EDTypesMod, only : ed_site_type use EDTypesMod, only : ed_cohort_type @@ -875,30 +864,31 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ! Locals integer :: s ! The local site index - integer :: io_si ! The site index of the IO array - integer :: io_co - integer :: incrementOffset - integer :: countCohort - integer :: countPft - integer :: countNcwd - integer :: countNclmax - integer :: countWaterMem - integer :: countSunZ - integer :: numCohorts - integer :: numPatches - - integer :: ivar ! index of IO variable object vector + + ! ---------------------------------------------------------------------------------- + ! The following group of integers indicate the positional index (idx) + ! of variables at different scales inside the I/O arrays (io) + ! Keep in mind that many of these variables have a composite dimension + ! at the patch scale. To hold this memory, we borrow the cohort + ! vector. Thus the head of each array points to the first cohort + ! of each patch. "io_idx_co_1st" + ! ---------------------------------------------------------------------------------- + integer :: io_idx_si ! site index + integer :: io_idx_co_1st ! 1st cohort of each patch + integer :: io_idx_co ! cohort index + integer :: io_idx_pa_pft ! each pft within each patch (pa_pft) + integer :: io_idx_pa_cwd ! each cwd class within each patch (pa_cwd) + integer :: io_idx_pa_cl ! each canopy layer class within each patch (pa_cl) + integer :: io_idx_pa_sunz ! index for the combined dimensions for radiation + integer :: io_idx_si_wmem ! each water memory class within each site + + ! Some counters (for checking mostly) + integer :: totalcohorts ! total cohort count on this thread (diagnostic) + integer :: patchespersite ! number of patches per site + integer :: cohortsperpatch ! number of cohorts per patch + integer :: ft ! functional type index - integer :: scpf ! index of the size-class x pft bin - integer :: sc ! index of the size-class bin - integer :: totalcohorts ! total cohort count integer :: k,j,i ! indices to the radiation matrix - - real(r8) :: n_density ! individual of cohort per m2. - real(r8) :: n_perm2 ! individuals per m2 for the whole column - real(r8) :: patch_scaling_scalar ! ratio of canopy to patch area for - ! counteracting patch scaling - real(r8) :: dbh ! diameter ("at breast height") type(fates_restart_variable_type) :: rvar type(ed_patch_type),pointer :: cpatch @@ -995,93 +985,92 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ! For the first site, if that site aligns with the first column index ! in the clump, than the offset should be be equal to begCohort - io_si = this%restart_map(nc)%site_index(s) - io_co = this%restart_map(nc)%cohort1_index(s) - - incrementOffset = io_co - countCohort = io_co - countPft = io_co - countNcwd = io_co - countNclmax = io_co - countWaterMem = io_co - countSunZ = io_co + io_idx_si = this%restart_map(nc)%site_index(s) + io_idx_co_1st = this%restart_map(nc)%cohort1_index(s) + + io_idx_co = io_idx_co_1st + io_idx_pa_pft = io_idx_co_1st + io_idx_pa_cwd = io_idx_co_1st + io_idx_pa_cl = io_idx_co_1st + io_idx_si_wmem = io_idx_co_1st + io_idx_pa_sunz = io_idx_co_1st ! write seed_bank info(site-level, but PFT-resolved) do i = 1,numpft_ed - rio_seed_bank_co(incrementOffset+i-1) = sites(s)%seed_bank(i) + rio_seed_bank_co(io_idx_co_1st+i-1) = sites(s)%seed_bank(i) end do cpatch => sites(s)%oldest_patch ! new column, reset num patches - numPatches = 0 + patchespersite = 0 do while(associated(cpatch)) ! found patch, increment - numPatches = numPatches + 1 + patchespersite = patchespersite + 1 ccohort => cpatch%shortest ! new patch, reset num cohorts - numCohorts = 0 + cohortsperpatch = 0 do while(associated(ccohort)) ! found cohort, increment - numCohorts = numCohorts + 1 + cohortsperpatch = cohortsperpatch + 1 totalCohorts = totalCohorts + 1 if ( DEBUG ) then - write(fates_log(),*) 'CLTV countCohort ', countCohort + write(fates_log(),*) 'CLTV io_idx_co ', io_idx_co write(fates_log(),*) 'CLTV lowerbound ', lbound(rio_npp_acc_co,1) write(fates_log(),*) 'CLTV upperbound ', ubound(rio_npp_acc_co,1) endif - rio_balive_co(countCohort) = ccohort%balive - rio_bdead_co(countCohort) = ccohort%bdead - rio_bleaf_co(countCohort) = ccohort%bl - rio_broot_co(countCohort) = ccohort%br - rio_bstore_co(countCohort) = ccohort%bstore - rio_canopy_layer_co(countCohort) = ccohort%canopy_layer - rio_canopy_trim_co(countCohort) = ccohort%canopy_trim - rio_dbh_co(countCohort) = ccohort%dbh - rio_height_co(countCohort) = ccohort%hite - rio_laimemory_co(countCohort) = ccohort%laimemory - rio_leaf_md_co(countCohort) = ccohort%leaf_md - rio_root_md_co(countCohort) = ccohort%root_md - rio_nplant_co(countCohort) = ccohort%n - rio_gpp_acc_co(countCohort) = ccohort%gpp_acc - rio_npp_acc_co(countCohort) = ccohort%npp_acc - rio_gpp_co(countCohort) = ccohort%gpp - rio_npp_co(countCohort) = ccohort%npp - rio_npp_leaf_co(countCohort) = ccohort%npp_leaf - rio_npp_froot_co(countCohort) = ccohort%npp_froot - rio_npp_sw_co(countCohort) = ccohort%npp_bsw - rio_npp_dead_co(countCohort) = ccohort%npp_bdead - rio_npp_seed_co(countCohort) = ccohort%npp_bseed - rio_npp_store_co(countCohort) = ccohort%npp_store - rio_bmort_co(countCohort) = ccohort%bmort - rio_hmort_co(countCohort) = ccohort%hmort - rio_cmort_co(countCohort) = ccohort%cmort - rio_imort_co(countCohort) = ccohort%imort - rio_fmort_co(countCohort) = ccohort%fmort - rio_ddbhdt_co(countCohort) = ccohort%ddbhdt - rio_resp_tstep_co(countCohort) = ccohort%resp_tstep - rio_pft_co(countCohort) = ccohort%pft - rio_status_co(countCohort) = ccohort%status_coh + rio_balive_co(io_idx_co) = ccohort%balive + rio_bdead_co(io_idx_co) = ccohort%bdead + rio_bleaf_co(io_idx_co) = ccohort%bl + rio_broot_co(io_idx_co) = ccohort%br + rio_bstore_co(io_idx_co) = ccohort%bstore + rio_canopy_layer_co(io_idx_co) = ccohort%canopy_layer + rio_canopy_trim_co(io_idx_co) = ccohort%canopy_trim + rio_dbh_co(io_idx_co) = ccohort%dbh + rio_height_co(io_idx_co) = ccohort%hite + rio_laimemory_co(io_idx_co) = ccohort%laimemory + rio_leaf_md_co(io_idx_co) = ccohort%leaf_md + rio_root_md_co(io_idx_co) = ccohort%root_md + rio_nplant_co(io_idx_co) = ccohort%n + rio_gpp_acc_co(io_idx_co) = ccohort%gpp_acc + rio_npp_acc_co(io_idx_co) = ccohort%npp_acc + rio_gpp_co(io_idx_co) = ccohort%gpp + rio_npp_co(io_idx_co) = ccohort%npp + rio_npp_leaf_co(io_idx_co) = ccohort%npp_leaf + rio_npp_froot_co(io_idx_co) = ccohort%npp_froot + rio_npp_sw_co(io_idx_co) = ccohort%npp_bsw + rio_npp_dead_co(io_idx_co) = ccohort%npp_bdead + rio_npp_seed_co(io_idx_co) = ccohort%npp_bseed + rio_npp_store_co(io_idx_co) = ccohort%npp_store + rio_bmort_co(io_idx_co) = ccohort%bmort + rio_hmort_co(io_idx_co) = ccohort%hmort + rio_cmort_co(io_idx_co) = ccohort%cmort + rio_imort_co(io_idx_co) = ccohort%imort + rio_fmort_co(io_idx_co) = ccohort%fmort + rio_ddbhdt_co(io_idx_co) = ccohort%ddbhdt + rio_resp_tstep_co(io_idx_co) = ccohort%resp_tstep + rio_pft_co(io_idx_co) = ccohort%pft + rio_status_co(io_idx_co) = ccohort%status_coh if ( ccohort%isnew ) then - rio_isnew_co(countCohort) = new_cohort + rio_isnew_co(io_idx_co) = new_cohort else - rio_isnew_co(countCohort) = old_cohort + rio_isnew_co(io_idx_co) = old_cohort endif if ( DEBUG ) then - write(fates_log(),*) 'CLTV offsetNumCohorts II ',countCohort, & - numCohorts + write(fates_log(),*) 'CLTV offsetNumCohorts II ',io_idx_co, & + cohortsperpatch endif - countCohort = countCohort + 1 + io_idx_co = io_idx_co + 1 ccohort => ccohort%taller @@ -1090,16 +1079,16 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ! ! deal with patch level fields here ! - rio_livegrass_pa(incrementOffset) = cpatch%livegrass - rio_age_pa(incrementOffset) = cpatch%age - rio_area_pa(incrementOffset) = cpatch%area + rio_livegrass_pa(io_idx_co_1st) = cpatch%livegrass + rio_age_pa(io_idx_co_1st) = cpatch%age + rio_area_pa(io_idx_co_1st) = cpatch%area ! set cohorts per patch for IO - rio_ncohort_pa( incrementOffset ) = numCohorts + rio_ncohort_pa( io_idx_co_1st ) = cohortsperpatch if ( DEBUG ) then write(fates_log(),*) 'offsetNumCohorts III ' & - ,countCohort,cohorts_per_col, numCohorts + ,io_idx_co,cohorts_per_col, cohortsperpatch endif ! ! deal with patch level fields of arrays here @@ -1107,58 +1096,58 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ! these are arrays of length numpft_ed, each patch contains one ! vector so we increment do i = 1,numpft_ed - rio_leaf_litter_paft(countPft) = cpatch%leaf_litter(i) - rio_root_litter_paft(countPft) = cpatch%root_litter(i) - rio_leaf_litter_in_paft(countPft) = cpatch%leaf_litter_in(i) - rio_root_litter_in_paft(countPft) = cpatch%root_litter_in(i) - countPft = countPft + 1 + rio_leaf_litter_paft(io_idx_pa_pft) = cpatch%leaf_litter(i) + rio_root_litter_paft(io_idx_pa_pft) = cpatch%root_litter(i) + rio_leaf_litter_in_paft(io_idx_pa_pft) = cpatch%leaf_litter_in(i) + rio_root_litter_in_paft(io_idx_pa_pft) = cpatch%root_litter_in(i) + io_idx_pa_pft = io_idx_pa_pft + 1 end do do i = 1,ncwd ! ncwd currently 4 - rio_cwd_ag_pacw(countNcwd) = cpatch%cwd_ag(i) - rio_cwd_bg_pacw(countNcwd) = cpatch%cwd_bg(i) - countNcwd = countNcwd + 1 + rio_cwd_ag_pacw(io_idx_pa_cwd) = cpatch%cwd_ag(i) + rio_cwd_bg_pacw(io_idx_pa_cwd) = cpatch%cwd_bg(i) + io_idx_pa_cwd = io_idx_pa_cwd + 1 end do do i = 1,cp_nclmax ! cp_nclmax currently 2 - rio_spread_pacl(countNclmax) = cpatch%spread(i) - countNclmax = countNclmax + 1 + rio_spread_pacl(io_idx_pa_cl) = cpatch%spread(i) + io_idx_pa_cl = io_idx_pa_cl + 1 end do - if ( DEBUG ) write(fates_log(),*) 'CLTV countSunZ 1 ',countSunZ + if ( DEBUG ) write(fates_log(),*) 'CLTV io_idx_pa_sunz 1 ',io_idx_pa_sunz if ( DEBUG ) write(fates_log(),*) 'CLTV 1186 ',cp_nlevcan,numpft_ed,cp_nclmax do k = 1,cp_nlevcan ! cp_nlevcan currently 40 do j = 1,numpft_ed ! numpft_ed currently 2 do i = 1,cp_nclmax ! cp_nclmax currently 2 - rio_fsun_paclftls(countSunZ) = cpatch%f_sun(i,j,k) - rio_fabd_sun_z_paclftls(countSunZ) = cpatch%fabd_sun_z(i,j,k) - rio_fabi_sun_z_paclftls(countSunZ) = cpatch%fabi_sun_z(i,j,k) - rio_fabd_sha_z_paclftls(countSunZ) = cpatch%fabd_sha_z(i,j,k) - rio_fabi_sha_z_paclftls(countSunZ) = cpatch%fabi_sha_z(i,j,k) - countSunZ = countSunZ + 1 + rio_fsun_paclftls(io_idx_pa_sunz) = cpatch%f_sun(i,j,k) + rio_fabd_sun_z_paclftls(io_idx_pa_sunz) = cpatch%fabd_sun_z(i,j,k) + rio_fabi_sun_z_paclftls(io_idx_pa_sunz) = cpatch%fabi_sun_z(i,j,k) + rio_fabd_sha_z_paclftls(io_idx_pa_sunz) = cpatch%fabd_sha_z(i,j,k) + rio_fabi_sha_z_paclftls(io_idx_pa_sunz) = cpatch%fabi_sha_z(i,j,k) + io_idx_pa_sunz = io_idx_pa_sunz + 1 end do end do end do - if ( DEBUG ) write(fates_log(),*) 'CLTV countSunZ 2 ',countSunZ + if ( DEBUG ) write(fates_log(),*) 'CLTV io_idx_pa_sunz 2 ',io_idx_pa_sunz - incrementOffset = incrementOffset + numCohortsPerPatch + io_idx_co_1st = io_idx_co_1st + maxCohortsPerPatch ! reset counters so that they are all advanced evenly. Currently ! the offset is 10, the max of numpft_ed, ncwd, cp_nclmax, - ! countWaterMem and the number of allowed cohorts per patch - countPft = incrementOffset - countNcwd = incrementOffset - countNclmax = incrementOffset - countCohort = incrementOffset - countSunZ = incrementOffset + ! io_idx_si_wmem and the number of allowed cohorts per patch + io_idx_pa_pft = io_idx_co_1st + io_idx_pa_cwd = io_idx_co_1st + io_idx_pa_cl = io_idx_co_1st + io_idx_co = io_idx_co_1st + io_idx_pa_sunz = io_idx_co_1st if ( DEBUG ) then - write(fates_log(),*) 'CLTV incrementOffset ', incrementOffset + write(fates_log(),*) 'CLTV io_idx_co_1st ', io_idx_co_1st write(fates_log(),*) 'CLTV cohorts_per_col ', cohorts_per_col - write(fates_log(),*) 'CLTV numCohort ', numCohorts + write(fates_log(),*) 'CLTV numCohort ', cohortsperpatch write(fates_log(),*) 'CLTV totalCohorts ', totalCohorts end if @@ -1166,37 +1155,37 @@ subroutine set_restart_vectors(this,nc,nsites,sites) enddo ! cpatch do while - rio_old_stock_si(io_si) = sites(s)%old_stock - rio_cd_status_si(io_si) = sites(s)%status - rio_dd_status_si(io_si) = sites(s)%dstatus - rio_nchill_days_si(io_si) = sites(s)%ncd - rio_leafondate_si(io_si) = sites(s)%leafondate - rio_leafoffdate_si(io_si) = sites(s)%leafoffdate - rio_dleafondate_si(io_si) = sites(s)%dleafondate - rio_dleafoffdate_si(io_si) = sites(s)%dleafoffdate - rio_acc_ni_si(io_si) = sites(s)%acc_NI - rio_gdd_si(io_si) = sites(s)%ED_GDD_site + rio_old_stock_si(io_idx_si) = sites(s)%old_stock + rio_cd_status_si(io_idx_si) = sites(s)%status + rio_dd_status_si(io_idx_si) = sites(s)%dstatus + rio_nchill_days_si(io_idx_si) = sites(s)%ncd + rio_leafondate_si(io_idx_si) = sites(s)%leafondate + rio_leafoffdate_si(io_idx_si) = sites(s)%leafoffdate + rio_dleafondate_si(io_idx_si) = sites(s)%dleafondate + rio_dleafoffdate_si(io_idx_si) = sites(s)%dleafoffdate + rio_acc_ni_si(io_idx_si) = sites(s)%acc_NI + rio_gdd_si(io_idx_si) = sites(s)%ED_GDD_site ! Carbon Balance and Checks - rio_nep_timeintegrated_si(io_si) = sites(s)%nep_timeintegrated - rio_npp_timeintegrated_si(io_si) = sites(s)%npp_timeintegrated - rio_hr_timeintegrated_si(io_si) = sites(s)%hr_timeintegrated - rio_totecosysc_old_si(io_si) = sites(s)%totecosysc_old - rio_totfatesc_old_si(io_si) = sites(s)%totfatesc_old - rio_totbgcc_old_si(io_si) = sites(s)%totbgcc_old - rio_cbal_err_fates_si(io_si) = sites(s)%cbal_err_fates - rio_cbal_err_bgc_si(io_si) = sites(s)%cbal_err_bgc - rio_cbal_err_tot_si(io_si) = sites(s)%cbal_err_tot - rio_fates_to_bgc_this_ts_si(io_si) = sites(s)%fates_to_bgc_this_ts - rio_fates_to_bgc_last_ts_si(io_si) = sites(s)%fates_to_bgc_last_ts - rio_seedrainflux_si(io_si) = sites(s)%tot_seed_rain_flux + rio_nep_timeintegrated_si(io_idx_si) = sites(s)%nep_timeintegrated + rio_npp_timeintegrated_si(io_idx_si) = sites(s)%npp_timeintegrated + rio_hr_timeintegrated_si(io_idx_si) = sites(s)%hr_timeintegrated + rio_totecosysc_old_si(io_idx_si) = sites(s)%totecosysc_old + rio_totfatesc_old_si(io_idx_si) = sites(s)%totfatesc_old + rio_totbgcc_old_si(io_idx_si) = sites(s)%totbgcc_old + rio_cbal_err_fates_si(io_idx_si) = sites(s)%cbal_err_fates + rio_cbal_err_bgc_si(io_idx_si) = sites(s)%cbal_err_bgc + rio_cbal_err_tot_si(io_idx_si) = sites(s)%cbal_err_tot + rio_fates_to_bgc_this_ts_si(io_idx_si) = sites(s)%fates_to_bgc_this_ts + rio_fates_to_bgc_last_ts_si(io_idx_si) = sites(s)%fates_to_bgc_last_ts + rio_seedrainflux_si(io_idx_si) = sites(s)%tot_seed_rain_flux ! set numpatches for this column - rio_npatch_si(io_si) = numPatches + rio_npatch_si(io_idx_si) = patchespersite do i = 1,numWaterMem ! numWaterMem currently 10 - rio_watermem_siwm( countWaterMem ) = sites(s)%water_memory(i) - countWaterMem = countWaterMem + 1 + rio_watermem_siwm( io_idx_si_wmem ) = sites(s)%water_memory(i) + io_idx_si_wmem = io_idx_si_wmem + 1 end do enddo @@ -1225,7 +1214,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites ) use EDTypesMod, only : ncwd use EDTypesMod, only : cp_nlevcan use EDTypesMod, only : cp_nclmax - use EDTypesMod, only : numCohortsPerPatch + use EDTypesMod, only : maxCohortsPerPatch use EDTypesMod, only : numpft_ed use EDTypesMod, only : area use EDPatchDynamicsMod, only : zero_patch @@ -1254,9 +1243,10 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites ) real(r8) :: patch_age integer :: cohortstatus integer :: s ! site index - integer :: patchIdx ! local patch index, 1: - integer :: io_si ! global site index in IO vector - integer :: io_co ! global cohort index in IO vector + integer :: idx_pa ! local patch index + integer :: io_idx_si ! global site index in IO vector + integer :: io_idx_co_1st ! global cohort index in IO vector + integer :: fto integer :: ft @@ -1280,8 +1270,8 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites ) do s = 1,nsites - io_si = this%restart_map(nc)%site_index(s) - io_co = this%restart_map(nc)%cohort1_index(s) + io_idx_si = this%restart_map(nc)%site_index(s) + io_idx_co_1st = this%restart_map(nc)%cohort1_index(s) call zero_site( sites(s) ) @@ -1292,9 +1282,9 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites ) sites(s)%ncd = 0.0_r8 - if ( rio_npatch_si(io_si)<0 .or. rio_npatch_si(io_si) > 10000 ) then + if ( rio_npatch_si(io_idx_si)<0 .or. rio_npatch_si(io_idx_si) > 10000 ) then write(fates_log(),*) 'a column was expected to contain a valid number of patches' - write(fates_log(),*) '0 is a valid number, but this column seems uninitialized',rio_npatch_si(io_si) + write(fates_log(),*) '0 is a valid number, but this column seems uninitialized',rio_npatch_si(io_idx_si) call endrun(msg=errMsg(sourcefile, __LINE__)) end if @@ -1302,11 +1292,11 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites ) sites(s)%youngest_patch => null() sites(s)%oldest_patch => null() - do patchIdx = 1,rio_npatch_si(io_si) + do idx_pa = 1,rio_npatch_si(io_idx_si) if ( DEBUG ) then - write(fates_log(),*) 'create patch ',patchIdx - write(fates_log(),*) 'patchIdx 1-numCohorts : ', rio_ncohort_pa( io_co ) + write(fates_log(),*) 'create patch ',idx_pa + write(fates_log(),*) 'idx_pa 1-cohortsperpatch : ', rio_ncohort_pa( io_idx_co_1st ) end if ! create patch @@ -1320,9 +1310,9 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites ) newp%siteptr => sites(s) ! give this patch a unique patch number - newp%patchno = patchIdx + newp%patchno = idx_pa - do fto = 1, rio_ncohort_pa( io_co ) + do fto = 1, rio_ncohort_pa( io_idx_co_1st ) allocate(temp_cohort) @@ -1368,9 +1358,9 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites ) ! 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 (idx_pa == 1) then ! nothing associated yet. first patch is pointed to by youngest and oldest - if ( DEBUG ) write(fates_log(),*) 'patchIdx = 1 ',patchIdx + if ( DEBUG ) write(fates_log(),*) 'idx_pa = 1 ',idx_pa sites(s)%youngest_patch => newp sites(s)%oldest_patch => newp @@ -1379,9 +1369,9 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites ) sites(s)%oldest_patch%younger => null() sites(s)%oldest_patch%older => null() - else if (patchIdx == 2) then ! add second patch to list + else if (idx_pa == 2) then ! add second patch to list - if ( DEBUG ) write(fates_log(),*) 'patchIdx = 2 ',patchIdx + if ( DEBUG ) write(fates_log(),*) 'idx_pa = 2 ',idx_pa sites(s)%youngest_patch => newp sites(s)%youngest_patch%younger => null() @@ -1391,7 +1381,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites ) else ! more than 2 patches, insert patch into youngest slot - if ( DEBUG ) write(fates_log(),*) 'patchIdx > 2 ',patchIdx + if ( DEBUG ) write(fates_log(),*) 'idx_pa > 2 ',idx_pa newp%older => sites(s)%youngest_patch sites(s)%youngest_patch%younger => newp @@ -1400,9 +1390,9 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites ) endif - io_co = io_co + numCohortsPerPatch + io_idx_co_1st = io_idx_co_1st + maxCohortsPerPatch - enddo ! ends loop over patchIdx + enddo ! ends loop over idx_pa enddo ! ends loop over s @@ -1420,7 +1410,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) use EDTypesMod, only : ncwd use EDTypesMod, only : cp_nlevcan use EDTypesMod, only : cp_nclmax - use EDTypesMod, only : numCohortsPerPatch + use EDTypesMod, only : maxCohortsPerPatch use EDTypesMod, only : cohorts_per_col use EDTypesMod, only : numWaterMem @@ -1693,7 +1683,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ! Now increment the position of the first cohort to that of the next ! patch - io_idx_co_1st = io_idx_co_1st + numcohortsPerPatch + io_idx_co_1st = io_idx_co_1st + maxCohortsPerPatch ! and the number of allowed cohorts per patch (currently 200) io_idx_pa_pft = io_idx_co_1st From 2201bac0cf0dd097637a745cb125de63530cd5e0 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 17 Nov 2016 16:21:58 -0800 Subject: [PATCH 242/437] Subroutine SetThreadBounds was a procedure in two different classes doing two different things, changed the name of one procedure to reduce confusion. --- main/FatesHistoryInterfaceMod.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index ec8c9813..59721fc3 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -174,7 +174,7 @@ module FatesHistoryInterfaceMod contains procedure, public :: Init - procedure, public :: SetThreadBounds + procedure, public :: SetThreadBoundsEach procedure, public :: initialize_history_vars procedure, public :: assemble_history_output_types @@ -249,7 +249,7 @@ subroutine Init(this, num_threads, fates_bounds) end subroutine Init ! ====================================================================== - subroutine SetThreadBounds(this, thread_index, thread_bounds) + subroutine SetThreadBoundsEach(this, thread_index, thread_bounds) use FatesIODimensionsMod, only : fates_bounds_type @@ -278,7 +278,7 @@ subroutine SetThreadBounds(this, thread_index, thread_bounds) call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%pft_class_begin, thread_bounds%pft_class_end) - end subroutine SetThreadBounds + end subroutine SetThreadBoundsEach ! =================================================================================== subroutine assemble_history_output_types(this) From 0efd21af8b8a46d0308f11f6f1dd273294e8a90c Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 17 Nov 2016 17:09:01 -0800 Subject: [PATCH 243/437] Removal of old EDRestartVectorMod and some stail use calls to it. --- main/EDRestVectorMod.F90 | 2383 -------------------------------------- 1 file changed, 2383 deletions(-) delete mode 100755 main/EDRestVectorMod.F90 diff --git a/main/EDRestVectorMod.F90 b/main/EDRestVectorMod.F90 deleted file mode 100755 index b7a94fa2..00000000 --- a/main/EDRestVectorMod.F90 +++ /dev/null @@ -1,2383 +0,0 @@ -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 spmdMod , only : masterproc - use decompMod , only : bounds_type - use pftconMod , only : pftcon - use EDTypesMod , only : area, cohorts_per_col, numpft_ed, numWaterMem, cp_nclmax, maxCohortsPerPatch - use EDTypesMod , only : ncwd, invalidValue, cp_nlevcan - use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type - use abortutils , only : endrun - - ! - implicit none - private - ! - ! integer constants for storing logical data - integer, parameter :: old_cohort = 0 - integer, parameter :: new_cohort = 1 - ! - ! 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 :: numPatchesPerCol(:) - 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 :: gpp(:) - real(r8), pointer :: npp(:) - real(r8), pointer :: npp_leaf(:) - real(r8), pointer :: npp_froot(:) - real(r8), pointer :: npp_bsw(:) - real(r8), pointer :: npp_bdead(:) - real(r8), pointer :: npp_bseed(:) - real(r8), pointer :: npp_store(:) - real(r8), pointer :: bmort(:) - real(r8), pointer :: hmort(:) - real(r8), pointer :: cmort(:) - real(r8), pointer :: imort(:) - real(r8), pointer :: fmort(:) - real(r8), pointer :: ddbhdt(:) - real(r8), pointer :: resp_tstep(:) - integer, pointer :: pft(:) - integer, pointer :: status_coh(:) - integer, pointer :: isnew(:) - ! - ! 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(:) - ! - ! 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(:) - real(r8), pointer :: f_sun(:) - real(r8), pointer :: fabd_sun_z(:) - real(r8), pointer :: fabi_sun_z(:) - real(r8), pointer :: fabd_sha_z(:) - real(r8), pointer :: fabi_sha_z(:) - ! - ! site level restart vars - ! - real(r8), pointer :: water_memory(:) - real(r8), pointer :: old_stock(:) - real(r8), pointer :: cd_status(:) - real(r8), pointer :: dd_status(:) - real(r8), pointer :: ED_GDD_site(:) - real(r8), pointer :: ncd(:) - real(r8), pointer :: leafondate(:) - real(r8), pointer :: leafoffdate(:) - real(r8), pointer :: dleafondate(:) - real(r8), pointer :: dleafoffdate(:) - real(r8), pointer :: acc_NI(:) - - ! Site level carbon state/flux checks - real(r8), pointer :: nep_timeintegrated_si(:) - real(r8), pointer :: npp_timeintegrated_si(:) - real(r8), pointer :: hr_timeintegrated_si(:) - real(r8), pointer :: totecosys_old_si(:) - real(r8), pointer :: cbal_err_fates_si(:) - real(r8), pointer :: cbal_err_bgc_si(:) - real(r8), pointer :: cbal_err_tot_si(:) - real(r8), pointer :: tot_fatesc_old_si(:) - real(r8), pointer :: tot_bgcc_old_si(:) - real(r8), pointer :: fates_to_bgc_this_ts_si(:) - real(r8), pointer :: fates_to_bgc_last_ts_si(:) - real(r8), pointer :: seedrain_flux_si(:) - ! - ! site x pft - real(r8), pointer :: seed_bank(:) - - - 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 - - character(len=*), private, parameter :: mod_filename = __FILE__ - - ! - ! 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%numPatchesPerCol ) - 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%gpp ) - deallocate(this%npp ) - deallocate(this%npp_leaf ) - deallocate(this%npp_froot ) - deallocate(this%npp_bsw ) - deallocate(this%npp_bdead ) - deallocate(this%npp_bseed ) - deallocate(this%npp_store ) - deallocate(this%bmort ) - deallocate(this%hmort ) - deallocate(this%cmort ) - deallocate(this%imort ) - deallocate(this%fmort ) - deallocate(this%ddbhdt ) - deallocate(this%resp_tstep ) - deallocate(this%pft ) - deallocate(this%status_coh ) - deallocate(this%isnew ) - 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%f_sun ) - deallocate(this%fabd_sun_z ) - deallocate(this%fabi_sun_z ) - deallocate(this%fabd_sha_z ) - deallocate(this%fabi_sha_z ) - deallocate(this%water_memory ) - deallocate(this%old_stock ) - deallocate(this%cd_status ) - deallocate(this%dd_status ) - deallocate(this%ED_GDD_site ) - deallocate(this%ncd ) - deallocate(this%leafondate ) - deallocate(this%leafoffdate ) - deallocate(this%dleafondate ) - deallocate(this%dleafoffdate ) - deallocate(this%acc_NI ) - - deallocate(this%nep_timeintegrated_si) - deallocate(this%npp_timeintegrated_si) - deallocate(this%hr_timeintegrated_si) - deallocate(this%totecosys_old_si) - deallocate(this%cbal_err_fates_si) - deallocate(this%cbal_err_bgc_si) - deallocate(this%cbal_err_tot_si) - deallocate(this%tot_fatesc_old_si) - deallocate(this%tot_bgcc_old_si) - deallocate(this%fates_to_bgc_this_ts_si) - deallocate(this%fates_to_bgc_last_ts_si) - deallocate(this%seedrain_flux_si) - - 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 - - ! Column level variables - - allocate(new%numPatchesPerCol & - (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%numPatchesPerCol(:) = invalidValue - - allocate(new%old_stock & - (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%old_stock(:) = 0.0_r8 - - allocate(new%cd_status & - (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%cd_status(:) = 0_r8 - - allocate(new%dd_status & - (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%dd_status(:) = 0_r8 - - allocate(new%ncd & - (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%ncd(:) = 0_r8 - - - allocate(new%leafondate & - (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%leafondate(:) = 0_r8 - - allocate(new%leafoffdate & - (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%leafoffdate(:) = 0_r8 - - allocate(new%dleafondate & - (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%dleafondate(:) = 0_r8 - - allocate(new%dleafoffdate & - (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%dleafoffdate(:) = 0_r8 - - allocate(new%acc_NI & - (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%acc_NI(:) = 0_r8 - - allocate(new%ED_GDD_site & - (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%ED_GDD_site(:) = 0_r8 - - - allocate(new%nep_timeintegrated_si & - (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%nep_timeintegrated_si(:) = 0_r8 - - allocate(new%npp_timeintegrated_si & - (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%npp_timeintegrated_si(:) = 0_r8 - - allocate(new%hr_timeintegrated_si & - (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%hr_timeintegrated_si(:) = 0_r8 - - allocate(new%totecosys_old_si & - (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%totecosys_old_si(:) = 0_r8 - - allocate(new%cbal_err_fates_si & - (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%cbal_err_fates_si(:) = 0_r8 - - allocate(new%cbal_err_bgc_si & - (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%cbal_err_bgc_si(:) = 0_r8 - - allocate(new%cbal_err_tot_si & - (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%cbal_err_tot_si(:) = 0_r8 - - allocate(new%tot_fatesc_old_si & - (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%tot_fatesc_old_si(:) = 0_r8 - - allocate(new%tot_bgcc_old_si & - (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%tot_bgcc_old_si(:) = 0_r8 - - allocate(new%fates_to_bgc_this_ts_si & - (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%fates_to_bgc_this_ts_si(:) = 0_r8 - - allocate(new%fates_to_bgc_last_ts_si & - (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%fates_to_bgc_last_ts_si(:) = 0_r8 - - allocate(new%seedrain_flux_si & - (bounds%begc:bounds%endc), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%seedrain_flux_si(:) = 0_r8 - - - ! cohort level variables - - allocate(new%cohortsPerPatch & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%cohortsPerPatch(:) = invalidValue - - allocate(new%balive & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%balive(:) = 0.0_r8 - - allocate(new%bdead & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%bdead(:) = 0.0_r8 - - allocate(new%bl & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%bl(:) = 0.0_r8 - - allocate(new%br & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%br(:) = 0.0_r8 - - allocate(new%bstore & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%bstore(:) = 0.0_r8 - - allocate(new%canopy_layer & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%canopy_layer(:) = 0.0_r8 - - allocate(new%canopy_trim & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%canopy_trim(:) = 0.0_r8 - - allocate(new%dbh & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%dbh(:) = 0.0_r8 - - allocate(new%hite & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%hite(:) = 0.0_r8 - - allocate(new%laimemory & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%laimemory(:) = 0.0_r8 - - allocate(new%leaf_md & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%leaf_md(:) = 0.0_r8 - - allocate(new%root_md & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%root_md(:) = 0.0_r8 - - allocate(new%n & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%n(:) = 0.0_r8 - - allocate(new%gpp_acc & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%gpp_acc(:) = 0.0_r8 - - allocate(new%npp_acc & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%npp_acc(:) = 0.0_r8 - - allocate(new%gpp & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%gpp(:) = 0.0_r8 - - allocate(new%npp & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%npp(:) = 0.0_r8 - - allocate(new%npp_leaf & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%npp_leaf(:) = 0.0_r8 - - allocate(new%npp_froot & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%npp_froot(:) = 0.0_r8 - - allocate(new%npp_bsw & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%npp_bsw(:) = 0.0_r8 - - allocate(new%npp_bdead & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%npp_bdead(:) = 0.0_r8 - - allocate(new%npp_bseed & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%npp_bseed(:) = 0.0_r8 - - allocate(new%npp_store & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%npp_store(:) = 0.0_r8 - - allocate(new%bmort & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%bmort(:) = 0.0_r8 - - allocate(new%hmort & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%hmort(:) = 0.0_r8 - - allocate(new%cmort & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%cmort(:) = 0.0_r8 - - allocate(new%imort & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%imort(:) = 0.0_r8 - - allocate(new%fmort & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%fmort(:) = 0.0_r8 - - allocate(new%ddbhdt & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%ddbhdt(:) = 0.0_r8 - - allocate(new%resp_tstep & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%resp_tstep(:) = 0.0_r8 - - allocate(new%pft & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%pft(:) = 0 - - allocate(new%status_coh & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%status_coh(:) = 0 - - allocate(new%isnew & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%isnew(:) = new_cohort - - ! - ! some patch level variables that are required on restart - ! - allocate(new%cwd_ag & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%cwd_ag(:) = 0.0_r8 - - allocate(new%cwd_bg & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%cwd_bg(:) = 0.0_r8 - - allocate(new%leaf_litter & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%leaf_litter(:) = 0.0_r8 - - allocate(new%root_litter & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%root_litter(:) = 0.0_r8 - - allocate(new%leaf_litter_in & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%leaf_litter_in(:) = 0.0_r8 - - allocate(new%root_litter_in & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%root_litter_in(:) = 0.0_r8 - - allocate(new%seed_bank & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%seed_bank(:) = 0.0_r8 - - allocate(new%spread & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%spread(:) = 0.0_r8 - - allocate(new%livegrass & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%livegrass(:) = 0.0_r8 - - allocate(new%age & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%age(:) = 0.0_r8 - - allocate(new%areaRestart & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%areaRestart(:) = 0.0_r8 - - allocate(new%f_sun & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%f_sun(:) = 0.0_r8 - - allocate(new%fabd_sun_z & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%fabd_sun_z(:) = 0.0_r8 - - allocate(new%fabi_sun_z & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%fabi_sun_z(:) = 0.0_r8 - - allocate(new%fabd_sha_z & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%fabd_sha_z(:) = 0.0_r8 - - allocate(new%fabi_sha_z & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%fabi_sha_z(:) = 0.0_r8 - - ! - ! Site level variable stored with cohort indexing - ! (to accomodate the second dimension) - ! - - allocate(new%water_memory & - (new%vectorLengthStart:new%vectorLengthStop), stat=retVal) - SHR_ASSERT(( retVal == allocOK ), errMsg(mod_filename, __LINE__)) - new%water_memory(:) = 0.0_r8 - - - end associate - - end function newEDRestartVectorClass - - !-------------------------------------------------------------------------------! - subroutine setVectors( this, bounds, nsites, sites, fcolumn ) - ! - ! !DESCRIPTION: - ! implement setVectors - ! - ! !USES: - use clm_time_manager , only : get_nstep - ! - ! !ARGUMENTS: - class(EDRestartVectorClass) , intent(inout) :: this - type(bounds_type) , intent(in) :: bounds - integer , intent(in) :: nsites - type(ed_site_type) , intent(in), target :: sites(nsites) - integer , intent(in) :: fcolumn(nsites) - ! - ! !LOCAL VARIABLES: - !----------------------------------------------------------------------- - - if ( masterproc ) write(iulog,*) 'edtime setVectors ',get_nstep() - - !if (this%DEBUG) then - ! call this%printIoInfoLL ( bounds, sites, nsites ) - ! call this%printDataInfoLL ( bounds, sites, nsites ) - !end if - - call this%convertCohortListToVector ( bounds, nsites, sites, fcolumn ) - - if (this%DEBUG) then - call this%printIoInfoLL ( bounds, nsites, sites, fcolumn ) - call this%printDataInfoLL ( bounds, nsites, sites ) - - ! RGK: Commenting this out because it is calling several - ! variables over the wrong indices -! call this%printDataInfoVector ( ) - end if - - end subroutine setVectors - - !-------------------------------------------------------------------------------! - subroutine getVectors( this, bounds, nsites, sites, fcolumn) - ! - ! !DESCRIPTION: - ! implement getVectors - ! - ! !USES: - use clm_time_manager , only : get_nstep - use EDMainMod , only : ed_update_site - ! - ! !ARGUMENTS: - class(EDRestartVectorClass) , intent(inout) :: this - type(bounds_type) , intent(in) :: bounds - integer , intent(in) :: nsites - type(ed_site_type) , intent(inout), target :: sites(nsites) - integer , intent(in) :: fcolumn(nsites) - ! - ! !LOCAL VARIABLES: - integer :: s - !----------------------------------------------------------------------- - - if (this%DEBUG) then - write(iulog,*) 'edtime getVectors ',get_nstep() - end if - - call this%createPatchCohortStructure ( bounds, nsites, sites, fcolumn ) - - call this%convertCohortVectorToList ( bounds, nsites , sites, fcolumn) - - do s = 1,nsites - call ed_update_site( sites(s) ) - end do - - if (this%DEBUG) then - call this%printIoInfoLL ( bounds, nsites, sites, fcolumn ) - call this%printDataInfoLL ( bounds, nsites, sites ) - call this%printDataInfoVector ( ) - 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 : namec, nameCohort - use spmdMod, only : iam - ! - ! !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) :: coh_dimName = trim(nameCohort) - character(len=16) :: col_dimName = trim(namec) - !----------------------------------------------------------------------- - - - if(this%DEBUG) then - write(iulog,*) 'flag:',flag - write(iulog,*) 'dimname:',col_dimName - write(iulog,*) 'readvar:',readvar - write(iulog,*) 'associated?',associated(this%numPatchesPerCol) - write(iulog,*) '' - write(iulog,*) 'col size:',size(this%numPatchesPerCol) - write(iulog,*) 'col lbound:',lbound(this%numPatchesPerCol) - write(iulog,*) 'col ubound:',ubound(this%numPatchesPerCol) - - write(iulog,*) 'coh size:',size(this%cohortsPerPatch) - write(iulog,*) 'coh lbound:',lbound(this%cohortsPerPatch) - write(iulog,*) 'coh ubound:',ubound(this%cohortsPerPatch) - write(iulog,*) '' - end if - - call restartvar(ncid=ncid, flag=flag, varname='ed_io_numPatchesPerCol', xtype=ncd_int, & - dim1name=col_dimName, & - long_name='Num patches per column', units='unitless', & - interpinic_flag='interp', data=this%numPatchesPerCol, & - readvar=readvar) - - call restartvar(ncid=ncid, flag=flag, varname='ed_old_stock', xtype=ncd_double, & - dim1name=col_dimName, & - long_name='ed cohort - old_stock', units='unitless', & - interpinic_flag='interp', data=this%old_stock, & - readvar=readvar) - - call restartvar(ncid=ncid, flag=flag, varname='ed_cd_status', xtype=ncd_double, & - dim1name=col_dimName, & - long_name='ed cold dec status', units='unitless', & - interpinic_flag='interp', data=this%cd_status, & - readvar=readvar) - - call restartvar(ncid=ncid, flag=flag, varname='ed_dd_status', xtype=ncd_double, & - dim1name=col_dimName, & - long_name='ed drought dec status', units='unitless', & - interpinic_flag='interp', data=this%dd_status, & - readvar=readvar) - - call restartvar(ncid=ncid, flag=flag, varname='ed_chilling_days', xtype=ncd_double, & - dim1name=col_dimName, & - long_name='ed chilling day counter', units='unitless', & - interpinic_flag='interp', data=this%ncd, & - readvar=readvar) - - call restartvar(ncid=ncid, flag=flag, varname='ed_leafondate', xtype=ncd_double, & - dim1name=col_dimName, & - long_name='ed leafondate', units='unitless', & - interpinic_flag='interp', data=this%leafondate, & - readvar=readvar) - - call restartvar(ncid=ncid, flag=flag, varname='ed_leafoffdate', xtype=ncd_double, & - dim1name=col_dimName, & - long_name='ed leafoffdate', units='unitless', & - interpinic_flag='interp', data=this%leafoffdate, & - readvar=readvar) - - call restartvar(ncid=ncid, flag=flag, varname='ed_dleafondate', xtype=ncd_double, & - dim1name=col_dimName, & - long_name='ed dleafondate', units='unitless', & - interpinic_flag='interp', data=this%dleafondate, & - readvar=readvar) - - call restartvar(ncid=ncid, flag=flag, varname='ed_dleafoffdate', xtype=ncd_double, & - dim1name=col_dimName, & - long_name='ed dleafoffdate', units='unitless', & - interpinic_flag='interp', data=this%dleafoffdate, & - readvar=readvar) - - call restartvar(ncid=ncid, flag=flag, varname='ed_acc_NI', xtype=ncd_double, & - dim1name=col_dimName, & - long_name='ed nesterov index', units='unitless', & - interpinic_flag='interp', data=this%acc_NI, & - readvar=readvar) - - call restartvar(ncid=ncid, flag=flag, varname='ed_gdd_site', xtype=ncd_double, & - dim1name=col_dimName, & - long_name='ed GDD site', units='unitless', & - interpinic_flag='interp', data=this%ED_GDD_site, & - readvar=readvar) - - call restartvar(ncid=ncid, flag=flag, varname='nep_timeintegrated_col', xtype=ncd_double, & - dim1name=col_dimName, long_name='', units='', & - interpinic_flag='interp', readvar=readvar, data=this%nep_timeintegrated_si) - - call restartvar(ncid=ncid, flag=flag, varname='npp_timeintegrated_col', xtype=ncd_double, & - dim1name='column', long_name='', units='', & - interpinic_flag='interp', readvar=readvar, data=this%npp_timeintegrated_si) - - call restartvar(ncid=ncid, flag=flag, varname='hr_timeintegrated_col', xtype=ncd_double, & - dim1name='column', long_name='', units='', & - interpinic_flag='interp', readvar=readvar, data=this%hr_timeintegrated_si) - - call restartvar(ncid=ncid, flag=flag, varname='cbalance_error_ed_col', xtype=ncd_double, & - dim1name='column', long_name='', units='', & - interpinic_flag='interp', readvar=readvar, data=this%cbal_err_fates_si) - - call restartvar(ncid=ncid, flag=flag, varname='cbalance_error_bgc_col', xtype=ncd_double, & - dim1name='column', long_name='', units='', & - interpinic_flag='interp', readvar=readvar, data=this%cbal_err_bgc_si) - - call restartvar(ncid=ncid, flag=flag, varname='cbalance_error_total_col', xtype=ncd_double, & - dim1name='column', long_name='', units='', & - interpinic_flag='interp', readvar=readvar, data=this%cbal_err_tot_si) - - call restartvar(ncid=ncid, flag=flag, varname='totecosysc_old_col', xtype=ncd_double, & - dim1name='column', long_name='', units='', & - interpinic_flag='interp', readvar=readvar, data=this%totecosys_old_si) - - call restartvar(ncid=ncid, flag=flag, varname='totedc_old_col', xtype=ncd_double, & - dim1name='column', long_name='', units='', & - interpinic_flag='interp', readvar=readvar, data=this%tot_fatesc_old_si) - - call restartvar(ncid=ncid, flag=flag, varname='totbgcc_old_col', xtype=ncd_double, & - dim1name='column', long_name='', units='', & - interpinic_flag='interp', readvar=readvar, data=this%tot_bgcc_old_si) - - call restartvar(ncid=ncid, flag=flag, varname='ed_to_bgc_this_edts_col', xtype=ncd_double, & - dim1name='column', long_name='', units='', & - interpinic_flag='interp', readvar=readvar, data=this%fates_to_bgc_this_ts_si) - - call restartvar(ncid=ncid, flag=flag, varname='ed_to_bgc_last_edts_col', xtype=ncd_double, & - dim1name='column', long_name='', units='', & - interpinic_flag='interp', readvar=readvar, data=this%fates_to_bgc_last_ts_si) - - call restartvar(ncid=ncid, flag=flag, varname='seed_rain_flux_col', xtype=ncd_double, & - dim1name='column', long_name='', units='', & - interpinic_flag='interp', readvar=readvar, data=this%seedrain_flux_si) - - - call restartvar(ncid=ncid, flag=flag, varname='ed_balive', xtype=ncd_double, & - dim1name=coh_dimName, & - long_name='ed cohort ed_balive', units='unitless', & - interpinic_flag='interp', data=this%balive, & - readvar=readvar) - - - ! - ! cohort level vars - ! - call restartvar(ncid=ncid, flag=flag, varname='ed_io_cohortsPerPatch', xtype=ncd_int, & - dim1name=coh_dimName, & - long_name='cohorts per patch, indexed by numPatchesPerCol', units='unitless', & - interpinic_flag='interp', data=this%cohortsPerPatch, & - readvar=readvar) - - call restartvar(ncid=ncid, flag=flag, varname='ed_bdead', xtype=ncd_double, & - dim1name=coh_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=coh_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=coh_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=coh_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=coh_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=coh_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=coh_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=coh_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=coh_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=coh_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=coh_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=coh_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=coh_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=coh_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_gpp', xtype=ncd_double, & - dim1name=coh_dimName, & - long_name='ed cohort - gpp', units='unitless', & - interpinic_flag='interp', data=this%gpp, & - readvar=readvar) - - call restartvar(ncid=ncid, flag=flag, varname='ed_npp', xtype=ncd_double, & - dim1name=coh_dimName, & - long_name='ed cohort - npp', units='unitless', & - interpinic_flag='interp', data=this%npp, & - readvar=readvar) - - call restartvar(ncid=ncid, flag=flag, varname='ed_npp_leaf', xtype=ncd_double, & - dim1name=coh_dimName, & - long_name='ed cohort - npp_leaf', units='unitless', & - interpinic_flag='interp', data=this%npp_leaf, & - readvar=readvar) - - call restartvar(ncid=ncid, flag=flag, varname='ed_npp_froot', xtype=ncd_double, & - dim1name=coh_dimName, & - long_name='ed cohort - npp_froot', units='unitless', & - interpinic_flag='interp', data=this%npp_froot, & - readvar=readvar) - - call restartvar(ncid=ncid, flag=flag, varname='ed_npp_bsw', xtype=ncd_double, & - dim1name=coh_dimName, & - long_name='ed cohort - npp_bsw', units='unitless', & - interpinic_flag='interp', data=this%npp_bsw, & - readvar=readvar) - - call restartvar(ncid=ncid, flag=flag, varname='ed_npp_bdead', xtype=ncd_double, & - dim1name=coh_dimName, & - long_name='ed cohort - npp_bdead', units='unitless', & - interpinic_flag='interp', data=this%npp_bdead, & - readvar=readvar) - - call restartvar(ncid=ncid, flag=flag, varname='ed_npp_bseed', xtype=ncd_double, & - dim1name=coh_dimName, & - long_name='ed cohort - npp_bseed', units='unitless', & - interpinic_flag='interp', data=this%npp_bseed, & - readvar=readvar) - - call restartvar(ncid=ncid, flag=flag, varname='ed_npp_store', xtype=ncd_double, & - dim1name=coh_dimName, & - long_name='ed cohort - npp_store', units='unitless', & - interpinic_flag='interp', data=this%npp_store, & - readvar=readvar) - - call restartvar(ncid=ncid, flag=flag, varname='ed_bmort', xtype=ncd_double, & - dim1name=coh_dimName, & - long_name='ed cohort - bmort', units='unitless', & - interpinic_flag='interp', data=this%bmort, & - readvar=readvar) - - call restartvar(ncid=ncid, flag=flag, varname='ed_hmort', xtype=ncd_double, & - dim1name=coh_dimName, & - long_name='ed cohort - hmort', units='unitless', & - interpinic_flag='interp', data=this%hmort, & - readvar=readvar) - - call restartvar(ncid=ncid, flag=flag, varname='ed_cmort', xtype=ncd_double, & - dim1name=coh_dimName, & - long_name='ed cohort - cmort', units='unitless', & - interpinic_flag='interp', data=this%cmort, & - readvar=readvar) - - call restartvar(ncid=ncid, flag=flag, varname='ed_imort', xtype=ncd_double, & - dim1name=coh_dimName, & - long_name='ed cohort - imort', units='unitless', & - interpinic_flag='interp', data=this%imort, & - readvar=readvar) - - call restartvar(ncid=ncid, flag=flag, varname='ed_fmort', xtype=ncd_double, & - dim1name=coh_dimName, & - long_name='ed cohort - fmort', units='unitless', & - interpinic_flag='interp', data=this%fmort, & - readvar=readvar) - - call restartvar(ncid=ncid, flag=flag, varname='ed_ddbhdt', xtype=ncd_double, & - dim1name=coh_dimName, & - long_name='ed cohort - ddbhdt', units='unitless', & - interpinic_flag='interp', data=this%ddbhdt, & - readvar=readvar) - - call restartvar(ncid=ncid, flag=flag, varname='ed_resp_tstep', xtype=ncd_double, & - dim1name=coh_dimName, & - long_name='ed cohort - resp_tstep', units='unitless', & - interpinic_flag='interp', data=this%resp_tstep, & - readvar=readvar) - - call restartvar(ncid=ncid, flag=flag, varname='ed_pft', xtype=ncd_int, & - dim1name=coh_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=coh_dimName, & - long_name='ed cohort - status_coh', units='unitless', & - interpinic_flag='interp', data=this%status_coh, & - readvar=readvar) - - call restartvar(ncid=ncid, flag=flag, varname='ed_isnew', xtype=ncd_int, & - dim1name=coh_dimName, & - long_name='ed cohort - isnew', units='unitless', & - interpinic_flag='interp', data=this%isnew, & - readvar=readvar) - - ! - ! patch level vars - ! - - call restartvar(ncid=ncid, flag=flag, varname='ed_cwd_ag', xtype=ncd_double, & - dim1name=coh_dimName, & - long_name='ed patch - 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=coh_dimName, & - long_name='ed patch - 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=coh_dimName, & - long_name='ed patch - 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=coh_dimName, & - long_name='ed patch - 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=coh_dimName, & - long_name='ed patch - 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=coh_dimName, & - long_name='ed patch - 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=coh_dimName, & - long_name='ed site - 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=coh_dimName, & - long_name='ed patch - spread', units='unitless', & - interpinic_flag='interp', data=this%spread, & - readvar=readvar) - - call restartvar(ncid=ncid, flag=flag, varname='ed_livegrass', xtype=ncd_double, & - dim1name=coh_dimName, & - long_name='ed patch - livegrass', units='unitless', & - interpinic_flag='interp', data=this%livegrass, & - readvar=readvar) - - call restartvar(ncid=ncid, flag=flag, varname='ed_age', xtype=ncd_double, & - dim1name=coh_dimName, & - long_name='ed patch - age', units='unitless', & - interpinic_flag='interp', data=this%age, & - readvar=readvar) - - call restartvar(ncid=ncid, flag=flag, varname='ed_area', xtype=ncd_double, & - dim1name=coh_dimName, & - long_name='ed patch - area', units='unitless', & - interpinic_flag='interp', data=this%areaRestart, & - readvar=readvar) - - call restartvar(ncid=ncid, flag=flag, varname='ed_f_sun', xtype=ncd_double, & - dim1name=coh_dimName, & - long_name='ed patch - f_sun', units='unitless', & - interpinic_flag='interp', data=this%f_sun, & - readvar=readvar) - - call restartvar(ncid=ncid, flag=flag, varname='ed_fabd_sun_z', xtype=ncd_double, & - dim1name=coh_dimName, & - long_name='ed patch - fabd_sun_z', units='unitless', & - interpinic_flag='interp', data=this%fabd_sun_z, & - readvar=readvar) - - call restartvar(ncid=ncid, flag=flag, varname='ed_fabi_sun_z', xtype=ncd_double, & - dim1name=coh_dimName, & - long_name='ed patch - fabi_sun_z', units='unitless', & - interpinic_flag='interp', data=this%fabi_sun_z, & - readvar=readvar) - - call restartvar(ncid=ncid, flag=flag, varname='ed_fabd_sha_z', xtype=ncd_double, & - dim1name=coh_dimName, & - long_name='ed patch - fabd_sha_z', units='unitless', & - interpinic_flag='interp', data=this%fabd_sha_z, & - readvar=readvar) - - call restartvar(ncid=ncid, flag=flag, varname='ed_fabi_sha_z', xtype=ncd_double, & - dim1name=coh_dimName, & - long_name='ed patch - fabi_sha_z', units='unitless', & - interpinic_flag='interp', data=this%fabi_sha_z, & - readvar=readvar) - ! - ! site level vars - ! - - call restartvar(ncid=ncid, flag=flag, varname='ed_water_memory', xtype=ncd_double, & - dim1name=coh_dimName, & - long_name='ed cohort - water_memory', units='unitless', & - interpinic_flag='interp', data=this%water_memory, & - readvar=readvar) - - - - - - - end subroutine doVectorIO - - !-------------------------------------------------------------------------------! - subroutine printDataInfoVector( this ) - ! - ! !DESCRIPTION: - ! - ! !USES: - ! - ! !ARGUMENTS: - class(EDRestartVectorClass), intent(inout) :: this - ! - ! !LOCAL VARIABLES: - character(len=32) :: methodName = 'PDIV ' - integer :: iSta, iSto - !----------------------------------------------------------------------- - - ! RGK: changed the vector end-point on column variables to match the start point - ! this avoids exceeding bounds on the last column of the dataset - - 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)//' :: gpp ', & - this%gpp(iSta:iSto) - write(iulog,*) trim(methodName)//' :: npp ', & - this%npp(iSta:iSto) - write(iulog,*) trim(methodName)//' :: npp_leaf ', & - this%npp_leaf(iSta:iSto) - write(iulog,*) trim(methodName)//' :: npp_froot ', & - this%npp_froot(iSta:iSto) - write(iulog,*) trim(methodName)//' :: npp_bsw ', & - this%npp_bsw(iSta:iSto) - write(iulog,*) trim(methodName)//' :: npp_bdead ', & - this%npp_bdead(iSta:iSto) - write(iulog,*) trim(methodName)//' :: npp_bseed ', & - this%npp_bseed(iSta:iSto) - write(iulog,*) trim(methodName)//' :: npp_store ', & - this%npp_store(iSta:iSto) - write(iulog,*) trim(methodName)//' :: bmort ', & - this%bmort(iSta:iSto) - write(iulog,*) trim(methodName)//' :: hmort ', & - this%hmort(iSta:iSto) - write(iulog,*) trim(methodName)//' :: cmort ', & - this%cmort(iSta:iSto) - write(iulog,*) trim(methodName)//' :: imort ', & - this%imort(iSta:iSto) - write(iulog,*) trim(methodName)//' :: fmort ', & - this%fmort(iSta:iSto) - write(iulog,*) trim(methodName)//' :: ddbhdt ', & - this%ddbhdt(iSta:iSto) - write(iulog,*) trim(methodName)//' :: resp_tstep ', & - this%resp_tstep(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)//' :: isnew ', & - this%isnew(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)//' :: f_sun ', & - this%f_sun(iSta:iSto) - write(iulog,*) trim(methodName)//' :: fabd_sun_z ', & - this%fabd_sun_z(iSta:iSto) - write(iulog,*) trim(methodName)//' :: fabi_sun_z ', & - this%fabi_sun_z(iSta:iSto) - write(iulog,*) trim(methodName)//' :: fabd_sha_z ', & - this%fabd_sha_z(iSta:iSto) - write(iulog,*) trim(methodName)//' :: fabi_sha_z ', & - this%fabi_sha_z(iSta:iSto) - write(iulog,*) trim(methodName)//' :: water_memory ', & - this%water_memory(iSta:iSto) - - write(iulog,*) trim(methodName)//' :: old_stock ', & - this%old_stock(iSta:iSta) - write(iulog,*) trim(methodName)//' :: cd_status', & - this%cd_status(iSta:iSta) - write(iulog,*) trim(methodName)//' :: dd_status', & - this%cd_status(iSta:iSto) - write(iulog,*) trim(methodName)//' :: ED_GDD_site', & - this%ED_GDD_site(iSta:iSto) - write(iulog,*) trim(methodName)//' :: ncd', & - this%ncd(iSta:iSta) - write(iulog,*) trim(methodName)//' :: leafondate', & - this%leafondate(iSta:iSta) - write(iulog,*) trim(methodName)//' :: leafoffdate', & - this%leafoffdate(iSta:iSta) - write(iulog,*) trim(methodName)//' :: dleafondate', & - this%dleafondate(iSta:iSta) - write(iulog,*) trim(methodName)//' :: dleafoffdate', & - this%dleafoffdate(iSta:iSta) - write(iulog,*) trim(methodName)//' :: acc_NI', & - this%acc_NI(iSta:iSta) - - end subroutine printDataInfoVector - - !-------------------------------------------------------------------------------! - subroutine printDataInfoLL( this, bounds, nsites, sites ) - ! - ! !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 - integer , intent(in) :: nsites - type(ed_site_type) , intent(in), target :: sites(nsites) - ! - ! !LOCAL VARIABLES: - type (ed_patch_type), pointer :: currentPatch - type (ed_cohort_type), pointer :: currentCohort - integer :: s - integer :: totalCohorts - integer :: numCohort - integer :: numPatches,totPatchCount - character(len=32) :: methodName = 'printDataInfoLL ' - !----------------------------------------------------------------------- - - totalCohorts = 0 - totPatchCount = 1 - - write(iulog,*) 'vecLenStart ',this%vectorLengthStart - - do s = 1,nsites - - currentPatch => sites(s)%oldest_patch - - numPatches = 1 - - do while(associated(currentPatch)) - currentCohort => currentPatch%shortest - - 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)//' gpp ' ,totalCohorts,currentCohort%gpp - write(iulog,*) trim(methodName)//' npp ' ,totalCohorts,currentCohort%npp - write(iulog,*) trim(methodName)//' npp_leaf ' ,totalCohorts,currentCohort%npp_leaf - write(iulog,*) trim(methodName)//' npp_froot ' ,totalCohorts,currentCohort%npp_froot - write(iulog,*) trim(methodName)//' npp_bsw ' ,totalCohorts,currentCohort%npp_bsw - write(iulog,*) trim(methodName)//' npp_bdead ' ,totalCohorts,currentCohort%npp_bdead - write(iulog,*) trim(methodName)//' npp_bseed ' ,totalCohorts,currentCohort%npp_bseed - write(iulog,*) trim(methodName)//' npp_store ' ,totalCohorts,currentCohort%npp_store - write(iulog,*) trim(methodName)//' bmort ' ,totalCohorts,currentCohort%bmort - write(iulog,*) trim(methodName)//' hmort ' ,totalCohorts,currentCohort%hmort - write(iulog,*) trim(methodName)//' cmort ' ,totalCohorts,currentCohort%cmort - write(iulog,*) trim(methodName)//' imort ' ,totalCohorts,currentCohort%imort - write(iulog,*) trim(methodName)//' fmort ' ,totalCohorts,currentCohort%fmort - write(iulog,*) trim(methodName)//' ddbhdt ' ,totalCohorts,currentCohort%ddbhdt - write(iulog,*) trim(methodName)//' resp_tstep ' ,totalCohorts,currentCohort%resp_tstep - write(iulog,*) trim(methodName)//' pft ' ,totalCohorts,currentCohort%pft - write(iulog,*) trim(methodName)//' status_coh ' ,totalCohorts,currentCohort%status_coh - write(iulog,*) trim(methodName)//' isnew ' ,totalCohorts,currentCohort%isnew - - numCohort = numCohort + 1 - - currentCohort => currentCohort%taller - enddo ! currentCohort do while - - write(iulog,*) trim(methodName)//': numpatches for col ',& - 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)//' 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)//' f_sun (sum) ' ,sum(currentPatch%f_sun) - write(iulog,*) trim(methodName)//' fabd_sun_z (sum) ' ,sum(currentPatch%fabd_sun_z) - write(iulog,*) trim(methodName)//' fabi_sun_z (sum) ' ,sum(currentPatch%fabi_sun_z) - write(iulog,*) trim(methodName)//' fabd_sha_z (sum) ' ,sum(currentPatch%fabd_sha_z) - write(iulog,*) trim(methodName)//' fabi_sha_z (sum) ' ,sum(currentPatch%fabi_sha_z) - - write(iulog,*) trim(methodName)//' old_stock ' ,sites(s)%old_stock - write(iulog,*) trim(methodName)//' cd_status ' ,sites(s)%status - write(iulog,*) trim(methodName)//' dd_status ' ,sites(s)%dstatus - write(iulog,*) trim(methodName)//' ncd ' ,sites(s)%ncd - write(iulog,*) trim(methodName)//' leafondate ' ,sites(s)%leafondate - write(iulog,*) trim(methodName)//' leafoffdate ' ,sites(s)%leafoffdate - write(iulog,*) trim(methodName)//' dleafondate ' ,sites(s)%dleafondate - write(iulog,*) trim(methodName)//' dleafoffdate ' ,sites(s)%dleafoffdate - write(iulog,*) trim(methodName)//' acc_NI' ,sites(s)%acc_NI - write(iulog,*) trim(methodName)//' ED_GDD_site ' ,sites(s)%ED_GDD_site - write(iulog,*) trim(methodName)//' seed_bank ' ,sites(s)%seed_bank - - currentPatch => currentPatch%younger - - totPatchCount = totPatchCount + 1 - numPatches = numPatches + 1 - enddo ! currentPatch do while - - write(iulog,*) trim(methodName)//' water_memory ',sites(s)%water_memory(1) - - enddo - - write(iulog,*) trim(methodName)//': total cohorts ',totalCohorts - - end subroutine printDataInfoLL - - !-------------------------------------------------------------------------------! - subroutine printIoInfoLL( this, bounds, nsites, sites, fcolumn ) - !! - ! !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 - integer , intent(in) :: nsites - type(ed_site_type) , intent(in), target :: sites(nsites) - integer , intent(in) :: fcolumn(nsites) - ! - ! !LOCAL VARIABLES: - type (ed_patch_type), pointer :: currentPatch - type (ed_cohort_type), pointer :: currentCohort - integer s - integer totalCohorts - integer numCohort - integer numPatches,totPatchCount - character(len=32) :: methodName = 'printIoInfoLL ' - !----------------------------------------------------------------------- - - totalCohorts = 0 - totPatchCount = 1 - - write(iulog,*) 'vecLenStart ',this%vectorLengthStart - - do s = 1,nsites - - currentPatch => sites(s)%oldest_patch - - numPatches = 1 - - do while(associated(currentPatch)) - currentCohort => currentPatch%shortest - - write(iulog,*) trim(methodName)//': found column with patch(s) ',fcolumn(s) - - 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)//' gpp ',currentCohort%gpp - write(iulog,*) trim(methodName)//' npp ',currentCohort%npp - write(iulog,*) trim(methodName)//' npp_leaf ',currentCohort%npp_leaf - write(iulog,*) trim(methodName)//' npp_froot ',currentCohort%npp_froot - write(iulog,*) trim(methodName)//' npp_bsw ',currentCohort%npp_bsw - write(iulog,*) trim(methodName)//' npp_bdead ',currentCohort%npp_bdead - write(iulog,*) trim(methodName)//' npp_bseed ',currentCohort%npp_bseed - write(iulog,*) trim(methodName)//' npp_store ',currentCohort%npp_store - write(iulog,*) trim(methodName)//' bmort ',currentCohort%bmort - write(iulog,*) trim(methodName)//' hmort ',currentCohort%hmort - write(iulog,*) trim(methodName)//' cmort ',currentCohort%cmort - write(iulog,*) trim(methodName)//' imort ',currentCohort%imort - write(iulog,*) trim(methodName)//' fmort ',currentCohort%fmort - write(iulog,*) trim(methodName)//' ddbhdt ',currentCohort%ddbhdt - write(iulog,*) trim(methodName)//' resp_tstep ',currentCohort%resp_tstep - write(iulog,*) trim(methodName)//' pft ',currentCohort%pft - write(iulog,*) trim(methodName)//' status_coh ',currentCohort%status_coh - write(iulog,*) trim(methodName)//' isnew ',currentCohort%isnew - - currentCohort => currentCohort%taller - enddo ! currentCohort do while - - write(iulog,*) trim(methodName)//': numpatches for column ',numPatches - write(iulog,*) trim(methodName)//': patches and cohorts ',totPatchCount,numCohort - - currentPatch => currentPatch%younger - - totPatchCount = totPatchCount + 1 - numPatches = numPatches + 1 - enddo ! currentPatch do while - enddo - - return - end subroutine printIoInfoLL - - !-------------------------------------------------------------------------------! - subroutine convertCohortListToVector( this, bounds, nsites, sites, fcolumn ) - ! - ! !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 EDTypesMod, only : cp_nclmax - ! - ! !ARGUMENTS: - class(EDRestartVectorClass) , intent(inout) :: this - type(bounds_type) , intent(in) :: bounds - integer , intent(in) :: nsites - type(ed_site_type) , intent(in), target :: sites(nsites) - integer , intent(in) :: fcolumn(nsites) - ! - ! !LOCAL VARIABLES: - type (ed_patch_type), pointer :: currentPatch - type (ed_cohort_type), pointer :: currentCohort - integer :: s, c - 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 :: countSunZ - integer :: i,j,k - integer :: incrementOffset - !----------------------------------------------------------------------- - - totalCohorts = 0 - -! if(fcolumn(1).eq.bounds%begc .and. & -! (fcolumn(1)-1)*cohorts_per_col+1.ne.bounds%begCohort) then -! write(iulog,*) 'fcolumn(1) in this clump, points to the first column of the clump' -! write(iulog,*) 'but the assumption on first cohort index does not jive' -! call endrun(msg=errMsg(mod_filename, __LINE__)) -! end if - - - do s = 1,nsites - - ! Calculate the offsets - ! fcolumn is the global column index of the current site. - ! For the first site, if that site aligns with the first column index - ! in the clump, than the offset should be be equal to begCohort - - c = fcolumn(s) - - incrementOffset = bounds%begCohort+(c-bounds%begc)*cohorts_per_col + 1 - countCohort = bounds%begCohort+(c-bounds%begc)*cohorts_per_col + 1 - countPft = bounds%begCohort+(c-bounds%begc)*cohorts_per_col + 1 - countNcwd = bounds%begCohort+(c-bounds%begc)*cohorts_per_col + 1 - countNclmax = bounds%begCohort+(c-bounds%begc)*cohorts_per_col + 1 - countWaterMem = bounds%begCohort+(c-bounds%begc)*cohorts_per_col + 1 - countSunZ = bounds%begCohort+(c-bounds%begc)*cohorts_per_col + 1 - - ! write seed_bank info(site-level, but PFT-resolved) - do i = 1,numpft_ed - this%seed_bank(incrementOffset+i-1) = sites(s)%seed_bank(i) - end do - - currentPatch => sites(s)%oldest_patch - - ! new column, 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,*) 'CLTV countCohort ', countCohort - write(iulog,*) 'CLTV vecLenStart ', this%vectorLengthStart - write(iulog,*) 'CLTV vecLenStop ', 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%gpp(countCohort) = currentCohort%gpp - this%npp(countCohort) = currentCohort%npp - this%npp_leaf(countCohort) = currentCohort%npp_leaf - this%npp_froot(countCohort) = currentCohort%npp_froot - this%npp_bsw(countCohort) = currentCohort%npp_bsw - this%npp_bdead(countCohort) = currentCohort%npp_bdead - this%npp_bseed(countCohort) = currentCohort%npp_bseed - this%npp_store(countCohort) = currentCohort%npp_store - this%bmort(countCohort) = currentCohort%bmort - this%hmort(countCohort) = currentCohort%hmort - this%cmort(countCohort) = currentCohort%cmort - this%imort(countCohort) = currentCohort%imort - this%fmort(countCohort) = currentCohort%fmort - this%ddbhdt(countCohort) = currentCohort%ddbhdt - this%resp_tstep(countCohort) = currentCohort%resp_tstep - this%pft(countCohort) = currentCohort%pft - this%status_coh(countCohort) = currentCohort%status_coh - if ( currentCohort%isnew ) then - this%isnew(countCohort) = new_cohort - else - this%isnew(countCohort) = old_cohort - endif - - if (this%DEBUG) then - write(iulog,*) 'CLTV offsetNumCohorts II ',countCohort, & - numCohort - endif - - countCohort = countCohort + 1 - - currentCohort => currentCohort%taller - - enddo ! currentCohort do while - - ! - ! deal with patch level fields here - ! - this%livegrass(incrementOffset) = currentPatch%livegrass - this%age(incrementOffset) = currentPatch%age - this%areaRestart(incrementOffset) = currentPatch%area - - ! set cohorts per patch for IO - this%cohortsPerPatch( incrementOffset ) = numCohort - - if (this%DEBUG) then - write(iulog,*) 'offsetNumCohorts III ' & - ,countCohort,cohorts_per_col, 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 - 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) - 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,cp_nclmax ! cp_nclmax currently 2 - this%spread(countNclmax) = currentPatch%spread(i) - countNclmax = countNclmax + 1 - end do - - if (this%DEBUG) write(iulog,*) 'CLTV countSunZ 1 ',countSunZ - - if (this%DEBUG) write(iulog,*) 'CLTV 1186 ',cp_nlevcan,numpft_ed,cp_nclmax - - do k = 1,cp_nlevcan ! cp_nlevcan currently 40 - do j = 1,numpft_ed ! numpft_ed currently 2 - do i = 1,cp_nclmax ! cp_nclmax currently 2 - this%f_sun(countSunZ) = currentPatch%f_sun(i,j,k) - this%fabd_sun_z(countSunZ) = currentPatch%fabd_sun_z(i,j,k) - this%fabi_sun_z(countSunZ) = currentPatch%fabi_sun_z(i,j,k) - this%fabd_sha_z(countSunZ) = currentPatch%fabd_sha_z(i,j,k) - this%fabi_sha_z(countSunZ) = currentPatch%fabi_sha_z(i,j,k) - countSunZ = countSunZ + 1 - end do - end do - end do - - if (this%DEBUG) write(iulog,*) 'CLTV countSunZ 2 ',countSunZ - - incrementOffset = incrementOffset + maxCohortsPerPatch - - ! reset counters so that they are all advanced evenly. Currently - ! the offset is 10, the max of numpft_ed, ncwd, cp_nclmax, - ! countWaterMem and the number of allowed cohorts per patch - countPft = incrementOffset - countNcwd = incrementOffset - countNclmax = incrementOffset - countCohort = incrementOffset - countSunZ = incrementOffset - - if (this%DEBUG) then - write(iulog,*) 'CLTV incrementOffset ', incrementOffset - write(iulog,*) 'CLTV cohorts_per_col ', cohorts_per_col - write(iulog,*) 'CLTV numCohort ', numCohort - write(iulog,*) 'CLTV totalCohorts ', totalCohorts - end if - - currentPatch => currentPatch%younger - - enddo ! currentPatch do while - - this%old_stock(c) = sites(s)%old_stock - this%cd_status(c) = sites(s)%status - this%dd_status(c) = sites(s)%dstatus - this%ncd(c) = sites(s)%ncd - this%leafondate(c) = sites(s)%leafondate - this%leafoffdate(c) = sites(s)%leafoffdate - this%dleafondate(c) = sites(s)%dleafondate - this%dleafoffdate(c) = sites(s)%dleafoffdate - this%acc_NI(c) = sites(s)%acc_NI - this%ED_GDD_site(c) = sites(s)%ED_GDD_site - - ! Carbon Balance and Checks - this%nep_timeintegrated_si(c) = sites(s)%nep_timeintegrated - this%npp_timeintegrated_si(c) = sites(s)%npp_timeintegrated - this%hr_timeintegrated_si(c) = sites(s)%hr_timeintegrated - this%totecosys_old_si(c) = sites(s)%totecosysc_old - this%tot_fatesc_old_si(c) = sites(s)%totfatesc_old - this%tot_bgcc_old_si(c) = sites(s)%totbgcc_old - this%cbal_err_fates_si(c) = sites(s)%cbal_err_fates - this%cbal_err_bgc_si(c) = sites(s)%cbal_err_bgc - this%cbal_err_tot_si(c) = sites(s)%cbal_err_tot - this%fates_to_bgc_this_ts_si(c) = sites(s)%fates_to_bgc_this_ts - this%fates_to_bgc_last_ts_si(c) = sites(s)%fates_to_bgc_last_ts - this%seedrain_flux_si(c) = sites(s)%tot_seed_rain_flux - - ! set numpatches for this column - this%numPatchesPerCol(c) = numPatches - - do i = 1,numWaterMem ! numWaterMem currently 10 - this%water_memory( countWaterMem ) = sites(s)%water_memory(i) - countWaterMem = countWaterMem + 1 - end do - - enddo - - if (this%DEBUG) then - write(iulog,*) 'CLTV total cohorts ',totalCohorts - end if - - return - end subroutine convertCohortListToVector - - !-------------------------------------------------------------------------------! - subroutine createPatchCohortStructure( this, bounds, nsites, sites, fcolumn ) - ! - ! !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 - use ColumnType , only : col - ! - ! !ARGUMENTS: - class(EDRestartVectorClass) , intent(inout) :: this - type(bounds_type) , intent(in) :: bounds - integer , intent(in) :: nsites - type(ed_site_type) , intent(inout), target :: sites(nsites) - integer , intent(in) :: fcolumn(nsites) - ! - ! !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(cp_nclmax) - real(r8) :: leaf_litter_local(numpft_ed),root_litter_local(numpft_ed) - real(r8) :: age !notional age of this patch - integer :: cohortstatus - integer :: s ! site index - integer :: c ! column index - integer :: g ! grid index - integer :: patchIdx,currIdx, fto, ft - !----------------------------------------------------------------------- - - - - 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 s = 1,nsites - - c = fcolumn(s) - if( (s-1) .ne. (c-bounds%begc) ) then - write(iulog,*) 'NAT COLUMNS REALLY ARENT MONOTONICALLY INCREASING' - write(iulog,*) s,c,bounds%begc,s-1,c-bounds%begc - end if - - g = col%gridcell(c) - - currIdx = bounds%begCohort + (c-bounds%begc)*cohorts_per_col + 1 -! currIdx = (c-1)*cohorts_per_col + 1 ! global cohort index at the head of the column - - call zero_site( sites(s) ) - ! - ! set a few items that are necessary on restart for ED but not on the - ! restart file - ! - - sites(s)%lat = grc%latdeg(g) - sites(s)%lon = grc%londeg(g) - sites(s)%ncd = 0.0_r8 - - if (this%numPatchesPerCol(c)<0 .or. this%numPatchesPerCol(c)>10000) then - write(iulog,*) 'a column was expected to contain a valid number of patches' - write(iulog,*) '0 is a valid number, but this column seems uninitialized',this%numPatchesPerCol(c) - call endrun(msg=errMsg(mod_filename, __LINE__)) - end if - - ! Initialize the site pointers to null - sites(s)%youngest_patch => null() - sites(s)%oldest_patch => null() - - do patchIdx = 1,this%numPatchesPerCol(c) - - if (this%DEBUG) then - write(iulog,*) 'create patch ',patchIdx - write(iulog,*) 'patchIdx 1-numCohorts : ',this%cohortsPerPatch(currIdx) - end if - - ! create patch - allocate(newp) - - ! make new patch - call create_patch(sites(s), newp, age, area, & - spread_local, cwd_ag_local, cwd_bg_local, & - leaf_litter_local, root_litter_local) - - newp%siteptr => sites(s) - - ! 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 - - write(iulog,*) 'EDRestVectorMod.F90::createPatchCohortStructure call create_cohort ' - - 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 = 1 ',patchIdx - - sites(s)%youngest_patch => newp - sites(s)%oldest_patch => newp - sites(s)%youngest_patch%younger => null() - sites(s)%youngest_patch%older => null() - sites(s)%oldest_patch%younger => null() - sites(s)%oldest_patch%older => null() - - else if (patchIdx == 2) then ! add second patch to list - - if (this%DEBUG) write(iulog,*) 'patchIdx = 2 ',patchIdx - - sites(s)%youngest_patch => newp - sites(s)%youngest_patch%younger => null() - sites(s)%youngest_patch%older => sites(s)%oldest_patch - sites(s)%oldest_patch%younger => sites(s)%youngest_patch - sites(s)%oldest_patch%older => null() - - else ! more than 2 patches, insert patch into youngest slot - - if (this%DEBUG) write(iulog,*) 'patchIdx > 2 ',patchIdx - - newp%older => sites(s)%youngest_patch - sites(s)%youngest_patch%younger => newp - newp%younger => null() - sites(s)%youngest_patch => newp - - endif - - currIdx = currIdx + maxCohortsPerPatch - - enddo ! ends loop over patchIdx - - enddo ! ends loop over s - - end subroutine createPatchCohortStructure - - !-------------------------------------------------------------------------------! - subroutine convertCohortVectorToList( this, bounds, nsites, sites, fcolumn ) - ! - ! !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 - integer , intent(in) :: nsites - type(ed_site_type) , intent(inout), target :: sites(nsites) - integer , intent(in) :: fcolumn(nsites) - - ! - ! !LOCAL VARIABLES: - type (ed_patch_type), pointer :: currentPatch - type (ed_cohort_type),pointer :: currentCohort - integer :: c, s - 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 :: countSunZ - integer :: i,j,k - integer :: incrementOffset - !----------------------------------------------------------------------- - - totalCohorts = 0 - - do s = 1,nsites - - c = fcolumn(s) - - incrementOffset = bounds%begCohort+(c-bounds%begc)*cohorts_per_col + 1 - - countCohort = bounds%begCohort+(c-bounds%begc)*cohorts_per_col + 1 - countPft = bounds%begCohort+(c-bounds%begc)*cohorts_per_col + 1 - countNcwd = bounds%begCohort+(c-bounds%begc)*cohorts_per_col + 1 - countNclmax = bounds%begCohort+(c-bounds%begc)*cohorts_per_col + 1 - countWaterMem = bounds%begCohort+(c-bounds%begc)*cohorts_per_col + 1 - countSunZ = bounds%begCohort+(c-bounds%begc)*cohorts_per_col + 1 - - ! read seed_bank info(site-level, but PFT-resolved) - do i = 1,numpft_ed - sites(s)%seed_bank(i) = this%seed_bank(incrementOffset+i-1) - end do - - currentPatch => sites(s)%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,*) '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%gpp = this%gpp(countCohort) - currentCohort%npp = this%npp(countCohort) - currentCohort%npp_leaf = this%npp_leaf(countCohort) - currentCohort%npp_froot = this%npp_froot(countCohort) - currentCohort%npp_bsw = this%npp_bsw(countCohort) - currentCohort%npp_bdead = this%npp_bdead(countCohort) - currentCohort%npp_bseed = this%npp_bseed(countCohort) - currentCohort%npp_store = this%npp_store(countCohort) - currentCohort%bmort = this%bmort(countCohort) - currentCohort%hmort = this%hmort(countCohort) - currentCohort%cmort = this%cmort(countCohort) - currentCohort%imort = this%imort(countCohort) - currentCohort%fmort = this%fmort(countCohort) - currentCohort%ddbhdt = this%ddbhdt(countCohort) - currentCohort%resp_tstep = this%resp_tstep(countCohort) - currentCohort%pft = this%pft(countCohort) - currentCohort%status_coh = this%status_coh(countCohort) - currentCohort%isnew = ( this%isnew(countCohort) .eq. new_cohort ) - - if (this%DEBUG) then - write(iulog,*) 'CVTL II ',countCohort, & - numCohort - endif - - countCohort = countCohort + 1 - - currentCohort => currentCohort%taller - - enddo ! current cohort do while - - - ! 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%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) - - ! set cohorts per patch for IO - - if (this%DEBUG) then - write(iulog,*) 'CVTL III ' & - ,countCohort,cohorts_per_col, 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) - 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,cp_nclmax ! cp_nclmax currently 2 - currentPatch%spread(i) = this%spread(countNclmax) - countNclmax = countNclmax + 1 - end do - - if (this%DEBUG) write(iulog,*) 'CVTL countSunZ 1 ',countSunZ - - do k = 1,cp_nlevcan ! cp_nlevcan currently 40 - do j = 1,numpft_ed ! numpft_ed currently 2 - do i = 1,cp_nclmax ! cp_nclmax currently 2 - currentPatch%f_sun(i,j,k) = this%f_sun(countSunZ) - currentPatch%fabd_sun_z(i,j,k) = this%fabd_sun_z(countSunZ) - currentPatch%fabi_sun_z(i,j,k) = this%fabi_sun_z(countSunZ) - currentPatch%fabd_sha_z(i,j,k) = this%fabd_sha_z(countSunZ) - currentPatch%fabi_sha_z(i,j,k) = this%fabi_sha_z(countSunZ) - countSunZ = countSunZ + 1 - end do - end do - end do - - if (this%DEBUG) write(iulog,*) 'CVTL countSunZ 2 ',countSunZ - - incrementOffset = incrementOffset + maxCohortsPerPatch - - ! and the number of allowed cohorts per patch (currently 200) - countPft = incrementOffset - countNcwd = incrementOffset - countNclmax = incrementOffset - countCohort = incrementOffset - countSunZ = incrementOffset - - if (this%DEBUG) then - write(iulog,*) 'CVTL incrementOffset ', incrementOffset - write(iulog,*) 'CVTL cohorts_per_col ', cohorts_per_col - write(iulog,*) 'CVTL numCohort ', numCohort - write(iulog,*) 'CVTL totalCohorts ', totalCohorts - end if - - currentPatch => currentPatch%younger - - enddo ! currentPatch do while - - do i = 1,numWaterMem - sites(s)%water_memory(i) = this%water_memory( countWaterMem ) - countWaterMem = countWaterMem + 1 - end do - - sites(s)%old_stock = this%old_stock(c) - sites(s)%status = this%cd_status(c) - sites(s)%dstatus = this%dd_status(c) - sites(s)%ncd = this%ncd(c) - sites(s)%leafondate = this%leafondate(c) - sites(s)%leafoffdate = this%leafoffdate(c) - sites(s)%dleafondate = this%dleafondate(c) - sites(s)%dleafoffdate = this%dleafoffdate(c) - sites(s)%acc_NI = this%acc_NI(c) - sites(s)%ED_GDD_site = this%ED_GDD_site(c) - - ! Carbon Balance and Checks - sites(s)%nep_timeintegrated = this%nep_timeintegrated_si(c) - sites(s)%npp_timeintegrated = this%npp_timeintegrated_si(c) - sites(s)%hr_timeintegrated = this%hr_timeintegrated_si(c) - sites(s)%totecosysc_old = this%totecosys_old_si(c) - sites(s)%totfatesc_old = this%tot_fatesc_old_si(c) - sites(s)%totbgcc_old = this%tot_bgcc_old_si(c) - sites(s)%cbal_err_fates = this%cbal_err_fates_si(c) - sites(s)%cbal_err_bgc = this%cbal_err_bgc_si(c) - sites(s)%cbal_err_tot = this%cbal_err_tot_si(c) - sites(s)%fates_to_bgc_this_ts = this%fates_to_bgc_this_ts_si(c) - sites(s)%fates_to_bgc_last_ts = this%fates_to_bgc_last_ts_si(c) - sites(s)%tot_seed_rain_flux = this%seedrain_flux_si(c) - - enddo - - if (this%DEBUG) then - write(iulog,*) 'CVTL total cohorts ',totalCohorts - end if - - end subroutine convertCohortVectorToList - - !--------------------------------------------! - ! Non Type-Bound Procedures Here: - !--------------------------------------------! - - !-------------------------------------------------------------------------------! - subroutine EDRest ( bounds, nsites, sites, fcolumn, ncid, flag ) - ! - ! !DESCRIPTION: - ! Read/write ED restart data - ! EDRest called from restFileMod.F90 - ! - ! !USES: - - use ncdio_pio , only : file_desc_t - ! - ! !ARGUMENTS: - type(bounds_type) , intent(in) :: bounds ! bounds - type(file_desc_t) , intent(inout) :: ncid ! netcdf id - integer , intent(in) :: nsites - type(ed_site_type) , intent(inout), target :: sites(nsites) ! The site vector - integer , intent(in) :: fcolumn(nsites) - character(len=*) , intent(in) :: flag !'read' or 'write' - ! - ! !LOCAL VARIABLES: - type(EDRestartVectorClass) :: ervc - - !----------------------------------------------------------------------- - ! - ! Note: ed_allsites_inst already exists and is allocated in clm_instInit - ! - - ervc = newEDRestartVectorClass( bounds ) - - if (ervc%DEBUG) then - write(iulog,*) 'EDRestVectorMod:EDRest flag ',flag - end if - - if ( flag == 'write' ) then - call ervc%setVectors( bounds, nsites, sites, fcolumn ) - endif - - call ervc%doVectorIO( ncid, flag ) - - if ( flag == 'read' ) then - call ervc%getVectors( bounds, nsites, sites, fcolumn ) - endif - - call ervc%deleteEDRestartVectorClass () - - end subroutine EDRest - -end module EDRestVectorMod From 5a35f70f247e5252fb8c2770c2e45feb265d998c Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Sun, 20 Nov 2016 14:36:20 -0800 Subject: [PATCH 244/437] Renamed a variable, some minor reformatting, changed mapping calculation. --- main/FatesRestartInterfaceMod.F90 | 52 +++++++++++++++---------------- 1 file changed, 26 insertions(+), 26 deletions(-) diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index dee2cbb1..29ae66b1 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -108,7 +108,7 @@ module FatesRestartInterfaceMod integer, private :: ir_root_litter_paft integer, private :: ir_leaf_litter_in_paft integer, private :: ir_root_litter_in_paft - integer, private :: ir_seed_bank_co + integer, private :: ir_seed_bank_sift integer, private :: ir_spread_pacl integer, private :: ir_livegrass_pa integer, private :: ir_age_pa @@ -141,7 +141,6 @@ module FatesRestartInterfaceMod ! more for things like flushing type restart_map_type integer, allocatable :: site_index(:) ! maps site indexes to the HIO site position -! integer, allocatable :: patch1_index(:) ! maps site index to the HIO patch 1st position integer, allocatable :: cohort1_index(:) ! maps site index to the HIO cohort 1st position end type restart_map_type @@ -340,7 +339,7 @@ end subroutine set_column_index integer function column_index(this) implicit none class(fates_restart_interface_type), intent(in) :: this - column_index = this%column_index_ + column_index = this%column_index_ end function column_index ! ======================================================================= @@ -733,10 +732,9 @@ subroutine define_restart_vars(this, initialize_variables) long_name='ed patch - root_litter_in', units='unitless', & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_root_litter_in_paft ) - ! TODO: THIS SAYS SITE BUT USES COHORT LEVEL, INVESTIGATE (RGK) call this%set_restart_var(vname='ed_seed_bank', vtype=cohort_r8, & long_name='ed site? - seed_bank', units='unitless', & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_seed_bank_co ) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_seed_bank_sift ) call this%set_restart_var(vname='ed_spread', vtype=cohort_r8, & long_name='ed patch - spread', units='unitless', & @@ -857,7 +855,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) use EDTypesMod, only : numWaterMem ! Arguments - class(fates_restart_interface_type) :: this + class(fates_restart_interface_type) :: this integer , intent(in) :: nc ! clump index integer , intent(in) :: nsites type(ed_site_type) , intent(inout), target :: sites(nsites) @@ -958,7 +956,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_root_litter_paft => this%rvars(ir_root_litter_paft)%r81d, & rio_leaf_litter_in_paft => this%rvars(ir_leaf_litter_in_paft)%r81d, & rio_root_litter_in_paft => this%rvars(ir_root_litter_in_paft)%r81d, & - rio_seed_bank_co => this%rvars(ir_seed_bank_co)%r81d, & + rio_seed_bank_sift => this%rvars(ir_seed_bank_sift)%r81d, & rio_spread_pacl => this%rvars(ir_spread_pacl)%r81d, & rio_livegrass_pa => this%rvars(ir_livegrass_pa)%r81d, & rio_age_pa => this%rvars(ir_age_pa)%r81d, & @@ -985,19 +983,19 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ! For the first site, if that site aligns with the first column index ! in the clump, than the offset should be be equal to begCohort - io_idx_si = this%restart_map(nc)%site_index(s) + io_idx_si = this%restart_map(nc)%site_index(s) io_idx_co_1st = this%restart_map(nc)%cohort1_index(s) - io_idx_co = io_idx_co_1st - io_idx_pa_pft = io_idx_co_1st - io_idx_pa_cwd = io_idx_co_1st - io_idx_pa_cl = io_idx_co_1st - io_idx_si_wmem = io_idx_co_1st - io_idx_pa_sunz = io_idx_co_1st + io_idx_co = io_idx_co_1st + io_idx_pa_pft = io_idx_co_1st + io_idx_pa_cwd = io_idx_co_1st + io_idx_pa_cl = io_idx_co_1st + io_idx_si_wmem = io_idx_co_1st + io_idx_pa_sunz = io_idx_co_1st ! write seed_bank info(site-level, but PFT-resolved) do i = 1,numpft_ed - rio_seed_bank_co(io_idx_co_1st+i-1) = sites(s)%seed_bank(i) + rio_seed_bank_sift(io_idx_co_1st+i-1) = sites(s)%seed_bank(i) end do cpatch => sites(s)%oldest_patch @@ -1018,8 +1016,8 @@ subroutine set_restart_vectors(this,nc,nsites,sites) do while(associated(ccohort)) ! found cohort, increment - cohortsperpatch = cohortsperpatch + 1 - totalCohorts = totalCohorts + 1 + cohortsperpatch = cohortsperpatch + 1 + totalCohorts = totalCohorts + 1 if ( DEBUG ) then write(fates_log(),*) 'CLTV io_idx_co ', io_idx_co @@ -1132,7 +1130,10 @@ subroutine set_restart_vectors(this,nc,nsites,sites) end do if ( DEBUG ) write(fates_log(),*) 'CLTV io_idx_pa_sunz 2 ',io_idx_pa_sunz - + + + ! Set the first cohort index to the start of the next patch, increment + ! by the maximum number of cohorts per patch io_idx_co_1st = io_idx_co_1st + maxCohortsPerPatch ! reset counters so that they are all advanced evenly. Currently @@ -1517,7 +1518,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) rio_root_litter_paft => this%rvars(ir_root_litter_paft)%r81d, & rio_leaf_litter_in_paft => this%rvars(ir_leaf_litter_in_paft)%r81d, & rio_root_litter_in_paft => this%rvars(ir_root_litter_in_paft)%r81d, & - rio_seed_bank_co => this%rvars(ir_seed_bank_co)%r81d, & + rio_seed_bank_sift => this%rvars(ir_seed_bank_sift)%r81d, & rio_spread_pacl => this%rvars(ir_spread_pacl)%r81d, & rio_livegrass_pa => this%rvars(ir_livegrass_pa)%r81d, & rio_age_pa => this%rvars(ir_age_pa)%r81d, & @@ -1545,7 +1546,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ! read seed_bank info(site-level, but PFT-resolved) do i = 1,numpft_ed - rio_seed_bank_co(io_idx_co_1st+i-1) = sites(s)%seed_bank(i) + rio_seed_bank_sift(io_idx_co_1st+i-1) = sites(s)%seed_bank(i) enddo ! Perform a check on the number of patches per site @@ -1669,10 +1670,10 @@ subroutine get_restart_vectors(this, nc, nsites, sites) do j = 1,numpft_ed ! numpft_ed currently 2 do i = 1,cp_nclmax ! cp_nclmax currently 2 cpatch%f_sun(i,j,k) = rio_fsun_paclftls(io_idx_pa_sunz) - cpatch%fabd_sun_z(i,j,k) = rio_fabd_sun_z_paclftls(io_idx_pa_sunz) - cpatch%fabi_sun_z(i,j,k) = rio_fabi_sun_z_paclftls(io_idx_pa_sunz) - cpatch%fabd_sha_z(i,j,k) = rio_fabd_sha_z_paclftls(io_idx_pa_sunz) - cpatch%fabi_sha_z(i,j,k) = rio_fabi_sha_z_paclftls(io_idx_pa_sunz) + cpatch%fabd_sun_z(i,j,k) = rio_fabd_sun_z_paclftls(io_idx_pa_sunz) + cpatch%fabi_sun_z(i,j,k) = rio_fabi_sun_z_paclftls(io_idx_pa_sunz) + cpatch%fabd_sha_z(i,j,k) = rio_fabd_sha_z_paclftls(io_idx_pa_sunz) + cpatch%fabi_sha_z(i,j,k) = rio_fabi_sha_z_paclftls(io_idx_pa_sunz) io_idx_pa_sunz = io_idx_pa_sunz + 1 end do end do @@ -1685,7 +1686,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) io_idx_co_1st = io_idx_co_1st + maxCohortsPerPatch - ! and the number of allowed cohorts per patch (currently 200) + ! and max the number of allowed cohorts per patch io_idx_pa_pft = io_idx_co_1st io_idx_pa_cwd = io_idx_co_1st io_idx_pa_cl = io_idx_co_1st @@ -1708,7 +1709,6 @@ subroutine get_restart_vectors(this, nc, nsites, sites) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - do i = 1,numWaterMem sites(s)%water_memory(i) = rio_watermem_siwm( io_idx_si_wmem ) io_idx_si_wmem = io_idx_si_wmem + 1 From 2e6aabe0b0a30028e9ff2f09db24f690a4f83654 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 21 Nov 2016 14:56:29 -0800 Subject: [PATCH 245/437] Reverted some changes to test if the restart files created during ERS testing match with the baseline. --- main/FatesRestartInterfaceMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 29ae66b1..ea726695 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -648,7 +648,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name='ed cohort - npp_froot', units='unitless', & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_npp_froot_co ) - call this%set_restart_var(vname='ed_npp_sw', vtype=cohort_r8, & + call this%set_restart_var(vname='ed_npp_bsw', vtype=cohort_r8, & long_name='ed cohort - npp_sw', units='unitless', & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_npp_sw_co ) From 8aef388bfc1a17fbe058d7572f3d2c0047802ab0 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 22 Nov 2016 18:08:08 -0800 Subject: [PATCH 246/437] Changed to a flushing and initialization system that enables different flush types. The main reason for this is to enable strict comparisons with baseline restart files. --- main/FatesRestartInterfaceMod.F90 | 171 +++++++++++++++--------------- main/FatesRestartVariableType.F90 | 34 +++--- 2 files changed, 106 insertions(+), 99 deletions(-) diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index ea726695..85db6dec 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -183,7 +183,7 @@ module FatesRestartInterfaceMod procedure, private :: set_dim_indices procedure, private :: set_cohort_index procedure, private :: set_column_index - procedure, private :: flushzero_rvars + procedure, private :: flush_rvars procedure, private :: define_restart_vars procedure, private :: set_restart_var @@ -422,7 +422,7 @@ end subroutine initialize_restart_vars ! ====================================================================================== - subroutine flushzero_rvars(this,nc) + subroutine flush_rvars(this,nc) class(fates_restart_interface_type) :: this integer,intent(in) :: nc @@ -433,11 +433,11 @@ subroutine flushzero_rvars(this,nc) do ivar=1,ubound(this%rvars,1) associate( rvar => this%rvars(ivar) ) - call rvar%FlushZero(nc, this%dim_bounds, this%dim_kinds) + call rvar%Flush(nc, this%dim_bounds, this%dim_kinds) end associate end do - end subroutine flushzero_rvars + end subroutine flush_rvars @@ -464,102 +464,105 @@ subroutine define_restart_vars(this, initialize_variables) class(fates_restart_interface_type), intent(inout) :: this logical, intent(in) :: initialize_variables ! are we 'count'ing or 'initializ'ing? - integer :: ivar + real(r8), parameter :: flushinvalid = -9999.0 + real(r8), parameter :: flushzero = 0.0 + real(r8), parameter :: flushone = 1.0 + ivar=0 ! Site level counting variables call this%set_restart_var(vname='ed_io_numPatchesPerCol', vtype=site_int, & - long_name='Total number of ED patches per column', units='none', & + long_name='Total number of ED patches per column', units='none', flushval = flushinvalid, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_npatch_si ) call this%set_restart_var(vname='ed_old_stock', vtype=site_r8, & - long_name='ed cohort - old_stock', units='unitless', & + long_name='ed cohort - old_stock', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_oldstock_si ) call this%set_restart_var(vname='ed_cd_status', vtype=site_r8, & - long_name='ed cold dec status', units='unitless', & + long_name='ed cold dec status', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_cd_status_si ) call this%set_restart_var(vname='ed_dd_status', vtype=site_r8, & - long_name='ed drought dec status', units='unitless', & + long_name='ed drought dec status', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_dd_status_si ) call this%set_restart_var(vname='ed_chilling_days', vtype=site_r8, & - long_name='ed chilling day counter', units='unitless', & + long_name='ed chilling day counter', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_nchill_days_si ) call this%set_restart_var(vname='ed_leafondate', vtype=site_r8, & - long_name='ed leafondate', units='unitless', & + long_name='ed leafondate', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_leafondate_si ) call this%set_restart_var(vname='ed_leafoffdate', vtype=site_r8, & - long_name='ed leafoffdate', units='unitless', & + long_name='ed leafoffdate', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_leafoffdate_si ) call this%set_restart_var(vname='ed_dleafondate', vtype=site_r8, & - long_name='ed dleafondate', units='unitless', & + long_name='ed dleafondate', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_dleafondate_si ) call this%set_restart_var(vname='ed_dleafoffdate', vtype=site_r8, & - long_name='ed dleafoffdate', units='unitless', & + long_name='ed dleafoffdate', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_dleafoffdate_si ) call this%set_restart_var(vname='ed_acc_NI', vtype=site_r8, & - long_name='ed nesterov index', units='unitless', & + long_name='ed nesterov index', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_acc_ni_si ) call this%set_restart_var(vname='ed_gdd_site', vtype=site_r8, & - long_name='ed GDD site', units='unitless', & + long_name='ed GDD site', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_gdd_si ) call this%set_restart_var(vname='nep_timeintegrated_col', vtype=site_r8, & - long_name='NA', units='NA', & + long_name='NA', units='NA', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_nep_timeintegrated_si ) call this%set_restart_var(vname='npp_timeintegrated_col', vtype=site_r8, & - long_name='NA', units='NA', & + long_name='NA', units='NA', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_npp_timeintegrated_si ) call this%set_restart_var(vname='hr_timeintegrated_col', vtype=site_r8, & - long_name='NA', units='NA', & + long_name='NA', units='NA', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hr_timeintegrated_si ) call this%set_restart_var(vname='cbalance_error_ed_col', vtype=site_r8, & - long_name='NA', units='NA', & + long_name='NA', units='NA', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_cbal_error_fates_si ) call this%set_restart_var(vname='cbalance_error_bgc_col', vtype=site_r8, & - long_name='NA', units='NA', & + long_name='NA', units='NA', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_cbal_error_bgc_si ) call this%set_restart_var(vname='cbalance_error_total_col', vtype=site_r8, & - long_name='NA', units='NA', & + long_name='NA', units='NA', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_cbal_error_total_si ) call this%set_restart_var(vname='totecosysc_old_col', vtype=site_r8, & - long_name='NA', units='NA', & + long_name='NA', units='NA', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_totecosysc_old_si ) call this%set_restart_var(vname='totedc_old_col', vtype=site_r8, & - long_name='NA', units='NA', & + long_name='NA', units='NA', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_totfatesc_old_si ) call this%set_restart_var(vname='totbgcc_old_col', vtype=site_r8, & - long_name='NA', units='NA', & + long_name='NA', units='NA', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_totbgcc_old_si ) call this%set_restart_var(vname='ed_to_bgc_this_edts_col', vtype=site_r8, & - long_name='NA', units='NA', & + long_name='NA', units='NA', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fates_to_bgc_this_ts_si ) call this%set_restart_var(vname='ed_to_bgc_last_edts_col', vtype=site_r8, & - long_name='NA', units='NA', & + long_name='NA', units='NA', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fates_to_bgc_last_ts_si ) call this%set_restart_var(vname='seed_rain_flux_col', vtype=site_r8, & - long_name='NA', units='NA', & + long_name='NA', units='NA', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_seedrainflux_si ) ! @@ -569,139 +572,139 @@ subroutine define_restart_vars(this, initialize_variables) ! This variable may be confusing, because it is a patch level variables ! but it is using the cohort IO vector to hold data call this%set_restart_var(vname='ed_io_cohortsPerPatch', vtype=cohort_int, & - long_name='cohorts per patch, indexed by numPatchesPerCol', units='unitless', & + long_name='cohorts per patch, indexed by numPatchesPerCol', units='unitless', flushval = flushinvalid, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_ncohort_pa ) call this%set_restart_var(vname='ed_balive', vtype=cohort_r8, & - long_name='ed cohort ed_balive', units='unitless', & + long_name='ed cohort ed_balive', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_balive_co ) call this%set_restart_var(vname='ed_bdead', vtype=cohort_r8, & - long_name='ed cohort - bdead', units='unitless', & + long_name='ed cohort - bdead', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_bdead_co ) call this%set_restart_var(vname='ed_bl', vtype=cohort_r8, & - long_name='ed cohort - bl', units='unitless', & + long_name='ed cohort - bl', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_bleaf_co ) call this%set_restart_var(vname='ed_br', vtype=cohort_r8, & - long_name='ed cohort - br', units='unitless', & + long_name='ed cohort - br', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_broot_co ) call this%set_restart_var(vname='ed_bstore', vtype=cohort_r8, & - long_name='ed cohort - bstore', units='unitless', & + long_name='ed cohort - bstore', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_bstore_co ) call this%set_restart_var(vname='ed_canopy_layer', vtype=cohort_r8, & - long_name='ed cohort - canopy_layer', units='unitless', & + long_name='ed cohort - canopy_layer', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_canopy_layer_co ) call this%set_restart_var(vname='ed_canopy_trim', vtype=cohort_r8, & - long_name='ed cohort - canopy_trim', units='unitless', & + long_name='ed cohort - canopy_trim', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_canopy_trim_co ) call this%set_restart_var(vname='ed_dbh', vtype=cohort_r8, & - long_name='ed cohort - dbh', units='unitless', & + long_name='ed cohort - dbh', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_dbh_co ) call this%set_restart_var(vname='ed_hite', vtype=cohort_r8, & - long_name='ed cohort - hite', units='unitless', & + long_name='ed cohort - hite', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_height_co ) call this%set_restart_var(vname='ed_laimemory', vtype=cohort_r8, & - long_name='ed cohort - laimemory', units='unitless', & + long_name='ed cohort - laimemory', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_laimemory_co ) call this%set_restart_var(vname='ed_leaf_md', vtype=cohort_r8, & - long_name='ed cohort - leaf_md', units='unitless', & + long_name='ed cohort - leaf_md', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_leaf_md_co ) call this%set_restart_var(vname='ed_root_md', vtype=cohort_r8, & - long_name='ed cohort - root_md', units='unitless', & + long_name='ed cohort - root_md', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_root_md_co ) call this%set_restart_var(vname='ed_n', vtype=cohort_r8, & - long_name='ed cohort - n', units='unitless', & + long_name='ed cohort - n', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_nplant_co ) call this%set_restart_var(vname='ed_gpp_acc', vtype=cohort_r8, & - long_name='ed cohort - gpp_acc', units='unitless', & + long_name='ed cohort - gpp_acc', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_gpp_acc_co ) call this%set_restart_var(vname='ed_npp_acc', vtype=cohort_r8, & - long_name='ed cohort - npp_acc', units='unitless', & + long_name='ed cohort - npp_acc', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_npp_acc_co ) call this%set_restart_var(vname='ed_gpp', vtype=cohort_r8, & - long_name='ed cohort - gpp', units='unitless', & + long_name='ed cohort - gpp', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_gpp_co ) call this%set_restart_var(vname='ed_npp', vtype=cohort_r8, & - long_name='ed cohort - npp', units='unitless', & + long_name='ed cohort - npp', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_npp_co ) call this%set_restart_var(vname='ed_npp_leaf', vtype=cohort_r8, & - long_name='ed cohort - npp_leaf', units='unitless', & + long_name='ed cohort - npp_leaf', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_npp_leaf_co ) call this%set_restart_var(vname='ed_npp_froot', vtype=cohort_r8, & - long_name='ed cohort - npp_froot', units='unitless', & + long_name='ed cohort - npp_froot', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_npp_froot_co ) call this%set_restart_var(vname='ed_npp_bsw', vtype=cohort_r8, & - long_name='ed cohort - npp_sw', units='unitless', & + long_name='ed cohort - npp_sw', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_npp_sw_co ) call this%set_restart_var(vname='ed_npp_bdead', vtype=cohort_r8, & - long_name='ed cohort - npp_bdead', units='unitless', & + long_name='ed cohort - npp_bdead', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_npp_dead_co ) call this%set_restart_var(vname='ed_npp_bseed', vtype=cohort_r8, & - long_name='ed cohort - npp_bseed', units='unitless', & + long_name='ed cohort - npp_bseed', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_npp_seed_co ) call this%set_restart_var(vname='ed_npp_store', vtype=cohort_r8, & - long_name='ed cohort - npp_store', units='unitless', & + long_name='ed cohort - npp_store', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_npp_store_co ) call this%set_restart_var(vname='ed_bmort', vtype=cohort_r8, & - long_name='ed cohort - bmort', units='unitless', & + long_name='ed cohort - bmort', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_bmort_co ) call this%set_restart_var(vname='ed_hmort', vtype=cohort_r8, & - long_name='ed cohort - hmort', units='unitless', & + long_name='ed cohort - hmort', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hmort_co ) call this%set_restart_var(vname='ed_cmort', vtype=cohort_r8, & - long_name='ed cohort - cmort', units='unitless', & + long_name='ed cohort - cmort', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_cmort_co ) call this%set_restart_var(vname='ed_imort', vtype=cohort_r8, & - long_name='ed cohort - imort', units='unitless', & + long_name='ed cohort - imort', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_imort_co ) call this%set_restart_var(vname='ed_fmort', vtype=cohort_r8, & - long_name='ed cohort - fmort', units='unitless', & + long_name='ed cohort - fmort', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fmort_co ) call this%set_restart_var(vname='ed_ddbhdt', vtype=cohort_r8, & - long_name='ed cohort - ddbhdt', units='unitless', & + long_name='ed cohort - ddbhdt', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_ddbhdt_co ) call this%set_restart_var(vname='ed_resp_tstep', vtype=cohort_r8, & - long_name='ed cohort - resp_tstep', units='unitless', & + long_name='ed cohort - resp_tstep', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_resp_tstep_co ) call this%set_restart_var(vname='ed_pft', vtype=cohort_int, & - long_name='ed cohort - pft', units='unitless', & + long_name='ed cohort - pft', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_pft_co ) call this%set_restart_var(vname='ed_status_coh', vtype=cohort_int, & - long_name='ed cohort - status_coh', units='unitless', & + long_name='ed cohort - status_coh', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_status_co ) call this%set_restart_var(vname='ed_isnew', vtype=cohort_int, & - long_name='ed cohort - isnew', units='unitless', & + long_name='ed cohort - isnew', units='unitless', flushval = flushone, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_isnew_co ) ! @@ -709,68 +712,68 @@ subroutine define_restart_vars(this, initialize_variables) ! call this%set_restart_var(vname='ed_cwd_ag', vtype=cohort_r8, & - long_name='ed patch - cwd_ag', units='unitless', & + long_name='ed patch - cwd_ag', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_cwd_ag_pacw ) call this%set_restart_var(vname='ed_cwd_bg', vtype=cohort_r8, & - long_name='ed patch - cwd_bg', units='unitless', & + long_name='ed patch - cwd_bg', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_cwd_bg_pacw ) call this%set_restart_var(vname='ed_leaf_litter', vtype=cohort_r8, & - long_name='fates: leaf litter by patch x pft', units='unitless', & + long_name='fates: leaf litter by patch x pft', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_leaf_litter_paft ) call this%set_restart_var(vname='ed_root_litter', vtype=cohort_r8, & - long_name='ed patch - root_litter', units='unitless', & + long_name='ed patch - root_litter', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_root_litter_paft ) call this%set_restart_var(vname='ed_leaf_litter_in', vtype=cohort_r8, & - long_name='ed patch - leaf_litter_in', units='unitless', & + long_name='ed patch - leaf_litter_in', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_leaf_litter_in_paft ) call this%set_restart_var(vname='ed_root_litter_in', vtype=cohort_r8, & - long_name='ed patch - root_litter_in', units='unitless', & + long_name='ed patch - root_litter_in', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_root_litter_in_paft ) call this%set_restart_var(vname='ed_seed_bank', vtype=cohort_r8, & - long_name='ed site? - seed_bank', units='unitless', & + long_name='ed site? - seed_bank', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_seed_bank_sift ) call this%set_restart_var(vname='ed_spread', vtype=cohort_r8, & - long_name='ed patch - spread', units='unitless', & + long_name='ed patch - spread', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_spread_pacl ) call this%set_restart_var(vname='ed_livegrass', vtype=cohort_r8, & - long_name='ed patch - livegrass', units='unitless', & + long_name='ed patch - livegrass', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_livegrass_pa ) call this%set_restart_var(vname='ed_age', vtype=cohort_r8, & - long_name='ed patch - age', units='unitless', & + long_name='ed patch - age', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_age_pa ) call this%set_restart_var(vname='ed_area', vtype=cohort_r8, & - long_name='ed patch - area', units='unitless', & + long_name='ed patch - area', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_area_pa ) ! These dimensions are pa "patch" cl "canopy layer" ft "functional type" ls "layer sublevel" call this%set_restart_var(vname='ed_f_sun', vtype=cohort_r8, & - long_name='ed patch - f_sun', units='unitless', & + long_name='ed patch - f_sun', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fsun_paclftls ) call this%set_restart_var(vname='ed_fabd_sun_z', vtype=cohort_r8, & - long_name='ed patch - fabd_sun_z', units='unitless', & + long_name='ed patch - fabd_sun_z', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fabd_sun_paclftls ) call this%set_restart_var(vname='ed_fabi_sun_z', vtype=cohort_r8, & - long_name='ed patch - fabi_sun_z', units='unitless', & + long_name='ed patch - fabi_sun_z', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fabi_sun_paclftls ) call this%set_restart_var(vname='ed_fabd_sha_z', vtype=cohort_r8, & - long_name='ed patch - fabd_sha_z', units='unitless', & + long_name='ed patch - fabd_sha_z', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fabd_sha_paclftls ) call this%set_restart_var(vname='ed_fabi_sha_z', vtype=cohort_r8, & - long_name='ed patch - fabi_sha_z', units='unitless', & + long_name='ed patch - fabi_sha_z', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fabi_sha_paclftls ) ! @@ -778,7 +781,7 @@ subroutine define_restart_vars(this, initialize_variables) ! call this%set_restart_var(vname='ed_water_memory', vtype=cohort_r8, & - long_name='ed cohort - water_memory', units='unitless', & + long_name='ed cohort - water_memory', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_watermem_siwm ) @@ -790,7 +793,8 @@ end subroutine define_restart_vars ! ===================================================================================== - subroutine set_restart_var(this,vname,vtype,long_name,units,hlms,initialize,ivar,index) + subroutine set_restart_var(this,vname,vtype,long_name,units,flushval, & + hlms,initialize,ivar,index) use FatesUtilsMod, only : check_hlm_list use EDTypesMod, only : cp_hlm_name @@ -799,7 +803,8 @@ subroutine set_restart_var(this,vname,vtype,long_name,units,hlms,initialize,ivar class(fates_restart_interface_type) :: this character(len=*),intent(in) :: vname character(len=*),intent(in) :: vtype - character(len=*),intent(in) :: units + character(len=*),intent(in) :: units + real(r8), intent(in) :: flushval character(len=*),intent(in) :: long_name character(len=*),intent(in) :: hlms logical, intent(in) :: initialize @@ -827,7 +832,7 @@ subroutine set_restart_var(this,vname,vtype,long_name,units,hlms,initialize,ivar if( initialize )then - call this%rvars(ivar)%Init(vname, units, long_name, vtype, & + call this%rvars(ivar)%Init(vname, units, long_name, vtype, flushval, & fates_restart_num_dim_kinds, this%dim_kinds, this%dim_bounds) end if @@ -974,7 +979,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ! Flush arrays to values defined by %flushval (see registry entry in ! subroutine define_history_vars() ! --------------------------------------------------------------------------------- - call this%flushzero_rvars(nc) + call this%flush_rvars(nc) do s = 1,nsites diff --git a/main/FatesRestartVariableType.F90 b/main/FatesRestartVariableType.F90 index 17b58fa3..40648fb4 100644 --- a/main/FatesRestartVariableType.F90 +++ b/main/FatesRestartVariableType.F90 @@ -24,13 +24,13 @@ module FatesRestartVariableMod integer, pointer :: int1d(:) contains procedure, public :: Init - procedure, public :: FlushZero + procedure, public :: Flush procedure, private :: GetBounds end type fates_restart_variable_type contains - subroutine Init(this, vname, units, long, vtype, num_dim_kinds, dim_kinds, dim_bounds) + subroutine Init(this, vname, units, long, vtype, flushval, num_dim_kinds, dim_kinds, dim_bounds) use FatesIODimensionsMod, only : fates_io_dimension_type use FatesIOVariableKindMod, only : patch_r8, site_r8, cohort_r8 @@ -44,6 +44,7 @@ subroutine Init(this, vname, units, long, vtype, num_dim_kinds, dim_kinds, dim_b character(len=*), intent(in) :: units character(len=*), intent(in) :: long character(len=*), intent(in) :: vtype + real(r8), intent(in) :: flushval integer, intent(in) :: num_dim_kinds type(fates_io_dimension_type), intent(in) :: dim_bounds(:) type(fates_io_variable_kind_type), intent(inout) :: dim_kinds(:) @@ -55,6 +56,7 @@ subroutine Init(this, vname, units, long, vtype, num_dim_kinds, dim_kinds, dim_b this%units = units this%long = long this%vtype = vtype + this%flushval = flushval nullify(this%r81d) nullify(this%int1d) @@ -75,27 +77,27 @@ subroutine Init(this, vname, units, long, vtype, num_dim_kinds, dim_kinds, dim_b case(cohort_r8) allocate(this%r81d(lb1:ub1)) - this%r81d(:) = 0.0_r8 + this%r81d(:) = flushval case(patch_r8) allocate(this%r81d(lb1:ub1)) - this%r81d(:) = 0.0_r8 + this%r81d(:) = flushval case(site_r8) allocate(this%r81d(lb1:ub1)) - this%r81d(:) = 0.0_r8 + this%r81d(:) = flushval case(cohort_int) allocate(this%int1d(lb1:ub1)) - this%int1d(:) = 0 + this%int1d(:) = idnint(flushval) case(patch_int) allocate(this%int1d(lb1:ub1)) - this%int1d(:) = 0 + this%int1d(:) = idnint(flushval) case(site_int) allocate(this%int1d(lb1:ub1)) - this%int1d(:) = 0 + this%int1d(:) = idnint(flushval) case default write(fates_log(),*) 'Incompatible vtype passed to set_restart_var' @@ -159,7 +161,7 @@ end subroutine GetBounds ! ==================================================================================== - subroutine FlushZero(this, thread, dim_bounds, dim_kinds) + subroutine flush(this, thread, dim_bounds, dim_kinds) use FatesIODimensionsMod, only : fates_io_dimension_type use FatesIOVariableKindMod, only : patch_r8, site_r8, cohort_r8 @@ -178,17 +180,17 @@ subroutine FlushZero(this, thread, dim_bounds, dim_kinds) select case(trim(dim_kinds(this%dim_kinds_index)%name)) case(patch_r8) - this%r81d(lb1:ub1) = 0.0_r8 + this%r81d(lb1:ub1) = this%flushval case(site_r8) - this%r81d(lb1:ub1) = 0.0_r8 + this%r81d(lb1:ub1) = this%flushval case(cohort_r8) - this%r81d(lb1:ub1) = 0.0_r8 + this%r81d(lb1:ub1) = this%flushval case(patch_int) - this%int1d(lb1:ub1) = 0 + this%int1d(lb1:ub1) = nint(this%flushval) case(site_int) - this%int1d(lb1:ub1) = 0 + this%int1d(lb1:ub1) = nint(this%flushval) case(cohort_int) - this%int1d(lb1:ub1) = 0 + this%int1d(lb1:ub1) = nint(this%flushval) case default write(fates_log(),*) 'fates history variable type undefined while flushing history variables' @@ -196,6 +198,6 @@ subroutine FlushZero(this, thread, dim_bounds, dim_kinds) !end_run end select - end subroutine FlushZero + end subroutine Flush end module FatesRestartVariableMod From 0c1d833e6c8678060325247a17cf668f59a75cb3 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 23 Nov 2016 15:56:00 -0800 Subject: [PATCH 247/437] During the call to pass vectors to linked list, I had the seed_bank passing reversed. Fixed. --- main/FatesRestartInterfaceMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 85db6dec..197bcbdb 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -1551,7 +1551,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ! read seed_bank info(site-level, but PFT-resolved) do i = 1,numpft_ed - rio_seed_bank_sift(io_idx_co_1st+i-1) = sites(s)%seed_bank(i) + sites(s)%seed_bank(i) = rio_seed_bank_sift(io_idx_co_1st+i-1) enddo ! Perform a check on the number of patches per site From fc3f10ad8e9fef4b6e10fd442d4aacd87a539bff Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Sun, 27 Nov 2016 16:48:46 -0800 Subject: [PATCH 248/437] Cleaned up restart variable names, long names and units. --- main/FatesRestartInterfaceMod.F90 | 365 +++++++++++++++++------------- 1 file changed, 211 insertions(+), 154 deletions(-) diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 197bcbdb..81d9246c 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -472,316 +472,373 @@ subroutine define_restart_vars(this, initialize_variables) ivar=0 - ! Site level counting variables - call this%set_restart_var(vname='ed_io_numPatchesPerCol', vtype=site_int, & - long_name='Total number of ED patches per column', units='none', flushval = flushinvalid, & + ! ----------------------------------------------------------------------------------- + ! Site level variables + ! ----------------------------------------------------------------------------------- + + call this%set_restart_var(vname='fates_PatchesPerSite', vtype=site_int, & + long_name='Total number of FATES patches per column', units='none', flushval = flushinvalid, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_npatch_si ) - call this%set_restart_var(vname='ed_old_stock', vtype=site_r8, & - long_name='ed cohort - old_stock', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_old_stock', vtype=site_r8, & + long_name='biomass stock in each site (previous step)', units='kgC/site', & + flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_oldstock_si ) - call this%set_restart_var(vname='ed_cd_status', vtype=site_r8, & - long_name='ed cold dec status', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_cold_dec_status', vtype=site_r8, & + long_name='status flag for cold deciduous plants', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_cd_status_si ) - call this%set_restart_var(vname='ed_dd_status', vtype=site_r8, & - long_name='ed drought dec status', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_drought_dec_status', vtype=site_r8, & + long_name='status flag for drought deciduous plants', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_dd_status_si ) - call this%set_restart_var(vname='ed_chilling_days', vtype=site_r8, & - long_name='ed chilling day counter', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_chilling_days', vtype=site_r8, & + long_name='chilling day counter', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_nchill_days_si ) - call this%set_restart_var(vname='ed_leafondate', vtype=site_r8, & - long_name='ed leafondate', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_leafondate', vtype=site_r8, & + long_name='the day of year for leaf on', units='day of year', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_leafondate_si ) - call this%set_restart_var(vname='ed_leafoffdate', vtype=site_r8, & - long_name='ed leafoffdate', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_leafoffdate', vtype=site_r8, & + long_name='the day of year for leaf off', units='day of year', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_leafoffdate_si ) - call this%set_restart_var(vname='ed_dleafondate', vtype=site_r8, & - long_name='ed dleafondate', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_drought_leafondate', vtype=site_r8, & + long_name='the day of year for drought based leaf-on', units='day of year', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_dleafondate_si ) - call this%set_restart_var(vname='ed_dleafoffdate', vtype=site_r8, & - long_name='ed dleafoffdate', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_drought_leafoffdate', vtype=site_r8, & + long_name='the day of year for drought based leaf-off', units='day of year', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_dleafoffdate_si ) - call this%set_restart_var(vname='ed_acc_NI', vtype=site_r8, & - long_name='ed nesterov index', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_acc_nesterov_id', vtype=site_r8, & + long_name='a nesterov index accumulator', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_acc_ni_si ) - call this%set_restart_var(vname='ed_gdd_site', vtype=site_r8, & - long_name='ed GDD site', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_gdd_site', vtype=site_r8, & + long_name='growing degree days at each site', units='degC days', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_gdd_si ) - call this%set_restart_var(vname='nep_timeintegrated_col', vtype=site_r8, & - long_name='NA', units='NA', flushval = flushzero, & + call this%set_restart_var(vname='fates_nep_timeintegrated_site', vtype=site_r8, & + long_name='NEP integrated over model time-steps', units='gc/m2', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_nep_timeintegrated_si ) - call this%set_restart_var(vname='npp_timeintegrated_col', vtype=site_r8, & - long_name='NA', units='NA', flushval = flushzero, & + call this%set_restart_var(vname='fates_npp_timeintegrated_site', vtype=site_r8, & + long_name='NPP integrated over model time-steps', units='gc/m2', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_npp_timeintegrated_si ) - call this%set_restart_var(vname='hr_timeintegrated_col', vtype=site_r8, & - long_name='NA', units='NA', flushval = flushzero, & + call this%set_restart_var(vname='fates_hr_timeintegrated_site', vtype=site_r8, & + long_name='heterotrophic respiration integrated over model time-steps', & + units='gc/m2', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hr_timeintegrated_si ) - call this%set_restart_var(vname='cbalance_error_ed_col', vtype=site_r8, & - long_name='NA', units='NA', flushval = flushzero, & + call this%set_restart_var(vname='fates_cbal_err_fatesite', vtype=site_r8, & + long_name='the carbon accounting error for FATES processes', & + units='gC/m2/s', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_cbal_error_fates_si ) - call this%set_restart_var(vname='cbalance_error_bgc_col', vtype=site_r8, & - long_name='NA', units='NA', flushval = flushzero, & + call this%set_restart_var(vname='fates_cbal_err_bgcsite', vtype=site_r8, & + long_name='the carbon accounting error for (fates relevant) BGC processes', & + units='gC/m2/s', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_cbal_error_bgc_si ) - call this%set_restart_var(vname='cbalance_error_total_col', vtype=site_r8, & - long_name='NA', units='NA', flushval = flushzero, & + call this%set_restart_var(vname='fates_cbal_err_totsite', vtype=site_r8, & + long_name='the carbon accounting error for fates and bgc processes', & + units='gC/m2/s', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_cbal_error_total_si ) - call this%set_restart_var(vname='totecosysc_old_col', vtype=site_r8, & - long_name='NA', units='NA', flushval = flushzero, & + call this%set_restart_var(vname='fates_totecosysc_old_site', vtype=site_r8, & + long_name='total ecosystem carbon above and below ground (previous time-step)', & + units='gC/m2', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_totecosysc_old_si ) - call this%set_restart_var(vname='totedc_old_col', vtype=site_r8, & - long_name='NA', units='NA', flushval = flushzero, & + call this%set_restart_var(vname='fates_totfatesc_old_site', vtype=site_r8, & + long_name='total carbon tracked in FATES, (previous time-step)', & + units='gc/m2', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_totfatesc_old_si ) - call this%set_restart_var(vname='totbgcc_old_col', vtype=site_r8, & - long_name='NA', units='NA', flushval = flushzero, & + call this%set_restart_var(vname='fates_totbgcc_old_site', vtype=site_r8, & + long_name='total carbon tracked in the BGC module', & + units='gc/m2', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_totbgcc_old_si ) - call this%set_restart_var(vname='ed_to_bgc_this_edts_col', vtype=site_r8, & - long_name='NA', units='NA', flushval = flushzero, & + call this%set_restart_var(vname='fates_to_bgc_this_edts_col', vtype=site_r8, & + long_name='total flux of carbon from FATES to BGC models on current timestep', & + units='gC/m2/s', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fates_to_bgc_this_ts_si ) - call this%set_restart_var(vname='ed_to_bgc_last_edts_col', vtype=site_r8, & - long_name='NA', units='NA', flushval = flushzero, & + call this%set_restart_var(vname='fates_to_bgc_last_edts_col', vtype=site_r8, & + long_name='total flux of carbon from FATES to BGC models on previous timestep', & + units='gC/m2/s', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fates_to_bgc_last_ts_si ) - call this%set_restart_var(vname='seed_rain_flux_col', vtype=site_r8, & - long_name='NA', units='NA', flushval = flushzero, & + call this%set_restart_var(vname='fates_seed_rain_flux_site', vtype=site_r8, & + long_name='flux of seeds from exterior', & + units='kgC/m2/year', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_seedrainflux_si ) - ! - ! cohort level vars - ! + ! ----------------------------------------------------------------------------------- + ! Variables stored within cohort vectors + ! Note: Some of these are multi-dimensional variables in the patch/site dimension + ! that are collapsed into the cohort vectors for storage and transfer + ! ----------------------------------------------------------------------------------- ! This variable may be confusing, because it is a patch level variables ! but it is using the cohort IO vector to hold data - call this%set_restart_var(vname='ed_io_cohortsPerPatch', vtype=cohort_int, & - long_name='cohorts per patch, indexed by numPatchesPerCol', units='unitless', flushval = flushinvalid, & + call this%set_restart_var(vname='fates_CohortsPerPatch', vtype=cohort_int, & + long_name='the number of cohorts per patch', units='unitless', flushval = flushinvalid, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_ncohort_pa ) - call this%set_restart_var(vname='ed_balive', vtype=cohort_r8, & - long_name='ed cohort ed_balive', units='unitless', flushval = flushzero, & + ! 1D cohort Variables + ! ----------------------------------------------------------------------------------- + + call this%set_restart_var(vname='fates_balive', vtype=cohort_r8, & + long_name='ed cohort alive biomass', units='kgC/indiv', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_balive_co ) - call this%set_restart_var(vname='ed_bdead', vtype=cohort_r8, & - long_name='ed cohort - bdead', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_bdead', vtype=cohort_r8, & + long_name='ed cohort - dead (structural) biomass in living plants', & + units='kgC/indiv', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_bdead_co ) - call this%set_restart_var(vname='ed_bl', vtype=cohort_r8, & - long_name='ed cohort - bl', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_bl', vtype=cohort_r8, & + long_name='ed cohort - leaf biomass', units='kgC/indiv', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_bleaf_co ) - call this%set_restart_var(vname='ed_br', vtype=cohort_r8, & - long_name='ed cohort - br', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_br', vtype=cohort_r8, & + long_name='ed cohort - fine root biomass', units='kgC/indiv', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_broot_co ) - call this%set_restart_var(vname='ed_bstore', vtype=cohort_r8, & - long_name='ed cohort - bstore', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_bstore', vtype=cohort_r8, & + long_name='ed cohort - storage biomass', units='kgC/indiv', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_bstore_co ) - call this%set_restart_var(vname='ed_canopy_layer', vtype=cohort_r8, & + call this%set_restart_var(vname='fates_canopy_layer', vtype=cohort_r8, & long_name='ed cohort - canopy_layer', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_canopy_layer_co ) - call this%set_restart_var(vname='ed_canopy_trim', vtype=cohort_r8, & - long_name='ed cohort - canopy_trim', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_canopy_trim', vtype=cohort_r8, & + long_name='ed cohort - canopy_trim', units='fraction', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_canopy_trim_co ) - call this%set_restart_var(vname='ed_dbh', vtype=cohort_r8, & - long_name='ed cohort - dbh', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_dbh', vtype=cohort_r8, & + long_name='ed cohort - diameter at breast height', units='cm', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_dbh_co ) - call this%set_restart_var(vname='ed_hite', vtype=cohort_r8, & - long_name='ed cohort - hite', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_height', vtype=cohort_r8, & + long_name='ed cohort - plant height', units='m', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_height_co ) - call this%set_restart_var(vname='ed_laimemory', vtype=cohort_r8, & - long_name='ed cohort - laimemory', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_laimemory', vtype=cohort_r8, & + long_name='ed cohort - target leaf biomass set from prev year', & + units='kgC/indiv', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_laimemory_co ) - call this%set_restart_var(vname='ed_leaf_md', vtype=cohort_r8, & - long_name='ed cohort - leaf_md', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_leaf_maint_dmnd', vtype=cohort_r8, & + long_name='ed cohort - leaf maintenance demand', & + units='kgC/indiv/year', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_leaf_md_co ) - call this%set_restart_var(vname='ed_root_md', vtype=cohort_r8, & - long_name='ed cohort - root_md', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_root_maint_dmnd', vtype=cohort_r8, & + long_name='ed cohort - fine root maintenance demand', & + units='kgC/indiv', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_root_md_co ) - call this%set_restart_var(vname='ed_n', vtype=cohort_r8, & - long_name='ed cohort - n', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_nplant', vtype=cohort_r8, & + long_name='ed cohort - number of plants in the cohort', & + units='/patch', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_nplant_co ) - call this%set_restart_var(vname='ed_gpp_acc', vtype=cohort_r8, & - long_name='ed cohort - gpp_acc', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_gpp_acc', vtype=cohort_r8, & + long_name='ed cohort - accumulated gpp over dynamics step', & + units='kgC/indiv', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_gpp_acc_co ) - call this%set_restart_var(vname='ed_npp_acc', vtype=cohort_r8, & - long_name='ed cohort - npp_acc', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_npp_acc', vtype=cohort_r8, & + long_name='ed cohort - accumulated npp over dynamics step', & + units='kgC/indiv', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_npp_acc_co ) - call this%set_restart_var(vname='ed_gpp', vtype=cohort_r8, & - long_name='ed cohort - gpp', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_gpp', vtype=cohort_r8, & + long_name='ed cohort - current step gpp', & + units='kgC/indiv/year', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_gpp_co ) - call this%set_restart_var(vname='ed_npp', vtype=cohort_r8, & - long_name='ed cohort - npp', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_npp', vtype=cohort_r8, & + long_name='ed cohort - current step npp', & + units='kgC/indiv/year', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_npp_co ) - call this%set_restart_var(vname='ed_npp_leaf', vtype=cohort_r8, & - long_name='ed cohort - npp_leaf', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_npp_leaf', vtype=cohort_r8, & + long_name='ed cohort - npp sent to leaves', & + units='kgC/indiv/day', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_npp_leaf_co ) - call this%set_restart_var(vname='ed_npp_froot', vtype=cohort_r8, & - long_name='ed cohort - npp_froot', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_npp_froot', vtype=cohort_r8, & + long_name='ed cohort - npp sent to fine roots', & + units='kgC/indiv/day', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_npp_froot_co ) - call this%set_restart_var(vname='ed_npp_bsw', vtype=cohort_r8, & - long_name='ed cohort - npp_sw', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_npp_sapwood', vtype=cohort_r8, & + long_name='ed cohort - npp sent to sapwood', & + units='kgC/indiv/day', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_npp_sw_co ) - call this%set_restart_var(vname='ed_npp_bdead', vtype=cohort_r8, & - long_name='ed cohort - npp_bdead', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_npp_bdead', vtype=cohort_r8, & + long_name='ed cohort - npp sent to dead (structure) biomass in live plants', & + units='kgC/indiv/day', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_npp_dead_co ) - call this%set_restart_var(vname='ed_npp_bseed', vtype=cohort_r8, & - long_name='ed cohort - npp_bseed', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_npp_seed', vtype=cohort_r8, & + long_name='ed cohort - npp sent to seed biomass', & + units='kgC/indiv/day', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_npp_seed_co ) - call this%set_restart_var(vname='ed_npp_store', vtype=cohort_r8, & - long_name='ed cohort - npp_store', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_npp_store', vtype=cohort_r8, & + long_name='ed cohort - npp sent to storage biomass', & + units='kgC/indiv/day', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_npp_store_co ) - call this%set_restart_var(vname='ed_bmort', vtype=cohort_r8, & - long_name='ed cohort - bmort', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_bmort', vtype=cohort_r8, & + long_name='ed cohort - background mortality rate', & + units='/year', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_bmort_co ) - call this%set_restart_var(vname='ed_hmort', vtype=cohort_r8, & - long_name='ed cohort - hmort', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_hmort', vtype=cohort_r8, & + long_name='ed cohort - hydraulic mortality rate', & + units='/year', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hmort_co ) - call this%set_restart_var(vname='ed_cmort', vtype=cohort_r8, & - long_name='ed cohort - cmort', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_cmort', vtype=cohort_r8, & + long_name='ed cohort - carbon starvation mortality rate', & + units='/year', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_cmort_co ) - call this%set_restart_var(vname='ed_imort', vtype=cohort_r8, & - long_name='ed cohort - imort', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_imort', vtype=cohort_r8, & + long_name='ed cohort - impact mortality rate', & + units='/year', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_imort_co ) - call this%set_restart_var(vname='ed_fmort', vtype=cohort_r8, & - long_name='ed cohort - fmort', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_fmort', vtype=cohort_r8, & + long_name='ed cohort - frost mortality rate', & + units='/year', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fmort_co ) - call this%set_restart_var(vname='ed_ddbhdt', vtype=cohort_r8, & - long_name='ed cohort - ddbhdt', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_ddbhdt', vtype=cohort_r8, & + long_name='ed cohort - differential: ddbh/dt', & + units='cm/year', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_ddbhdt_co ) - call this%set_restart_var(vname='ed_resp_tstep', vtype=cohort_r8, & - long_name='ed cohort - resp_tstep', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_resp_tstep', vtype=cohort_r8, & + long_name='ed cohort - autotrophic respiration over timestep', & + units='kgC/indiv/timestep', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_resp_tstep_co ) - call this%set_restart_var(vname='ed_pft', vtype=cohort_int, & - long_name='ed cohort - pft', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_pft', vtype=cohort_int, & + long_name='ed cohort - plant functional type', units='index', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_pft_co ) - call this%set_restart_var(vname='ed_status_coh', vtype=cohort_int, & - long_name='ed cohort - status_coh', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_status_coh', vtype=cohort_int, & + long_name='ed cohort - plant phenology status', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_status_co ) - call this%set_restart_var(vname='ed_isnew', vtype=cohort_int, & - long_name='ed cohort - isnew', units='unitless', flushval = flushone, & + call this%set_restart_var(vname='fates_isnew', vtype=cohort_int, & + long_name='ed cohort - binary flag specifying if a plant has experienced a full day cycle', & + units='0/1', flushval = flushone, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_isnew_co ) - ! - ! patch level vars - ! - call this%set_restart_var(vname='ed_cwd_ag', vtype=cohort_r8, & - long_name='ed patch - cwd_ag', units='unitless', flushval = flushzero, & + ! Mixed dimension variables using the cohort vector + ! ----------------------------------------------------------------------------------- + + call this%set_restart_var(vname='fates_cwd_ag', vtype=cohort_r8, & + long_name='coarse woody debris above ground (non-respiring), by patch x cw class', & + units='kgC/m2', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_cwd_ag_pacw ) - call this%set_restart_var(vname='ed_cwd_bg', vtype=cohort_r8, & - long_name='ed patch - cwd_bg', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_cwd_bg', vtype=cohort_r8, & + long_name='coarse woody debris below ground (non-respiring), by patch x cw class', & + units='kgC/m2', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_cwd_bg_pacw ) - call this%set_restart_var(vname='ed_leaf_litter', vtype=cohort_r8, & - long_name='fates: leaf litter by patch x pft', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_leaf_litter', vtype=cohort_r8, & + long_name='leaf litter, by patch x pft (non-respiring)', & + units='kgC/m2', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_leaf_litter_paft ) - call this%set_restart_var(vname='ed_root_litter', vtype=cohort_r8, & - long_name='ed patch - root_litter', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_root_litter', vtype=cohort_r8, & + long_name='root litter, by patch x pft (non-respiring)', & + units='kgC/m2', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_root_litter_paft ) - call this%set_restart_var(vname='ed_leaf_litter_in', vtype=cohort_r8, & - long_name='ed patch - leaf_litter_in', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_leaf_litter_in', vtype=cohort_r8, & + long_name='leaf litter flux from turnover and mort, by patch x pft', & + units='kgC/m2', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_leaf_litter_in_paft ) - call this%set_restart_var(vname='ed_root_litter_in', vtype=cohort_r8, & - long_name='ed patch - root_litter_in', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_root_litter_in', vtype=cohort_r8, & + long_name='root litter flux from turnover and mort, by patch x pft', & + units='kgC/m2', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_root_litter_in_paft ) - call this%set_restart_var(vname='ed_seed_bank', vtype=cohort_r8, & - long_name='ed site? - seed_bank', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_seed_bank', vtype=cohort_r8, & + long_name='seed pool for each functional type, by site x pft', & + units='kgC/m2/year', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_seed_bank_sift ) - call this%set_restart_var(vname='ed_spread', vtype=cohort_r8, & - long_name='ed patch - spread', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_spread', vtype=cohort_r8, & + long_name='dynamic ratio of dbh to canopy area, by patch x canopy-layer', & + units='cm/m2', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_spread_pacl ) - call this%set_restart_var(vname='ed_livegrass', vtype=cohort_r8, & - long_name='ed patch - livegrass', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_livegrass', vtype=cohort_r8, & + long_name='total AGB from grass, by patch', & + units='kgC/m2', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_livegrass_pa ) - call this%set_restart_var(vname='ed_age', vtype=cohort_r8, & - long_name='ed patch - age', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_age', vtype=cohort_r8, & + long_name='age of the ED patch', units='yr', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_age_pa ) - call this%set_restart_var(vname='ed_area', vtype=cohort_r8, & - long_name='ed patch - area', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_area', vtype=cohort_r8, & + long_name='are of the ED patch', units='m2', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_area_pa ) ! These dimensions are pa "patch" cl "canopy layer" ft "functional type" ls "layer sublevel" - call this%set_restart_var(vname='ed_f_sun', vtype=cohort_r8, & - long_name='ed patch - f_sun', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_f_sun', vtype=cohort_r8, & + long_name='fraction of sunlit leaves, by patch x can-layer x pft x sublayer', & + units='fraction', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fsun_paclftls ) - call this%set_restart_var(vname='ed_fabd_sun_z', vtype=cohort_r8, & - long_name='ed patch - fabd_sun_z', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_fabd_sun_z', vtype=cohort_r8, & + long_name='sun fraction of direct light absorbed, by patch x can-layer x pft x sublayer', & + units='fraction', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fabd_sun_paclftls ) - call this%set_restart_var(vname='ed_fabi_sun_z', vtype=cohort_r8, & - long_name='ed patch - fabi_sun_z', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_fabi_sun_z', vtype=cohort_r8, & + long_name='sun fraction of indirect light absorbed, by patch x can-layer x pft x sublayer', & + units='fraction', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fabi_sun_paclftls ) - call this%set_restart_var(vname='ed_fabd_sha_z', vtype=cohort_r8, & - long_name='ed patch - fabd_sha_z', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_fabd_sha_z', vtype=cohort_r8, & + long_name='shade fraction of direct light absorbed, by patch x can-layer x pft x sublayer', & + units='fraction', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fabd_sha_paclftls ) - call this%set_restart_var(vname='ed_fabi_sha_z', vtype=cohort_r8, & - long_name='ed patch - fabi_sha_z', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_fabi_sha_z', vtype=cohort_r8, & + long_name='shade fraction of indirect light absorbed, by patch x can-layer x pft x sublayer', & + units='fraction', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fabi_sha_paclftls ) ! ! site x time level vars ! - call this%set_restart_var(vname='ed_water_memory', vtype=cohort_r8, & - long_name='ed cohort - water_memory', units='unitless', flushval = flushzero, & + call this%set_restart_var(vname='fates_water_memory', vtype=cohort_r8, & + long_name='last 10 days of volumetric soil water, by site x day-index', & + units='m3/m3', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_watermem_siwm ) From 3982efd1fd909658c980226697e9a075a505e719 Mon Sep 17 00:00:00 2001 From: Ben Andre Date: Thu, 1 Dec 2016 11:59:29 -0700 Subject: [PATCH 249/437] Remove temporary_SF_switch Remove temporary_SF_switch. Spitfire is runtime configurable via name list and is now off by default. This switch was only used to disable spitfire at compile time. Fixes: 140 User interface changes?: spitfire configured at runtime instead of compile time. Code review: self Test suite: SMS_D_Mmpi-serial_Ld5.5x5_amazon.ICLM45ED.yellowstone_intel.clm-edTest Test baseline: 2ac7960 Test namelist changes: none Test answer changes: bit for bit Test summary: pass --- fire/SFMainMod.F90 | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index f86b006c..be53100a 100755 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -52,11 +52,8 @@ subroutine fire_model( currentSite, atm2lnd_inst, temperature_inst) type (ed_patch_type), pointer :: currentPatch - integer temporary_SF_switch - !zero fire things currentPatch => currentSite%youngest_patch - temporary_SF_switch = 1 do while(associated(currentPatch)) currentPatch%frac_burnt = 0.0_r8 currentPatch%AB = 0.0_r8 @@ -68,7 +65,7 @@ subroutine fire_model( currentSite, atm2lnd_inst, temperature_inst) write(iulog,*) 'use_ed_spit_fire',use_ed_spit_fire endif - if(use_ed_spit_fire.and.temporary_SF_switch==1)then + if(use_ed_spit_fire)then call fire_danger_index(currentSite, temperature_inst, atm2lnd_inst) call wind_effect(currentSite, atm2lnd_inst) call charecteristics_of_fuel(currentSite) From 242520955256d301e1087f59331406f730297ddd Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 1 Dec 2016 11:54:20 -0800 Subject: [PATCH 250/437] Reduced a line-length in EDCohortDynanicsMod.F90 to appease the nag gods. --- biogeochem/EDCohortDynamicsMod.F90 | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 1ed42734..81143bd5 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -719,9 +719,16 @@ subroutine fuse_cohorts(patchptr) if ( DEBUG ) write(fates_log(),*) 'EDcohortDyn V ',currentCohort%npp_acc if ( DEBUG ) write(fates_log(),*) 'EDcohortDyn VI ',currentCohort%resp_acc - currentCohort%resp_acc_hold = (currentCohort%n*currentCohort%resp_acc_hold + nextc%n*nextc%resp_acc_hold)/newn - currentCohort%npp_acc_hold = (currentCohort%n*currentCohort%npp_acc_hold + nextc%n*nextc%npp_acc_hold)/newn - currentCohort%gpp_acc_hold = (currentCohort%n*currentCohort%gpp_acc_hold + nextc%n*nextc%gpp_acc_hold)/newn + currentCohort%resp_acc_hold = & + (currentCohort%n*currentCohort%resp_acc_hold + & + nextc%n*nextc%resp_acc_hold)/newn + currentCohort%npp_acc_hold = & + (currentCohort%n*currentCohort%npp_acc_hold + & + nextc%n*nextc%npp_acc_hold)/newn + currentCohort%gpp_acc_hold = & + (currentCohort%n*currentCohort%gpp_acc_hold + & + nextc%n*nextc%gpp_acc_hold)/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 From 8b1e63ffda04ca576a59eccfd0bf0bcd5a78d34a Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 1 Dec 2016 13:14:55 -0800 Subject: [PATCH 251/437] Partial refactors on photosynthesis. --- biogeophys/EDPhotosynthesisMod.F90 | 1018 +++++++++++++++++----------- 1 file changed, 624 insertions(+), 394 deletions(-) diff --git a/biogeophys/EDPhotosynthesisMod.F90 b/biogeophys/EDPhotosynthesisMod.F90 index a9e6cf50..a0597d1e 100644 --- a/biogeophys/EDPhotosynthesisMod.F90 +++ b/biogeophys/EDPhotosynthesisMod.F90 @@ -105,9 +105,9 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) real(r8) :: ci ! intracellular leaf CO2 (Pa) real(r8) :: lnc(mxpft) ! leaf N concentration (gN leaf/m^2) - real(r8) :: kc( numpatchespercol ) ! Michaelis-Menten constant for CO2 (Pa) - real(r8) :: ko( numpatchespercol ) ! Michaelis-Menten constant for O2 (Pa) - real(r8) :: co2_cp( numpatchespercol ) ! CO2 compensation point (Pa) + real(r8) :: kc ! Michaelis-Menten constant for CO2 (Pa) + real(r8) :: ko ! Michaelis-Menten constant for O2 (Pa) + real(r8) :: co2_cp ! CO2 compensation point (Pa) ! --------------------------------------------------------------- ! TO-DO: bbbopt is slated to be transferred to the parameter file @@ -127,17 +127,11 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) 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) @@ -172,7 +166,6 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) 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) @@ -193,9 +186,7 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) 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(cp_nclmax,mxpft,cp_nlevcan) ! co-limited gross leaf photosynthesis (umol CO2/m**2/s) - real(r8) :: an(cp_nclmax,mxpft,cp_nlevcan) ! net leaf photosynthesis (umol CO2/m**2/s) - real(r8) :: an_av(cp_nclmax,mxpft,cp_nlevcan) ! 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. @@ -273,9 +264,6 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) ! 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 @@ -316,101 +304,68 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) do s = 1,nsites + ! Multi-layer parameters scaled by leaf nitrogen profile. + ! Loop through each canopy layer to calculate nitrogen profile using + ! cumulative lai at the midpoint of the layer + ifp = 0 currentpatch => sites(s)%oldest_patch do while (associated(currentpatch)) - ifp = ifp+1 + ifp = ifp+1 + NCL_p = currentPatch%NCL_p + + ! Part I. Zero output boundary conditions + ! --------------------------------------------------------------------------- bc_out(s)%psncanopy_pa(ifp) = 0._r8 bc_out(s)%lmrcanopy_pa(ifp) = 0._r8 bc_out(s)%rssun_pa(ifp) = 0._r8 bc_out(s)%rssha_pa(ifp) = 0._r8 bc_out(s)%gccanopy_pa(ifp) = 0._r8 + ! Part II. Filter out patches ! Patch level filter flag for photosynthesis calculations ! has a short memory, flags: ! 1 = patch has not been called ! 2 = patch is currently marked for photosynthesis - ! 3 = patch has been called for photosynthesis at least once + ! 3 = patch has been called for photosynthesis already + ! --------------------------------------------------------------------------- if(bc_in(s)%filter_photo_pa(ifp)==2)then - 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,cp_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 - - ! 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 - ! + ! Part III. Calculate the number of sublayers for each pft and layer. And then identify + ! which layer/pft combinations have things in them. Output: + ! currentPatch%ncan(:,:) + ! currentPatch%present(:,:) + call UpdateCanopyNCanNRadPresent(currentPatch) + - kc25 = (404.9_r8 / 1.e06_r8) * bc_in(s)%forc_pbot - ko25 = (278.4_r8 / 1.e03_r8) * bc_in(s)%forc_pbot - sco = 0.5_r8 * 0.209_r8 / (42.75_r8 / 1.e06_r8) - cp25 = 0.5_r8 * bc_in(s)%oair_pa(ifp) / sco + ! Part IV. Identify some environmentally derived parameters: + ! Michaelis-Menten constant for CO2 (Pa) + ! Michaelis-Menten constant for O2 (Pa) + ! CO2 compensation point (Pa) + + call GetCanopyGasParameters(bc_in(s)%forc_pbot,bc_in(s)%oair_pa(ifp), & + bc_in(s)%t_veg_pa(ifp),kc,ko,co2_cp) + + + ! THESE HARD CODED CONVERSIONS NEED TO BE CALLED FROM GLOBAL CONSTANTS (RGK 10-13-2016) + cf = bc_in(s)%forc_pbot/(rgas*1.e-3_r8*bc_in(s)%tgcm_pa(ifp))*1.e06_r8 + gb = 1._r8/bc_in(s)%rb_pa(ifp) + gb_mol = gb * cf - if(bc_in(s)%t_veg_pa(ifp).gt.150_r8.and.bc_in(s)%t_veg_pa(ifp).lt.350_r8)then - kc(ifp) = kc25 * ft1_f(bc_in(s)%t_veg_pa(ifp), kcha) - ko(ifp) = ko25 * ft1_f(bc_in(s)%t_veg_pa(ifp), koha) - co2_cp(ifp) = cp25 * ft1_f(bc_in(s)%t_veg_pa(ifp), cpha) - else - kc(ifp) = 1 - ko(ifp) = 1 - co2_cp(ifp) = 1 - end if + ! 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(bc_in(s)%eair_pa(ifp), 0.05_r8*bc_in(s)%esat_tv_pa(ifp)), bc_in(s)%esat_tv_pa(ifp) ) - end if - - currentpatch => currentpatch%younger - 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 - - ifp = 0 - currentpatch => sites(s)%oldest_patch - do while (associated(currentpatch)) - ifp = ifp+1 - if(bc_in(s)%filter_photo_pa(ifp)==2)then - - NCL_p = currentPatch%NCL_p - - do FT = 1,numpft_ed !calculate patch and pft specific propserties at canopy top. - - if (nint(c3psn(FT)) == 1)then - ps = 1 - else - ps = 2 - end if - bbb(FT) = max (bbbopt(ps)*currentPatch%btran_ft(FT), 1._r8) + ! Part V. Pre-process some variables that are PFT dependent + ! but not environmentally dependent + ! ------------------------------------------------------------------------ + do FT = 1,numpft_ed !calculate patch and pft specific properties 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)) @@ -452,21 +407,20 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) end do !FT + + ! If we are using plant hydro-dynamics, then several photosynthesis + ! variables will be available at the cohort scale, and not the + ! pft scale. So here we split and use different looping structures + ! ------------------------------------------------------------------ +! if ( use_fates_plant_hydro ) + + !==============================================================================! ! 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(fates_log(),*) '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,cp_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? @@ -478,6 +432,15 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) ! 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) + + if (use_fates_plant_hydro) then + !! bbb = max (bbbopt(ps)*currentCohort%btran(iv), 1._r8) + !! btran = currentCohort%btran(iv) + else + !! bbb = max (bbbopt(ps)*currentPatch%btran_ft(FT), 1._r8) + !! btran = currentPatch%btran_ft(currentCohort%pft) + end if + 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 @@ -485,313 +448,45 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) 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_f(bc_in(s)%t_veg_pa(ifp), lmrha) * & - fth_f(bc_in(s)%t_veg_pa(ifp), lmrhd, lmrse, lmrc) - else - lmr_z(CL,FT,iv) = lmr25 * 2._r8**((bc_in(s)%t_veg_pa(ifp)-(tfrz+25._r8))/10._r8) - lmr_z(CL,FT,iv) = lmr_z(CL,FT,iv) / (1._r8 + exp( 1.3_r8*(bc_in(s)%t_veg_pa(ifp)-(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_f(bc_in(s)%t_veg_pa(ifp), vcmaxha) * & - fth_f(bc_in(s)%t_veg_pa(ifp), vcmaxhd, vcmaxse, vcmaxc) - jmax_z(CL,FT,iv) = jmax25 * ft1_f(bc_in(s)%t_veg_pa(ifp), jmaxha) * & - fth_f(bc_in(s)%t_veg_pa(ifp), jmaxhd, jmaxse, jmaxc) - tpu_z(CL,FT,iv) = tpu25 * ft1_f(bc_in(s)%t_veg_pa(ifp), tpuha) * & - fth_f(bc_in(s)%t_veg_pa(ifp), tpuhd, tpuse, tpuc) - - if (nint(c3psn(FT)) /= 1) then - vcmax_z(CL,FT,iv) = vcmax25 * 2._r8**((bc_in(s)%t_veg_pa(ifp)-(tfrz+25._r8))/10._r8) - vcmax_z(CL,FT,iv) = vcmax_z(CL,FT,iv) / (1._r8 + & - exp( 0.2_r8*((tfrz+15._r8)-bc_in(s)%t_veg_pa(ifp)) )) - vcmax_z(CL,FT,iv) = vcmax_z(CL,FT,iv) / (1._r8 + & - exp( 0.3_r8*(bc_in(s)%t_veg_pa(ifp)-(tfrz+40._r8)) )) - end if - kp_z(CL,FT,iv) = kp25 * 2._r8**((bc_in(s)%t_veg_pa(ifp)-(tfrz+25._r8))/10._r8) !q10 response of product limited psn. - end if - ! Adjust for soil water:(umol co2/m**2/s) + call LeafLayerPhotosynthesis(currentPatch%ed_parsun_z(CL,FT,iv), & ! in + currentPatch%ed_parsha_z(CL,FT,iv), & ! in + currentPatch%ed_laisun_z(CL,FT,iv), & ! in + currentPatch%ed_laisha_z(CL,FT,iv), & ! in + currentPatch%canopy_area_profile(CL,FT,iv), & ! in + ft, & ! in + nscaler, & ! in + lmr25top(ft), & ! in + vcmax25top(ft), & ! in + jmax25top(ft), & ! in + tpu25top(ft), & ! in + kp25top(ft), & ! in + bc_in(s)%t_veg_pa(ifp), & ! in + btran, & ! in + bbb, & ! in + cf, & ! in + gb_mol, & ! in + lmr_z(CL,FT,iv), & ! out + currentPatch%psn_z(cl,ft,iv), & ! out + rs_z(CL,FT,iv), & ! out + an_av(CL,FT,iv)) ! out + - 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 - !==============================================================================! - ! Leaf boundary layer conductance, umol/m**2/s - ! THESE HARD CODED CONVERSIONS NEED TO BE CALLED FROM GLOBAL CONSTANTS (RGK 10-13-2016) - cf = bc_in(s)%forc_pbot/(rgas*1.e-3_r8*bc_in(s)%tgcm_pa(ifp))*1.e06_r8 - gb = 1._r8/bc_in(s)%rb_pa(ifp) - 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(bc_in(s)%eair_pa(ifp), 0.05_r8*bc_in(s)%esat_tv_pa(ifp)), bc_in(s)%esat_tv_pa(ifp) ) - - ! 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 ( DEBUG ) write(fates_log(),*) 'EDphoto 581 ',currentPatch%ed_parsun_z(CL,ft,iv) - 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 ( DEBUG ) write(fates_log(),*) 'EDphot 594 ',currentPatch%ed_laisun_z(CL,ft,iv) - if ( DEBUG ) write(fates_log(),*) 'EDphot 595 ',currentPatch%ed_laisha_z(CL,ft,iv) - - if(currentPatch%ed_laisun_z(CL,ft,iv)+currentPatch%ed_laisha_z(cl,ft,iv) > 0._r8)then - - if ( DEBUG ) write(fates_log(),*) '600 in laisun, laisha loop ' - - !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_f (aquad, bquad, cquad, r1, r2) - je = min(r1,r2) - - ! Iterative loop for ci beginning with initial guess - ! THIS CALL APPEARS TO BE REDUNDANT WITH LINE 423 (RGK) - - if (nint(c3psn(FT)) == 1)then - ci = init_a2l_co2_c3 * bc_in(s)%cair_pa(ifp) - else - ci = init_a2l_co2_c4 * bc_in(s)%cair_pa(ifp) - 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 - - ! Photosynthesis limitation rate calculations - if (nint(c3psn(FT)) == 1)then - ! C3: Rubisco-limited photosynthesis - ac = vcmax_z(cl,ft,iv) * max(ci-co2_cp(ifp), 0._r8) / (ci+kc(ifp)* & - (1._r8+bc_in(s)%oair_pa(ifp)/ko(ifp))) - ! C3: RuBP-limited photosynthesis - aj = je * max(ci-co2_cp(ifp), 0._r8) / (4._r8*ci+8._r8*co2_cp(ifp)) - ! 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, 0._r8) / bc_in(s)%forc_pbot - 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_f (aquad, bquad, cquad, r1, r2) - ai = min(r1,r2) - - aquad = theta_ip - bquad = -(ai + ap) - cquad = ai * ap - call quadratic_f (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 = bc_in(s)%cair_pa(ifp) - 1.4_r8/gb_mol * an(cl,ft,iv) * bc_in(s)%forc_pbot - cs = max(cs,1.e-06_r8) - aquad = cs - bquad = cs*(gb_mol - bbb(FT)) - bb_slope(ft)*an(cl,ft,iv)*bc_in(s)%forc_pbot - cquad = -gb_mol*(cs*bbb(FT) + & - bb_slope(ft)*an(cl,ft,iv)*bc_in(s)%forc_pbot*ceair/bc_in(s)%esat_tv_pa(ifp)) - call quadratic_f (aquad, bquad, cquad, r1, r2) - gs_mol = max(r1,r2) - - ! Derive new estimate for ci - ci = bc_in(s)%cair_pa(ifp) - an(cl,ft,iv) * bc_in(s)%forc_pbot * & - (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-ciold)/bc_in(s)%forc_pbot*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 = bc_in(s)%cair_pa(ifp) - 1.4_r8/gb_mol * an(cl,ft,iv) * bc_in(s)%forc_pbot - cs = max(cs,1.e-06_r8) - ci = bc_in(s)%cair_pa(ifp) - & - an(cl,ft,iv) * bc_in(s)%forc_pbot * (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 - - if ( DEBUG ) write(fates_log(),*) 'EDPhoto 737 ', currentPatch%psn_z(cl,ft,iv) - if ( DEBUG ) write(fates_log(),*) 'EDPhoto 738 ', ag(cl,ft,iv) - if ( DEBUG ) write(fates_log(),*) 'EDPhoto 739 ', currentPatch%f_sun(cl,ft,iv) - - !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 - - if ( DEBUG ) write(fates_log(),*) 'EDPhoto 758 ', currentPatch%psn_z(cl,ft,iv) - if ( DEBUG ) write(fates_log(),*) 'EDPhoto 759 ', ag(cl,ft,iv) - if ( DEBUG ) write(fates_log(),*) 'EDPhoto 760 ', currentPatch%f_sun(cl,ft,iv) - - ! Make sure iterative solution is correct - if (gs_mol < 0._r8) then - write (fates_log(),*)'Negative stomatal conductance:' - write (fates_log(),*)'ifp,iv,gs_mol= ',ifp,iv,gs_mol - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - ! Compare with Ball-Berry model: gs_mol = m * an * hs/cs p + b - hs = (gb_mol*ceair + gs_mol*bc_in(s)%esat_tv_pa(ifp)) / ((gb_mol+gs_mol)*bc_in(s)%esat_tv_pa(ifp)) - gs_mol_err = bb_slope(ft)*max(an(cl,ft,iv), 0._r8)*hs/cs*bc_in(s)%forc_pbot + bbb(FT) - - if (abs(gs_mol-gs_mol_err) > 1.e-01_r8) then - write (fates_log(),*) 'CF: Ball-Berry error check - stomatal conductance error:' - write (fates_log(),*) 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) - else !No leaf area. This layer is present only because of stems. (leaves are off, or have reduced to 0 - currentPatch%psn_z(cl,ft,iv) = 0._r8 - rs_z(CL,FT,iv) = min(rsmax0, 1._r8/bbb(FT) * cf) - - 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 + !==============================================================================! ! Unpack fluxes from arrays into cohorts @@ -883,9 +578,17 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! THIS CALCULATION SHOULD BE MOVED TO THE ALLOMETRY MODULE (RGK 10-8-2016) + ! ------ IT ALSO SHOULD ALREADY HAVE BEEN CALCULATED RIGHT? + ! ------ CHANGING TO A CHECK ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - currentCohort%bsw = EDecophyscon%sapwood_ratio(currentCohort%pft) * & - currentCohort%hite * (currentCohort%balive + currentCohort%laimemory)*leaf_frac + if ( abs(currentCohort%bsw - (EDecophyscon%sapwood_ratio(currentCohort%pft) * & + currentCohort%hite * (currentCohort%balive + currentCohort%laimemory)*leaf_frac) ) & + > 1e-9 ) then + write(fates_log(),*) 'Sapwood biomass calculated during photosynthesis' + write(fates_log(),*) 'does not match what is contained in cohort%bsw' + write(fates_log(),*) 'which is the prognostic variable. Stopping.' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if ! Calculate the amount of nitrogen in the above and below ground ! stem and root pools, used for maint resp @@ -1021,11 +724,396 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) end do !site loop end associate - end subroutine Photosynthesis_ED ! ======================================================================================= +subroutine LeafLayerPhotosynthesis(parsun_lsl, & ! in + parsha_lsl, & ! in + laisun_lsl, & ! in + laisha_lsl, & ! in + canopy_area_lsl, & ! in + ft, & ! in + nscaler, & ! in + lmr25top_ft, & ! in + vcmax25top_ft, & ! in + jmax25top_ft, & ! in + tpu25top_ft, & ! in + kp25top_ft, & ! in + t_veg, & ! in + btran, & ! in + bbb, & ! in + cf, & ! in + gb_mol, & ! in + lmr_out, & ! out + psn_out, & ! out + rstoma_out, & ! out + anet_av_out) ! out + + ! ------------------------------------------------------------------------------------ + ! This subroutine calculates photosynthesis and stomatal conductance within each leaf + ! sublayer. + ! A note on naming conventions: As this subroutine is called for every + ! leaf-sublayer, many of the arguments are specific to that "leaf sub layer" + ! (LSL), those variables are given a dimension tag "_lsl" + ! Other arguments or variables may be indicative of scales broader than the LSL. + ! ------------------------------------------------------------------------------------ + + ! Arguments + ! ------------------------------------------------------------------------ + real(r8), intent(in) :: parsun_lsl + real(r8), intent(in) :: parsha_lsl + real(r8), intent(in) :: laisun_lsl + real(r8), intent(in) :: laisha_lsl + real(r8), intent(in) :: elai_lsl + real(r8), intent(in) :: esai_lsl + real(r8), intent(in) :: canopy_area_lsl + integer, intent(in) :: ft ! (plant) Functional Type Index + real(r8), intent(in) :: nscaler ! Scale for leaf nitrogen profile + real(r8), intent(in) :: lmr25top_ft ! canopy top leaf maint resp rate at 25C + ! for this pft (umol CO2/m**2/s) + real(r8), intent(in) :: vcmax25top_ft ! canopy top maximum rate of carboxylation at 25C + ! for this pft (umol CO2/m**2/s) + real(r8), intent(in) :: jmax25top_ft ! canopy top maximum electron transport rate at 25C + ! for this pft (umol electrons/m**2/s) + real(r8), intent(in) :: tpu25top_ft ! canopy top triose phosphate utilization rate at 25C + ! for this pft (umol CO2/m**2/s) + real(r8), intent(in) :: co2_rcurve_islope25top_ft ! initial slope of CO2 response curve + ! (C4 plants) at 25C, canopy top, this pft + real(r8), intent(in) :: t_veg ! vegetation temperature + real(r8), intent(in) :: btran ! + real(r8), intent(in) :: bbb + real(r8), intent(in) :: cf + real(r8), intent(in) :: gb_mol + + real(r8), intent(out) :: lmr_out + real(r8), intent(out) :: psn_out + real(r8), intent(out) :: rstoma_out ! stomatal resistance (1/gs_lsl) (s/m) + real(r8), intent(out) :: anet_av_out ! net leaf photosynthesis (umol CO2/m**2/s) averaged over sun and shade leaves. + real(r8), intent(out) :: gstoma_out ! Stomatal Conductance of this leaf layer (m/s) + + + + ! Locals + ! ------------------------------------------------------------------------ + integer :: ps ! Index for the different photosynthetic pathways C3,C4 + integer :: sunsha ! Index for differentiating sun and shade + + 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) :: co2_rcurve_islope25 ! leaf layer: Initial slope of CO2 response curve (C4 plants) at 25C + + + !!!!!!! NOTE: WE CAN REMOVE THE LSL IDENTIFIER FROM LOCALS AFTER THEY HAVE MORE VERBOSE NAMES + ! + + real(r8) :: vcmax ! maximum rate of carboxylation (umol co2/m**2/s) + real(r8) :: jmax ! maximum electron transport rate (umol electrons/m**2/s) + real(r8) :: tpu ! triose phosphate utilization rate (umol CO2/m**2/s) + real(r8) :: co2_rcurve_islope ! initial slope of CO2 response curve (C4 plants) + + + real(r8) :: agross ! co-limited gross leaf photosynthesis (umol CO2/m**2/s) + real(r8) :: anet ! net leaf photosynthesis (umol CO2/m**2/s) + + + + ! Parameters + ! ------------------------------------------------------------------------ + + 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) + frootcn => pftcon%frootcn , & ! froot C:N (gc/gN) + bb_slope => EDecophyscon%BB_slope ) ! slope of BB relationship + + + if (nint(c3psn(ft)) == 1)then + ps = 1 + else + ps = 2 + end if + + + + ! Part I: Leaf Maintenance respiration: umol CO2 / m**2 [leaf] / s + ! ---------------------------------------------------------------------------------- + lmr25 = lmr25top_ft * nscaler + if ( nint(c3psn(ft)) == 1)then + lmr_out = lmr25 * ft1_f(t_veg, lmrha) * & + fth_f(t_veg, lmrhd, lmrse, lmrc) + else + lmr_out = lmr25 * 2._r8**((t_veg-(tfrz+25._r8))/10._r8) + lmr_out = lmr_out / (1._r8 + exp( 1.3_r8*(t_veg-(tfrz+55._r8)) )) + end if + + + + + ! Part II: Localized Biophysical Rates + ! ---------------------------------------------------------------------------------- + + if ( parsun_lsl <= 0._r8) then ! night time + vcmax = 0._r8 + jmax = 0._r8 + tpu = 0._r8 + co2_rcurve_islope = 0._r8 + else ! day time + vcmax25 = vcmax25top_ft * nscaler + jmax25 = jmax25top_ft * nscaler + tpu25 = tpu25top_ft * nscaler + co2_rcurve_islope25 = co2_rcurve_islope25top_ft * nscaler + + ! Adjust for temperature + vcmax = vcmax25 * ft1_f(t_veg, vcmaxha) * fth_f(t_veg, vcmaxhd, vcmaxse, vcmaxc) + jmax = jmax25 * ft1_f(t_veg, jmaxha) * fth_f(t_veg, jmaxhd, jmaxse, jmaxc) + tpu = tpu25 * ft1_f(t_veg, tpuha) * fth_f(t_veg, tpuhd, tpuse, tpuc) + + if (nint(c3psn(FT)) /= 1) then + vcmax = vcmax25 * 2._r8**((t_veg-(tfrz+25._r8))/10._r8) + vcmax = vcmax / (1._r8 + exp( 0.2_r8*((tfrz+15._r8)-t_veg ) )) + vcmax = vcmax / (1._r8 + exp( 0.3_r8*(t_veg-(tfrz+40._r8)) )) + end if + co2_rcurve_islope = co2_rcurve_islope25 * 2._r8**((t_veg-(tfrz+25._r8))/10._r8) !q10 response of product limited psn. + end if + + ! Adjust for water limitations + vcmax = vcmax * btran + + ! Leaf Maintenance Respiration has no direct water limitation effect + ! lmr_out = lmr_out * (nothing) + + + + + + + ! Part III: Photosynthesis and Conductance + ! ---------------------------------------------------------------------------------- + + if ( parsun_lsl <= 0._r8 ) then ! night time + + anet_av_out = 0._r8 + psn_out = 0._r8 + rstoma_out = min(rsmax0, 1._r8/bbb * cf) + + else ! day time (a little bit more complicated ...) + + if ( DEBUG ) write(fates_log(),*) 'EDphot 594 ',laisun_lsl + if ( DEBUG ) write(fates_log(),*) 'EDphot 595 ',laisha_lsl + + !is there leaf area? - (NV can be larger than 0 with only stem area if deciduous) + if ( laisun_lsl + laisha_lsl > 0._r8 ) then + + if ( DEBUG ) write(fates_log(),*) '600 in laisun, laisha loop ' + + !Loop aroun shaded and unshaded leaves + psn_out = 0._r8 ! psn is accumulated across sun and shaded leaves. + rstoma_out = 0._r8 ! 1/rs is accumulated across sun and shaded leaves. + anet_av_out = 0._r8 + gstoma_out = 0._r8 + + do sunsha = 1,2 + ! Electron transport rate for C3 plants. Convert par from W/m2 to umol photons/m**2/s + ! using the factor 4.6 + ! Convert from units of par absorbed per unit ground area to par absorbed per unit leaf area. + + if(sunsha == 1)then !sunlit + if(( laisun_lsl * canopy_area_lsl) > 0.0000000001_r8)then + + qabs = parsun_lsl / (laisun_lsl * canopy_area_profile_lsl ) + qabs = qabs * 0.5_r8 * (1._r8 - fnps) * 4.6_r8 + + else + qabs = 0.0_r8 + end if + else + + qabs = currentPatch%ed_parsha_lsl / (currentPatch%ed_laisha_lsl * & + currentPatch%canopy_area_profile_lsl) + 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_f (aquad, bquad, cquad, r1, r2) + je = min(r1,r2) + + ! Iterative loop for ci beginning with initial guess + ! THIS CALL APPEARS TO BE REDUNDANT WITH LINE 423 (RGK) + + if (nint(c3psn(FT)) == 1)then + ci = init_a2l_co2_c3 * bc_in(s)%cair_pa(ifp) + else + ci = init_a2l_co2_c4 * bc_in(s)%cair_pa(ifp) + 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 + + ! Photosynthesis limitation rate calculations + if (nint(c3psn(FT)) == 1)then + ! C3: Rubisco-limited photosynthesis + ac = vcmax_z(cl,ft,iv) * max(ci-co2_cp, 0._r8) / (ci+kc * & + (1._r8+bc_in(s)%oair_pa(ifp)/ko)) + ! C3: RuBP-limited photosynthesis + aj = je * max(ci-co2_cp, 0._r8) / (4._r8*ci+8._r8*co2_cp) + ! 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 = co2_rcurve_islope_z(cl,ft,iv) * max(ci, 0._r8) / bc_in(s)%forc_pbot + 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_f (aquad, bquad, cquad, r1, r2) + ai = min(r1,r2) + + aquad = theta_ip + bquad = -(ai + ap) + cquad = ai * ap + call quadratic_f (aquad, bquad, cquad, r1, r2) + agross = min(r1,r2) + + ! Net carbon assimilation. Exit iteration if an < 0 + anet = agross - lmr_out + if (anet < 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 = bc_in(s)%cair_pa(ifp) - 1.4_r8/gb_mol * anet * bc_in(s)%forc_pbot + cs = max(cs,1.e-06_r8) + aquad = cs + bquad = cs*(gb_mol - bbb(FT)) - bb_slope(ft)*anet*bc_in(s)%forc_pbot + cquad = -gb_mol*(cs*bbb(FT) + & + bb_slope(ft)*anet*bc_in(s)%forc_pbot*ceair/bc_in(s)%esat_tv_pa(ifp)) + call quadratic_f (aquad, bquad, cquad, r1, r2) + gs_mol = max(r1,r2) + + ! Derive new estimate for ci + ci = bc_in(s)%cair_pa(ifp) - anet * bc_in(s)%forc_pbot * & + (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-ciold)/bc_in(s)%forc_pbot*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 (anet < 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 = bc_in(s)%cair_pa(ifp) - 1.4_r8/gb_mol * anet * bc_in(s)%forc_pbot + cs = max(cs,1.e-06_r8) + ci = bc_in(s)%cair_pa(ifp) - & + anet * bc_in(s)%forc_pbot * (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 + + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 737 ', currentPatch%psn_z(cl,ft,iv) + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 738 ', agross + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 739 ', currentPatch%f_sun(cl,ft,iv) + + !accumulate total photosynthesis umol/m2 ground/s-1. weight per unit sun and sha leaves. + if(sunsha == 1)then !sunlit + + psn_out = psn_out + agross * f_sun_lsl + anet_av_out = anet_av_out + anet * f_sun_lsl + gstoma_out = gstoma_out + 1._r8/(min(1._r8/gs, rsmax0)) * f_sun_lsl + + else + + psn_out = psn_out + agross * (1.0_r8-f_sun_lsl) + anet_av_out = anet_av + anet * (1.0_r8-f_sun_lsl) + gstoma_out = gstoma_out + & + 1._r8/(min(1._r8/gs, rsmax0)) * (1.0_r8-f_sun_lsl) + + end if + + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 758 ', currentPatch%psn_z(cl,ft,iv) + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 759 ', agross + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 760 ', currentPatch%f_sun(cl,ft,iv) + + ! Make sure iterative solution is correct + if (gs_mol < 0._r8) then + write (fates_log(),*)'Negative stomatal conductance:' + write (fates_log(),*)'ifp,iv,gs_mol= ',ifp,iv,gs_mol + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + ! Compare with Ball-Berry model: gs_mol = m * an * hs/cs p + b + hs = (gb_mol*ceair + gs_mol*bc_in(s)%esat_tv_pa(ifp)) / ((gb_mol+gs_mol)*bc_in(s)%esat_tv_pa(ifp)) + gs_mol_err = bb_slope(ft)*max(anet, 0._r8)*hs/cs*bc_in(s)%forc_pbot + bbb(FT) + + if (abs(gs_mol-gs_mol_err) > 1.e-01_r8) then + write (fates_log(),*) 'CF: Ball-Berry error check - stomatal conductance error:' + write (fates_log(),*) gs_mol, gs_mol_err + end if + + enddo !sunsha loop + + !average leaf-level stomatal resistance rate over sun and shade leaves... + rstoma_out = 1._r8/gstoma_out + + else !No leaf area. This layer is present only because of stems. (leaves are off, or have reduced to 0 + currentPatch%psn_z(cl,ft,iv) = 0._r8 + rs_lsl = min(rsmax0, 1._r8/bbb(FT) * cf) + + end if !is there leaf area? + + + end if ! night or day + end associate + end subroutine LeafLayerPhotosynthesis + +! ======================================================================================= + function ft1_f(tl, ha) result(ans) ! !!DESCRIPTION: @@ -1157,4 +1245,146 @@ subroutine quadratic_f (a, b, c, r1, r2) end subroutine quadratic_f + ! ==================================================================================== + + subroutine UpdateCanopyNCanNRadPresent(currentPatch) + + ! --------------------------------------------------------------------------------- + ! This subroutine calculates two patch level quanities: + ! currentPatch%ncan and + ! currentPatch%present + ! + ! currentPatch%ncan(:,:) is a two dimensional array that indicates + ! the total number of leaf layers (including those that are not exposed to light) + ! in each canopy layer and for each functional type. + ! + ! currentPatch%nrad(:,:) is a two dimensional array that indicates + ! the total number of EXPOSED leaf layers, but for all intents and purposes + ! in the photosynthesis routine, this appears to be the same as %ncan... + ! + ! currentPatch%present(:,:) has the same dimensions, is binary, and + ! indicates whether or not leaf layers are present (by evaluating the canopy area + ! profile). + ! --------------------------------------------------------------------------------- + + use EDTypesMod, only : cp_nclmax + use EDTypesMOd, only : numpft_ed + + ! Arguments + type(ed_patch_type), target :: currentPatch + type(ed_cohort_type), pointer :: currentCohort + + ! Locals + integer :: CL ! Canopy Layer Index + integer :: ft ! Function Type Index + integer :: iv ! index of the exposed leaf layer for each canopy layer and pft + + ! Loop through the cohorts in this patch, associate each cohort with a layer and PFT + ! and use the cohort's memory of how many layer's it takes up to assign the maximum + ! of the layer/pft index it is in + ! --------------------------------------------------------------------------------- + + currentPatch%ncan(:,:) = 0 + !redo the canopy structure algorithm to get round a bug that is happening for site 125, FT13. + currentCohort => currentPatch%tallest + do while(associated(currentCohort)) + + currentPatch%ncan(currentCohort%canopy_layer,currentCohort%pft) = & + max(currentPatch%ncan(currentCohort%canopy_layer,currentCohort%pft),currentCohort%NV) + + currentCohort => currentCohort%shorter + + enddo !cohort + + ! NRAD = NCAN ... + currentPatch%nrad = currentPatch%ncan + + ! Now loop through and identify which layer and pft combo has scattering elements + do CL = 1,cp_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 + + return + end subroutine UpdateCanopyNCanNRadPresent + + ! ==================================================================================== + + subroutine GetCanopyGasParameters(can_press, can_o2_partialpress, & + veg_temp,mm_kco2,mm_ko2,co2_comppoint) + + ! --------------------------------------------------------------------------------- + ! This subroutine calculates the specific Michaelis Menten Parameters (pa) for CO2 + ! and O2, as well as the CO2 compentation point. + ! --------------------------------------------------------------------------------- + + use FatesConstantsMod, only :: umol_per_mol + use FatesConstantsMod, only :: mmol_per_mol + + ! Arguments + real(r8), intent(in) :: can_press ! Air pressure within the canopy (Pa) + real(r8), intent(in) :: can_o2_partialpress ! Partial press of o2 in the canopy (Pa) + real(r8), intent(in) :: veg_tempk ! The temperature of the vegetation (K) + + real(r8), intent(out) :: mm_kco2 ! Michaelis-Menten constant for CO2 (Pa) + real(r8), intent(out) :: mm_ko2 ! Michaelis-Menten constant for O2 (Pa) + real(r8), intent(out) :: co2_comppoint ! CO2 compensation point (Pa) + + ! Locals + real(r8) :: kc25 ! Michaelis-Menten constant for CO2 at 25C (Pa) + real(r8) :: ko25 ! Michaelis-Menten constant for O2 at 25C (Pa) + real(r8) :: sco ! relative specificity of rubisco + real(r8) :: cp25 ! CO2 compensation point at 25C (Pa) + + ! --------------------------------------------------------------------------------- + ! Intensive values (per mol of air) + ! kc, ko, currentPatch, from: Bernacchi et al (2001) + ! Plant, Cell and Environment 24:253-259 + ! --------------------------------------------------------------------------------- + + real(r8), parameter :: mm_kc25_umol_per_mol = 404.9_r8 + real(r8), parameter :: mm_ko25_mmol_per_mol = 278.4_r8 + real(r8), parameter :: co2_comppoint_umol_per_mol = 42.75_r8 + + ! Activation energy, from: + ! Bernacchi et al (2001) Plant, Cell and Environment 24:253-259 + ! Bernacchi et al (2003) Plant, Cell and Environment 26:1419-1430 + ! except TPU from: Harley et al (1992) Plant, Cell and Environment 15:271-282 + + real(r8), parameter :: kcha = 79430._r8 ! activation energy for kc (J/mol) + real(r8), parameter :: koha = 36380._r8 ! activation energy for ko (J/mol) + real(r8), parameter :: cpha = 37830._r8 ! activation energy for cp (J/mol) + + + ! Derive sco from currentPatch and O2 using present-day O2 (0.209 mol/mol) and re-calculate + ! currentPatch to account for variation in O2 using currentPatch = 0.5 O2 / sco + + ! FIXME (RGK 11-30-2016 THere are more constants here, but I don't have enough information + ! about what they are or do, so I can't give them more descriptive names. Someone please + ! fill this in when possible) + + kc25 = ( mm_kc25_umol_per_mol / umol_per_mol ) * can_press + ko25 = ( mm_ko25_mmol_per_mol / mmol_per_mol ) * can_press + sco = 0.5_r8 * 0.209_r8 / (co2_comppoint_umol_per_mol / umol_per_mol ) + cp25 = 0.5_r8 * can_o2_partialpress / sco + + if( veg_tempk.gt.150_r8 .and. veg_tempk.lt.350_r8 )then + mm_kco2 = kc25 * ft1_f(veg_tempk, kcha) + mm_ko = ko25 * ft1_f(veg_tempk, koha) + co2_comppoint = cp25 * ft1_f(veg_tempk, cpha) + else + mm_kco2 = 1.0_r8 + mm_ko = 1.0_r8 + co2_comppoint = 1.0_r8 + end if + + return + end subroutine GetCanopyGasParameters + end module EDPhotosynthesisMod From 0bdf0d31830795dedf4c824357448d551737f496 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 1 Dec 2016 13:30:31 -0800 Subject: [PATCH 252/437] Reduced more line lengths to be compatible with nag. Also added a maximum line length to the eddi machine settings to help catch these before I submit. --- biogeochem/EDPhysiologyMod.F90 | 3 ++- biogeophys/EDSurfaceAlbedoMod.F90 | 17 +++++++++++------ main/EDRestVectorMod.F90 | 3 ++- 3 files changed, 15 insertions(+), 8 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index aa2ba42c..fccd8c08 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -836,7 +836,8 @@ subroutine Growth_Derivatives( currentSite, currentCohort) if ( DEBUG ) write(iulog,*) 'EDphys 760 ',currentCohort%npp_acc_hold, currentCohort%md, & EDecophyscon%leaf_stor_priority(currentCohort%pft) - currentCohort%carbon_balance = currentCohort%npp_acc_hold - currentCohort%md * EDecophyscon%leaf_stor_priority(currentCohort%pft) + currentCohort%carbon_balance = currentCohort%npp_acc_hold - & + currentCohort%md * EDecophyscon%leaf_stor_priority(currentCohort%pft) ! Allowing only carbon from NPP pool to account for npp flux into the maintenance pools ! ie this does not include any use of storage carbon or balive to make up for missing carbon balance in the transfer diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index c4bdd45d..2086dcb1 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -401,7 +401,8 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) !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) + 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 !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! @@ -418,13 +419,17 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) ! 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)* & + 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) + 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!cp_numSWb endif ! currentPatch%present diff --git a/main/EDRestVectorMod.F90 b/main/EDRestVectorMod.F90 index b1678bb0..a24a493f 100755 --- a/main/EDRestVectorMod.F90 +++ b/main/EDRestVectorMod.F90 @@ -168,7 +168,8 @@ module EDRestVectorMod module procedure newEDRestartVectorClass end interface EDRestartVectorClass - character(len=*), private, parameter :: mod_filename = __FILE__ + character(len=*), private, parameter :: mod_filename = & + __FILE__ ! ! non type-bound procedures From bffdbeb2d10d2198bffdd91ce4fb9f51608a48c0 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 1 Dec 2016 18:41:55 -0800 Subject: [PATCH 253/437] Photosynthesis refactor: most of the code has been re-organized. Next step is careful step-by-step pass through comparing with existing version. --- biogeophys/EDPhotosynthesisMod.F90 | 1163 +++++++++++++++------------- 1 file changed, 626 insertions(+), 537 deletions(-) diff --git a/biogeophys/EDPhotosynthesisMod.F90 b/biogeophys/EDPhotosynthesisMod.F90 index a0597d1e..f1dfe07a 100644 --- a/biogeophys/EDPhotosynthesisMod.F90 +++ b/biogeophys/EDPhotosynthesisMod.F90 @@ -1,30 +1,45 @@ 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. + ! + ! Parameter for activation and deactivation energies were taken from: + ! Activation energy, from: + ! Bernacchi et al (2001) Plant, Cell and Environment 24:253-259 + ! Bernacchi et al (2003) Plant, Cell and Environment 26:1419-1430 + ! except TPU from: Harley et al (1992) Plant, Cell and Environment 15:271-282 + ! High temperature deactivation, from: + ! Leuning (2002) Plant, Cell and Environment 25:1205-1210 + ! The factor "c" scales the deactivation to a value of 1.0 at 25C + ! ------------------------------------------------------------------------------------ + + ! !USES: + ! - !------------------------------------------------------------------------------ - ! !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: - ! - - use abortutils, only : endrun - use FatesGlobals, only : fates_log - use FatesConstantsMod, only : r8 => fates_r8 - use shr_log_mod , only : errMsg => shr_log_errMsg - - implicit none - private - - - ! PUBLIC MEMBER FUNCTIONS: - public :: Photosynthesis_ED !ED specific photosynthesis routine - - character(len=*), parameter, private :: sourcefile = & - __FILE__ - !------------------------------------------------------------------------------ + use abortutils, only : endrun + use FatesGlobals, only : fates_log + use FatesConstantsMod, only : r8 => fates_r8 + use shr_log_mod , only : errMsg => shr_log_errMsg + + implicit none + private + + + ! PUBLIC MEMBER FUNCTIONS: + public :: Photosynthesis_ED !ED specific photosynthesis routine + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !------------------------------------------------------------------------------ + + ! maximum stomatal resistance [s/m] (used across several procedures) + real(r8),parameter :: rsmax0 = 2.e4_r8 + + logical :: DEBUG = .false. contains @@ -90,10 +105,12 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) integer , parameter :: psn_type = 2 !c3 or c4. - logical :: DEBUG = .false. - + real(r8) :: btran_eff ! effective transpiration wetness factor (0 to 1) + ! either from cohort or patch-pft ! ! Leaf photosynthesis parameters + ! Note: None of these variables need to be an array. We put them + ! in arrays only to enable user debugging diagnostics real(r8) :: vcmax_z(cp_nclmax,mxpft,cp_nlevcan) ! maximum rate of carboxylation (umol co2/m**2/s) real(r8) :: jmax_z(cp_nclmax,mxpft,cp_nlevcan) ! maximum electron transport rate (umol electrons/m**2/s) real(r8) :: tpu_z(cp_nclmax,mxpft,cp_nlevcan) ! triose phosphate utilization rate (umol CO2/m**2/s) @@ -101,19 +118,19 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) real(r8) :: lmr_z(cp_nclmax,mxpft,cp_nlevcan) ! initial slope of CO2 response curve (C4 plants) real(r8) :: rs_z(cp_nclmax,mxpft,cp_nlevcan) ! stomatal resistance s/m real(r8) :: gs_z(cp_nclmax,mxpft,cp_nlevcan) ! stomatal conductance m/s - - real(r8) :: ci ! intracellular leaf CO2 (Pa) - real(r8) :: lnc(mxpft) ! leaf N concentration (gN leaf/m^2) - - real(r8) :: kc ! Michaelis-Menten constant for CO2 (Pa) - real(r8) :: ko ! Michaelis-Menten constant for O2 (Pa) - real(r8) :: co2_cp ! CO2 compensation point (Pa) + real(r8) :: anet_av(cp_nclmax,mxpft,cp_nlevcan) ! net leaf photosynthesis (umol CO2/m**2/s) + ! averaged over sun and shade leaves. + + real(r8) :: lnc ! leaf N concentration (gN leaf/m^2) + real(r8) :: mm_kco2 ! Michaelis-Menten constant for CO2 (Pa) + real(r8) :: mm_ko2 ! Michaelis-Menten constant for O2 (Pa) + real(r8) :: co2_cpoint ! CO2 compensation point (Pa) ! --------------------------------------------------------------- ! TO-DO: bbbopt is slated to be transferred to the parameter file ! ---------------------------------------------------------------- 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) :: bbb ! Ball-Berry minimum leaf conductance (umol H2O/m**2/s) 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) @@ -122,83 +139,24 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) 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) :: 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) :: 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,s,iv,j,ps,ft,ifp ! indices + integer :: cl,s,iv,j,ps,ft,ifp ! indices integer :: NCL_p ! number of canopy layers in patch real(r8) :: cf ! s m**2/umol -> 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) :: 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) :: ai ! intermediate co-limited photosynthesis (umol CO2/m**2/s) - real(r8) :: ac ! Rubisco-limited gross photosynthesis (umol CO2/m**2/s) - real(r8) :: aj ! RuBP-limited gross photosynthesis (umol CO2/m**2/s) - real(r8) :: ap ! product-limited (C3) or CO2-limited (C4) gross photosynthesis (umol CO2/m**2/s) - - real(r8) :: ai ! intermediate co-limited photosynthesis (umol CO2/m**2/s) real(r8) :: 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) :: tcwood ! Temperature response function for wood - - real(r8) :: q10 ! temperature dependence of root respiration - integer :: sunsha ! sun (1) or shaded (2) leaves... - real(r8) :: coarse_wood_frac ! amount of woody biomass that is coarse... +! real(r8) :: coarse_wood_frac ! amount of woody biomass that is coarse... real(r8) :: tree_area real(r8) :: gs_cohort real(r8) :: rscanopy @@ -222,84 +180,25 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) real(r8),parameter :: base_mr_20 = 2.525e-6_r8 - ! maximum stomatal resistance [s/m] - real(r8),parameter :: rsmax0 = 2.e4_r8 - - ! First guess on ratio between intracellular co2 and the atmosphere - ! an iterator converges on actual - real(r8),parameter :: init_a2l_co2_c3 = 0.7_r8 - real(r8),parameter :: init_a2l_co2_c4 = 0.4_r8 - - - associate( & - c3psn => pftcon%c3psn , & ! photosynthetic pathway: 0. = c4, 1. = c3 + associate( & + c3psn => pftcon%c3psn , & 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) - frootcn => pftcon%frootcn , & ! froot C:N (gc/gN) - bb_slope => EDecophyscon%BB_slope ) ! slope of BB relationship + frootcn => pftcon%frootcn , & ! froot C:N (gc/gN) ! slope of BB relationship + q10 => EDParamsShareInst%Q10) - ! 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 * mg_per_g / sec_per_min - - ! 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 - - 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_f(vcmaxhd, vcmaxse) - jmaxc = fth25_f(jmaxhd, jmaxse) - tpuc = fth25_f(tpuhd, tpuse) - lmrc = fth25_f(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 - - qe(2) = 0.05_r8 - theta_cj(2) = 0.80_r8 bbbopt(2) = 40000._r8 do s = 1,nsites @@ -341,24 +240,26 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) ! Part IV. Identify some environmentally derived parameters: + ! These quantities are biologically irrelevant ! Michaelis-Menten constant for CO2 (Pa) ! Michaelis-Menten constant for O2 (Pa) ! CO2 compensation point (Pa) - - call GetCanopyGasParameters(bc_in(s)%forc_pbot,bc_in(s)%oair_pa(ifp), & - bc_in(s)%t_veg_pa(ifp),kc,ko,co2_cp) - - - ! THESE HARD CODED CONVERSIONS NEED TO BE CALLED FROM GLOBAL CONSTANTS (RGK 10-13-2016) - cf = bc_in(s)%forc_pbot/(rgas*1.e-3_r8*bc_in(s)%tgcm_pa(ifp))*1.e06_r8 - gb = 1._r8/bc_in(s)%rb_pa(ifp) - 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(bc_in(s)%eair_pa(ifp), 0.05_r8*bc_in(s)%esat_tv_pa(ifp)), bc_in(s)%esat_tv_pa(ifp) ) - - + ! CF? I have no idea what cf is (rgk 12-01-2016) + ! leaf boundary layer conductance of h20 + ! constrained vapor pressure + call GetCanopyGasParameters(bc_in(s)%forc_pbot, & ! in + bc_in(s)%oair_pa(ifp), & ! in + bc_in(s)%t_veg_pa(ifp), & ! in + bc_in(s)%tgcm_pa(ifp), & ! in + bc_in(s)%eair_pa(ifp), & ! in + bc_in(s)%esat_tv_pa(ifp), & ! in + bc_in(s)%rb_pa(ifp), & ! in + mm_kco2, & ! out + mm_ko2, & ! out + co2_cpoint, & ! out + cf, & ! out + gb_mol, & ! out + ceair) ! out ! Part V. Pre-process some variables that are PFT dependent ! but not environmentally dependent @@ -367,7 +268,7 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) do FT = 1,numpft_ed !calculate patch and pft specific properties 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)) + lnc = 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... @@ -403,7 +304,7 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) ! 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) / (umolC_to_kgC * g_per_kg) + lmr25top(FT) = lmr25top(FT) * lnc / (umolC_to_kgC * g_per_kg) end do !FT @@ -412,7 +313,7 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) ! variables will be available at the cohort scale, and not the ! pft scale. So here we split and use different looping structures ! ------------------------------------------------------------------ -! if ( use_fates_plant_hydro ) + ! if ( use_fates_plant_hydro ) !==============================================================================! @@ -433,13 +334,13 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) ! calculated every timestep. Others are calculated only if daytime do iv = 1, currentPatch%nrad(CL,FT) - if (use_fates_plant_hydro) then - !! bbb = max (bbbopt(ps)*currentCohort%btran(iv), 1._r8) - !! btran = currentCohort%btran(iv) - else - !! bbb = max (bbbopt(ps)*currentPatch%btran_ft(FT), 1._r8) - !! btran = currentPatch%btran_ft(currentCohort%pft) - end if + !! if (use_fates_plant_hydro) then + !! !! bbb = max (bbbopt(ps)*currentCohort%btran(iv), 1._r8) + !! !! btran = currentCohort%btran(iv) + !! else + bbb = max (bbbopt(nint(c3psn(ft)))*currentPatch%btran_ft(FT), 1._r8) + btran_eff = currentPatch%btran_ft(ft) + !! end if vai = (currentPatch%elai_profile(CL,FT,iv)+currentPatch%esai_profile(CL,FT,iv)) !vegetation area index. if (iv == 1) then @@ -451,42 +352,64 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) ! Scale for leaf nitrogen profile nscaler = exp(-kn(FT) * laican) - - - call LeafLayerPhotosynthesis(currentPatch%ed_parsun_z(CL,FT,iv), & ! in - currentPatch%ed_parsha_z(CL,FT,iv), & ! in - currentPatch%ed_laisun_z(CL,FT,iv), & ! in - currentPatch%ed_laisha_z(CL,FT,iv), & ! in - currentPatch%canopy_area_profile(CL,FT,iv), & ! in - ft, & ! in - nscaler, & ! in - lmr25top(ft), & ! in - vcmax25top(ft), & ! in - jmax25top(ft), & ! in - tpu25top(ft), & ! in - kp25top(ft), & ! in - bc_in(s)%t_veg_pa(ifp), & ! in - btran, & ! in - bbb, & ! in - cf, & ! in - gb_mol, & ! in - lmr_z(CL,FT,iv), & ! out - currentPatch%psn_z(cl,ft,iv), & ! out - rs_z(CL,FT,iv), & ! out - an_av(CL,FT,iv)) ! out - - + + call LeafLayerMaintenanceRespiration( lmr25top(ft), & ! in + nscaler, & ! in + ft, & ! in + bc_in(s)%t_veg_pa(ifp), & ! in + lmr_z(CL,FT,iv)) ! out + call LeafLayerBiophysicalRates(currentPatch%ed_parsun_z(CL,FT,iv), & ! in + ft, & ! in + vcmax25top(ft), & ! in + jmax25top(ft), & ! in + tpu25top(ft), & ! in + kp25top(ft), & ! in + nscaler, & ! in + bc_in(s)%t_veg_pa(ifp), & ! in + btran_eff, & ! in + vcmax_z(CL,FT,iv), & ! out + jmax_z(CL,FT,iv), & ! out + tpu_z(CL,FT,iv), & ! out + kp_z(CL,FT,iv) ) ! out + + call LeafLayerPhotosynthesis(currentPatch%f_sun(CL,FT,iv), & ! in + currentPatch%ed_parsun_z(CL,FT,iv), & ! in + currentPatch%ed_parsha_z(CL,FT,iv), & ! in + currentPatch%ed_laisun_z(CL,FT,iv), & ! in + currentPatch%ed_laisha_z(CL,FT,iv), & ! in + currentPatch%canopy_area_profile(CL,FT,iv), & ! in + ft, & ! in + nscaler, & ! in + vcmax_z(CL,FT,iv), & ! in + jmax_z(CL,FT,iv), & ! in + tpu_z(CL,FT,iv), & ! in + kp_z(CL,FT,iv), & ! in + bc_in(s)%t_veg_pa(ifp), & ! in + bc_in(s)%esat_tv_pa(ifp), & ! in + bc_in(s)%forc_pbot, & ! in + bc_in(s)%cair_pa(ifp), & ! in + bc_in(s)%oair_pa(ifp), & ! in + btran_eff, & ! in + bbb, & ! in + cf, & ! in + gb_mol, & ! in + ceair, & ! in + mm_kco2, & ! in + mm_ko2, & ! in + co2_cpoint, & ! in + lmr_z(CL,FT,iv), & ! in + currentPatch%psn_z(cl,ft,iv), & ! out + rs_z(CL,FT,iv), & ! out + anet_av(CL,FT,iv)) ! out + end do ! iv end if !present enddo !PFT enddo !CL - ! Leaf boundary layer conductance, umol/m**2/s - - !==============================================================================! ! Unpack fluxes from arrays into cohorts @@ -526,14 +449,14 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) if (currentCohort%nv > 1) then !is there canopy, and are the leaves on? - currentCohort%gpp_tstep = sum(currentPatch%psn_z(cl,ft,1:currentCohort%nv-1) * & + currentCohort%gpp_tstep = sum(currentPatch%psn_z(cl,ft,1:currentCohort%nv-1) * & currentPatch%elai_profile(cl,ft,1:currentCohort%nv-1)) * tree_area - currentCohort%rdark = sum(lmr_z(cl,ft,1:currentCohort%nv-1) * & + currentCohort%rdark = 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)+bc_in(s)%rb_pa(ifp)))) * tree_area - currentCohort%ts_net_uptake(1:currentCohort%nv) = an_av(cl,ft,1:currentCohort%nv) * umolC_to_kgC * dtime + currentCohort%gscan = sum((1.0_r8/(rs_z(cl,ft,1:currentCohort%nv-1)+bc_in(s)%rb_pa(ifp)))) * tree_area + currentCohort%ts_net_uptake(1:currentCohort%nv) = anet_av(cl,ft,1:currentCohort%nv) * umolC_to_kgC * dtime else @@ -611,9 +534,9 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) ! Live stem MR (kgC/plant/s) (above ground sapwood) ! ------------------------------------------------------------------ if (woody(ft) == 1) then - tc = q10**((bc_in(s)%t_veg_pa(ifp)-tfrz - 20.0_r8)/10.0_r8) + tcwood = q10**((bc_in(s)%t_veg_pa(ifp)-tfrz - 20.0_r8)/10.0_r8) ! kgC/s = kgN * kgC/kgN/s - currentCohort%livestem_mr = live_stem_n * base_mr_20 * tc + currentCohort%livestem_mr = live_stem_n * base_mr_20 * tcwood else currentCohort%livestem_mr = 0._r8 end if @@ -728,28 +651,36 @@ end subroutine Photosynthesis_ED ! ======================================================================================= -subroutine LeafLayerPhotosynthesis(parsun_lsl, & ! in +subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in + parsun_lsl, & ! in parsha_lsl, & ! in laisun_lsl, & ! in laisha_lsl, & ! in canopy_area_lsl, & ! in ft, & ! in nscaler, & ! in - lmr25top_ft, & ! in - vcmax25top_ft, & ! in - jmax25top_ft, & ! in - tpu25top_ft, & ! in - kp25top_ft, & ! in - t_veg, & ! in + vcmax, & ! in + jmax, & ! in + tpu, & ! in + co2_rcurve_islope, & ! in + veg_tempk, & ! in + veg_esat, & ! in + can_press, & ! in + can_co2_ppress, & ! in + can_o2_ppress, & ! in btran, & ! in bbb, & ! in cf, & ! in gb_mol, & ! in - lmr_out, & ! out + ceair, & ! in + mm_kco2, & ! in + mm_ko2, & ! in + co2_cpoint, & ! in + lmr, & ! in psn_out, & ! out rstoma_out, & ! out anet_av_out) ! out - + ! ------------------------------------------------------------------------------------ ! This subroutine calculates photosynthesis and stomatal conductance within each leaf ! sublayer. @@ -759,141 +690,111 @@ subroutine LeafLayerPhotosynthesis(parsun_lsl, & ! in ! Other arguments or variables may be indicative of scales broader than the LSL. ! ------------------------------------------------------------------------------------ + use EDEcophysContype , only : EDecophyscon + use pftconMod , only : pftcon + ! Arguments ! ------------------------------------------------------------------------ + real(r8), intent(in) :: f_sun_lsl real(r8), intent(in) :: parsun_lsl real(r8), intent(in) :: parsha_lsl real(r8), intent(in) :: laisun_lsl real(r8), intent(in) :: laisha_lsl - real(r8), intent(in) :: elai_lsl - real(r8), intent(in) :: esai_lsl real(r8), intent(in) :: canopy_area_lsl - integer, intent(in) :: ft ! (plant) Functional Type Index - real(r8), intent(in) :: nscaler ! Scale for leaf nitrogen profile - real(r8), intent(in) :: lmr25top_ft ! canopy top leaf maint resp rate at 25C - ! for this pft (umol CO2/m**2/s) - real(r8), intent(in) :: vcmax25top_ft ! canopy top maximum rate of carboxylation at 25C - ! for this pft (umol CO2/m**2/s) - real(r8), intent(in) :: jmax25top_ft ! canopy top maximum electron transport rate at 25C - ! for this pft (umol electrons/m**2/s) - real(r8), intent(in) :: tpu25top_ft ! canopy top triose phosphate utilization rate at 25C - ! for this pft (umol CO2/m**2/s) - real(r8), intent(in) :: co2_rcurve_islope25top_ft ! initial slope of CO2 response curve - ! (C4 plants) at 25C, canopy top, this pft - real(r8), intent(in) :: t_veg ! vegetation temperature - real(r8), intent(in) :: btran ! - real(r8), intent(in) :: bbb - real(r8), intent(in) :: cf - real(r8), intent(in) :: gb_mol + integer, intent(in) :: ft ! (plant) Functional Type Index + real(r8), intent(in) :: nscaler ! Scale for leaf nitrogen profile + real(r8), intent(in) :: vcmax ! maximum rate of carboxylation (umol co2/m**2/s) + real(r8), intent(in) :: jmax ! maximum electron transport rate (umol electrons/m**2/s) + real(r8), intent(in) :: tpu ! triose phosphate utilization rate (umol CO2/m**2/s) + real(r8), intent(in) :: co2_rcurve_islope ! initial slope of CO2 response curve (C4 plants) + real(r8), intent(in) :: veg_tempk ! vegetation temperature + real(r8), intent(in) :: veg_esat ! saturation vapor pressure at veg_tempk (Pa) + + ! Important Note on the following gas pressures. This photosynthesis scheme will iteratively + ! solve for the co2 partial pressure at the leaf surface (ie in the stomata). The reference + ! point for these input values are NOT within that boundary layer that separates the stomata from + ! the canopy air space. The reference point for these is on the outside of that boundary + ! layer. This routine, which operates at the leaf scale, makes no assumptions about what the + ! scale of the refernce is, it could be lower atmosphere, it could be within the canopy + ! but most likely it is the closest value one can get to the edge of the leaf's boundary + ! layer. We use the convention "can_" because a reference point of within the canopy + ! ia a best reasonable scenario of where we can get that information from. + + real(r8), intent(in) :: can_press ! Air pressure NEAR the surface of the leaf (Pa) + real(r8), intent(in) :: can_co2_ppress ! Partial pressure of CO2 NEAR the leaf surface (Pa) + real(r8), intent(in) :: can_o2_ppress ! Partial pressure of O2 NEAR the leaf surface (Pa) + real(r8), intent(in) :: btran ! transpiration wetness factor (0 to 1) + real(r8), intent(in) :: bbb ! Ball-Berry minimum leaf conductance (umol H2O/m**2/s) + real(r8), intent(in) :: cf ! s m**2/umol -> s/m + real(r8), intent(in) :: gb_mol ! leaf boundary layer conductance (umol H2O/m**2/s) + real(r8), intent(in) :: ceair ! vapor pressure of air, constrained (Pa) + real(r8), intent(in) :: mm_kco2 ! Michaelis-Menten constant for CO2 (Pa) + real(r8), intent(in) :: mm_ko2 ! Michaelis-Menten constant for O2 (Pa) + real(r8), intent(in) :: co2_cpoint ! CO2 compensation point (Pa) + real(r8), intent(in) :: lmr ! Leaf Maintenance Respiration (umol CO2/m**2/s) - real(r8), intent(out) :: lmr_out - real(r8), intent(out) :: psn_out - real(r8), intent(out) :: rstoma_out ! stomatal resistance (1/gs_lsl) (s/m) - real(r8), intent(out) :: anet_av_out ! net leaf photosynthesis (umol CO2/m**2/s) averaged over sun and shade leaves. - real(r8), intent(out) :: gstoma_out ! Stomatal Conductance of this leaf layer (m/s) - + real(r8), intent(out) :: psn_out ! carbon assimilated in this leaf layer umolC/m2/s + real(r8), intent(out) :: rstoma_out ! stomatal resistance (1/gs_lsl) (s/m) + real(r8), intent(out) :: anet_av_out ! net leaf photosynthesis (umol CO2/m**2/s) + ! averaged over sun and shade leaves. ! Locals ! ------------------------------------------------------------------------ - integer :: ps ! Index for the different photosynthetic pathways C3,C4 - integer :: sunsha ! Index for differentiating sun and shade - - 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) :: co2_rcurve_islope25 ! leaf layer: Initial slope of CO2 response curve (C4 plants) at 25C - - - !!!!!!! NOTE: WE CAN REMOVE THE LSL IDENTIFIER FROM LOCALS AFTER THEY HAVE MORE VERBOSE NAMES - ! - - real(r8) :: vcmax ! maximum rate of carboxylation (umol co2/m**2/s) - real(r8) :: jmax ! maximum electron transport rate (umol electrons/m**2/s) - real(r8) :: tpu ! triose phosphate utilization rate (umol CO2/m**2/s) - real(r8) :: co2_rcurve_islope ! initial slope of CO2 response curve (C4 plants) - - + integer :: ps ! Index for the different photosynthetic pathways C3,C4 + integer :: sunsha ! Index for differentiating sun and shade + real(r8) :: gstoma ! Stomatal Conductance of this leaf layer (m/s) real(r8) :: agross ! co-limited gross leaf photosynthesis (umol CO2/m**2/s) real(r8) :: anet ! net leaf photosynthesis (umol CO2/m**2/s) + real(r8) :: je ! electron transport rate (umol electrons/m**2/s) + real(r8) :: qabs ! PAR absorbed by PS II (umol photons/m**2/s) + real(r8) :: aquad,bquad,cquad ! terms for quadratic equations + real(r8) :: r1,r2 ! roots of quadratic equation + real(r8) :: co2_intra_c ! intracellular leaf CO2 (Pa) + real(r8) :: co2_intra_c_old ! intracellular leaf CO2 (Pa) (previous iteration) + logical :: loop_continue ! Loop control variable + integer :: niter ! iteration loop index + real(r8) :: gs_mol ! leaf stomatal conductance (umol H2O/m**2/s) + real(r8) :: gs ! leaf stomatal conductance (m/s) + real(r8) :: hs ! fractional humidity at leaf surface (dimensionless) + real(r8) :: gs_mol_err ! gs_mol for error check + real(r8) :: ac ! Rubisco-limited gross photosynthesis (umol CO2/m**2/s) + real(r8) :: aj ! RuBP-limited gross photosynthesis (umol CO2/m**2/s) + real(r8) :: ap ! product-limited (C3) or CO2-limited (C4) gross photosynthesis (umol CO2/m**2/s) + real(r8) :: ai ! intermediate co-limited photosynthesis (umol CO2/m**2/s) + real(r8) :: leaf_co2_ppress ! CO2 partial pressure at leaf surface (Pa) + ! Parameters + ! ------------------------------------------------------------------------ + ! Fraction of light absorbed by non-photosynthetic pigments + real(r8),parameter :: fnps = 0.15_r8 + + ! empirical curvature parameter for electron transport rate + real(r8),parameter :: theta_psii = 0.7_r8 + ! First guess on ratio between intracellular co2 and the atmosphere + ! an iterator converges on actual + real(r8),parameter :: init_a2l_co2_c3 = 0.7_r8 + real(r8),parameter :: init_a2l_co2_c4 = 0.4_r8 + ! quantum efficiency, used only for C4 (mol CO2 / mol photons) + real(r8),parameter,dimension(2) :: quant_eff = [0.0_r8,0.05_r8] + + ! empirical curvature parameter for ac, aj photosynthesis co-limitation + real(r8),parameter,dimension(2) :: theta_cj = [0.98_r8,0.80_r8] + + ! empirical curvature parameter for ap photosynthesis co-limitation + real(r8),parameter :: theta_ip = 0.95_r8 - ! Parameters - ! ------------------------------------------------------------------------ - 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) - frootcn => pftcon%frootcn , & ! froot C:N (gc/gN) - bb_slope => EDecophyscon%BB_slope ) ! slope of BB relationship - - + associate( c3psn => pftcon%c3psn, & ! photosynthetic pathway: 0. = c4, 1. = c3 + bb_slope => EDecophyscon%BB_slope ) ! slope of BB relationship + if (nint(c3psn(ft)) == 1)then ps = 1 else ps = 2 end if - - - ! Part I: Leaf Maintenance respiration: umol CO2 / m**2 [leaf] / s - ! ---------------------------------------------------------------------------------- - lmr25 = lmr25top_ft * nscaler - if ( nint(c3psn(ft)) == 1)then - lmr_out = lmr25 * ft1_f(t_veg, lmrha) * & - fth_f(t_veg, lmrhd, lmrse, lmrc) - else - lmr_out = lmr25 * 2._r8**((t_veg-(tfrz+25._r8))/10._r8) - lmr_out = lmr_out / (1._r8 + exp( 1.3_r8*(t_veg-(tfrz+55._r8)) )) - end if - - - - - ! Part II: Localized Biophysical Rates - ! ---------------------------------------------------------------------------------- - - if ( parsun_lsl <= 0._r8) then ! night time - vcmax = 0._r8 - jmax = 0._r8 - tpu = 0._r8 - co2_rcurve_islope = 0._r8 - else ! day time - vcmax25 = vcmax25top_ft * nscaler - jmax25 = jmax25top_ft * nscaler - tpu25 = tpu25top_ft * nscaler - co2_rcurve_islope25 = co2_rcurve_islope25top_ft * nscaler - - ! Adjust for temperature - vcmax = vcmax25 * ft1_f(t_veg, vcmaxha) * fth_f(t_veg, vcmaxhd, vcmaxse, vcmaxc) - jmax = jmax25 * ft1_f(t_veg, jmaxha) * fth_f(t_veg, jmaxhd, jmaxse, jmaxc) - tpu = tpu25 * ft1_f(t_veg, tpuha) * fth_f(t_veg, tpuhd, tpuse, tpuc) - - if (nint(c3psn(FT)) /= 1) then - vcmax = vcmax25 * 2._r8**((t_veg-(tfrz+25._r8))/10._r8) - vcmax = vcmax / (1._r8 + exp( 0.2_r8*((tfrz+15._r8)-t_veg ) )) - vcmax = vcmax / (1._r8 + exp( 0.3_r8*(t_veg-(tfrz+40._r8)) )) - end if - co2_rcurve_islope = co2_rcurve_islope25 * 2._r8**((t_veg-(tfrz+25._r8))/10._r8) !q10 response of product limited psn. - end if - - ! Adjust for water limitations - vcmax = vcmax * btran - - ! Leaf Maintenance Respiration has no direct water limitation effect - ! lmr_out = lmr_out * (nothing) - - - - - - ! Part III: Photosynthesis and Conductance ! ---------------------------------------------------------------------------------- @@ -901,7 +802,7 @@ subroutine LeafLayerPhotosynthesis(parsun_lsl, & ! in anet_av_out = 0._r8 psn_out = 0._r8 - rstoma_out = min(rsmax0, 1._r8/bbb * cf) + rstoma_out = min(rsmax0, 1._r8/bbb * cf) else ! day time (a little bit more complicated ...) @@ -915,9 +816,9 @@ subroutine LeafLayerPhotosynthesis(parsun_lsl, & ! in !Loop aroun shaded and unshaded leaves psn_out = 0._r8 ! psn is accumulated across sun and shaded leaves. - rstoma_out = 0._r8 ! 1/rs is accumulated across sun and shaded leaves. + rstoma_out = 0._r8 ! 1/rs is accumulated across sun and shaded leaves. anet_av_out = 0._r8 - gstoma_out = 0._r8 + gstoma = 0._r8 do sunsha = 1,2 ! Electron transport rate for C3 plants. Convert par from W/m2 to umol photons/m**2/s @@ -927,7 +828,7 @@ subroutine LeafLayerPhotosynthesis(parsun_lsl, & ! in if(sunsha == 1)then !sunlit if(( laisun_lsl * canopy_area_lsl) > 0.0000000001_r8)then - qabs = parsun_lsl / (laisun_lsl * canopy_area_profile_lsl ) + qabs = parsun_lsl / (laisun_lsl * canopy_area_lsl ) qabs = qabs * 0.5_r8 * (1._r8 - fnps) * 4.6_r8 else @@ -935,182 +836,183 @@ subroutine LeafLayerPhotosynthesis(parsun_lsl, & ! in end if else - qabs = currentPatch%ed_parsha_lsl / (currentPatch%ed_laisha_lsl * & - currentPatch%canopy_area_profile_lsl) - 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_f (aquad, bquad, cquad, r1, r2) - je = min(r1,r2) - - ! Iterative loop for ci beginning with initial guess - ! THIS CALL APPEARS TO BE REDUNDANT WITH LINE 423 (RGK) - - if (nint(c3psn(FT)) == 1)then - ci = init_a2l_co2_c3 * bc_in(s)%cair_pa(ifp) - else - ci = init_a2l_co2_c4 * bc_in(s)%cair_pa(ifp) - 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 - - ! Photosynthesis limitation rate calculations - if (nint(c3psn(FT)) == 1)then - ! C3: Rubisco-limited photosynthesis - ac = vcmax_z(cl,ft,iv) * max(ci-co2_cp, 0._r8) / (ci+kc * & - (1._r8+bc_in(s)%oair_pa(ifp)/ko)) - ! C3: RuBP-limited photosynthesis - aj = je * max(ci-co2_cp, 0._r8) / (4._r8*ci+8._r8*co2_cp) - ! 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 = co2_rcurve_islope_z(cl,ft,iv) * max(ci, 0._r8) / bc_in(s)%forc_pbot - 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_f (aquad, bquad, cquad, r1, r2) - ai = min(r1,r2) - - aquad = theta_ip - bquad = -(ai + ap) - cquad = ai * ap - call quadratic_f (aquad, bquad, cquad, r1, r2) - agross = min(r1,r2) - - ! Net carbon assimilation. Exit iteration if an < 0 - anet = agross - lmr_out - if (anet < 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 = bc_in(s)%cair_pa(ifp) - 1.4_r8/gb_mol * anet * bc_in(s)%forc_pbot - cs = max(cs,1.e-06_r8) - aquad = cs - bquad = cs*(gb_mol - bbb(FT)) - bb_slope(ft)*anet*bc_in(s)%forc_pbot - cquad = -gb_mol*(cs*bbb(FT) + & - bb_slope(ft)*anet*bc_in(s)%forc_pbot*ceair/bc_in(s)%esat_tv_pa(ifp)) - call quadratic_f (aquad, bquad, cquad, r1, r2) - gs_mol = max(r1,r2) - - ! Derive new estimate for ci - ci = bc_in(s)%cair_pa(ifp) - anet * bc_in(s)%forc_pbot * & - (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-ciold)/bc_in(s)%forc_pbot*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 (anet < 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 = bc_in(s)%cair_pa(ifp) - 1.4_r8/gb_mol * anet * bc_in(s)%forc_pbot - cs = max(cs,1.e-06_r8) - ci = bc_in(s)%cair_pa(ifp) - & - anet * bc_in(s)%forc_pbot * (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 - - if ( DEBUG ) write(fates_log(),*) 'EDPhoto 737 ', currentPatch%psn_z(cl,ft,iv) - if ( DEBUG ) write(fates_log(),*) 'EDPhoto 738 ', agross - if ( DEBUG ) write(fates_log(),*) 'EDPhoto 739 ', currentPatch%f_sun(cl,ft,iv) - - !accumulate total photosynthesis umol/m2 ground/s-1. weight per unit sun and sha leaves. - if(sunsha == 1)then !sunlit - - psn_out = psn_out + agross * f_sun_lsl - anet_av_out = anet_av_out + anet * f_sun_lsl - gstoma_out = gstoma_out + 1._r8/(min(1._r8/gs, rsmax0)) * f_sun_lsl - - else - - psn_out = psn_out + agross * (1.0_r8-f_sun_lsl) - anet_av_out = anet_av + anet * (1.0_r8-f_sun_lsl) - gstoma_out = gstoma_out + & - 1._r8/(min(1._r8/gs, rsmax0)) * (1.0_r8-f_sun_lsl) - - end if - - if ( DEBUG ) write(fates_log(),*) 'EDPhoto 758 ', currentPatch%psn_z(cl,ft,iv) - if ( DEBUG ) write(fates_log(),*) 'EDPhoto 759 ', agross - if ( DEBUG ) write(fates_log(),*) 'EDPhoto 760 ', currentPatch%f_sun(cl,ft,iv) - - ! Make sure iterative solution is correct - if (gs_mol < 0._r8) then - write (fates_log(),*)'Negative stomatal conductance:' - write (fates_log(),*)'ifp,iv,gs_mol= ',ifp,iv,gs_mol - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - ! Compare with Ball-Berry model: gs_mol = m * an * hs/cs p + b - hs = (gb_mol*ceair + gs_mol*bc_in(s)%esat_tv_pa(ifp)) / ((gb_mol+gs_mol)*bc_in(s)%esat_tv_pa(ifp)) - gs_mol_err = bb_slope(ft)*max(anet, 0._r8)*hs/cs*bc_in(s)%forc_pbot + bbb(FT) - - if (abs(gs_mol-gs_mol_err) > 1.e-01_r8) then - write (fates_log(),*) 'CF: Ball-Berry error check - stomatal conductance error:' - write (fates_log(),*) gs_mol, gs_mol_err - end if - - enddo !sunsha loop - - !average leaf-level stomatal resistance rate over sun and shade leaves... - rstoma_out = 1._r8/gstoma_out - - else !No leaf area. This layer is present only because of stems. (leaves are off, or have reduced to 0 - currentPatch%psn_z(cl,ft,iv) = 0._r8 - rs_lsl = min(rsmax0, 1._r8/bbb(FT) * cf) - - end if !is there leaf area? - - - end if ! night or day - end associate - end subroutine LeafLayerPhotosynthesis + qabs = parsha_lsl / (laisha_lsl * canopy_area_lsl) + 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) + cquad = qabs * jmax + call quadratic_f (aquad, bquad, cquad, r1, r2) + je = min(r1,r2) + + ! Iterative loop for ci beginning with initial guess + ! THIS CALL APPEARS TO BE REDUNDANT WITH LINE 423 (RGK) + + if (nint(c3psn(FT)) == 1)then + co2_intra_c = init_a2l_co2_c3 * can_co2_ppress + else + co2_intra_c = init_a2l_co2_c4 * can_co2_ppress + end if + + niter = 0 + loop_continue = .true. + do while(loop_continue) + ! Increment iteration counter. Stop if too many iterations + niter = niter + 1 + + ! Save old co2_intra_c + co2_intra_c_old = co2_intra_c + + ! Photosynthesis limitation rate calculations + if (nint(c3psn(FT)) == 1)then + + ! C3: Rubisco-limited photosynthesis + ac = vcmax * max(co2_intra_c-co2_cpoint, 0._r8) / & + (co2_intra_c+mm_kco2 * (1._r8+can_o2_ppress / mm_ko2 )) + + ! C3: RuBP-limited photosynthesis + aj = je * max(co2_intra_c-co2_cpoint, 0._r8) / (4._r8*co2_intra_c+8._r8*co2_cpoint) + + ! C3: Product-limited photosynthesis + ap = 3._r8 * tpu + + else + + ! C4: Rubisco-limited photosynthesis + ac = vcmax + + ! C4: RuBP-limited photosynthesis + if(sunsha == 1)then !sunlit + if((laisun_lsl * canopy_area_lsl) > 0.0000000001_r8) then !guard against /0's in the night. + aj = quant_eff(ps) * parsun_lsl * 4.6_r8 + !convert from per cohort to per m2 of leaf) + aj = aj / (laisun_lsl * canopy_area_lsl) + else + aj = 0._r8 + end if + else + aj = quant_eff(ps) * parsha_lsl * 4.6_r8 + aj = aj / (laisha_lsl * canopy_area_lsl) + end if + + ! C4: PEP carboxylase-limited (CO2-limited) + ap = co2_rcurve_islope * max(co2_intra_c, 0._r8) / can_press + + 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_f (aquad, bquad, cquad, r1, r2) + ai = min(r1,r2) + + aquad = theta_ip + bquad = -(ai + ap) + cquad = ai * ap + call quadratic_f (aquad, bquad, cquad, r1, r2) + agross = min(r1,r2) + + ! Net carbon assimilation. Exit iteration if an < 0 + anet = agross - lmr + if (anet < 0._r8) then + loop_continue = .false. + end if + + ! Quadratic gs_mol calculation with an known. Valid for an >= 0. + ! With an <= 0, then gs_mol = bbb + + leaf_co2_ppress = can_co2_ppress- 1.4_r8/gb_mol * anet * can_press + leaf_co2_ppress = max(leaf_co2_ppress,1.e-06_r8) + aquad = leaf_co2_ppress + bquad = leaf_co2_ppress*(gb_mol - bbb) - bb_slope(ft) * anet * can_press + cquad = -gb_mol*(leaf_co2_ppress*bbb + bb_slope(ft)*anet*can_press * ceair/ veg_esat ) + + call quadratic_f (aquad, bquad, cquad, r1, r2) + gs_mol = max(r1,r2) + + ! Derive new estimate for co2_intra_c + co2_intra_c = can_co2_ppress - anet * can_press * & + (1.4_r8*gs_mol+1.6_r8*gb_mol) / (gb_mol*gs_mol) + + ! Check for co2_intra_c convergence. Delta co2_intra_c/pair = mol/mol. Multiply by 10**6 to + ! convert to umol/mol (ppm). Exit iteration if convergence criteria of +/- 1 x 10**-6 ppm + ! is met OR if at least ten iterations (niter=10) are completed + + if ((abs(co2_intra_c-co2_intra_c_old)/can_press*1.e06_r8 <= 2.e-06_r8) .or. niter == 5) then + loop_continue = .false. + end if + end do !iteration loop + + ! End of co2_intra_c iteration. Check for an < 0, in which case gs_mol = bbb + if (anet < 0._r8) then + gs_mol = bbb + end if + + ! Final estimates for leaf_co2_ppress and co2_intra_c (needed for early exit of co2_intra_c iteration when an < 0) + leaf_co2_ppress = can_co2_ppress - 1.4_r8/gb_mol * anet * can_press + leaf_co2_ppress = max(leaf_co2_ppress,1.e-06_r8) + co2_intra_c = can_co2_ppress - anet * can_press * (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 + + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 737 ', psn_out + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 738 ', agross + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 739 ', f_sun_lsl + + !accumulate total photosynthesis umol/m2 ground/s-1. weight per unit sun and sha leaves. + if(sunsha == 1)then !sunlit + psn_out = psn_out + agross * f_sun_lsl + anet_av_out = anet_av_out + anet * f_sun_lsl + gstoma = gstoma + 1._r8/(min(1._r8/gs, rsmax0)) * f_sun_lsl + else + psn_out = psn_out + agross * (1.0_r8-f_sun_lsl) + anet_av_out = anet_av_out + anet * (1.0_r8-f_sun_lsl) + gstoma = gstoma + & + 1._r8/(min(1._r8/gs, rsmax0)) * (1.0_r8-f_sun_lsl) + end if + + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 758 ', psn_out + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 759 ', agross + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 760 ', f_sun_lsl + + ! Make sure iterative solution is correct + if (gs_mol < 0._r8) then + write (fates_log(),*)'Negative stomatal conductance:' + write (fates_log(),*)'gs_mol= ',gs_mol + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + ! Compare with Ball-Berry model: gs_mol = m * an * hs/leaf_co2_ppress p + b + hs = (gb_mol*ceair + gs_mol* veg_esat ) / ((gb_mol+gs_mol)*veg_esat ) + gs_mol_err = bb_slope(ft)*max(anet, 0._r8)*hs/leaf_co2_ppress*can_press + bbb + + if (abs(gs_mol-gs_mol_err) > 1.e-01_r8) then + write (fates_log(),*) 'CF: Ball-Berry error check - stomatal conductance error:' + write (fates_log(),*) gs_mol, gs_mol_err + end if + + enddo !sunsha loop + + !average leaf-level stomatal resistance rate over sun and shade leaves... + rstoma_out = 1._r8/gstoma + + else !No leaf area. This layer is present only because of stems. (leaves are off, or have reduced to 0 + psn_out = 0._r8 + rstoma_out = min(rsmax0, 1._r8/bbb * cf) + + end if !is there leaf area? + + + end if ! night or day + end associate + return +end subroutine LeafLayerPhotosynthesis ! ======================================================================================= @@ -1267,9 +1169,11 @@ subroutine UpdateCanopyNCanNRadPresent(currentPatch) ! profile). ! --------------------------------------------------------------------------------- - use EDTypesMod, only : cp_nclmax - use EDTypesMOd, only : numpft_ed - + use EDTypesMod , only : cp_nclmax + use EDTypesMOd , only : numpft_ed + use EDTypesMod , only : ed_patch_type + use EDTypesMod , only : ed_cohort_type + ! Arguments type(ed_patch_type), target :: currentPatch type(ed_cohort_type), pointer :: currentCohort @@ -1316,25 +1220,44 @@ end subroutine UpdateCanopyNCanNRadPresent ! ==================================================================================== - subroutine GetCanopyGasParameters(can_press, can_o2_partialpress, & - veg_temp,mm_kco2,mm_ko2,co2_comppoint) + subroutine GetCanopyGasParameters(can_press, & + can_o2_partialpress, & + veg_tempk, & + air_tempk, & + air_vpress, & + veg_esat, & + rb, & + mm_kco2, & + mm_ko2, & + co2_cpoint, & + cf, & + gb_mol, & + ceair) ! --------------------------------------------------------------------------------- ! This subroutine calculates the specific Michaelis Menten Parameters (pa) for CO2 ! and O2, as well as the CO2 compentation point. ! --------------------------------------------------------------------------------- - use FatesConstantsMod, only :: umol_per_mol - use FatesConstantsMod, only :: mmol_per_mol - + use FatesConstantsMod, only: umol_per_mol + use FatesConstantsMod, only: mmol_per_mol + use FatesConstantsMod, only : rgas => rgas_J_K_kmol + ! Arguments real(r8), intent(in) :: can_press ! Air pressure within the canopy (Pa) real(r8), intent(in) :: can_o2_partialpress ! Partial press of o2 in the canopy (Pa) real(r8), intent(in) :: veg_tempk ! The temperature of the vegetation (K) - + real(r8), intent(in) :: air_tempk ! Temperature of canopy air (K) + real(r8), intent(in) :: air_vpress ! Vapor pressure of canopy air (Pa) + real(r8), intent(in) :: veg_esat ! Saturated vapor pressure at veg surf (Pa) + real(r8), intent(in) :: rb ! Leaf Boundary layer resistance (s/m) + real(r8), intent(out) :: mm_kco2 ! Michaelis-Menten constant for CO2 (Pa) real(r8), intent(out) :: mm_ko2 ! Michaelis-Menten constant for O2 (Pa) - real(r8), intent(out) :: co2_comppoint ! CO2 compensation point (Pa) + real(r8), intent(out) :: co2_cpoint ! CO2 compensation point (Pa) + real(r8), intent(out) :: cf ! s m**2/umol -> s/m + real(r8), intent(out) :: gb_mol ! leaf boundary layer conductance (umol H2O/m**2/s) + real(r8), intent(out) :: ceair ! vapor pressure of air, constrained (Pa) ! Locals real(r8) :: kc25 ! Michaelis-Menten constant for CO2 at 25C (Pa) @@ -1350,7 +1273,7 @@ subroutine GetCanopyGasParameters(can_press, can_o2_partialpress, & real(r8), parameter :: mm_kc25_umol_per_mol = 404.9_r8 real(r8), parameter :: mm_ko25_mmol_per_mol = 278.4_r8 - real(r8), parameter :: co2_comppoint_umol_per_mol = 42.75_r8 + real(r8), parameter :: co2_cpoint_umol_per_mol = 42.75_r8 ! Activation energy, from: ! Bernacchi et al (2001) Plant, Cell and Environment 24:253-259 @@ -1371,20 +1294,186 @@ subroutine GetCanopyGasParameters(can_press, can_o2_partialpress, & kc25 = ( mm_kc25_umol_per_mol / umol_per_mol ) * can_press ko25 = ( mm_ko25_mmol_per_mol / mmol_per_mol ) * can_press - sco = 0.5_r8 * 0.209_r8 / (co2_comppoint_umol_per_mol / umol_per_mol ) + sco = 0.5_r8 * 0.209_r8 / (co2_cpoint_umol_per_mol / umol_per_mol ) cp25 = 0.5_r8 * can_o2_partialpress / sco if( veg_tempk.gt.150_r8 .and. veg_tempk.lt.350_r8 )then mm_kco2 = kc25 * ft1_f(veg_tempk, kcha) - mm_ko = ko25 * ft1_f(veg_tempk, koha) - co2_comppoint = cp25 * ft1_f(veg_tempk, cpha) + mm_ko2 = ko25 * ft1_f(veg_tempk, koha) + co2_cpoint = cp25 * ft1_f(veg_tempk, cpha) else mm_kco2 = 1.0_r8 - mm_ko = 1.0_r8 - co2_comppoint = 1.0_r8 + mm_ko2 = 1.0_r8 + co2_cpoint = 1.0_r8 end if + ! THESE HARD CODED CONVERSIONS NEED TO BE CALLED FROM GLOBAL CONSTANTS (RGK 10-13-2016) + cf = can_press/(rgas*1.e-3_r8 * air_tempk )*1.e06_r8 + gb_mol = (1._r8/ rb) * cf + + ! Constrain eair >= 0.05*esat_tv so that solution does not blow up. This ensures + ! that hs does not go to zero. Also eair <= veg_esat so that hs <= 1 + ceair = min( max(air_vpress, 0.05_r8*veg_esat ),veg_esat ) + + + return end subroutine GetCanopyGasParameters + + ! ==================================================================================== + subroutine LeafLayerMaintenanceRespiration(lmr25top_ft, & + nscaler, & + ft, & + veg_tempk, & + lmr) + + use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm + use pftconMod , only : pftcon + + ! Arguments + real(r8), intent(in) :: lmr25top_ft ! canopy top leaf maint resp rate at 25C + ! for this pft (umol CO2/m**2/s) + integer, intent(in) :: ft ! (plant) Functional Type Index + real(r8), intent(in) :: nscaler ! Scale for leaf nitrogen profile + real(r8), intent(in) :: veg_tempk ! vegetation temperature + real(r8), intent(out) :: lmr ! Leaf Maintenance Respiration (umol CO2/m**2/s) + + ! Locals + real(r8) :: lmr25 ! leaf layer: leaf maintenance respiration rate at 25C (umol CO2/m**2/s) + + + ! Parameter + real(r8), parameter :: lmrha = 46390._r8 ! activation energy for lmr (J/mol) + real(r8), parameter :: lmrhd = 150650._r8 ! deactivation energy for lmr (J/mol) + real(r8), parameter :: lmrse = 490._r8 ! entropy term for lmr (J/mol/K) + real(r8), parameter :: lmrc = 1.15912391_r8 ! scaling factor for high temperature inhibition (25 C = 1.0) + + ! Part I: Leaf Maintenance respiration: umol CO2 / m**2 [leaf] / s + ! ---------------------------------------------------------------------------------- + lmr25 = lmr25top_ft * nscaler + + if ( nint(pftcon%c3psn(ft)) == 1)then + lmr = lmr25 * ft1_f(veg_tempk, lmrha) * & + fth_f(veg_tempk, lmrhd, lmrse, lmrc) + else + lmr = lmr25 * 2._r8**((veg_tempk-(tfrz+25._r8))/10._r8) + lmr = lmr / (1._r8 + exp( 1.3_r8*(veg_tempk-(tfrz+55._r8)) )) + end if + + ! Any hydrodynamic limitations could go here, currently none + ! lmr = lmr * (nothing) + + end subroutine LeafLayerMaintenanceRespiration + + ! ==================================================================================== + + subroutine LeafLayerBiophysicalRates( parsun_lsl, & + ft, & + vcmax25top_ft, & + jmax25top_ft, & + tpu25top_ft, & + co2_rcurve_islope25top_ft, & + nscaler, & + veg_tempk, & + btran, & + vcmax, & + jmax, & + tpu, & + co2_rcurve_islope ) + + ! --------------------------------------------------------------------------------- + ! This subroutine calculates the localized rates of several key photosynthesis + ! rates. By localized, we mean specific to the plant type and leaf layer, + ! which factors in leaf physiology, as well as environmental effects. + ! This procedure should be called prior to iterative solvers, and should + ! have pre-calculated the reference rates for the pfts before this. + ! + ! The output biophysical rates are: + ! vcmax: maximum rate of carboxilation, + ! jmax: maximum electron transport rate, + ! tpu: triose phosphate utilization rate and + ! co2_rcurve_islope: initial slope of CO2 response curve (C4 plants) + ! --------------------------------------------------------------------------------- + + use pftconMod , only : pftcon + use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm + + ! Arguments + ! ------------------------------------------------------------------------------ + + real(r8), intent(in) :: parsun_lsl ! PAR absorbed in sunlit leaves for this layer + integer, intent(in) :: ft ! (plant) Functional Type Index + real(r8), intent(in) :: nscaler ! Scale for leaf nitrogen profile + real(r8), intent(in) :: vcmax25top_ft ! canopy top maximum rate of carboxylation at 25C + ! for this pft (umol CO2/m**2/s) + real(r8), intent(in) :: jmax25top_ft ! canopy top maximum electron transport rate at 25C + ! for this pft (umol electrons/m**2/s) + real(r8), intent(in) :: tpu25top_ft ! canopy top triose phosphate utilization rate at 25C + ! for this pft (umol CO2/m**2/s) + real(r8), intent(in) :: co2_rcurve_islope25top_ft ! initial slope of CO2 response curve + ! (C4 plants) at 25C, canopy top, this pft + real(r8), intent(in) :: veg_tempk ! vegetation temperature + real(r8), intent(in) :: btran ! transpiration wetness factor (0 to 1) + + real(r8), intent(out) :: vcmax ! maximum rate of carboxylation (umol co2/m**2/s) + real(r8), intent(out) :: jmax ! maximum electron transport rate (umol electrons/m**2/s) + real(r8), intent(out) :: tpu ! triose phosphate utilization rate (umol CO2/m**2/s) + real(r8), intent(out) :: co2_rcurve_islope ! initial slope of CO2 response curve (C4 plants) + + ! Locals + ! ------------------------------------------------------------------------------- + real(r8) :: vcmax25 ! leaf layer: maximum rate of carboxylation at 25C (umol CO2/m**2/s) + real(r8) :: jmax25 ! leaf layer: maximum electron transport rate at 25C (umol electrons/m**2/s) + real(r8) :: tpu25 ! leaf layer: triose phosphate utilization rate at 25C (umol CO2/m**2/s) + real(r8) :: co2_rcurve_islope25 ! leaf layer: Initial slope of CO2 response curve (C4 plants) at 25C + + + ! Parameters + ! --------------------------------------------------------------------------------- + real(r8), parameter :: vcmaxha = 65330._r8 ! activation energy for vcmax (J/mol) + real(r8), parameter :: jmaxha = 43540._r8 ! activation energy for jmax (J/mol) + real(r8), parameter :: tpuha = 53100._r8 ! activation energy for tpu (J/mol) + real(r8), parameter :: vcmaxhd = 149250._r8 ! deactivation energy for vcmax (J/mol) + real(r8), parameter :: jmaxhd = 152040._r8 ! deactivation energy for jmax (J/mol) + real(r8), parameter :: tpuhd = 150650._r8 ! deactivation energy for tpu (J/mol) + real(r8), parameter :: vcmaxse = 485._r8 ! entropy term for vcmax (J/mol/K) + real(r8), parameter :: jmaxse = 495._r8 ! entropy term for jmax (J/mol/K) + real(r8), parameter :: tpuse = 490._r8 ! entropy term for tpu (J/mol/K) + real(r8), parameter :: vcmaxc = 1.1534040_r8 ! scaling factor for high temperature inhibition (25 C = 1.0) + real(r8), parameter :: jmaxc = 1.1657242_r8 ! scaling factor for high temperature inhibition (25 C = 1.0) + real(r8), parameter :: tpuc = 1.1591239_r8 ! scaling factor for high temperature inhibition (25 C = 1.0) + + if ( parsun_lsl <= 0._r8) then ! night time + vcmax = 0._r8 + jmax = 0._r8 + tpu = 0._r8 + co2_rcurve_islope = 0._r8 + else ! day time + vcmax25 = vcmax25top_ft * nscaler + jmax25 = jmax25top_ft * nscaler + tpu25 = tpu25top_ft * nscaler + co2_rcurve_islope25 = co2_rcurve_islope25top_ft * nscaler + + ! Adjust for temperature + vcmax = vcmax25 * ft1_f(veg_tempk, vcmaxha) * fth_f(veg_tempk, vcmaxhd, vcmaxse, vcmaxc) + jmax = jmax25 * ft1_f(veg_tempk, jmaxha) * fth_f(veg_tempk, jmaxhd, jmaxse, jmaxc) + tpu = tpu25 * ft1_f(veg_tempk, tpuha) * fth_f(veg_tempk, tpuhd, tpuse, tpuc) + + if (nint(pftcon%c3psn(ft)) /= 1) then + vcmax = vcmax25 * 2._r8**((veg_tempk-(tfrz+25._r8))/10._r8) + vcmax = vcmax / (1._r8 + exp( 0.2_r8*((tfrz+15._r8)-veg_tempk ) )) + vcmax = vcmax / (1._r8 + exp( 0.3_r8*(veg_tempk-(tfrz+40._r8)) )) + end if + co2_rcurve_islope = co2_rcurve_islope25 * 2._r8**((veg_tempk-(tfrz+25._r8))/10._r8) !q10 response of product limited psn. + end if + + ! Adjust for water limitations + vcmax = vcmax * btran + + return + end subroutine LeafLayerBiophysicalRates + + + end module EDPhotosynthesisMod From 14cda7a0f3d7e63ea01ce152df4eff284ae3fa5f Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 2 Dec 2016 00:05:39 -0800 Subject: [PATCH 254/437] Turns out sapwood in photosynthesis is sometimes out of phase with that which calculated in the dynamics time-step. I removed the check during photosynthesis. --- biogeochem/EDCohortDynamicsMod.F90 | 1 - biogeophys/EDPhotosynthesisMod.F90 | 33 +++++++++++++----------------- 2 files changed, 14 insertions(+), 20 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index cdca9ec6..229f4ef9 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -236,7 +236,6 @@ subroutine allocate_live_biomass(cc_p,mode) currentcohort%bsw = EDecophyscon%sapwood_ratio(ft) * currentcohort%hite *(currentcohort%balive + & currentcohort%laimemory)*leaf_frac - else ! Leaves are on (leaves_off_switch==1) !the purpose of this section is to figure out the root and stem biomass when the leaves are off diff --git a/biogeophys/EDPhotosynthesisMod.F90 b/biogeophys/EDPhotosynthesisMod.F90 index f1dfe07a..c0414b78 100644 --- a/biogeophys/EDPhotosynthesisMod.F90 +++ b/biogeophys/EDPhotosynthesisMod.F90 @@ -238,7 +238,7 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) ! currentPatch%present(:,:) call UpdateCanopyNCanNRadPresent(currentPatch) - + ! Part IV. Identify some environmentally derived parameters: ! These quantities are biologically irrelevant ! Michaelis-Menten constant for CO2 (Pa) @@ -267,9 +267,10 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) do FT = 1,numpft_ed !calculate patch and pft specific properties at canopy top. + ! Leaf nitrogen concentration at the top of the canopy (g N leaf / m**2 leaf) lnc = 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... @@ -342,7 +343,8 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) btran_eff = currentPatch%btran_ft(ft) !! end if - vai = (currentPatch%elai_profile(CL,FT,iv)+currentPatch%esai_profile(CL,FT,iv)) !vegetation area index. + ! Vegetation area index + vai = (currentPatch%elai_profile(CL,FT,iv)+currentPatch%esai_profile(CL,FT,iv)) if (iv == 1) then laican = laican + 0.5_r8 * vai else @@ -352,14 +354,13 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) ! Scale for leaf nitrogen profile nscaler = exp(-kn(FT) * laican) - + call LeafLayerMaintenanceRespiration( lmr25top(ft), & ! in nscaler, & ! in ft, & ! in bc_in(s)%t_veg_pa(ifp), & ! in lmr_z(CL,FT,iv)) ! out - call LeafLayerBiophysicalRates(currentPatch%ed_parsun_z(CL,FT,iv), & ! in ft, & ! in vcmax25top(ft), & ! in @@ -410,7 +411,6 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) enddo !PFT enddo !CL - !==============================================================================! ! Unpack fluxes from arrays into cohorts !==============================================================================! @@ -418,11 +418,11 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) call currentPatch%set_root_fraction(bc_in(s)%depth_gl) if(currentPatch%countcohorts > 0.0)then !avoid errors caused by empty patches - + currentCohort => currentPatch%tallest ! Cohort loop - + do while (associated(currentCohort)) ! Cohort loop - + if(currentCohort%n > 0._r8)then ! Zero cohort flux accumulators. @@ -435,6 +435,7 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) ! 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. !------------------------------------------------------------------------------ @@ -498,20 +499,14 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) leaf_frac = 1.0_r8/(currentCohort%canopy_trim + EDecophyscon%sapwood_ratio(currentCohort%pft) * & currentCohort%hite + pftcon%froot_leaf(currentCohort%pft)) - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! THIS CALCULATION SHOULD BE MOVED TO THE ALLOMETRY MODULE (RGK 10-8-2016) ! ------ IT ALSO SHOULD ALREADY HAVE BEEN CALCULATED RIGHT? ! ------ CHANGING TO A CHECK ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - if ( abs(currentCohort%bsw - (EDecophyscon%sapwood_ratio(currentCohort%pft) * & - currentCohort%hite * (currentCohort%balive + currentCohort%laimemory)*leaf_frac) ) & - > 1e-9 ) then - write(fates_log(),*) 'Sapwood biomass calculated during photosynthesis' - write(fates_log(),*) 'does not match what is contained in cohort%bsw' - write(fates_log(),*) 'which is the prognostic variable. Stopping.' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if + currentCohort%bsw = EDecophyscon%sapwood_ratio(currentCohort%pft) * & + currentCohort%hite * (currentCohort%balive + currentCohort%laimemory)*leaf_frac + ! Calculate the amount of nitrogen in the above and below ground ! stem and root pools, used for maint resp @@ -641,7 +636,7 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) end if currentPatch => currentPatch%younger - + end do end do !site loop From 0c851895303bfd3d23fed353ff56ef692bd2162e Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 2 Dec 2016 12:36:42 -0800 Subject: [PATCH 255/437] Added some documentation to the photosynthesis refactoring. --- biogeophys/EDPhotosynthesisMod.F90 | 58 +++++++++++++++++------------- 1 file changed, 34 insertions(+), 24 deletions(-) diff --git a/biogeophys/EDPhotosynthesisMod.F90 b/biogeophys/EDPhotosynthesisMod.F90 index c0414b78..66260d66 100644 --- a/biogeophys/EDPhotosynthesisMod.F90 +++ b/biogeophys/EDPhotosynthesisMod.F90 @@ -1,11 +1,10 @@ -module EDPhotosynthesisMod +module FATESPhotosynthesisMod - !------------------------------------------------------------------------------ + !------------------------------------------------------------------------------------- ! !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. + ! Calculates the photosynthetic fluxes for the FATES model + ! This code is similar to and was originally based off of the 'photosynthesis' + ! subroutine in the CLM model. ! ! Parameter for activation and deactivation energies were taken from: ! Activation energy, from: @@ -18,7 +17,6 @@ module EDPhotosynthesisMod ! ------------------------------------------------------------------------------------ ! !USES: - ! use abortutils, only : endrun use FatesGlobals, only : fates_log @@ -309,17 +307,24 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) end do !FT + ! ------------------------------------------------------------------------ + ! Part VI: Loop over all leaf layers. + ! The concept of leaf layers is a result of the radiative transfer scheme. + ! A leaf layer has uniform radiation environment. Leaf layers are a group + ! of vegetation surfaces (stems and leaves) which inhabit the same + ! canopy-layer "CL", have the same functional type "ft" and within those + ! two partitions are further partitioned into vertical layers where + ! downwelling radiation attenuates in order. + ! In this phase we loop over the leaf layers and calculate the + ! photosynthesis and respiration of the layer (since all biophysical + ! properties are homogeneous). After this step, we can loop through + ! our cohort list, associate each cohort with its list of leaf-layers + ! and transfer these quantities to the cohort. + ! With plant hydraulics, we must realize that photosynthesis and + ! respiration will be different for leaves of each cohort in the leaf + ! layers, as they will have there own hydraulic limitations. + ! ------------------------------------------------------------------------ - ! If we are using plant hydro-dynamics, then several photosynthesis - ! variables will be available at the cohort scale, and not the - ! pft scale. So here we split and use different looping structures - ! ------------------------------------------------------------------ - ! if ( use_fates_plant_hydro ) - - - !==============================================================================! - ! Calculate Nitrogen scaling factors and photosynthetic parameters. - !==============================================================================! do CL = 1, NCL_p do FT = 1,numpft_ed @@ -412,7 +417,10 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) enddo !CL !==============================================================================! - ! Unpack fluxes from arrays into cohorts + ! Part VII: Transfer leaf biophysical rates (like maintenance respiration, + ! carbon assimilation and conductance) that are defined by the leaf layer + ! (which is area independent, ie /m2) onto each cohort (where the rates become + ! per cohort, ie /individual). !==============================================================================! call currentPatch%set_root_fraction(bc_in(s)%depth_gl) @@ -499,11 +507,13 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) leaf_frac = 1.0_r8/(currentCohort%canopy_trim + EDecophyscon%sapwood_ratio(currentCohort%pft) * & currentCohort%hite + pftcon%froot_leaf(currentCohort%pft)) - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! THIS CALCULATION SHOULD BE MOVED TO THE ALLOMETRY MODULE (RGK 10-8-2016) - ! ------ IT ALSO SHOULD ALREADY HAVE BEEN CALCULATED RIGHT? - ! ------ CHANGING TO A CHECK - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + ! ------------------------------------------------------------------ + ! Part VIII: Calculate maintenance respiration in the sapwood and + ! fine root pools. + ! ------------------------------------------------------------------ + + currentCohort%bsw = EDecophyscon%sapwood_ratio(currentCohort%pft) * & currentCohort%hite * (currentCohort%balive + currentCohort%laimemory)*leaf_frac @@ -1471,4 +1481,4 @@ end subroutine LeafLayerBiophysicalRates -end module EDPhotosynthesisMod +end module FATESPhotosynthesisMod From 606998a9429e3db84257baf97812a2ea394e7e78 Mon Sep 17 00:00:00 2001 From: Rosie Fisher Date: Fri, 2 Dec 2016 14:59:40 -0700 Subject: [PATCH 256/437] first two non answer changing diffs. (nignitions and patch_area_in_m2) --- fire/SFMainMod.F90 | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index be53100a..490d25b5 100755 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -636,7 +636,7 @@ subroutine area_burnt ( currentSite ) !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 + use EDParamsMod, only : ED_val_nignitions use PatchType, only : patch type(ed_site_type), intent(inout), target :: currentSite @@ -690,7 +690,7 @@ subroutine area_burnt ( currentSite ) ! THIS SHOULD HAVE THE COLUMN AND LU AREA WEIGHT ALSO, NO? gridarea = ldomain%area(g) *1000000.0_r8 !convert from km2 into m2 - currentPatch%NF = ldomain%area(g) * ED_val_nfires * currentPatch%area/area /365 + currentPatch%NF = ldomain%area(g) * ED_val_nignitions * 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. @@ -700,19 +700,23 @@ subroutine area_burnt ( currentSite ) ! 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)) + + ! area of fires in m2. currentPatch%AB = size_of_fire * currentPatch%nf - if (currentPatch%AB > gridarea*currentPatch%area/area) then !all of patch burnt. + + patch_area_in_m2 = gridarea*currentPatch%area/area + if (currentPatch%AB > patch_area_in_m2 ) then !all of patch burnt. if (masterproc) write(iulog,*) 'burnt all of patch',currentPatch%patchno, & - currentPatch%area/area,currentPatch%ab,currentPatch%area/area*gridarea + currentPatch%area/area,currentPatch%ab,patch_area_in_m2 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 + currentPatch%AB = patch_area_in_m2 endif - currentPatch%frac_burnt = currentPatch%AB / (gridarea*currentPatch%area/area) + currentPatch%frac_burnt = currentPatch%AB / patch_area_in_m2 if(write_SF == 1)then if (masterproc) write(iulog,*) 'frac_burnt',currentPatch%frac_burnt endif From 6fe1c217ac90527e68ba07b9adbcd1183b6a4fa5 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 2 Dec 2016 17:48:39 -0800 Subject: [PATCH 257/437] Modified the looping structure in photosynthesis to accomodate leaf layer variability at the cohort and pft level. Also modularized the scaling of leaf-level fluxes back to cohorts. --- biogeophys/EDPhotosynthesisMod.F90 | 529 ++++++++++++++++------------- main/EDTypesMod.F90 | 10 + 2 files changed, 311 insertions(+), 228 deletions(-) diff --git a/biogeophys/EDPhotosynthesisMod.F90 b/biogeophys/EDPhotosynthesisMod.F90 index 66260d66..33d1a210 100644 --- a/biogeophys/EDPhotosynthesisMod.F90 +++ b/biogeophys/EDPhotosynthesisMod.F90 @@ -22,13 +22,14 @@ module FATESPhotosynthesisMod use FatesGlobals, only : fates_log use FatesConstantsMod, only : r8 => fates_r8 use shr_log_mod , only : errMsg => shr_log_errMsg + use EDTypesMod, only : use_fates_plant_hydro implicit none private ! PUBLIC MEMBER FUNCTIONS: - public :: Photosynthesis_ED !ED specific photosynthesis routine + public :: FATESPhotosynthesis !ED specific photosynthesis routine character(len=*), parameter, private :: sourcefile = & __FILE__ @@ -42,7 +43,7 @@ module FATESPhotosynthesisMod contains !--------------------------------------------------------- - subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) + subroutine FATESPhotosynthesis (nsites, sites,bc_in,bc_out,dtime) ! @@ -62,7 +63,7 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) use EDParamsMod , only : ED_val_ag_biomass use EDSharedParamsMod , only : EDParamsShareInst use EDTypesMod , only : numpft_ed - use EDTypesMod , only : dinc_ed + use EDTypesMod , only : ed_patch_type use EDTypesMod , only : ed_cohort_type use EDTypesMod , only : ed_site_type @@ -100,36 +101,45 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) ! ----------------------------------------------------------------------------------- type (ed_patch_type) , pointer :: currentPatch type (ed_cohort_type), pointer :: currentCohort - integer , parameter :: psn_type = 2 !c3 or c4. + ! ----------------------------------------------------------------------------------- + ! These three arrays hold leaf-level biophysical rates that are calculated + ! in one loop and then sent to the cohorts in another loop. If hydraulics are + ! on, we calculate a unique solution for each level-cohort-layer combination. + ! If we are not using hydraulics, we calculate a unique solution for each + ! level-pft-layer combination. Thus the following three arrays are statically + ! allocated for the maximum space of the two cases (numCohortsPerPatch) + ! ----------------------------------------------------------------------------------- + + ! leaf maintenance (dark) respiration + real(r8) :: lmr_z(cp_nclmax,mxpft,cp_nlevcan) - real(r8) :: btran_eff ! effective transpiration wetness factor (0 to 1) - ! either from cohort or patch-pft - ! - ! Leaf photosynthesis parameters - ! Note: None of these variables need to be an array. We put them - ! in arrays only to enable user debugging diagnostics - real(r8) :: vcmax_z(cp_nclmax,mxpft,cp_nlevcan) ! maximum rate of carboxylation (umol co2/m**2/s) - real(r8) :: jmax_z(cp_nclmax,mxpft,cp_nlevcan) ! maximum electron transport rate (umol electrons/m**2/s) - real(r8) :: tpu_z(cp_nclmax,mxpft,cp_nlevcan) ! triose phosphate utilization rate (umol CO2/m**2/s) - real(r8) :: kp_z(cp_nclmax,mxpft,cp_nlevcan) ! initial slope of CO2 response curve (C4 plants) - real(r8) :: lmr_z(cp_nclmax,mxpft,cp_nlevcan) ! initial slope of CO2 response curve (C4 plants) - real(r8) :: rs_z(cp_nclmax,mxpft,cp_nlevcan) ! stomatal resistance s/m - real(r8) :: gs_z(cp_nclmax,mxpft,cp_nlevcan) ! stomatal conductance m/s - real(r8) :: anet_av(cp_nclmax,mxpft,cp_nlevcan) ! net leaf photosynthesis (umol CO2/m**2/s) - ! averaged over sun and shade leaves. + ! stomatal resistance s/m + real(r8) :: rs_z(cp_nclmax,mxpft,cp_nlevcan) + + ! net leaf photosynthesis averaged over sun and shade leaves. (umol CO2/m**2/s) + real(r8) :: anet_av(cp_nclmax,mxpft,cp_nlevcan) + + ! Mask used to determine which leaf-layer biophysical rates have been + ! used already + logical :: rate_mask(cp_nclmax,mxpft,cp_nlevcan) + + real(r8) :: vcmax_z ! leaf layer maximum rate of carboxylation (umol co2/m**2/s) + real(r8) :: jmax_z ! leaf layer maximum electron transport rate (umol electrons/m**2/s) + real(r8) :: tpu_z ! leaf layer triose phosphate utilization rate (umol CO2/m**2/s) + real(r8) :: kp_z ! leaf layer initial slope of CO2 response curve (C4 plants) real(r8) :: lnc ! leaf N concentration (gN leaf/m^2) real(r8) :: mm_kco2 ! Michaelis-Menten constant for CO2 (Pa) real(r8) :: mm_ko2 ! Michaelis-Menten constant for O2 (Pa) real(r8) :: co2_cpoint ! CO2 compensation point (Pa) + real(r8) :: btran_eff ! effective transpiration wetness factor (0 to 1) ! --------------------------------------------------------------- ! TO-DO: bbbopt is slated to be transferred to the parameter file ! ---------------------------------------------------------------- real(r8) :: bbbopt(psn_type) ! Ball-Berry minimum leaf conductance, unstressed (umol H2O/m**2/s) real(r8) :: bbb ! Ball-Berry minimum leaf conductance (umol H2O/m**2/s) - 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) @@ -139,27 +149,22 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) ! Other integer :: cl,s,iv,j,ps,ft,ifp ! indices + integer :: nv ! number of leaf layers integer :: NCL_p ! number of canopy layers in patch real(r8) :: cf ! s m**2/umol -> s/m real(r8) :: gb_mol ! leaf boundary layer conductance (umol H2O/m**2/s) real(r8) :: ceair ! vapor pressure of air, constrained (Pa) real(r8) :: nscaler ! leaf nitrogen scaling coefficient real(r8) :: leaf_frac ! ratio of to leaf biomass to total alive biomass -! 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. - real(r8) :: laifrac real(r8) :: tcsoi ! Temperature response function for root respiration. real(r8) :: tcwood ! Temperature response function for wood - -! real(r8) :: coarse_wood_frac ! amount of woody biomass that is coarse... real(r8) :: tree_area real(r8) :: gs_cohort real(r8) :: rscanopy real(r8) :: elai - real(r8) :: live_stem_n ! Live stem (above-ground sapwood) nitrogen content (kgN/plant) real(r8) :: live_croot_n ! Live coarse root (below-ground sapwood) nitrogen content (kgN/plant) real(r8) :: froot_n ! Fine root nitrogen content (kgN/plant) @@ -178,6 +183,9 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) real(r8),parameter :: base_mr_20 = 2.525e-6_r8 + + + associate( & c3psn => pftcon%c3psn , & slatop => pftcon%slatop , & ! specific leaf area at top of canopy, projected area basis [m^2/gC] @@ -307,6 +315,9 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) end do !FT + call currentPatch%set_root_fraction(bc_in(s)%depth_gl) + + ! ------------------------------------------------------------------------ ! Part VI: Loop over all leaf layers. ! The concept of leaf layers is a result of the radiative transfer scheme. @@ -324,49 +335,74 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) ! respiration will be different for leaves of each cohort in the leaf ! layers, as they will have there own hydraulic limitations. ! ------------------------------------------------------------------------ + rate_mask(:,:,:) = .false. - do CL = 1, NCL_p - do FT = 1,numpft_ed + if(currentPatch%countcohorts > 0.0)then ! Ignore empty patches + + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) ! Cohort loop + + ! Identify the canopy layer (CL), functional type (FT) + ! and the leaf layer (IV) for this cohort + FT = currentCohort%pft + CL = currentCohort%canopy_layer 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) - - !! if (use_fates_plant_hydro) then - !! !! bbb = max (bbbopt(ps)*currentCohort%btran(iv), 1._r8) - !! !! btran = currentCohort%btran(iv) - !! else - bbb = max (bbbopt(nint(c3psn(ft)))*currentPatch%btran_ft(FT), 1._r8) - btran_eff = currentPatch%btran_ft(ft) - !! end if - - ! Vegetation area index - vai = (currentPatch%elai_profile(CL,FT,iv)+currentPatch%esai_profile(CL,FT,iv)) - 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 + + ! Loop over sublayers, only calculate the leaf-layers biophysical rates + ! if this unique set has not been calculated + ! In non-hydraulic runs, many cohorts of the same pft may share the + ! same leaf layer and the properties will be the same. + ! We will ignore these + + do iv = 1,currentCohort%nv - ! Scale for leaf nitrogen profile - nscaler = exp(-kn(FT) * laican) - - call LeafLayerMaintenanceRespiration( lmr25top(ft), & ! in + ! ----------------------------------------------------------- + ! If we are doing plant hydro-dynamics (or any run-type + ! where cohorts may generate different photosynthetic rates + ! of other cohorts in the same canopy-pft-layer combo), + ! we re-calculate the leaf biophysical rates for the + ! cohort-layer combo of interest. + ! but in the vanilla case, we only re-calculate if it has + ! not been done yet. + ! ----------------------------------------------------------- + + if ( .not.rate_mask(ft,cl,iv) .or. use_fates_plant_hydro ) then + + if (use_fates_plant_hydro) then + !! !! bbb = max (bbbopt(ps)*currentCohort%btran(iv), 1._r8) + !! !! btran = currentCohort%btran(iv) + else + bbb = max (bbbopt(nint(c3psn(ft)))*currentPatch%btran_ft(FT), 1._r8) + btran_eff = currentPatch%btran_ft(ft) + end if + + ! Vegetation area index + vai = (currentPatch%elai_profile(CL,FT,iv)+currentPatch%esai_profile(CL,FT,iv)) + 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) + + + call LeafLayerMaintenanceRespiration( lmr25top(ft), & ! in nscaler, & ! in ft, & ! in bc_in(s)%t_veg_pa(ifp), & ! in lmr_z(CL,FT,iv)) ! out - call LeafLayerBiophysicalRates(currentPatch%ed_parsun_z(CL,FT,iv), & ! in + call LeafLayerBiophysicalRates(currentPatch%ed_parsun_z(CL,FT,iv), & ! in ft, & ! in vcmax25top(ft), & ! in jmax25top(ft), & ! in @@ -375,12 +411,12 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) nscaler, & ! in bc_in(s)%t_veg_pa(ifp), & ! in btran_eff, & ! in - vcmax_z(CL,FT,iv), & ! out - jmax_z(CL,FT,iv), & ! out - tpu_z(CL,FT,iv), & ! out - kp_z(CL,FT,iv) ) ! out + vcmax_z, & ! out + jmax_z, & ! out + tpu_z, & ! out + kp_z ) ! out - call LeafLayerPhotosynthesis(currentPatch%f_sun(CL,FT,iv), & ! in + call LeafLayerPhotosynthesis(currentPatch%f_sun(CL,FT,iv), & ! in currentPatch%ed_parsun_z(CL,FT,iv), & ! in currentPatch%ed_parsha_z(CL,FT,iv), & ! in currentPatch%ed_laisun_z(CL,FT,iv), & ! in @@ -388,10 +424,10 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) currentPatch%canopy_area_profile(CL,FT,iv), & ! in ft, & ! in nscaler, & ! in - vcmax_z(CL,FT,iv), & ! in - jmax_z(CL,FT,iv), & ! in - tpu_z(CL,FT,iv), & ! in - kp_z(CL,FT,iv), & ! in + vcmax_z, & ! in + jmax_z, & ! in + tpu_z, & ! in + kp_z, & ! in bc_in(s)%t_veg_pa(ifp), & ! in bc_in(s)%esat_tv_pa(ifp), & ! in bc_in(s)%forc_pbot, & ! in @@ -409,115 +445,71 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) currentPatch%psn_z(cl,ft,iv), & ! out rs_z(CL,FT,iv), & ! out anet_av(CL,FT,iv)) ! out - - - end do ! iv - end if !present - enddo !PFT - enddo !CL - !==============================================================================! - ! Part VII: Transfer leaf biophysical rates (like maintenance respiration, - ! carbon assimilation and conductance) that are defined by the leaf layer - ! (which is area independent, ie /m2) onto each cohort (where the rates become - ! per cohort, ie /individual). - !==============================================================================! - - call currentPatch%set_root_fraction(bc_in(s)%depth_gl) - - if(currentPatch%countcohorts > 0.0)then !avoid errors caused by empty patches - - currentCohort => currentPatch%tallest ! Cohort loop - - do while (associated(currentCohort)) ! Cohort loop - - if(currentCohort%n > 0._r8)then - - ! Zero cohort flux accumulators. - currentCohort%npp_tstep = 0.0_r8 - currentCohort%resp_tstep = 0.0_r8 - currentCohort%gpp_tstep = 0.0_r8 - currentCohort%rdark = 0.0_r8 - currentCohort%resp_m = 0.0_r8 - - ! 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 ( DEBUG ) write(fates_log(),*) 'EDPhoto 816 ', currentCohort%gpp_tstep - if ( DEBUG ) write(fates_log(),*) 'EDPhoto 817 ', currentPatch%psn_z(cl,ft,1:currentCohort%nv-1) - if ( DEBUG ) write(fates_log(),*) 'EDPhoto 818 ', cl - if ( DEBUG ) write(fates_log(),*) 'EDPhoto 819 ', ft - if ( DEBUG ) write(fates_log(),*) 'EDPhoto 820 ', currentCohort%nv - if ( DEBUG ) write(fates_log(),*) 'EDPhoto 821 ', currentPatch%elai_profile(cl,ft,1:currentCohort%nv-1) - - if (currentCohort%nv > 1) then !is there canopy, and are the leaves on? - - currentCohort%gpp_tstep = sum(currentPatch%psn_z(cl,ft,1:currentCohort%nv-1) * & - currentPatch%elai_profile(cl,ft,1:currentCohort%nv-1)) * tree_area - - currentCohort%rdark = 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)+bc_in(s)%rb_pa(ifp)))) * tree_area - currentCohort%ts_net_uptake(1:currentCohort%nv) = anet_av(cl,ft,1:currentCohort%nv) * umolC_to_kgC * dtime + rate_mask(ft,cl,iv) = .true. + end if + end do + + ! Zero cohort flux accumulators. + currentCohort%npp_tstep = 0.0_r8 + currentCohort%resp_tstep = 0.0_r8 + currentCohort%gpp_tstep = 0.0_r8 + currentCohort%rdark = 0.0_r8 + currentCohort%resp_m = 0.0_r8 + currentCohort%ts_net_uptake = 0.0_r8 + + ! --------------------------------------------------------------- + ! Part VII: Transfer leaf flux rates (like maintenance respiration, + ! carbon assimilation and conductance) that are defined by the leaf layer + ! (which is area independent, ie /m2) onto each cohort (where the rates become + ! per cohort, ie /individual). Most likely a sum over layers. + ! --------------------------------------------------------------- + nv = currentCohort%nv + call ScaleLeafLayerFluxToCohort(nv, & !in + currentPatch%psn_z(cl,ft,1:nv), & !in + lmr_z(cl,ft,1:nv), & !in + rs_z(cl,ft,1:nv), & !in + anet_av(cl,ft,1:nv), & !in + currentPatch%elai_profile(cl,ft,1:nv), & !in + currentCohort%c_area, & !in + currentCohort%n, & !in + currentCohort%treelai, & !in + currentCohort%treesai, & !in + bc_in(s)%rb_pa(ifp), & !in + currentCohort%gscan, & ! out + currentCohort%gpp_tstep, & ! out + currentCohort%rdark) ! out + + ! Net Uptake does not need to be scaled, just transfer directly + currentCohort%ts_net_uptake(1:nv) = anet_av(cl,ft,1:nv) * umolC_to_kgC else - + + ! In this case, the cohort had no leaves, + ! so no productivity,conductance, transpiration uptake + ! or dark respiration + currentCohort%gpp_tstep = 0.0_r8 currentCohort%rdark = 0.0_r8 currentCohort%gscan = 0.0_r8 currentCohort%ts_net_uptake(:) = 0.0_r8 - - end if - - if ( DEBUG ) write(fates_log(),*) 'EDPhoto 832 ', currentCohort%gpp_tstep - - laifrac = (currentCohort%treelai+currentCohort%treesai)-(currentCohort%nv-1)*dinc_ed - - gs_cohort = 1.0_r8/(rs_z(cl,ft,currentCohort%nv)+bc_in(s)%rb_pa(ifp))*laifrac*tree_area - currentCohort%gscan = currentCohort%gscan+gs_cohort - - if ( DEBUG ) then - write(fates_log(),*) 'EDPhoto 868 ', currentCohort%gpp_tstep - write(fates_log(),*) 'EDPhoto 869 ', currentPatch%psn_z(cl,ft,currentCohort%nv) - write(fates_log(),*) 'EDPhoto 870 ', currentPatch%elai_profile(cl,ft,currentCohort%nv) - write(fates_log(),*) 'EDPhoto 871 ', laifrac - write(fates_log(),*) 'EDPhoto 872 ', tree_area - write(fates_log(),*) 'EDPhoto 873 ', currentCohort%nv, cl, ft - endif - - currentCohort%gpp_tstep = currentCohort%gpp_tstep + currentPatch%psn_z(cl,ft,currentCohort%nv) * & - currentPatch%elai_profile(cl,ft,currentCohort%nv) * laifrac * tree_area - - if ( DEBUG ) write(fates_log(),*) 'EDPhoto 843 ', currentCohort%rdark - - - currentCohort%rdark = currentCohort%rdark + lmr_z(cl,ft,currentCohort%nv) * & - currentPatch%elai_profile(cl,ft,currentCohort%nv) * laifrac * tree_area - - ! Convert dark respiration from umol/plant/s to kgC/plant/s - currentCohort%rdark = currentCohort%rdark * umolC_to_kgC - - leaf_frac = 1.0_r8/(currentCohort%canopy_trim + EDecophyscon%sapwood_ratio(currentCohort%pft) * & - currentCohort%hite + pftcon%froot_leaf(currentCohort%pft)) - + + end if ! if(currentPatch%present(CL,FT) == 1)then + ! ------------------------------------------------------------------ ! Part VIII: Calculate maintenance respiration in the sapwood and ! fine root pools. ! ------------------------------------------------------------------ - - + + 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%hite * (currentCohort%balive + currentCohort%laimemory)*leaf_frac + + ! Calculate the amount of nitrogen in the above and below ground ! stem and root pools, used for maint resp ! We are using the fine-root C:N ratio as an approximation for @@ -529,13 +521,13 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) live_croot_n = (1.0_r8-ED_val_ag_biomass) * currentCohort%bsw / & frootcn(currentCohort%pft) froot_n = currentCohort%br / frootcn(currentCohort%pft) - - + + !------------------------------------------------------------------------------ ! 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. !------------------------------------------------------------------------------ - + ! Live stem MR (kgC/plant/s) (above ground sapwood) ! ------------------------------------------------------------------ if (woody(ft) == 1) then @@ -545,8 +537,8 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) else currentCohort%livestem_mr = 0._r8 end if - - + + ! Fine Root MR (kgC/plant/s) ! ------------------------------------------------------------------ currentCohort%froot_mr = 0._r8 @@ -555,7 +547,7 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) currentCohort%froot_mr = currentCohort%froot_mr + & froot_n * base_mr_20 * tcsoi * currentPatch%rootfr_ft(ft,j) enddo - + ! Coarse Root MR (kgC/plant/s) (below ground sapwood) ! ------------------------------------------------------------------ if (woody(ft) == 1) then @@ -570,90 +562,73 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) else currentCohort%livecroot_mr = 0._r8 end if - + ! convert gpp from umol/indiv/s-1 to kgC/indiv/s-1 = X * 12 *10-6 * 10-3 - + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 904 ', currentCohort%resp_m if ( DEBUG ) write(fates_log(),*) 'EDPhoto 905 ', currentCohort%rdark if ( DEBUG ) write(fates_log(),*) 'EDPhoto 906 ', currentCohort%livestem_mr if ( DEBUG ) write(fates_log(),*) 'EDPhoto 907 ', currentCohort%livecroot_mr if ( DEBUG ) write(fates_log(),*) 'EDPhoto 908 ', currentCohort%froot_mr + + - currentCohort%gpp_tstep = currentCohort%gpp_tstep * umolC_to_kgC ! 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%rdark - + ! convert from kgC/indiv/s to kgC/indiv/timestep - currentCohort%resp_m = currentCohort%resp_m * dtime - currentCohort%gpp_tstep = currentCohort%gpp_tstep * dtime + currentCohort%resp_m = currentCohort%resp_m * dtime + currentCohort%gpp_tstep = currentCohort%gpp_tstep * dtime + currentCohort%ts_net_uptake = currentCohort%ts_net_uptake * dtime + + + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 911 ', currentCohort%gpp_tstep if ( DEBUG ) write(fates_log(),*) 'EDPhoto 912 ', currentCohort%resp_tstep if ( DEBUG ) write(fates_log(),*) 'EDPhoto 913 ', currentCohort%resp_m - + currentCohort%resp_g = ED_val_grperc(ft) * (max(0._r8,currentCohort%gpp_tstep - currentCohort%resp_m)) currentCohort%resp_tstep = currentCohort%resp_m + currentCohort%resp_g ! kgC/indiv/ts currentCohort%npp_tstep = currentCohort%gpp_tstep - currentCohort%resp_tstep ! 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_tstep = 0._r8 - currentCohort%resp_m = 0._r8 - currentCohort%gscan = 0._r8 - end if - else !pft<0 n<0 - write(fates_log(),*) 'CF: pft 0 or n 0',currentCohort%pft,currentCohort%n,currentCohort%indexnumber - currentCohort%gpp_tstep = 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 - - bc_out(s)%psncanopy_pa(ifp) = bc_out(s)%psncanopy_pa(ifp) + currentCohort%gpp_tstep - bc_out(s)%lmrcanopy_pa(ifp) = bc_out(s)%lmrcanopy_pa(ifp) + currentCohort%resp_m - ! accumulate cohort level canopy conductances over whole area before dividing by total area. - bc_out(s)%gccanopy_pa(ifp) = bc_out(s)%gccanopy_pa(ifp) + currentCohort%gscan * & - currentCohort%n /currentPatch%total_canopy_area - - currentCohort => currentCohort%shorter - - enddo ! end cohort loop. - end if !count_cohorts is more than zero. + + bc_out(s)%psncanopy_pa(ifp) = bc_out(s)%psncanopy_pa(ifp) + currentCohort%gpp_tstep + bc_out(s)%lmrcanopy_pa(ifp) = bc_out(s)%lmrcanopy_pa(ifp) + currentCohort%resp_m + ! accumulate cohort level canopy conductances over whole area before dividing by total area. + bc_out(s)%gccanopy_pa(ifp) = bc_out(s)%gccanopy_pa(ifp) + currentCohort%gscan * & + currentCohort%n /currentPatch%total_canopy_area + + currentCohort => currentCohort%shorter + + enddo ! end cohort loop. + end if !count_cohorts is more than zero. + + + elai = calc_areaindex(currentPatch,'elai') + + bc_out(s)%psncanopy_pa(ifp) = bc_out(s)%psncanopy_pa(ifp) / currentPatch%area + bc_out(s)%lmrcanopy_pa(ifp) = bc_out(s)%lmrcanopy_pa(ifp) / currentPatch%area + if(bc_out(s)%gccanopy_pa(ifp) > 1._r8/rsmax0 .and. elai > 0.0_r8)then + rscanopy = (1.0_r8/bc_out(s)%gccanopy_pa(ifp))-bc_in(s)%rb_pa(ifp)/elai ! this needs to be resistance per unit leaf area. + else + rscanopy = rsmax0 + end if + bc_out(s)%rssun_pa(ifp) = rscanopy + bc_out(s)%rssha_pa(ifp) = rscanopy + bc_out(s)%gccanopy_pa(ifp) = 1.0_r8/rscanopy*cf/umol_per_mmol !convert into umol m-2 s-1 then mmol m-2 s-1. + end if + currentPatch => currentPatch%younger - elai = calc_areaindex(currentPatch,'elai') - - bc_out(s)%psncanopy_pa(ifp) = bc_out(s)%psncanopy_pa(ifp) / currentPatch%area - bc_out(s)%lmrcanopy_pa(ifp) = bc_out(s)%lmrcanopy_pa(ifp) / currentPatch%area - if(bc_out(s)%gccanopy_pa(ifp) > 1._r8/rsmax0 .and. elai > 0.0_r8)then - rscanopy = (1.0_r8/bc_out(s)%gccanopy_pa(ifp))-bc_in(s)%rb_pa(ifp)/elai ! this needs to be resistance per unit leaf area. - else - rscanopy = rsmax0 - end if - bc_out(s)%rssun_pa(ifp) = rscanopy - bc_out(s)%rssha_pa(ifp) = rscanopy - bc_out(s)%gccanopy_pa(ifp) = 1.0_r8/rscanopy*cf/umol_per_mmol !convert into umol m-2 s-1 then mmol m-2 s-1. - end if - - currentPatch => currentPatch%younger + end do - end do + end do !site loop - end do !site loop - - end associate -end subroutine Photosynthesis_ED - + end associate + end subroutine FATESPhotosynthesis + ! ======================================================================================= subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in @@ -1018,7 +993,105 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in end associate return end subroutine LeafLayerPhotosynthesis - + +! ======================================================================================= + +subroutine ScaleLeafLayerFluxToCohort(nv, & ! in currentCohort%nv + psn_llz, & ! in %psn_z(cl,ft,1:currentCohort%nv) + lmr_llz, & ! in lmr_z(cl,ft,1:currentCohort%nv) + rs_llz, & ! in rs_z(cl,ft,1:currentCohort%nv) + anet_av_llz, & ! in anet_av_z(cl,ft,1:currentCohort%nv) + elai_llz, & ! in %elai_profile(cl,ft,1:currentCohort%nv) + c_area, & ! in currentCohort%c_area + nplant, & ! in currentCohort%n + treelai, & ! in currentCohort%treelai + treesai, & ! in currentCohort%treesai + rb, & ! in bc_in(s)%rb_pa(ifp) + gscan, & ! out currentCohort%gscan + gpp, & ! out currentCohort%gpp_tstep + rdark) ! out currentCohort%rdark + + ! ------------------------------------------------------------------------------------ + ! This subroutine effectively integrates leaf carbon fluxes over the + ! leaf layers to give cohort totals. + ! Some arguments have the suffix "_llz". This indicates that the vector + ! is stratefied in the leaf-layer (ll) dimension, and is a portion of the calling + ! array which has the "_z" tag, thus "llz". + ! ------------------------------------------------------------------------------------ + + use FatesConstantsMod, only : umolC_to_kgC + use EDTypesMod, only : dinc_ed + + ! Arguments + integer, intent(in) :: nv ! number of active leaf layers + real(r8), intent(in) :: psn_llz(nv) ! umolC/m2leaf/s + real(r8), intent(in) :: lmr_llz(nv) ! umolC/m2leaf/s + real(r8), intent(in) :: rs_llz(nv) ! s/m + real(r8), intent(in) :: anet_av_llz(nv) ! umolC/m2leaf/s + real(r8), intent(in) :: elai_llz(nv) ! exposed LAI per layer + real(r8), intent(in) :: c_area ! crown area m2/m2 + real(r8), intent(in) :: nplant ! indiv/m2 + real(r8), intent(in) :: treelai ! m2/m2 + real(r8), intent(in) :: treesai ! m2/m2 + real(r8), intent(in) :: rb ! boundary layer resistance (s/m) + + real(r8), intent(out) :: gscan ! Canopy conductance of the cohort m/s + real(r8), intent(out) :: gpp ! GPP (kgC/indiv/s) + real(r8), intent(out) :: rdark ! Dark Leaf Respiration (kgC/indiv/s) + + ! GPP IN THIS SUBROUTINE IS A RATE. THE CALLING ARGUMENT IS GPP_TSTEP. AFTER THIS + ! CALL THE RATE WILL BE MULTIPLIED BY THE INTERVAL TO GIVE THE INTEGRATED QUANT. + + + ! Locals + real(r8) :: tree_area + real(r8) :: laifrac + + ! Convert from umolC/m2leaf/s to umolC/indiv/s ( x canopy area x 1m2 leaf area). + tree_area = c_area/nplant + + ! The routine is only called if there are leaves. If there are leaves, + ! there is at least 1 layer + + laifrac = (treelai+treesai)-dble(nv-1)*dinc_ed + + ! Canopy Conductance + gscan = 1.0_r8/(rs_llz(nv)+rb)*laifrac*tree_area + + ! GPP + gpp = psn_llz(nv) * elai_llz(nv) * laifrac * tree_area + + ! Dark respiration + rdark = lmr_llz(nv) * elai_llz(nv) * laifrac * tree_area + + ! If there is more than one layer, add the sum over the others + if ( nv>1 ) then + gpp = gpp + sum(psn_llz(1:nv-1) * elai_llz(1:nv-1)) * tree_area + rdark = rdark + sum(lmr_llz(1:nv-1) * elai_llz(1:nv-1)) * tree_area + gscan = gscan + sum((1.0_r8/(rs_llz(1:nv-1) + rb ))) * tree_area + end if + + ! Convert dark respiration and GPP from umol/plant/s to kgC/plant/s + ! Note that + + rdark = rdark * umolC_to_kgC + gpp = gpp * umolC_to_kgC + + + if ( DEBUG ) then + write(fates_log(),*) 'EDPhoto 816 ', gpp + write(fates_log(),*) 'EDPhoto 817 ', psn_llz(1:nv) + write(fates_log(),*) 'EDPhoto 820 ', nv + write(fates_log(),*) 'EDPhoto 821 ', elai_llz(1:nv) + write(fates_log(),*) 'EDPhoto 843 ', rdark + write(fates_log(),*) 'EDPhoto 871 ', laifrac + write(fates_log(),*) 'EDPhoto 872 ', tree_area + write(fates_log(),*) 'EDPhoto 873 ', nv + endif + + return +end subroutine ScaleLeafLayerFluxToCohort + ! ======================================================================================= function ft1_f(tl, ha) result(ans) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index d02891cb..613bd9ef 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -149,6 +149,16 @@ module EDTypesMod ! HLM will interpret that the value should not be included in the average. real(r8) :: cp_hio_ignore_val + + + ! Module switches (this will be read in one day) + ! This variable only exists now to serve as a place holder + !!!!!!!!!! THIS SHOULD NOT BE SET TO TRUE !!!!!!!!!!!!!!!!! + logical,parameter :: use_fates_plant_hydro = .false. + + + + !************************************ !** COHORT type structure ** !************************************ From 021d2f19d2bfa6ef82076f5c31ba1565ec6b61a7 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Sun, 4 Dec 2016 16:17:41 -0800 Subject: [PATCH 258/437] Photosynthesis refactors: mostly formatting changes in this commit group. --- ...esisMod.F90 => FatesPhotosynthesisMod.F90} | 815 +++++++++--------- 1 file changed, 426 insertions(+), 389 deletions(-) rename biogeophys/{EDPhotosynthesisMod.F90 => FatesPhotosynthesisMod.F90} (72%) diff --git a/biogeophys/EDPhotosynthesisMod.F90 b/biogeophys/FatesPhotosynthesisMod.F90 similarity index 72% rename from biogeophys/EDPhotosynthesisMod.F90 rename to biogeophys/FatesPhotosynthesisMod.F90 index 33d1a210..7a313a65 100644 --- a/biogeophys/EDPhotosynthesisMod.F90 +++ b/biogeophys/FatesPhotosynthesisMod.F90 @@ -14,6 +14,8 @@ module FATESPhotosynthesisMod ! High temperature deactivation, from: ! Leuning (2002) Plant, Cell and Environment 25:1205-1210 ! The factor "c" scales the deactivation to a value of 1.0 at 25C + ! Photosynthesis and stomatal conductance parameters, from: + ! Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 ! ------------------------------------------------------------------------------------ ! !USES: @@ -33,7 +35,7 @@ module FATESPhotosynthesisMod character(len=*), parameter, private :: sourcefile = & __FILE__ - !------------------------------------------------------------------------------ + !------------------------------------------------------------------------------------- ! maximum stomatal resistance [s/m] (used across several procedures) real(r8),parameter :: rsmax0 = 2.e4_r8 @@ -41,20 +43,21 @@ module FATESPhotosynthesisMod logical :: DEBUG = .false. contains - - !--------------------------------------------------------- - subroutine FATESPhotosynthesis (nsites, sites,bc_in,bc_out,dtime) - + + !-------------------------------------------------------------------------------------- + + subroutine FatesPhotosynthesis (nsites, sites,bc_in,bc_out,dtime) - ! + ! ----------------------------------------------------------------------------------- ! !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 abortutils , only : endrun use clm_varpar , only : mxpft ! THIS WILL BE DEPRECATED WHEN PARAMETER ! READS ARE REFACTORED (RGK 10-13-2016) use pftconMod , only : pftcon ! THIS WILL BE DEPRECATED WHEN PARAMETER @@ -62,33 +65,24 @@ subroutine FATESPhotosynthesis (nsites, sites,bc_in,bc_out,dtime) use EDParamsMod , only : ED_val_grperc use EDParamsMod , only : ED_val_ag_biomass use EDSharedParamsMod , only : EDParamsShareInst - use EDTypesMod , only : numpft_ed - use EDTypesMod , only : ed_patch_type use EDTypesMod , only : ed_cohort_type use EDTypesMod , only : ed_site_type use EDTypesMod , only : numpft_ed - use EDTypesMod , only : numpatchespercol use EDTypesMod , only : cp_numlevsoil use EDTypesMod , only : cp_nlevcan use EDTypesMod , only : cp_nclmax - use EDEcophysContype , only : EDecophyscon - use FatesInterfaceMod , only : bc_in_type use FatesInterfaceMod , only : bc_out_type - use EDCanopyStructureMod, only : calc_areaindex - use FatesConstantsMod, only : umolC_to_kgC use FatesConstantsMod, only : g_per_kg - use FatesConstantsMod, only : mg_per_g - use FatesConstantsMod, only : sec_per_min use FatesConstantsMod, only : umol_per_mmol use FatesConstantsMod, only : rgas => rgas_J_K_kmol use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm - ! !ARGUMENTS: + ! ARGUMENTS: ! ----------------------------------------------------------------------------------- integer,intent(in) :: nsites type(ed_site_type),intent(inout),target :: sites(nsites) @@ -97,11 +91,11 @@ subroutine FATESPhotosynthesis (nsites, sites,bc_in,bc_out,dtime) real(r8),intent(in) :: dtime - ! !LOCAL VARIABLES: + ! LOCAL VARIABLES: ! ----------------------------------------------------------------------------------- type (ed_patch_type) , pointer :: currentPatch type (ed_cohort_type), pointer :: currentCohort - integer , parameter :: psn_type = 2 !c3 or c4. + ! ----------------------------------------------------------------------------------- ! These three arrays hold leaf-level biophysical rates that are calculated ! in one loop and then sent to the cohorts in another loop. If hydraulics are @@ -111,18 +105,18 @@ subroutine FATESPhotosynthesis (nsites, sites,bc_in,bc_out,dtime) ! allocated for the maximum space of the two cases (numCohortsPerPatch) ! ----------------------------------------------------------------------------------- - ! leaf maintenance (dark) respiration + ! leaf maintenance (dark) respiration (umol CO2/m**2/s) Double check this real(r8) :: lmr_z(cp_nclmax,mxpft,cp_nlevcan) ! stomatal resistance s/m real(r8) :: rs_z(cp_nclmax,mxpft,cp_nlevcan) ! net leaf photosynthesis averaged over sun and shade leaves. (umol CO2/m**2/s) - real(r8) :: anet_av(cp_nclmax,mxpft,cp_nlevcan) + real(r8) :: anet_av_z(cp_nclmax,mxpft,cp_nlevcan) ! Mask used to determine which leaf-layer biophysical rates have been ! used already - logical :: rate_mask(cp_nclmax,mxpft,cp_nlevcan) + logical :: rate_mask_z(cp_nclmax,mxpft,cp_nlevcan) real(r8) :: vcmax_z ! leaf layer maximum rate of carboxylation (umol co2/m**2/s) @@ -135,10 +129,7 @@ subroutine FATESPhotosynthesis (nsites, sites,bc_in,bc_out,dtime) real(r8) :: co2_cpoint ! CO2 compensation point (Pa) real(r8) :: btran_eff ! effective transpiration wetness factor (0 to 1) - ! --------------------------------------------------------------- - ! TO-DO: bbbopt is slated to be transferred to the parameter file - ! ---------------------------------------------------------------- - real(r8) :: bbbopt(psn_type) ! Ball-Berry minimum leaf conductance, unstressed (umol H2O/m**2/s) + real(r8) :: bbb ! Ball-Berry minimum leaf conductance (umol H2O/m**2/s) 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) @@ -183,7 +174,17 @@ subroutine FATESPhotosynthesis (nsites, sites,bc_in,bc_out,dtime) real(r8),parameter :: base_mr_20 = 2.525e-6_r8 - + ! ----------------------------------------------------------------------------------- + ! Photosynthesis and stomatal conductance parameters, from: + ! Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 + ! ----------------------------------------------------------------------------------- + + ! Ball-Berry minimum leaf conductance, unstressed (umol H2O/m**2/s) + ! For C3 and C4 plants + ! ----------------------------------------------------------------------------------- + ! TO-DO: bbbopt is slated to be transferred to the parameter file + ! ----------------------------------------------------------------------------------- + real(r8),parameter, dimension(2) :: bbbopt = [10000._r8,40000._r8] associate( & @@ -196,17 +197,6 @@ subroutine FATESPhotosynthesis (nsites, sites,bc_in,bc_out,dtime) frootcn => pftcon%frootcn , & ! froot C:N (gc/gN) ! slope of BB relationship q10 => EDParamsShareInst%Q10) - - !==============================================================================! - ! Photosynthesis and stomatal conductance parameters, from: - ! Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 - !==============================================================================! - - ! Miscellaneous parameters, from Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 - - bbbopt(1) = 10000._r8 - bbbopt(2) = 40000._r8 - do s = 1,nsites ! Multi-layer parameters scaled by leaf nitrogen profile. @@ -238,8 +228,9 @@ subroutine FATESPhotosynthesis (nsites, sites,bc_in,bc_out,dtime) if(bc_in(s)%filter_photo_pa(ifp)==2)then - ! Part III. Calculate the number of sublayers for each pft and layer. And then identify - ! which layer/pft combinations have things in them. Output: + ! Part III. Calculate the number of sublayers for each pft and layer. + ! And then identify which layer/pft combinations have things in them. + ! Output: ! currentPatch%ncan(:,:) ! currentPatch%present(:,:) call UpdateCanopyNCanNRadPresent(currentPatch) @@ -271,34 +262,42 @@ subroutine FATESPhotosynthesis (nsites, sites,bc_in,bc_out,dtime) ! but not environmentally dependent ! ------------------------------------------------------------------------ - do FT = 1,numpft_ed !calculate patch and pft specific properties at canopy top. + do ft = 1,numpft_ed ! Leaf nitrogen concentration at the top of the canopy (g N leaf / m**2 leaf) - lnc = 1._r8 / (slatop(FT) * leafcn(FT)) + lnc = 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... + ! at the moment in ED we assume that there is no active N cycle. + ! This should change, of course. FIX(RF,032414) Sep2011. + ! fudge - shortcut using fnitr as a proxy for vcmax... + vcmax25top(ft) = fnitr(ft) - ! 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 + ! 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)-tfrzc),11._r8),35._r8)) * vcmax25top(FT) + ! 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)-tfrzc),11._r8),35._r8)) * vcmax25top(ft) - jmax25top(FT) = 1.67_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 + jmax25top(ft) = 1.67_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 (bc_in(s)%dayl_factor_pa(ifp) == 0._r8) then - kn(FT) = 0._r8 + kn(ft) = 0._r8 else - kn(FT) = exp(0.00963_r8 * vcmax25top(FT) - 2.43_r8) + kn(ft) = exp(0.00963_r8 * vcmax25top(ft) - 2.43_r8) end if ! Leaf maintenance respiration to match the base rate used in CN @@ -310,14 +309,13 @@ subroutine FATESPhotosynthesis (nsites, sites,bc_in,bc_out,dtime) ! ! 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 / (umolC_to_kgC * g_per_kg) + lmr25top(ft) = 2.525e-6_r8 * (1.5_r8 ** ((25._r8 - 20._r8)/10._r8)) + lmr25top(ft) = lmr25top(ft) * lnc / (umolC_to_kgC * g_per_kg) - end do !FT + end do !ft call currentPatch%set_root_fraction(bc_in(s)%depth_gl) - ! ------------------------------------------------------------------------ ! Part VI: Loop over all leaf layers. ! The concept of leaf layers is a result of the radiative transfer scheme. @@ -335,35 +333,32 @@ subroutine FATESPhotosynthesis (nsites, sites,bc_in,bc_out,dtime) ! respiration will be different for leaves of each cohort in the leaf ! layers, as they will have there own hydraulic limitations. ! ------------------------------------------------------------------------ - rate_mask(:,:,:) = .false. + rate_mask_z(:,:,:) = .false. if(currentPatch%countcohorts > 0.0)then ! Ignore empty patches currentCohort => currentPatch%tallest do while (associated(currentCohort)) ! Cohort loop - ! Identify the canopy layer (CL), functional type (FT) + ! Identify the canopy layer (cl), functional type (ft) ! and the leaf layer (IV) for this cohort - FT = currentCohort%pft - CL = currentCohort%canopy_layer + ft = currentCohort%pft + cl = currentCohort%canopy_layer - if(currentPatch%present(CL,FT) == 1)then ! are there any leaves of this pft in this layer? + + ! are there any leaves of this pft in this layer? + if(currentPatch%present(cl,ft) == 1)then - if(CL==NCL_p)then !are we in the top canopy layer or a shaded 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)) + laican = sum(currentPatch%canopy_layer_lai(cl+1:NCL_p)) end if - - ! Loop over sublayers, only calculate the leaf-layers biophysical rates - ! if this unique set has not been calculated - ! In non-hydraulic runs, many cohorts of the same pft may share the - ! same leaf layer and the properties will be the same. - ! We will ignore these + ! Loop over leaf-layers do iv = 1,currentCohort%nv - ! ----------------------------------------------------------- + ! ------------------------------------------------------------ ! If we are doing plant hydro-dynamics (or any run-type ! where cohorts may generate different photosynthetic rates ! of other cohorts in the same canopy-pft-layer combo), @@ -371,82 +366,100 @@ subroutine FATESPhotosynthesis (nsites, sites,bc_in,bc_out,dtime) ! cohort-layer combo of interest. ! but in the vanilla case, we only re-calculate if it has ! not been done yet. - ! ----------------------------------------------------------- - - if ( .not.rate_mask(ft,cl,iv) .or. use_fates_plant_hydro ) then + ! ------------------------------------------------------------ + + if ( .not.rate_mask_z(ft,cl,iv) .or. use_fates_plant_hydro ) then if (use_fates_plant_hydro) then + write(fates_log(),*) 'use_fates_plant_hydro in EDTypes' + write(fates_log(),*) 'has been set to true. You have inadvartently' + write(fates_log(),*) 'turned on a future feature that is not in the' + write(fates_log(),*) 'FATES model codeset yet. Please set this to' + write(fates_log(),*) 'false and re-compile.' + call endrun(msg=errMsg(sourcefile, __LINE__)) !! !! bbb = max (bbbopt(ps)*currentCohort%btran(iv), 1._r8) !! !! btran = currentCohort%btran(iv) else - bbb = max (bbbopt(nint(c3psn(ft)))*currentPatch%btran_ft(FT), 1._r8) + bbb = max (bbbopt(nint(c3psn(ft)))*currentPatch%btran_ft(ft), 1._r8) btran_eff = currentPatch%btran_ft(ft) end if - + ! Vegetation area index - vai = (currentPatch%elai_profile(CL,FT,iv)+currentPatch%esai_profile(CL,FT,iv)) + vai = (currentPatch%elai_profile(cl,ft,iv)+currentPatch%esai_profile(cl,ft,iv)) 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 + 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) - + nscaler = exp(-kn(ft) * laican) + ! Part VII: Calculate dark respiration (leaf maintenance) for this layer call LeafLayerMaintenanceRespiration( lmr25top(ft), & ! in - nscaler, & ! in - ft, & ! in - bc_in(s)%t_veg_pa(ifp), & ! in - lmr_z(CL,FT,iv)) ! out - - call LeafLayerBiophysicalRates(currentPatch%ed_parsun_z(CL,FT,iv), & ! in - ft, & ! in - vcmax25top(ft), & ! in - jmax25top(ft), & ! in - tpu25top(ft), & ! in - kp25top(ft), & ! in - nscaler, & ! in - bc_in(s)%t_veg_pa(ifp), & ! in - btran_eff, & ! in - vcmax_z, & ! out - jmax_z, & ! out - tpu_z, & ! out - kp_z ) ! out - - call LeafLayerPhotosynthesis(currentPatch%f_sun(CL,FT,iv), & ! in - currentPatch%ed_parsun_z(CL,FT,iv), & ! in - currentPatch%ed_parsha_z(CL,FT,iv), & ! in - currentPatch%ed_laisun_z(CL,FT,iv), & ! in - currentPatch%ed_laisha_z(CL,FT,iv), & ! in - currentPatch%canopy_area_profile(CL,FT,iv), & ! in - ft, & ! in - nscaler, & ! in - vcmax_z, & ! in - jmax_z, & ! in - tpu_z, & ! in - kp_z, & ! in - bc_in(s)%t_veg_pa(ifp), & ! in - bc_in(s)%esat_tv_pa(ifp), & ! in - bc_in(s)%forc_pbot, & ! in - bc_in(s)%cair_pa(ifp), & ! in - bc_in(s)%oair_pa(ifp), & ! in - btran_eff, & ! in - bbb, & ! in - cf, & ! in - gb_mol, & ! in - ceair, & ! in - mm_kco2, & ! in - mm_ko2, & ! in - co2_cpoint, & ! in - lmr_z(CL,FT,iv), & ! in - currentPatch%psn_z(cl,ft,iv), & ! out - rs_z(CL,FT,iv), & ! out - anet_av(CL,FT,iv)) ! out - - rate_mask(ft,cl,iv) = .true. + nscaler, & ! in + ft, & ! in + bc_in(s)%t_veg_pa(ifp), & ! in + lmr_z(cl,ft,iv)) ! out + + ! Part VII: Calculate (1) maximum rate of carboxylation (vcmax), + ! (2) maximum electron transport rate, (3) triose phosphate + ! utilization rate and (4) the initial slope of CO2 response curve + ! (C4 plants). Earlier we calculated their base rates as dictated + ! by their plant functional type and some simple scaling rules for + ! nitrogen limitation baesd on canopy position (not prognostic). + ! These rates are the specific rates used in the actual photosynthesis + ! calculations that take localized environmental effects (temperature) + ! into consideration. + + call LeafLayerBiophysicalRates(currentPatch%ed_parsun_z(cl,ft,iv), & ! in + ft, & ! in + vcmax25top(ft), & ! in + jmax25top(ft), & ! in + tpu25top(ft), & ! in + kp25top(ft), & ! in + nscaler, & ! in + bc_in(s)%t_veg_pa(ifp), & ! in + btran_eff, & ! in + vcmax_z, & ! out + jmax_z, & ! out + tpu_z, & ! out + kp_z ) ! out + + ! Part IX: This call calculates the actual photosynthesis for the + ! leaf layer, as well as the stomatal resistance and the net assimilated carbon. + + call LeafLayerPhotosynthesis(currentPatch%f_sun(cl,ft,iv), & ! in + currentPatch%ed_parsun_z(cl,ft,iv), & ! in + currentPatch%ed_parsha_z(cl,ft,iv), & ! in + currentPatch%ed_laisun_z(cl,ft,iv), & ! in + currentPatch%ed_laisha_z(cl,ft,iv), & ! in + currentPatch%canopy_area_profile(cl,ft,iv), & ! in + ft, & ! in + vcmax_z, & ! in + jmax_z, & ! in + tpu_z, & ! in + kp_z, & ! in + bc_in(s)%t_veg_pa(ifp), & ! in + bc_in(s)%esat_tv_pa(ifp), & ! in + bc_in(s)%forc_pbot, & ! in + bc_in(s)%cair_pa(ifp), & ! in + bc_in(s)%oair_pa(ifp), & ! in + btran_eff, & ! in + bbb, & ! in + cf, & ! in + gb_mol, & ! in + ceair, & ! in + mm_kco2, & ! in + mm_ko2, & ! in + co2_cpoint, & ! in + lmr_z(cl,ft,iv), & ! in + currentPatch%psn_z(cl,ft,iv), & ! out + rs_z(cl,ft,iv), & ! out + anet_av_z(cl,ft,iv)) ! out + + rate_mask_z(ft,cl,iv) = .true. end if end do @@ -460,28 +473,29 @@ subroutine FATESPhotosynthesis (nsites, sites,bc_in,bc_out,dtime) ! --------------------------------------------------------------- ! Part VII: Transfer leaf flux rates (like maintenance respiration, - ! carbon assimilation and conductance) that are defined by the leaf layer - ! (which is area independent, ie /m2) onto each cohort (where the rates become - ! per cohort, ie /individual). Most likely a sum over layers. + ! carbon assimilation and conductance) that are defined by the + ! leaf layer (which is area independent, ie /m2) onto each cohort + ! (where the rates become per cohort, ie /individual). Most likely + ! a sum over layers. ! --------------------------------------------------------------- nv = currentCohort%nv call ScaleLeafLayerFluxToCohort(nv, & !in currentPatch%psn_z(cl,ft,1:nv), & !in lmr_z(cl,ft,1:nv), & !in rs_z(cl,ft,1:nv), & !in - anet_av(cl,ft,1:nv), & !in + anet_av_z(cl,ft,1:nv), & !in currentPatch%elai_profile(cl,ft,1:nv), & !in currentCohort%c_area, & !in currentCohort%n, & !in currentCohort%treelai, & !in currentCohort%treesai, & !in bc_in(s)%rb_pa(ifp), & !in - currentCohort%gscan, & ! out - currentCohort%gpp_tstep, & ! out - currentCohort%rdark) ! out + currentCohort%gscan, & !out + currentCohort%gpp_tstep, & !out + currentCohort%rdark) !out ! Net Uptake does not need to be scaled, just transfer directly - currentCohort%ts_net_uptake(1:nv) = anet_av(cl,ft,1:nv) * umolC_to_kgC + currentCohort%ts_net_uptake(1:nv) = anet_av_z(cl,ft,1:nv) * umolC_to_kgC else @@ -494,20 +508,22 @@ subroutine FATESPhotosynthesis (nsites, sites,bc_in,bc_out,dtime) currentCohort%gscan = 0.0_r8 currentCohort%ts_net_uptake(:) = 0.0_r8 - end if ! if(currentPatch%present(CL,FT) == 1)then + end if ! if(currentPatch%present(cl,ft) == 1)then ! ------------------------------------------------------------------ ! Part VIII: Calculate maintenance respiration in the sapwood and ! fine root pools. ! ------------------------------------------------------------------ - - leaf_frac = 1.0_r8/(currentCohort%canopy_trim + EDecophyscon%sapwood_ratio(currentCohort%pft) * & - currentCohort%hite + pftcon%froot_leaf(currentCohort%pft)) + + 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%hite * & + (currentCohort%balive + currentCohort%laimemory)*leaf_frac ! Calculate the amount of nitrogen in the above and below ground @@ -524,8 +540,12 @@ subroutine FATESPhotosynthesis (nsites, sites,bc_in,bc_out,dtime) !------------------------------------------------------------------------------ - ! 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. + ! Calculate Whole Plant Respiration + ! (this doesn't really need to be in this iteration at all, surely?) + ! Response: (RGK 12-2016): I think the positioning of these calls is + ! appropriate as of now. Maintenance calculations in sapwood and roots + ! vary by cohort and with changing temperature at the minimum, and there are + ! no sub-pools chopping up those pools any finer that need to be dealty with. !------------------------------------------------------------------------------ ! Live stem MR (kgC/plant/s) (above ground sapwood) @@ -574,31 +594,43 @@ subroutine FATESPhotosynthesis (nsites, sites,bc_in,bc_out,dtime) ! 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%livestem_mr + & + currentCohort%livecroot_mr + & + currentCohort%froot_mr + + ! no drought response right now.. something like: + ! resp_m = resp_m * (1.0_r8 - currentPatch%btran_ft(currentCohort%pft) * & + ! pftcon%resp_drought_response(ft)) + currentCohort%resp_m = currentCohort%resp_m + currentCohort%rdark ! convert from kgC/indiv/s to kgC/indiv/timestep - currentCohort%resp_m = currentCohort%resp_m * dtime - currentCohort%gpp_tstep = currentCohort%gpp_tstep * dtime - currentCohort%ts_net_uptake = currentCohort%ts_net_uptake * dtime - - - + currentCohort%resp_m = currentCohort%resp_m * dtime + currentCohort%gpp_tstep = currentCohort%gpp_tstep * dtime + currentCohort%ts_net_uptake = currentCohort%ts_net_uptake * dtime if ( DEBUG ) write(fates_log(),*) 'EDPhoto 911 ', currentCohort%gpp_tstep if ( DEBUG ) write(fates_log(),*) 'EDPhoto 912 ', currentCohort%resp_tstep if ( DEBUG ) write(fates_log(),*) 'EDPhoto 913 ', currentCohort%resp_m - currentCohort%resp_g = ED_val_grperc(ft) * (max(0._r8,currentCohort%gpp_tstep - currentCohort%resp_m)) - currentCohort%resp_tstep = currentCohort%resp_m + currentCohort%resp_g ! kgC/indiv/ts - currentCohort%npp_tstep = currentCohort%gpp_tstep - currentCohort%resp_tstep ! kgC/indiv/ts + currentCohort%resp_g = ED_val_grperc(ft) * & + (max(0._r8,currentCohort%gpp_tstep - & + currentCohort%resp_m)) + currentCohort%resp_tstep = currentCohort%resp_m + & + currentCohort%resp_g ! kgC/indiv/ts + currentCohort%npp_tstep = currentCohort%gpp_tstep - & + currentCohort%resp_tstep ! kgC/indiv/ts - bc_out(s)%psncanopy_pa(ifp) = bc_out(s)%psncanopy_pa(ifp) + currentCohort%gpp_tstep - bc_out(s)%lmrcanopy_pa(ifp) = bc_out(s)%lmrcanopy_pa(ifp) + currentCohort%resp_m - ! accumulate cohort level canopy conductances over whole area before dividing by total area. - bc_out(s)%gccanopy_pa(ifp) = bc_out(s)%gccanopy_pa(ifp) + currentCohort%gscan * & - currentCohort%n /currentPatch%total_canopy_area + bc_out(s)%psncanopy_pa(ifp) = bc_out(s)%psncanopy_pa(ifp) + & + currentCohort%gpp_tstep + bc_out(s)%lmrcanopy_pa(ifp) = bc_out(s)%lmrcanopy_pa(ifp) + & + currentCohort%resp_m + + ! accumulate cohort level canopy conductances over + ! whole area before dividing by total area + bc_out(s)%gccanopy_pa(ifp) = bc_out(s)%gccanopy_pa(ifp) + & + currentCohort%gscan * & + currentCohort%n /currentPatch%total_canopy_area currentCohort => currentCohort%shorter @@ -610,14 +642,16 @@ subroutine FATESPhotosynthesis (nsites, sites,bc_in,bc_out,dtime) bc_out(s)%psncanopy_pa(ifp) = bc_out(s)%psncanopy_pa(ifp) / currentPatch%area bc_out(s)%lmrcanopy_pa(ifp) = bc_out(s)%lmrcanopy_pa(ifp) / currentPatch%area + if(bc_out(s)%gccanopy_pa(ifp) > 1._r8/rsmax0 .and. elai > 0.0_r8)then - rscanopy = (1.0_r8/bc_out(s)%gccanopy_pa(ifp))-bc_in(s)%rb_pa(ifp)/elai ! this needs to be resistance per unit leaf area. + rscanopy = (1.0_r8/bc_out(s)%gccanopy_pa(ifp))-bc_in(s)%rb_pa(ifp)/elai else rscanopy = rsmax0 end if bc_out(s)%rssun_pa(ifp) = rscanopy bc_out(s)%rssha_pa(ifp) = rscanopy - bc_out(s)%gccanopy_pa(ifp) = 1.0_r8/rscanopy*cf/umol_per_mmol !convert into umol m-2 s-1 then mmol m-2 s-1. + !convert into umol m-2 s-1 then mmol m-2 s-1. + bc_out(s)%gccanopy_pa(ifp) = 1.0_r8/rscanopy*cf/umol_per_mmol end if currentPatch => currentPatch%younger @@ -627,78 +661,76 @@ subroutine FATESPhotosynthesis (nsites, sites,bc_in,bc_out,dtime) end do !site loop end associate - end subroutine FATESPhotosynthesis - -! ======================================================================================= - -subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in - parsun_lsl, & ! in - parsha_lsl, & ! in - laisun_lsl, & ! in - laisha_lsl, & ! in - canopy_area_lsl, & ! in - ft, & ! in - nscaler, & ! in - vcmax, & ! in - jmax, & ! in - tpu, & ! in - co2_rcurve_islope, & ! in - veg_tempk, & ! in - veg_esat, & ! in - can_press, & ! in - can_co2_ppress, & ! in - can_o2_ppress, & ! in - btran, & ! in - bbb, & ! in - cf, & ! in - gb_mol, & ! in - ceair, & ! in - mm_kco2, & ! in - mm_ko2, & ! in - co2_cpoint, & ! in - lmr, & ! in - psn_out, & ! out - rstoma_out, & ! out - anet_av_out) ! out - - ! ------------------------------------------------------------------------------------ - ! This subroutine calculates photosynthesis and stomatal conductance within each leaf - ! sublayer. - ! A note on naming conventions: As this subroutine is called for every - ! leaf-sublayer, many of the arguments are specific to that "leaf sub layer" - ! (LSL), those variables are given a dimension tag "_lsl" - ! Other arguments or variables may be indicative of scales broader than the LSL. - ! ------------------------------------------------------------------------------------ - - use EDEcophysContype , only : EDecophyscon - use pftconMod , only : pftcon - - ! Arguments - ! ------------------------------------------------------------------------ - real(r8), intent(in) :: f_sun_lsl - real(r8), intent(in) :: parsun_lsl - real(r8), intent(in) :: parsha_lsl - real(r8), intent(in) :: laisun_lsl - real(r8), intent(in) :: laisha_lsl - real(r8), intent(in) :: canopy_area_lsl - integer, intent(in) :: ft ! (plant) Functional Type Index - real(r8), intent(in) :: nscaler ! Scale for leaf nitrogen profile - real(r8), intent(in) :: vcmax ! maximum rate of carboxylation (umol co2/m**2/s) - real(r8), intent(in) :: jmax ! maximum electron transport rate (umol electrons/m**2/s) - real(r8), intent(in) :: tpu ! triose phosphate utilization rate (umol CO2/m**2/s) - real(r8), intent(in) :: co2_rcurve_islope ! initial slope of CO2 response curve (C4 plants) - real(r8), intent(in) :: veg_tempk ! vegetation temperature - real(r8), intent(in) :: veg_esat ! saturation vapor pressure at veg_tempk (Pa) - - ! Important Note on the following gas pressures. This photosynthesis scheme will iteratively - ! solve for the co2 partial pressure at the leaf surface (ie in the stomata). The reference - ! point for these input values are NOT within that boundary layer that separates the stomata from - ! the canopy air space. The reference point for these is on the outside of that boundary - ! layer. This routine, which operates at the leaf scale, makes no assumptions about what the - ! scale of the refernce is, it could be lower atmosphere, it could be within the canopy - ! but most likely it is the closest value one can get to the edge of the leaf's boundary - ! layer. We use the convention "can_" because a reference point of within the canopy - ! ia a best reasonable scenario of where we can get that information from. + end subroutine FatesPhotosynthesis + + ! ======================================================================================= + + subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in + parsun_lsl, & ! in + parsha_lsl, & ! in + laisun_lsl, & ! in + laisha_lsl, & ! in + canopy_area_lsl, & ! in + ft, & ! in + vcmax, & ! in + jmax, & ! in + tpu, & ! in + co2_rcurve_islope, & ! in + veg_tempk, & ! in + veg_esat, & ! in + can_press, & ! in + can_co2_ppress, & ! in + can_o2_ppress, & ! in + btran, & ! in + bbb, & ! in + cf, & ! in + gb_mol, & ! in + ceair, & ! in + mm_kco2, & ! in + mm_ko2, & ! in + co2_cpoint, & ! in + lmr, & ! in + psn_out, & ! out + rstoma_out, & ! out + anet_av_out) ! out + + ! ------------------------------------------------------------------------------------ + ! This subroutine calculates photosynthesis and stomatal conductance within each leaf + ! sublayer. + ! A note on naming conventions: As this subroutine is called for every + ! leaf-sublayer, many of the arguments are specific to that "leaf sub layer" + ! (LSL), those variables are given a dimension tag "_lsl" + ! Other arguments or variables may be indicative of scales broader than the LSL. + ! ------------------------------------------------------------------------------------ + + use EDEcophysContype , only : EDecophyscon + use pftconMod , only : pftcon + + ! Arguments + ! ------------------------------------------------------------------------------------ + real(r8), intent(in) :: f_sun_lsl ! + real(r8), intent(in) :: parsun_lsl ! Absorbed PAR in sunlist leaves + real(r8), intent(in) :: parsha_lsl ! Absorved PAR in shaded leaves + real(r8), intent(in) :: laisun_lsl ! LAI in sunlit leaves + real(r8), intent(in) :: laisha_lsl ! LAI in shaded leaves + real(r8), intent(in) :: canopy_area_lsl ! + integer, intent(in) :: ft ! (plant) Functional Type Index + real(r8), intent(in) :: vcmax ! maximum rate of carboxylation (umol co2/m**2/s) + real(r8), intent(in) :: jmax ! maximum electron transport rate (umol electrons/m**2/s) + real(r8), intent(in) :: tpu ! triose phosphate utilization rate (umol CO2/m**2/s) + real(r8), intent(in) :: co2_rcurve_islope ! initial slope of CO2 response curve (C4 plants) + real(r8), intent(in) :: veg_tempk ! vegetation temperature + real(r8), intent(in) :: veg_esat ! saturation vapor pressure at veg_tempk (Pa) + + ! Important Note on the following gas pressures. This photosynthesis scheme will iteratively + ! solve for the co2 partial pressure at the leaf surface (ie in the stomata). The reference + ! point for these input values are NOT within that boundary layer that separates the stomata from + ! the canopy air space. The reference point for these is on the outside of that boundary + ! layer. This routine, which operates at the leaf scale, makes no assumptions about what the + ! scale of the refernce is, it could be lower atmosphere, it could be within the canopy + ! but most likely it is the closest value one can get to the edge of the leaf's boundary + ! layer. We use the convention "can_" because a reference point of within the canopy + ! ia a best reasonable scenario of where we can get that information from. real(r8), intent(in) :: can_press ! Air pressure NEAR the surface of the leaf (Pa) real(r8), intent(in) :: can_co2_ppress ! Partial pressure of CO2 NEAR the leaf surface (Pa) @@ -721,7 +753,7 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in ! Locals ! ------------------------------------------------------------------------ - integer :: ps ! Index for the different photosynthetic pathways C3,C4 + integer :: pp_type ! Index for the different photosynthetic pathways C3,C4 integer :: sunsha ! Index for differentiating sun and shade real(r8) :: gstoma ! Stomatal Conductance of this leaf layer (m/s) real(r8) :: agross ! co-limited gross leaf photosynthesis (umol CO2/m**2/s) @@ -765,14 +797,12 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in ! empirical curvature parameter for ap photosynthesis co-limitation real(r8),parameter :: theta_ip = 0.95_r8 - - associate( c3psn => pftcon%c3psn, & ! photosynthetic pathway: 0. = c4, 1. = c3 - bb_slope => EDecophyscon%BB_slope ) ! slope of BB relationship + associate( bb_slope => EDecophyscon%BB_slope ) ! slope of BB relationship - if (nint(c3psn(ft)) == 1)then - ps = 1 + if (nint(pftcon%c3psn(ft)) == 1) then! photosynthetic pathway: 0. = c4, 1. = c3 + pp_type = 1 else - ps = 2 + pp_type = 2 end if ! Part III: Photosynthesis and Conductance @@ -832,7 +862,7 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in ! Iterative loop for ci beginning with initial guess ! THIS CALL APPEARS TO BE REDUNDANT WITH LINE 423 (RGK) - if (nint(c3psn(FT)) == 1)then + if (pp_type == 1)then co2_intra_c = init_a2l_co2_c3 * can_co2_ppress else co2_intra_c = init_a2l_co2_c4 * can_co2_ppress @@ -848,7 +878,7 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in co2_intra_c_old = co2_intra_c ! Photosynthesis limitation rate calculations - if (nint(c3psn(FT)) == 1)then + if (pp_type == 1)then ! C3: Rubisco-limited photosynthesis ac = vcmax * max(co2_intra_c-co2_cpoint, 0._r8) / & @@ -868,14 +898,14 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in ! C4: RuBP-limited photosynthesis if(sunsha == 1)then !sunlit if((laisun_lsl * canopy_area_lsl) > 0.0000000001_r8) then !guard against /0's in the night. - aj = quant_eff(ps) * parsun_lsl * 4.6_r8 + aj = quant_eff(pp_type) * parsun_lsl * 4.6_r8 !convert from per cohort to per m2 of leaf) aj = aj / (laisun_lsl * canopy_area_lsl) else aj = 0._r8 end if else - aj = quant_eff(ps) * parsha_lsl * 4.6_r8 + aj = quant_eff(pp_type) * parsha_lsl * 4.6_r8 aj = aj / (laisha_lsl * canopy_area_lsl) end if @@ -885,7 +915,7 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in end if ! Gross photosynthesis smoothing calculations. First co-limit ac and aj. Then co-limit ap - aquad = theta_cj(ps) + aquad = theta_cj(pp_type) bquad = -(ac + aj) cquad = ac * aj call quadratic_f (aquad, bquad, cquad, r1, r2) @@ -976,9 +1006,9 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in write (fates_log(),*) 'CF: Ball-Berry error check - stomatal conductance error:' write (fates_log(),*) gs_mol, gs_mol_err end if - + enddo !sunsha loop - + !average leaf-level stomatal resistance rate over sun and shade leaves... rstoma_out = 1._r8/gstoma @@ -992,111 +1022,108 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in end if ! night or day end associate return -end subroutine LeafLayerPhotosynthesis - -! ======================================================================================= - -subroutine ScaleLeafLayerFluxToCohort(nv, & ! in currentCohort%nv - psn_llz, & ! in %psn_z(cl,ft,1:currentCohort%nv) - lmr_llz, & ! in lmr_z(cl,ft,1:currentCohort%nv) - rs_llz, & ! in rs_z(cl,ft,1:currentCohort%nv) - anet_av_llz, & ! in anet_av_z(cl,ft,1:currentCohort%nv) - elai_llz, & ! in %elai_profile(cl,ft,1:currentCohort%nv) - c_area, & ! in currentCohort%c_area - nplant, & ! in currentCohort%n - treelai, & ! in currentCohort%treelai - treesai, & ! in currentCohort%treesai - rb, & ! in bc_in(s)%rb_pa(ifp) - gscan, & ! out currentCohort%gscan - gpp, & ! out currentCohort%gpp_tstep - rdark) ! out currentCohort%rdark - - ! ------------------------------------------------------------------------------------ - ! This subroutine effectively integrates leaf carbon fluxes over the - ! leaf layers to give cohort totals. - ! Some arguments have the suffix "_llz". This indicates that the vector - ! is stratefied in the leaf-layer (ll) dimension, and is a portion of the calling - ! array which has the "_z" tag, thus "llz". - ! ------------------------------------------------------------------------------------ - - use FatesConstantsMod, only : umolC_to_kgC - use EDTypesMod, only : dinc_ed - - ! Arguments - integer, intent(in) :: nv ! number of active leaf layers - real(r8), intent(in) :: psn_llz(nv) ! umolC/m2leaf/s - real(r8), intent(in) :: lmr_llz(nv) ! umolC/m2leaf/s - real(r8), intent(in) :: rs_llz(nv) ! s/m - real(r8), intent(in) :: anet_av_llz(nv) ! umolC/m2leaf/s - real(r8), intent(in) :: elai_llz(nv) ! exposed LAI per layer - real(r8), intent(in) :: c_area ! crown area m2/m2 - real(r8), intent(in) :: nplant ! indiv/m2 - real(r8), intent(in) :: treelai ! m2/m2 - real(r8), intent(in) :: treesai ! m2/m2 - real(r8), intent(in) :: rb ! boundary layer resistance (s/m) - - real(r8), intent(out) :: gscan ! Canopy conductance of the cohort m/s - real(r8), intent(out) :: gpp ! GPP (kgC/indiv/s) - real(r8), intent(out) :: rdark ! Dark Leaf Respiration (kgC/indiv/s) - - ! GPP IN THIS SUBROUTINE IS A RATE. THE CALLING ARGUMENT IS GPP_TSTEP. AFTER THIS - ! CALL THE RATE WILL BE MULTIPLIED BY THE INTERVAL TO GIVE THE INTEGRATED QUANT. - - - ! Locals - real(r8) :: tree_area - real(r8) :: laifrac - - ! Convert from umolC/m2leaf/s to umolC/indiv/s ( x canopy area x 1m2 leaf area). - tree_area = c_area/nplant - - ! The routine is only called if there are leaves. If there are leaves, - ! there is at least 1 layer - - laifrac = (treelai+treesai)-dble(nv-1)*dinc_ed - - ! Canopy Conductance - gscan = 1.0_r8/(rs_llz(nv)+rb)*laifrac*tree_area - - ! GPP - gpp = psn_llz(nv) * elai_llz(nv) * laifrac * tree_area - - ! Dark respiration - rdark = lmr_llz(nv) * elai_llz(nv) * laifrac * tree_area - - ! If there is more than one layer, add the sum over the others - if ( nv>1 ) then - gpp = gpp + sum(psn_llz(1:nv-1) * elai_llz(1:nv-1)) * tree_area - rdark = rdark + sum(lmr_llz(1:nv-1) * elai_llz(1:nv-1)) * tree_area - gscan = gscan + sum((1.0_r8/(rs_llz(1:nv-1) + rb ))) * tree_area - end if - - ! Convert dark respiration and GPP from umol/plant/s to kgC/plant/s - ! Note that + end subroutine LeafLayerPhotosynthesis - rdark = rdark * umolC_to_kgC - gpp = gpp * umolC_to_kgC - - - if ( DEBUG ) then - write(fates_log(),*) 'EDPhoto 816 ', gpp - write(fates_log(),*) 'EDPhoto 817 ', psn_llz(1:nv) - write(fates_log(),*) 'EDPhoto 820 ', nv - write(fates_log(),*) 'EDPhoto 821 ', elai_llz(1:nv) - write(fates_log(),*) 'EDPhoto 843 ', rdark - write(fates_log(),*) 'EDPhoto 871 ', laifrac - write(fates_log(),*) 'EDPhoto 872 ', tree_area - write(fates_log(),*) 'EDPhoto 873 ', nv - endif + ! ===================================================================================== + + subroutine ScaleLeafLayerFluxToCohort(nv, & ! in currentCohort%nv + psn_llz, & ! in %psn_z(cl,ft,1:currentCohort%nv) + lmr_llz, & ! in lmr_z(cl,ft,1:currentCohort%nv) + rs_llz, & ! in rs_z(cl,ft,1:currentCohort%nv) + anet_av_llz, & ! in anet_av_z(cl,ft,1:currentCohort%nv) + elai_llz, & ! in %elai_profile(cl,ft,1:currentCohort%nv) + c_area, & ! in currentCohort%c_area + nplant, & ! in currentCohort%n + treelai, & ! in currentCohort%treelai + treesai, & ! in currentCohort%treesai + rb, & ! in bc_in(s)%rb_pa(ifp) + gscan, & ! out currentCohort%gscan + gpp, & ! out currentCohort%gpp_tstep + rdark) ! out currentCohort%rdark - return -end subroutine ScaleLeafLayerFluxToCohort + ! ------------------------------------------------------------------------------------ + ! This subroutine effectively integrates leaf carbon fluxes over the + ! leaf layers to give cohort totals. + ! Some arguments have the suffix "_llz". This indicates that the vector + ! is stratefied in the leaf-layer (ll) dimension, and is a portion of the calling + ! array which has the "_z" tag, thus "llz". + ! ------------------------------------------------------------------------------------ + + use FatesConstantsMod, only : umolC_to_kgC + use EDTypesMod, only : dinc_ed + + ! Arguments + integer, intent(in) :: nv ! number of active leaf layers + real(r8), intent(in) :: psn_llz(nv) ! umolC/m2leaf/s + real(r8), intent(in) :: lmr_llz(nv) ! umolC/m2leaf/s + real(r8), intent(in) :: rs_llz(nv) ! s/m + real(r8), intent(in) :: anet_av_llz(nv) ! umolC/m2leaf/s + real(r8), intent(in) :: elai_llz(nv) ! exposed LAI per layer + real(r8), intent(in) :: c_area ! crown area m2/m2 + real(r8), intent(in) :: nplant ! indiv/m2 + real(r8), intent(in) :: treelai ! m2/m2 + real(r8), intent(in) :: treesai ! m2/m2 + real(r8), intent(in) :: rb ! boundary layer resistance (s/m) + + real(r8), intent(out) :: gscan ! Canopy conductance of the cohort m/s + real(r8), intent(out) :: gpp ! GPP (kgC/indiv/s) + real(r8), intent(out) :: rdark ! Dark Leaf Respiration (kgC/indiv/s) + + ! GPP IN THIS SUBROUTINE IS A RATE. THE CALLING ARGUMENT IS GPP_TSTEP. AFTER THIS + ! CALL THE RATE WILL BE MULTIPLIED BY THE INTERVAL TO GIVE THE INTEGRATED QUANT. + + ! Locals + real(r8) :: tree_area + real(r8) :: laifrac + + ! Convert from umolC/m2leaf/s to umolC/indiv/s ( x canopy area x 1m2 leaf area). + tree_area = c_area/nplant + + ! The routine is only called if there are leaves. If there are leaves, + ! there is at least 1 layer + + laifrac = (treelai+treesai)-dble(nv-1)*dinc_ed + + ! Canopy Conductance + gscan = 1.0_r8/(rs_llz(nv)+rb)*laifrac*tree_area + + ! GPP + gpp = psn_llz(nv) * elai_llz(nv) * laifrac * tree_area + + ! Dark respiration + rdark = lmr_llz(nv) * elai_llz(nv) * laifrac * tree_area + + ! If there is more than one layer, add the sum over the others + if ( nv>1 ) then + gpp = gpp + sum(psn_llz(1:nv-1) * elai_llz(1:nv-1)) * tree_area + rdark = rdark + sum(lmr_llz(1:nv-1) * elai_llz(1:nv-1)) * tree_area + gscan = gscan + sum((1.0_r8/(rs_llz(1:nv-1) + rb ))) * tree_area + end if + + ! Convert dark respiration and GPP from umol/plant/s to kgC/plant/s + + rdark = rdark * umolC_to_kgC + gpp = gpp * umolC_to_kgC + + if ( DEBUG ) then + write(fates_log(),*) 'EDPhoto 816 ', gpp + write(fates_log(),*) 'EDPhoto 817 ', psn_llz(1:nv) + write(fates_log(),*) 'EDPhoto 820 ', nv + write(fates_log(),*) 'EDPhoto 821 ', elai_llz(1:nv) + write(fates_log(),*) 'EDPhoto 843 ', rdark + write(fates_log(),*) 'EDPhoto 871 ', laifrac + write(fates_log(),*) 'EDPhoto 872 ', tree_area + write(fates_log(),*) 'EDPhoto 873 ', nv + endif + + return + end subroutine ScaleLeafLayerFluxToCohort -! ======================================================================================= + ! ===================================================================================== -function ft1_f(tl, ha) result(ans) - ! - !!DESCRIPTION: + function ft1_f(tl, ha) result(ans) + ! + !!DESCRIPTION: ! photosynthesis temperature response ! ! !REVISION HISTORY @@ -1257,7 +1284,7 @@ subroutine UpdateCanopyNCanNRadPresent(currentPatch) type(ed_cohort_type), pointer :: currentCohort ! Locals - integer :: CL ! Canopy Layer Index + integer :: cl ! Canopy Layer Index integer :: ft ! Function Type Index integer :: iv ! index of the exposed leaf layer for each canopy layer and pft @@ -1272,7 +1299,7 @@ subroutine UpdateCanopyNCanNRadPresent(currentPatch) do while(associated(currentCohort)) currentPatch%ncan(currentCohort%canopy_layer,currentCohort%pft) = & - max(currentPatch%ncan(currentCohort%canopy_layer,currentCohort%pft),currentCohort%NV) + max(currentPatch%ncan(currentCohort%canopy_layer,currentCohort%pft),currentCohort%NV) currentCohort => currentCohort%shorter @@ -1282,16 +1309,16 @@ subroutine UpdateCanopyNCanNRadPresent(currentPatch) currentPatch%nrad = currentPatch%ncan ! Now loop through and identify which layer and pft combo has scattering elements - do CL = 1,cp_nclmax + do cl = 1,cp_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 + 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 + enddo !cl return end subroutine UpdateCanopyNCanNRadPresent @@ -1385,7 +1412,9 @@ subroutine GetCanopyGasParameters(can_press, & co2_cpoint = 1.0_r8 end if - ! THESE HARD CODED CONVERSIONS NEED TO BE CALLED FROM GLOBAL CONSTANTS (RGK 10-13-2016) + ! THESE HARD CODED CONVERSIONS NEED TO BE CALLED FROM GLOBAL CONSTANTS + ! (RGK 10-13-201). THE MEANING OF CF IS UNCLEAR, BUT THIS APPEARS TO BE A MOLAR CONVERSION + cf = can_press/(rgas*1.e-3_r8 * air_tempk )*1.e06_r8 gb_mol = (1._r8/ rb) * cf @@ -1410,22 +1439,22 @@ subroutine LeafLayerMaintenanceRespiration(lmr25top_ft, & use pftconMod , only : pftcon ! Arguments - real(r8), intent(in) :: lmr25top_ft ! canopy top leaf maint resp rate at 25C - ! for this pft (umol CO2/m**2/s) - integer, intent(in) :: ft ! (plant) Functional Type Index - real(r8), intent(in) :: nscaler ! Scale for leaf nitrogen profile - real(r8), intent(in) :: veg_tempk ! vegetation temperature - real(r8), intent(out) :: lmr ! Leaf Maintenance Respiration (umol CO2/m**2/s) + real(r8), intent(in) :: lmr25top_ft ! canopy top leaf maint resp rate at 25C + ! for this pft (umol CO2/m**2/s) + integer, intent(in) :: ft ! (plant) Functional Type Index + real(r8), intent(in) :: nscaler ! Scale for leaf nitrogen profile + real(r8), intent(in) :: veg_tempk ! vegetation temperature + real(r8), intent(out) :: lmr ! Leaf Maintenance Respiration (umol CO2/m**2/s) ! Locals - real(r8) :: lmr25 ! leaf layer: leaf maintenance respiration rate at 25C (umol CO2/m**2/s) - + real(r8) :: lmr25 ! leaf layer: leaf maintenance respiration rate at 25C (umol CO2/m**2/s) ! Parameter real(r8), parameter :: lmrha = 46390._r8 ! activation energy for lmr (J/mol) real(r8), parameter :: lmrhd = 150650._r8 ! deactivation energy for lmr (J/mol) real(r8), parameter :: lmrse = 490._r8 ! entropy term for lmr (J/mol/K) - real(r8), parameter :: lmrc = 1.15912391_r8 ! scaling factor for high temperature inhibition (25 C = 1.0) + real(r8), parameter :: lmrc = 1.15912391_r8 ! scaling factor for high + ! temperature inhibition (25 C = 1.0) ! Part I: Leaf Maintenance respiration: umol CO2 / m**2 [leaf] / s ! ---------------------------------------------------------------------------------- @@ -1442,7 +1471,7 @@ subroutine LeafLayerMaintenanceRespiration(lmr25top_ft, & ! Any hydrodynamic limitations could go here, currently none ! lmr = lmr * (nothing) - end subroutine LeafLayerMaintenanceRespiration + end subroutine LeafLayerMaintenanceRespiration ! ==================================================================================== @@ -1495,16 +1524,22 @@ subroutine LeafLayerBiophysicalRates( parsun_lsl, & real(r8), intent(in) :: btran ! transpiration wetness factor (0 to 1) real(r8), intent(out) :: vcmax ! maximum rate of carboxylation (umol co2/m**2/s) - real(r8), intent(out) :: jmax ! maximum electron transport rate (umol electrons/m**2/s) - real(r8), intent(out) :: tpu ! triose phosphate utilization rate (umol CO2/m**2/s) + real(r8), intent(out) :: jmax ! maximum electron transport rate + ! (umol electrons/m**2/s) + real(r8), intent(out) :: tpu ! triose phosphate utilization rate + ! (umol CO2/m**2/s) real(r8), intent(out) :: co2_rcurve_islope ! initial slope of CO2 response curve (C4 plants) ! Locals ! ------------------------------------------------------------------------------- - real(r8) :: vcmax25 ! leaf layer: maximum rate of carboxylation at 25C (umol CO2/m**2/s) - real(r8) :: jmax25 ! leaf layer: maximum electron transport rate at 25C (umol electrons/m**2/s) - real(r8) :: tpu25 ! leaf layer: triose phosphate utilization rate at 25C (umol CO2/m**2/s) - real(r8) :: co2_rcurve_islope25 ! leaf layer: Initial slope of CO2 response curve (C4 plants) at 25C + real(r8) :: vcmax25 ! leaf layer: maximum rate of carboxylation at 25C + ! (umol CO2/m**2/s) + real(r8) :: jmax25 ! leaf layer: maximum electron transport rate at 25C + ! (umol electrons/m**2/s) + real(r8) :: tpu25 ! leaf layer: triose phosphate utilization rate at 25C + ! (umol CO2/m**2/s) + real(r8) :: co2_rcurve_islope25 ! leaf layer: Initial slope of CO2 response curve + ! (C4 plants) at 25C ! Parameters @@ -1518,9 +1553,12 @@ subroutine LeafLayerBiophysicalRates( parsun_lsl, & real(r8), parameter :: vcmaxse = 485._r8 ! entropy term for vcmax (J/mol/K) real(r8), parameter :: jmaxse = 495._r8 ! entropy term for jmax (J/mol/K) real(r8), parameter :: tpuse = 490._r8 ! entropy term for tpu (J/mol/K) - real(r8), parameter :: vcmaxc = 1.1534040_r8 ! scaling factor for high temperature inhibition (25 C = 1.0) - real(r8), parameter :: jmaxc = 1.1657242_r8 ! scaling factor for high temperature inhibition (25 C = 1.0) - real(r8), parameter :: tpuc = 1.1591239_r8 ! scaling factor for high temperature inhibition (25 C = 1.0) + real(r8), parameter :: vcmaxc = 1.1534040_r8 ! scaling factor for high + ! temperature inhibition (25 C = 1.0) + real(r8), parameter :: jmaxc = 1.1657242_r8 ! scaling factor for high + ! temperature inhibition (25 C = 1.0) + real(r8), parameter :: tpuc = 1.1591239_r8 ! scaling factor for high + ! temperature inhibition (25 C = 1.0) if ( parsun_lsl <= 0._r8) then ! night time vcmax = 0._r8 @@ -1543,15 +1581,14 @@ subroutine LeafLayerBiophysicalRates( parsun_lsl, & vcmax = vcmax / (1._r8 + exp( 0.2_r8*((tfrz+15._r8)-veg_tempk ) )) vcmax = vcmax / (1._r8 + exp( 0.3_r8*(veg_tempk-(tfrz+40._r8)) )) end if - co2_rcurve_islope = co2_rcurve_islope25 * 2._r8**((veg_tempk-(tfrz+25._r8))/10._r8) !q10 response of product limited psn. + !q10 response of product limited psn. + co2_rcurve_islope = co2_rcurve_islope25 * 2._r8**((veg_tempk-(tfrz+25._r8))/10._r8) end if ! Adjust for water limitations vcmax = vcmax * btran - + return - end subroutine LeafLayerBiophysicalRates - - + end subroutine LeafLayerBiophysicalRates end module FATESPhotosynthesisMod From 682a17f1dad0dda6a309c7bc16b8790a1fdd2823 Mon Sep 17 00:00:00 2001 From: Jacquelyn Shuman Date: Mon, 5 Dec 2016 15:25:03 -0700 Subject: [PATCH 259/437] variable change per spitfire cleanup updated 'use_ed_spit_fire' to 'use_ed_spitfire' Fixes: part of spitfire cleanup to variables user interface changes?: No Code review: JK Shuman Testing: none, will test following further variable cleanup --- fire/SFMainMod.F90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index 490d25b5..bd8474ee 100755 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -44,7 +44,7 @@ module SFMainMod ! ============================================================================ subroutine fire_model( currentSite, atm2lnd_inst, temperature_inst) - use clm_varctl, only : use_ed_spit_fire + use clm_varctl, only : use_ed_spitfire type(ed_site_type) , intent(inout), target :: currentSite type(atm2lnd_type) , intent(in) :: atm2lnd_inst @@ -62,10 +62,10 @@ subroutine fire_model( currentSite, atm2lnd_inst, temperature_inst) enddo if(write_SF==1)then - write(iulog,*) 'use_ed_spit_fire',use_ed_spit_fire + write(iulog,*) 'use_ed_spitfire',use_ed_spitfire endif - if(use_ed_spit_fire)then + if(use_ed_spitfire)then call fire_danger_index(currentSite, temperature_inst, atm2lnd_inst) call wind_effect(currentSite, atm2lnd_inst) call charecteristics_of_fuel(currentSite) @@ -579,7 +579,7 @@ subroutine fire_intensity ( currentSite ) !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 clm_varctl, only : use_ed_spitfire use SFParamsMod, only : SF_val_fdi_alpha,SF_val_fuel_energy, & SF_val_max_durat, SF_val_durat_slope @@ -619,7 +619,7 @@ subroutine fire_intensity ( currentSite ) 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 + if(.not. use_ed_spitfire)then currentPatch%fire = 0 !fudge to turn fire off endif From daa2aeb73244bf141183cb78c85bd4b01d3b13a7 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 5 Dec 2016 15:23:26 -0800 Subject: [PATCH 260/437] Some minor format refactors, mostly line length truncation and removing unused variables. --- biogeophys/FatesPhotosynthesisMod.F90 | 170 +++++++++++++++----------- 1 file changed, 96 insertions(+), 74 deletions(-) diff --git a/biogeophys/FatesPhotosynthesisMod.F90 b/biogeophys/FatesPhotosynthesisMod.F90 index 7a313a65..51ec13f3 100644 --- a/biogeophys/FatesPhotosynthesisMod.F90 +++ b/biogeophys/FatesPhotosynthesisMod.F90 @@ -103,6 +103,8 @@ subroutine FatesPhotosynthesis (nsites, sites,bc_in,bc_out,dtime) ! If we are not using hydraulics, we calculate a unique solution for each ! level-pft-layer combination. Thus the following three arrays are statically ! allocated for the maximum space of the two cases (numCohortsPerPatch) + ! The "_z" suffix indicates these variables are discretized at the "leaf_layer" + ! scale. ! ----------------------------------------------------------------------------------- ! leaf maintenance (dark) respiration (umol CO2/m**2/s) Double check this @@ -118,47 +120,52 @@ subroutine FatesPhotosynthesis (nsites, sites,bc_in,bc_out,dtime) ! used already logical :: rate_mask_z(cp_nclmax,mxpft,cp_nlevcan) - - real(r8) :: vcmax_z ! leaf layer maximum rate of carboxylation (umol co2/m**2/s) - real(r8) :: jmax_z ! leaf layer maximum electron transport rate (umol electrons/m**2/s) - real(r8) :: tpu_z ! leaf layer triose phosphate utilization rate (umol CO2/m**2/s) - real(r8) :: kp_z ! leaf layer initial slope of CO2 response curve (C4 plants) - real(r8) :: lnc ! leaf N concentration (gN leaf/m^2) - real(r8) :: mm_kco2 ! Michaelis-Menten constant for CO2 (Pa) - real(r8) :: mm_ko2 ! Michaelis-Menten constant for O2 (Pa) - real(r8) :: co2_cpoint ! CO2 compensation point (Pa) - real(r8) :: btran_eff ! effective transpiration wetness factor (0 to 1) - - - real(r8) :: bbb ! Ball-Berry minimum leaf conductance (umol H2O/m**2/s) - 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 - - ! Other - integer :: cl,s,iv,j,ps,ft,ifp ! indices - integer :: nv ! number of leaf layers - integer :: NCL_p ! number of canopy layers in patch - real(r8) :: cf ! s m**2/umol -> s/m - real(r8) :: gb_mol ! leaf boundary layer conductance (umol H2O/m**2/s) - real(r8) :: ceair ! vapor pressure of air, constrained (Pa) - real(r8) :: nscaler ! leaf nitrogen scaling coefficient - real(r8) :: leaf_frac ! ratio of to leaf biomass to total alive biomass - real(r8) :: laican ! canopy sum of lai_z - real(r8) :: vai ! leaf and steam area in ths layer. - real(r8) :: laifrac - real(r8) :: tcsoi ! Temperature response function for root respiration. - real(r8) :: tcwood ! Temperature response function for wood - real(r8) :: tree_area - real(r8) :: gs_cohort - real(r8) :: rscanopy - real(r8) :: elai - real(r8) :: live_stem_n ! Live stem (above-ground sapwood) nitrogen content (kgN/plant) - real(r8) :: live_croot_n ! Live coarse root (below-ground sapwood) nitrogen content (kgN/plant) - real(r8) :: froot_n ! Fine root nitrogen content (kgN/plant) + real(r8) :: vcmax_z ! leaf layer maximum rate of carboxylation + ! (umol co2/m**2/s) + real(r8) :: jmax_z ! leaf layer maximum electron transport rate + ! (umol electrons/m**2/s) + real(r8) :: tpu_z ! leaf layer triose phosphate utilization rate + ! (umol CO2/m**2/s) + real(r8) :: kp_z ! leaf layer initial slope of CO2 response + ! curve (C4 plants) + real(r8) :: lnc ! leaf N concentration (gN leaf/m^2) + real(r8) :: mm_kco2 ! Michaelis-Menten constant for CO2 (Pa) + real(r8) :: mm_ko2 ! Michaelis-Menten constant for O2 (Pa) + real(r8) :: co2_cpoint ! CO2 compensation point (Pa) + real(r8) :: btran_eff ! effective transpiration wetness factor (0 to 1) + real(r8) :: bbb ! Ball-Berry minimum leaf conductance (umol H2O/m**2/s) + 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) :: cf ! s m**2/umol -> s/m + real(r8) :: gb_mol ! leaf boundary layer conductance (umol H2O/m**2/s) + real(r8) :: ceair ! vapor pressure of air, constrained (Pa) + real(r8) :: nscaler ! leaf nitrogen scaling coefficient + real(r8) :: leaf_frac ! ratio of to leaf biomass to total alive biomass + real(r8) :: laican ! canopy sum of lai_z + real(r8) :: vai ! leaf and steam area in ths layer. + real(r8) :: tcsoi ! Temperature response function for root respiration. + real(r8) :: tcwood ! Temperature response function for wood + real(r8) :: rscanopy ! Canopy resistance [s/m] + real(r8) :: elai ! exposed LAI (patch scale) + real(r8) :: live_stem_n ! Live stem (above-ground sapwood) + ! nitrogen content (kgN/plant) + real(r8) :: live_croot_n ! Live coarse root (below-ground sapwood) + ! nitrogen content (kgN/plant) + real(r8) :: froot_n ! Fine root nitrogen content (kgN/plant) + + + integer :: cl,s,iv,j,ps,ft,ifp ! indices + integer :: nv ! number of leaf layers + integer :: NCL_p ! number of canopy layers in patch ! Parameters ! ----------------------------------------------------------------------- @@ -188,13 +195,15 @@ subroutine FatesPhotosynthesis (nsites, sites,bc_in,bc_out,dtime) associate( & - c3psn => pftcon%c3psn , & - 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) - frootcn => pftcon%frootcn , & ! froot C:N (gc/gN) ! slope of BB relationship + c3psn => pftcon%c3psn , & + 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) + frootcn => pftcon%frootcn, & ! froot C:N (gc/gN) ! slope of BB relationship q10 => EDParamsShareInst%Q10) do s = 1,nsites @@ -750,7 +759,6 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in real(r8), intent(out) :: anet_av_out ! net leaf photosynthesis (umol CO2/m**2/s) ! averaged over sun and shade leaves. - ! Locals ! ------------------------------------------------------------------------ integer :: pp_type ! Index for the different photosynthetic pathways C3,C4 @@ -772,7 +780,8 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in real(r8) :: gs_mol_err ! gs_mol for error check real(r8) :: ac ! Rubisco-limited gross photosynthesis (umol CO2/m**2/s) real(r8) :: aj ! RuBP-limited gross photosynthesis (umol CO2/m**2/s) - real(r8) :: ap ! product-limited (C3) or CO2-limited (C4) gross photosynthesis (umol CO2/m**2/s) + real(r8) :: ap ! product-limited (C3) or CO2-limited + ! (C4) gross photosynthesis (umol CO2/m**2/s) real(r8) :: ai ! intermediate co-limited photosynthesis (umol CO2/m**2/s) real(r8) :: leaf_co2_ppress ! CO2 partial pressure at leaf surface (Pa) ! Parameters @@ -826,14 +835,15 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in !Loop aroun shaded and unshaded leaves psn_out = 0._r8 ! psn is accumulated across sun and shaded leaves. - rstoma_out = 0._r8 ! 1/rs is accumulated across sun and shaded leaves. + rstoma_out = 0._r8 ! 1/rs is accumulated across sun and shaded leaves. anet_av_out = 0._r8 gstoma = 0._r8 do sunsha = 1,2 - ! Electron transport rate for C3 plants. Convert par from W/m2 to umol photons/m**2/s - ! using the factor 4.6 - ! Convert from units of par absorbed per unit ground area to par absorbed per unit leaf area. + ! Electron transport rate for C3 plants. + ! Convert par from W/m2 to umol photons/m**2/s using the factor 4.6 + ! Convert from units of par absorbed per unit ground area to par + ! absorbed per unit leaf area. if(sunsha == 1)then !sunlit if(( laisun_lsl * canopy_area_lsl) > 0.0000000001_r8)then @@ -885,7 +895,8 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in (co2_intra_c+mm_kco2 * (1._r8+can_o2_ppress / mm_ko2 )) ! C3: RuBP-limited photosynthesis - aj = je * max(co2_intra_c-co2_cpoint, 0._r8) / (4._r8*co2_intra_c+8._r8*co2_cpoint) + aj = je * max(co2_intra_c-co2_cpoint, 0._r8) / & + (4._r8*co2_intra_c+8._r8*co2_cpoint) ! C3: Product-limited photosynthesis ap = 3._r8 * tpu @@ -897,7 +908,8 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in ! C4: RuBP-limited photosynthesis if(sunsha == 1)then !sunlit - if((laisun_lsl * canopy_area_lsl) > 0.0000000001_r8) then !guard against /0's in the night. + !guard against /0's in the night. + if((laisun_lsl * canopy_area_lsl) > 0.0000000001_r8) then aj = quant_eff(pp_type) * parsun_lsl * 4.6_r8 !convert from per cohort to per m2 of leaf) aj = aj / (laisun_lsl * canopy_area_lsl) @@ -939,8 +951,9 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in leaf_co2_ppress = can_co2_ppress- 1.4_r8/gb_mol * anet * can_press leaf_co2_ppress = max(leaf_co2_ppress,1.e-06_r8) aquad = leaf_co2_ppress - bquad = leaf_co2_ppress*(gb_mol - bbb) - bb_slope(ft) * anet * can_press - cquad = -gb_mol*(leaf_co2_ppress*bbb + bb_slope(ft)*anet*can_press * ceair/ veg_esat ) + bquad = leaf_co2_ppress*(gb_mol - bbb) - bb_slope(ft) * anet * can_press + cquad = -gb_mol*(leaf_co2_ppress*bbb + & + bb_slope(ft)*anet*can_press * ceair/ veg_esat ) call quadratic_f (aquad, bquad, cquad, r1, r2) gs_mol = max(r1,r2) @@ -949,11 +962,13 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in co2_intra_c = can_co2_ppress - anet * can_press * & (1.4_r8*gs_mol+1.6_r8*gb_mol) / (gb_mol*gs_mol) - ! Check for co2_intra_c convergence. Delta co2_intra_c/pair = mol/mol. Multiply by 10**6 to - ! convert to umol/mol (ppm). Exit iteration if convergence criteria of +/- 1 x 10**-6 ppm - ! is met OR if at least ten iterations (niter=10) are completed + ! Check for co2_intra_c convergence. Delta co2_intra_c/pair = mol/mol. + ! Multiply by 10**6 to convert to umol/mol (ppm). Exit iteration if + ! convergence criteria of +/- 1 x 10**-6 ppm is met OR if at least ten + ! iterations (niter=10) are completed - if ((abs(co2_intra_c-co2_intra_c_old)/can_press*1.e06_r8 <= 2.e-06_r8) .or. niter == 5) then + if ((abs(co2_intra_c-co2_intra_c_old)/can_press*1.e06_r8 <= 2.e-06_r8) & + .or. niter == 5) then loop_continue = .false. end if end do !iteration loop @@ -963,10 +978,12 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in gs_mol = bbb end if - ! Final estimates for leaf_co2_ppress and co2_intra_c (needed for early exit of co2_intra_c iteration when an < 0) + ! Final estimates for leaf_co2_ppress and co2_intra_c + ! (needed for early exit of co2_intra_c iteration when an < 0) leaf_co2_ppress = can_co2_ppress - 1.4_r8/gb_mol * anet * can_press leaf_co2_ppress = max(leaf_co2_ppress,1.e-06_r8) - co2_intra_c = can_co2_ppress - anet * can_press * (1.4_r8*gs_mol+1.6_r8*gb_mol) / (gb_mol*gs_mol) + co2_intra_c = can_co2_ppress - anet * can_press * & + (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 @@ -975,7 +992,8 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in if ( DEBUG ) write(fates_log(),*) 'EDPhoto 738 ', agross if ( DEBUG ) write(fates_log(),*) 'EDPhoto 739 ', f_sun_lsl - !accumulate total photosynthesis umol/m2 ground/s-1. weight per unit sun and sha leaves. + ! Accumulate total photosynthesis umol/m2 ground/s-1. + ! weight per unit sun and sha leaves. if(sunsha == 1)then !sunlit psn_out = psn_out + agross * f_sun_lsl anet_av_out = anet_av_out + anet * f_sun_lsl @@ -1012,7 +1030,9 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in !average leaf-level stomatal resistance rate over sun and shade leaves... rstoma_out = 1._r8/gstoma - else !No leaf area. This layer is present only because of stems. (leaves are off, or have reduced to 0 + else + !No leaf area. This layer is present only because of stems. + ! (leaves are off, or have reduced to 0) psn_out = 0._r8 rstoma_out = min(rsmax0, 1._r8/bbb * cf) @@ -1163,10 +1183,10 @@ function fth_f(tl,hd,se,scaleFactor) result(ans) ! ! !ARGUMENTS: - real(r8), intent(in) :: tl ! leaf temperature in photosynthesis temperature function (K) - real(r8), intent(in) :: hd ! deactivation energy in photosynthesis temperature function (J/mol) - real(r8), intent(in) :: se ! entropy term in photosynthesis temperature function (J/mol/K) - real(r8), intent(in) :: scaleFactor ! scaling factor for high temperature inhibition (25 C = 1.0) + real(r8), intent(in) :: tl ! leaf temperature in photosynthesis temp function (K) + real(r8), intent(in) :: hd ! deactivation energy in photosynthesis temp function (J/mol) + real(r8), intent(in) :: se ! entropy term in photosynthesis temp function (J/mol/K) + real(r8), intent(in) :: scaleFactor ! scaling factor for high temp inhibition (25 C = 1.0) ! ! !LOCAL VARIABLES: real(r8) :: ans @@ -1195,8 +1215,8 @@ function fth25_f(hd,se)result(ans) ! ! !ARGUMENTS: - real(r8), intent(in) :: hd ! deactivation energy in photosynthesis temperature function (J/mol) - real(r8), intent(in) :: se ! entropy term in photosynthesis temperature function (J/mol/K) + real(r8), intent(in) :: hd ! deactivation energy in photosynthesis temp function (J/mol) + real(r8), intent(in) :: se ! entropy term in photosynthesis temp function (J/mol/K) ! ! !LOCAL VARIABLES: real(r8) :: ans @@ -1294,12 +1314,14 @@ subroutine UpdateCanopyNCanNRadPresent(currentPatch) ! --------------------------------------------------------------------------------- currentPatch%ncan(:,:) = 0 - !redo the canopy structure algorithm to get round a bug that is happening for site 125, FT13. + ! 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) + max(currentPatch%ncan(currentCohort%canopy_layer,currentCohort%pft), & + currentCohort%NV) currentCohort => currentCohort%shorter From e347c545ebcbf989ef90618a562d63b1cf28273b Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 6 Dec 2016 11:22:23 -0800 Subject: [PATCH 261/437] More minor syntactical changes to photosynthesis, some comments. --- ...od.F90 => FatesPlantRespPhotosynthMod.F90} | 21 ++++++++++++++----- 1 file changed, 16 insertions(+), 5 deletions(-) rename biogeophys/{FatesPhotosynthesisMod.F90 => FatesPlantRespPhotosynthMod.F90} (98%) diff --git a/biogeophys/FatesPhotosynthesisMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 similarity index 98% rename from biogeophys/FatesPhotosynthesisMod.F90 rename to biogeophys/FatesPlantRespPhotosynthMod.F90 index 51ec13f3..a2b615a1 100644 --- a/biogeophys/FatesPhotosynthesisMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -1,8 +1,8 @@ -module FATESPhotosynthesisMod +module FATESPlantRespPhotosynthMod !------------------------------------------------------------------------------------- ! !DESCRIPTION: - ! Calculates the photosynthetic fluxes for the FATES model + ! Calculates the plant respiration and photosynthetic fluxes for the FATES model ! This code is similar to and was originally based off of the 'photosynthesis' ! subroutine in the CLM model. ! @@ -591,8 +591,12 @@ subroutine FatesPhotosynthesis (nsites, sites,bc_in,bc_out,dtime) else currentCohort%livecroot_mr = 0._r8 end if - - ! convert gpp from umol/indiv/s-1 to kgC/indiv/s-1 = X * 12 *10-6 * 10-3 + + + ! ------------------------------------------------------------------ + ! Part IX: Perform some unit conversions (rate to integrated) and + ! calcualate some fluxes that are sums and nets of the base fluxes + ! ------------------------------------------------------------------ if ( DEBUG ) write(fates_log(),*) 'EDPhoto 904 ', currentCohort%resp_m if ( DEBUG ) write(fates_log(),*) 'EDPhoto 905 ', currentCohort%rdark @@ -630,6 +634,13 @@ subroutine FatesPhotosynthesis (nsites, sites,bc_in,bc_out,dtime) currentCohort%npp_tstep = currentCohort%gpp_tstep - & currentCohort%resp_tstep ! kgC/indiv/ts + + + ! psncanopy (gpp) and lmrcanopy (dark resp) are not used + ! by the host model right now. Once upon a time they were diagnostics. + ! Now we have our own diagnostics for GPP and LMR, so this step + ! is not really needed. + ! -------------------------------------------------------------------- bc_out(s)%psncanopy_pa(ifp) = bc_out(s)%psncanopy_pa(ifp) + & currentCohort%gpp_tstep bc_out(s)%lmrcanopy_pa(ifp) = bc_out(s)%lmrcanopy_pa(ifp) + & @@ -1613,4 +1624,4 @@ subroutine LeafLayerBiophysicalRates( parsun_lsl, & return end subroutine LeafLayerBiophysicalRates -end module FATESPhotosynthesisMod + end module FATESPlantRespPhotosynthMod From 21c11c2deab9769ef9bca57c2c66364fe54ec397 Mon Sep 17 00:00:00 2001 From: Jacquelyn Shuman Date: Tue, 6 Dec 2016 14:33:38 -0700 Subject: [PATCH 262/437] complete update of var 'use_ed_spit_fire' to 'use_ed_spitfire' --- main/EDInitMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 18a52c16..d35f39ee 100755 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -9,7 +9,7 @@ module EDInitMod use decompMod , only : bounds_type use abortutils , only : endrun use EDTypesMod , only : cp_nclmax - use clm_varctl , only : iulog, use_ed_spit_fire + use clm_varctl , only : iulog, use_ed_spitfire use clm_time_manager , only : is_restart use CanopyStateType , only : canopystate_type use WaterStateType , only : waterstate_type From 9af057a30794ce2f7731641af22116353913553d Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 6 Dec 2016 15:27:29 -0800 Subject: [PATCH 263/437] Changed the name of the photosynthesis module to reflect that it is fates, not ED, and that it handles respiration as well as photosynthesis. --- biogeophys/FatesPlantRespPhotosynthMod.F90 | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index a2b615a1..362aea48 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -29,9 +29,7 @@ module FATESPlantRespPhotosynthMod implicit none private - - ! PUBLIC MEMBER FUNCTIONS: - public :: FATESPhotosynthesis !ED specific photosynthesis routine + public :: FatesPlantRespPhotosynthDrive ! Called by the HLM-Fates interface character(len=*), parameter, private :: sourcefile = & __FILE__ @@ -46,7 +44,7 @@ module FATESPlantRespPhotosynthMod !-------------------------------------------------------------------------------------- - subroutine FatesPhotosynthesis (nsites, sites,bc_in,bc_out,dtime) + subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! ----------------------------------------------------------------------------------- ! !DESCRIPTION: @@ -681,7 +679,7 @@ subroutine FatesPhotosynthesis (nsites, sites,bc_in,bc_out,dtime) end do !site loop end associate - end subroutine FatesPhotosynthesis + end subroutine FatesPlantRespPhotosynthDrive ! ======================================================================================= From 11e122f18d5c5dc5db61daad42687a71a7372510 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 9 Dec 2016 14:52:19 -0800 Subject: [PATCH 264/437] Fixed index order on the rate_mask_z array. --- biogeophys/FatesPlantRespPhotosynthMod.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index 362aea48..abe0c7de 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -375,7 +375,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! not been done yet. ! ------------------------------------------------------------ - if ( .not.rate_mask_z(ft,cl,iv) .or. use_fates_plant_hydro ) then + if ( .not.rate_mask_z(cl,ft,iv) .or. use_fates_plant_hydro ) then if (use_fates_plant_hydro) then write(fates_log(),*) 'use_fates_plant_hydro in EDTypes' @@ -466,7 +466,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) rs_z(cl,ft,iv), & ! out anet_av_z(cl,ft,iv)) ! out - rate_mask_z(ft,cl,iv) = .true. + rate_mask_z(cl,ft,iv) = .true. end if end do From 04b503e8eea2230e1e236a65d577d92991b567ff Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 19 Dec 2016 14:54:06 -0800 Subject: [PATCH 265/437] Removed some unnecessary boundary conditions (LMR,PSN,GC). Reduced the scope of what is flushed in the photosynthesis mask to speed things up. --- biogeophys/FatesPlantRespPhotosynthMod.F90 | 134 +++++++-------------- main/EDTypesMod.F90 | 8 +- main/FatesInterfaceMod.F90 | 9 -- 3 files changed, 53 insertions(+), 98 deletions(-) diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index 362aea48..efb912b3 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -79,6 +79,8 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) use FatesConstantsMod, only : umol_per_mmol use FatesConstantsMod, only : rgas => rgas_J_K_kmol use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm + use FatesParameterDerivedMod, only : param_derived + ! ARGUMENTS: ! ----------------------------------------------------------------------------------- @@ -104,7 +106,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! The "_z" suffix indicates these variables are discretized at the "leaf_layer" ! scale. ! ----------------------------------------------------------------------------------- - + ! leaf maintenance (dark) respiration (umol CO2/m**2/s) Double check this real(r8) :: lmr_z(cp_nclmax,mxpft,cp_nlevcan) @@ -126,23 +128,13 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! (umol CO2/m**2/s) real(r8) :: kp_z ! leaf layer initial slope of CO2 response ! curve (C4 plants) - real(r8) :: lnc ! leaf N concentration (gN leaf/m^2) + real(r8) :: mm_kco2 ! Michaelis-Menten constant for CO2 (Pa) real(r8) :: mm_ko2 ! Michaelis-Menten constant for O2 (Pa) real(r8) :: co2_cpoint ! CO2 compensation point (Pa) real(r8) :: btran_eff ! effective transpiration wetness factor (0 to 1) real(r8) :: bbb ! Ball-Berry minimum leaf conductance (umol H2O/m**2/s) 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) :: cf ! s m**2/umol -> s/m real(r8) :: gb_mol ! leaf boundary layer conductance (umol H2O/m**2/s) real(r8) :: ceair ! vapor pressure of air, constrained (Pa) @@ -159,7 +151,14 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) real(r8) :: live_croot_n ! Live coarse root (below-ground sapwood) ! nitrogen content (kgN/plant) real(r8) :: froot_n ! Fine root nitrogen content (kgN/plant) - + real(r8) :: gccanopy_pa ! Patch level canopy stomatal conductance [mmol m-2 s-1] + + ! ----------------------------------------------------------------------------------- + ! Keeping these two definitions in case they need to be added later + ! + ! ----------------------------------------------------------------------------------- + !real(r8) :: psncanopy_pa ! patch sunlit leaf photosynthesis (umol CO2 /m**2/ s) + !real(r8) :: lmrcanopy_pa ! patch sunlit leaf maintenance respiration rate (umol CO2/m**2/s) integer :: cl,s,iv,j,ps,ft,ifp ! indices integer :: nv ! number of leaf layers @@ -202,7 +201,8 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) fnitr => pftcon%fnitr , & ! foliage nitrogen limitation factor (-) leafcn => pftcon%leafcn , & ! leaf C:N (gC/gN) frootcn => pftcon%frootcn, & ! froot C:N (gc/gN) ! slope of BB relationship - q10 => EDParamsShareInst%Q10) + q10 => EDParamsShareInst%Q10 ) + do s = 1,nsites @@ -219,11 +219,13 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! Part I. Zero output boundary conditions ! --------------------------------------------------------------------------- - bc_out(s)%psncanopy_pa(ifp) = 0._r8 - bc_out(s)%lmrcanopy_pa(ifp) = 0._r8 bc_out(s)%rssun_pa(ifp) = 0._r8 bc_out(s)%rssha_pa(ifp) = 0._r8 - bc_out(s)%gccanopy_pa(ifp) = 0._r8 + + gccanopy_pa = 0._r8 + + !psncanopy_pa = 0._r8 + !lmrcanopy_pa = 0._r8 ! Part II. Filter out patches ! Patch level filter flag for photosynthesis calculations @@ -270,32 +272,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! ------------------------------------------------------------------------ do ft = 1,numpft_ed - - - ! Leaf nitrogen concentration at the top of the canopy (g N leaf / m**2 leaf) - lnc = 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. - ! fudge - shortcut using fnitr as a proxy for vcmax... - vcmax25top(ft) = fnitr(ft) - - ! 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)-tfrzc),11._r8),35._r8)) * vcmax25top(ft) - - jmax25top(ft) = 1.67_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 @@ -304,20 +281,8 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) if (bc_in(s)%dayl_factor_pa(ifp) == 0._r8) then kn(ft) = 0._r8 else - kn(ft) = exp(0.00963_r8 * vcmax25top(ft) - 2.43_r8) + kn(ft) = exp(0.00963_r8 * param_derived%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. - ! - ! - ! 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 / (umolC_to_kgC * g_per_kg) end do !ft @@ -339,8 +304,10 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! With plant hydraulics, we must realize that photosynthesis and ! respiration will be different for leaves of each cohort in the leaf ! layers, as they will have there own hydraulic limitations. + ! NOTE: Only need to flush mask on the number of used pfts, not the whole + ! scratch space. ! ------------------------------------------------------------------------ - rate_mask_z(:,:,:) = .false. + rate_mask_z(:,1:numpft_ed,:) = .false. if(currentPatch%countcohorts > 0.0)then ! Ignore empty patches @@ -375,7 +342,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! not been done yet. ! ------------------------------------------------------------ - if ( .not.rate_mask_z(ft,cl,iv) .or. use_fates_plant_hydro ) then + if ( .not.rate_mask_z(cl,ft,iv) .or. use_fates_plant_hydro ) then if (use_fates_plant_hydro) then write(fates_log(),*) 'use_fates_plant_hydro in EDTypes' @@ -404,7 +371,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) nscaler = exp(-kn(ft) * laican) ! Part VII: Calculate dark respiration (leaf maintenance) for this layer - call LeafLayerMaintenanceRespiration( lmr25top(ft), & ! in + call LeafLayerMaintenanceRespiration( param_derived%lmr25top(ft),& ! in nscaler, & ! in ft, & ! in bc_in(s)%t_veg_pa(ifp), & ! in @@ -422,10 +389,10 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) call LeafLayerBiophysicalRates(currentPatch%ed_parsun_z(cl,ft,iv), & ! in ft, & ! in - vcmax25top(ft), & ! in - jmax25top(ft), & ! in - tpu25top(ft), & ! in - kp25top(ft), & ! in + param_derived%vcmax25top(ft), & ! in + param_derived%jmax25top(ft), & ! in + param_derived%tpu25top(ft), & ! in + param_derived%kp25top(ft), & ! in nscaler, & ! in bc_in(s)%t_veg_pa(ifp), & ! in btran_eff, & ! in @@ -466,7 +433,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) rs_z(cl,ft,iv), & ! out anet_av_z(cl,ft,iv)) ! out - rate_mask_z(ft,cl,iv) = .true. + rate_mask_z(cl,ft,iv) = .true. end if end do @@ -631,25 +598,15 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) currentCohort%resp_g ! kgC/indiv/ts currentCohort%npp_tstep = currentCohort%gpp_tstep - & currentCohort%resp_tstep ! kgC/indiv/ts + + ! Accumulate stomatal conductance over the patch + gccanopy_pa = gccanopy_pa + & + currentCohort%gscan * & + currentCohort%n /currentPatch%total_canopy_area - - - ! psncanopy (gpp) and lmrcanopy (dark resp) are not used - ! by the host model right now. Once upon a time they were diagnostics. - ! Now we have our own diagnostics for GPP and LMR, so this step - ! is not really needed. - ! -------------------------------------------------------------------- - bc_out(s)%psncanopy_pa(ifp) = bc_out(s)%psncanopy_pa(ifp) + & - currentCohort%gpp_tstep - bc_out(s)%lmrcanopy_pa(ifp) = bc_out(s)%lmrcanopy_pa(ifp) + & - currentCohort%resp_m - - ! accumulate cohort level canopy conductances over - ! whole area before dividing by total area - bc_out(s)%gccanopy_pa(ifp) = bc_out(s)%gccanopy_pa(ifp) + & - currentCohort%gscan * & - currentCohort%n /currentPatch%total_canopy_area - + !psncanopy_pa = psncanopy_pa + currentCohort%gpp_tstep + !lmrcanopy_pa = lmrcanopy_pa + currentCohort%resp_m + currentCohort => currentCohort%shorter enddo ! end cohort loop. @@ -658,18 +615,19 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) elai = calc_areaindex(currentPatch,'elai') - bc_out(s)%psncanopy_pa(ifp) = bc_out(s)%psncanopy_pa(ifp) / currentPatch%area - bc_out(s)%lmrcanopy_pa(ifp) = bc_out(s)%lmrcanopy_pa(ifp) / currentPatch%area - - if(bc_out(s)%gccanopy_pa(ifp) > 1._r8/rsmax0 .and. elai > 0.0_r8)then - rscanopy = (1.0_r8/bc_out(s)%gccanopy_pa(ifp))-bc_in(s)%rb_pa(ifp)/elai + !psncanopy_pa(ifp) = psncanopy_pa(ifp) / currentPatch%area + !lmrcanopy_pa(ifp) = lmrcanopy_pa(ifp) / currentPatch%area + + if(gccanopy_pa > 1._r8/rsmax0 .and. elai > 0.0_r8)then + rscanopy = (1.0_r8/gccanopy_pa)-bc_in(s)%rb_pa(ifp)/elai else rscanopy = rsmax0 end if + bc_out(s)%rssun_pa(ifp) = rscanopy bc_out(s)%rssha_pa(ifp) = rscanopy - !convert into umol m-2 s-1 then mmol m-2 s-1. - bc_out(s)%gccanopy_pa(ifp) = 1.0_r8/rscanopy*cf/umol_per_mmol + + end if currentPatch => currentPatch%younger diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index d3e697e3..5896931f 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -614,7 +614,7 @@ function map_clmpatch_to_edpatch(site, clmpatch_number) result(edpatch_pointer) type(ed_patch_type), pointer :: edpatch_pointer !---------------------------------------------------------------------- - ! There is a one-to-one mapping between edpatches and clmpatches. To obtain + ! There is a one-to-one mapping between edpatches and clmpatches. To obtainFatesDerivedFromParameters ! 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 @@ -670,4 +670,10 @@ subroutine set_root_fraction( this , depth_gl) end subroutine set_root_fraction + + ! ===================================================================================== + + + + end module EDTypesMod diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 356951bc..752e3576 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -191,9 +191,6 @@ module FatesInterfaceMod ! Shaded canopy resistance [s/m] real(r8), allocatable :: rssha_pa(:) - ! Canopy conductance [mmol m-2 s-1] - real(r8), allocatable :: gccanopy_pa(:) - ! patch sunlit leaf photosynthesis (umol CO2 /m**2/ s) real(r8), allocatable :: psncanopy_pa(:) @@ -406,9 +403,6 @@ subroutine allocate_bcout(bc_out) ! Photosynthesis allocate(bc_out%rssun_pa(numPatchesPerCol)) allocate(bc_out%rssha_pa(numPatchesPerCol)) - allocate(bc_out%gccanopy_pa(numPatchesPerCol)) - allocate(bc_out%lmrcanopy_pa(numPatchesPerCol)) - allocate(bc_out%psncanopy_pa(numPatchesPerCol)) ! Canopy Radiation allocate(bc_out%albd_parb(numPatchesPerCol,cp_numSWb)) @@ -481,9 +475,6 @@ subroutine zero_bcs(this,s) this%bc_out(s)%rssun_pa(:) = 0.0_r8 this%bc_out(s)%rssha_pa(:) = 0.0_r8 - this%bc_out(s)%gccanopy_pa(:) = 0.0_r8 - this%bc_out(s)%psncanopy_pa(:) = 0.0_r8 - this%bc_out(s)%lmrcanopy_pa(:) = 0.0_r8 this%bc_out(s)%albd_parb(:,:) = 0.0_r8 this%bc_out(s)%albi_parb(:,:) = 0.0_r8 From 57888d9ea04ee7d46d8b9af32c96fdabfc66584d Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 19 Dec 2016 14:55:50 -0800 Subject: [PATCH 266/437] Correction of minor typo. --- main/EDTypesMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 5896931f..c70f5c07 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -614,7 +614,7 @@ function map_clmpatch_to_edpatch(site, clmpatch_number) result(edpatch_pointer) type(ed_patch_type), pointer :: edpatch_pointer !---------------------------------------------------------------------- - ! There is a one-to-one mapping between edpatches and clmpatches. To obtainFatesDerivedFromParameters + ! 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 From d9a27df96da7b8f94083233f4607e049f29bb2da Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 20 Dec 2016 14:56:48 -0800 Subject: [PATCH 267/437] Adding the parameter derived module to version control. --- main/FatesParameterDerivedMod.F90 | 116 ++++++++++++++++++++++++++++++ 1 file changed, 116 insertions(+) create mode 100644 main/FatesParameterDerivedMod.F90 diff --git a/main/FatesParameterDerivedMod.F90 b/main/FatesParameterDerivedMod.F90 new file mode 100644 index 00000000..41641d75 --- /dev/null +++ b/main/FatesParameterDerivedMod.F90 @@ -0,0 +1,116 @@ +module FatesParameterDerivedMod + + ! ------------------------------------------------------------------------------------- + ! This module contains all procedures types and settings for any quantities that are + ! statically derived from static model parameters. These are unchanging quantities + ! and are based off of simple relationships from parameters that the user can + ! vary. This should be called once, and early in the model initialization call + ! sequence immediately after FATES parameters are read in. + ! ------------------------------------------------------------------------------------- + + use FatesConstantsMod, only : r8 => fates_r8 + use FatesConstantsMod, only : umolC_to_kgC + use FatesConstantsMod, only : g_per_kg + + type param_derived_type + + real(r8), allocatable :: vcmax25top(:) ! canopy top: maximum rate of carboxylation + ! at 25C (umol CO2/m**2/s) + real(r8), allocatable :: jmax25top(:) ! canopy top: maximum electron transport + ! rate at 25C (umol electrons/m**2/s) + real(r8), allocatable :: tpu25top(:) ! canopy top: triose phosphate utilization + ! rate at 25C (umol CO2/m**2/s) + real(r8), allocatable :: kp25top(:) ! canopy top: initial slope of CO2 response + ! curve (C4 plants) at 25C + real(r8), allocatable :: lmr25top(:) ! canopy top: leaf maintenance respiration + ! rate at 25C (umol CO2/m**2/s) + contains + + procedure :: Init + procedure :: InitAllocate + + end type param_derived_type + + type(param_derived_type) :: param_derived + +contains + + subroutine InitAllocate(this,maxpft) + + class(param_derived_type), intent(inout) :: this + integer, intent(in) :: maxpft + + allocate(this%vcmax25top(maxpft)) + allocate(this%jmax25top(maxpft)) + allocate(this%tpu25top(maxpft)) + allocate(this%kp25top(maxpft)) + allocate(this%lmr25top(maxpft)) + + return + end subroutine InitAllocate + + ! ===================================================================================== + + subroutine Init(this,maxpft) + + use pftconMod , only: pftcon + + class(param_derived_type), intent(inout) :: this + integer, intent(in) :: maxpft + + ! local variables + integer :: ft ! pft index + real(r8) :: lnc ! leaf N concentration (gN leaf/m^2) + + associate( & + slatop => pftcon%slatop , & ! specific leaf area at top of canopy, + ! projected area basis [m^2/gC] + fnitr => pftcon%fnitr , & ! foliage nitrogen limitation factor (-) + leafcn => pftcon%leafcn ) ! leaf C:N (gC/gN) + + call this%InitAllocate(maxpft) + + do ft = 1,maxpft + + ! Leaf nitrogen concentration at the top of the canopy (g N leaf / m**2 leaf) + lnc = 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. + ! fudge - shortcut using fnitr as a proxy for vcmax... + this%vcmax25top(ft) = fnitr(ft) + + ! 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)-tfrzc),11._r8),35._r8)) * vcmax25top(ft) + + this%jmax25top(ft) = 1.67_r8 * this%vcmax25top(ft) + this%tpu25top(ft) = 0.167_r8 * this%vcmax25top(ft) + this%kp25top(ft) = 20000._r8 * this%vcmax25top(ft) + + ! Leaf maintenance respiration to match the base rate used in CN + ! but with the new temperature functions for C3 and C4 plants. + ! + ! + ! CN respiration has units: g C / g N [leaf] / s. This needs to be + ! converted from g C / g N [leaf] / s to umol CO2 / m**2 [leaf] / s + ! + ! Then scale this value at the top of the canopy for canopy depth + + this%lmr25top(ft) = 2.525e-6_r8 * (1.5_r8 ** ((25._r8 - 20._r8)/10._r8)) + this%lmr25top(ft) = this%lmr25top(ft) * lnc / (umolC_to_kgC * g_per_kg) + + end do !ft + end associate + return + end subroutine Init + + +end module FatesParameterDerivedMod From 6d31307d3095d51a131fef3e505ad125930023aa Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 21 Dec 2016 11:40:23 -0800 Subject: [PATCH 268/437] Some minor optimizations in leaf layer photosynthesis; including the commenting out of debug calls, setting the initialization of a loop earlier in the code to remove a logic call, and adding an optional fast quadratic solver that simply removes error checking. The fast solve was left out, as this PR changegroup is not targetting optimization. --- biogeophys/FatesPlantRespPhotosynthMod.F90 | 88 ++++++++++++++++------ 1 file changed, 66 insertions(+), 22 deletions(-) diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index efb912b3..2b15e137 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -346,9 +346,9 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) if (use_fates_plant_hydro) then write(fates_log(),*) 'use_fates_plant_hydro in EDTypes' - write(fates_log(),*) 'has been set to true. You have inadvartently' + write(fates_log(),*) 'has been set to true. You have inadvertently' write(fates_log(),*) 'turned on a future feature that is not in the' - write(fates_log(),*) 'FATES model codeset yet. Please set this to' + write(fates_log(),*) 'FATES codeset yet. Please set this to' write(fates_log(),*) 'false and re-compile.' call endrun(msg=errMsg(sourcefile, __LINE__)) !! !! bbb = max (bbbopt(ps)*currentCohort%btran(iv), 1._r8) @@ -750,7 +750,8 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in real(r8) :: ap ! product-limited (C3) or CO2-limited ! (C4) gross photosynthesis (umol CO2/m**2/s) real(r8) :: ai ! intermediate co-limited photosynthesis (umol CO2/m**2/s) - real(r8) :: leaf_co2_ppress ! CO2 partial pressure at leaf surface (Pa) + real(r8) :: leaf_co2_ppress ! CO2 partial pressure at leaf surface (Pa) + real(r8) :: init_co2_intra_c ! First guess intracellular co2 specific to C path ! Parameters ! ------------------------------------------------------------------------ ! Fraction of light absorbed by non-photosynthetic pigments @@ -777,8 +778,10 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in if (nint(pftcon%c3psn(ft)) == 1) then! photosynthetic pathway: 0. = c4, 1. = c3 pp_type = 1 + init_co2_intra_c = init_a2l_co2_c3 * can_co2_ppress else pp_type = 2 + init_co2_intra_c = init_a2l_co2_c4 * can_co2_ppress end if ! Part III: Photosynthesis and Conductance @@ -792,13 +795,13 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in else ! day time (a little bit more complicated ...) - if ( DEBUG ) write(fates_log(),*) 'EDphot 594 ',laisun_lsl - if ( DEBUG ) write(fates_log(),*) 'EDphot 595 ',laisha_lsl +! if ( DEBUG ) write(fates_log(),*) 'EDphot 594 ',laisun_lsl +! if ( DEBUG ) write(fates_log(),*) 'EDphot 595 ',laisha_lsl !is there leaf area? - (NV can be larger than 0 with only stem area if deciduous) if ( laisun_lsl + laisha_lsl > 0._r8 ) then - if ( DEBUG ) write(fates_log(),*) '600 in laisun, laisha loop ' +! if ( DEBUG ) write(fates_log(),*) '600 in laisun, laisha loop ' !Loop aroun shaded and unshaded leaves psn_out = 0._r8 ! psn is accumulated across sun and shaded leaves. @@ -836,14 +839,8 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in call quadratic_f (aquad, bquad, cquad, r1, r2) je = min(r1,r2) - ! Iterative loop for ci beginning with initial guess - ! THIS CALL APPEARS TO BE REDUNDANT WITH LINE 423 (RGK) - - if (pp_type == 1)then - co2_intra_c = init_a2l_co2_c3 * can_co2_ppress - else - co2_intra_c = init_a2l_co2_c4 * can_co2_ppress - end if + ! Initialize intracellular co2 + co2_intra_c = init_co2_intra_c niter = 0 loop_continue = .true. @@ -855,7 +852,7 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in co2_intra_c_old = co2_intra_c ! Photosynthesis limitation rate calculations - if (pp_type == 1)then + if (pp_type == 1)then ! C3: Rubisco-limited photosynthesis ac = vcmax * max(co2_intra_c-co2_cpoint, 0._r8) / & @@ -875,7 +872,7 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in ! C4: RuBP-limited photosynthesis if(sunsha == 1)then !sunlit - !guard against /0's in the night. + !guard against /0's in the night. if((laisun_lsl * canopy_area_lsl) > 0.0000000001_r8) then aj = quant_eff(pp_type) * parsun_lsl * 4.6_r8 !convert from per cohort to per m2 of leaf) @@ -955,9 +952,9 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in ! Convert gs_mol (umol H2O/m**2/s) to gs (m/s) and then to rs (s/m) gs = gs_mol / cf - if ( DEBUG ) write(fates_log(),*) 'EDPhoto 737 ', psn_out - if ( DEBUG ) write(fates_log(),*) 'EDPhoto 738 ', agross - if ( DEBUG ) write(fates_log(),*) 'EDPhoto 739 ', f_sun_lsl +! if ( DEBUG ) write(fates_log(),*) 'EDPhoto 737 ', psn_out +! if ( DEBUG ) write(fates_log(),*) 'EDPhoto 738 ', agross +! if ( DEBUG ) write(fates_log(),*) 'EDPhoto 739 ', f_sun_lsl ! Accumulate total photosynthesis umol/m2 ground/s-1. ! weight per unit sun and sha leaves. @@ -972,9 +969,9 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in 1._r8/(min(1._r8/gs, rsmax0)) * (1.0_r8-f_sun_lsl) end if - if ( DEBUG ) write(fates_log(),*) 'EDPhoto 758 ', psn_out - if ( DEBUG ) write(fates_log(),*) 'EDPhoto 759 ', agross - if ( DEBUG ) write(fates_log(),*) 'EDPhoto 760 ', f_sun_lsl +! if ( DEBUG ) write(fates_log(),*) 'EDPhoto 758 ', psn_out +! if ( DEBUG ) write(fates_log(),*) 'EDPhoto 759 ', agross +! if ( DEBUG ) write(fates_log(),*) 'EDPhoto 760 ', f_sun_lsl ! Make sure iterative solution is correct if (gs_mol < 0._r8) then @@ -1238,6 +1235,53 @@ subroutine quadratic_f (a, b, c, r1, r2) end if end subroutine quadratic_f + + ! ==================================================================================== + + subroutine quadratic_fast (a, b, c, r1, r2) + ! + ! !DESCRIPTION: + !==============================================================================! + !----------------- Solve quadratic equation for its two roots -----------------! + ! THIS METHOD SIMPLY REMOVES THE DIV0 CHECK AND ERROR REPORTING ! + !==============================================================================! + ! Solution from Press et al (1986) Numerical Recipes: The Art of Scientific + ! Computing (Cambridge University Press, Cambridge), pp. 145. + ! + ! !REVISION HISTORY: + ! 4/5/10: Adapted from /home/bonan/ecm/psn/An_gs_iterative.f90 by Keith Oleson + ! 7/23/16: Copied over from CLM by Ryan Knox + ! + ! !USES: + ! + ! !ARGUMENTS: + real(r8), intent(in) :: a,b,c ! Terms for quadratic equation + real(r8), intent(out) :: r1,r2 ! Roots of quadratic equation + ! + ! !LOCAL VARIABLES: + real(r8) :: q ! Temporary term for quadratic solution + !------------------------------------------------------------------------------ + + ! if (a == 0._r8) then + ! write (fates_log(),*) 'Quadratic solution error: a = ',a + ! call endrun(msg=errMsg(sourcefile, __LINE__)) + ! end if + + if (b >= 0._r8) then + q = -0.5_r8 * (b + sqrt(b*b - 4._r8*a*c)) + else + q = -0.5_r8 * (b - sqrt(b*b - 4._r8*a*c)) + end if + + r1 = q / a + ! if (q /= 0._r8) then + r2 = c / q + ! else + ! r2 = 1.e36_r8 + ! end if + + end subroutine quadratic_fast + ! ==================================================================================== From 7d36492182245de083bf1d8f0b29ef337c63a956 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 4 Jan 2017 12:00:45 -0800 Subject: [PATCH 269/437] Potential fix to the negative leaf npp accounting problem. Still working on some diagnostics. Diagnostics are generating a floating point error. --- biogeochem/EDPhysiologyMod.F90 | 23 +++++++++++++++-------- 1 file changed, 15 insertions(+), 8 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index fccd8c08..2dd840be 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -839,12 +839,12 @@ subroutine Growth_Derivatives( currentSite, currentCohort) currentCohort%carbon_balance = currentCohort%npp_acc_hold - & currentCohort%md * EDecophyscon%leaf_stor_priority(currentCohort%pft) - ! Allowing only carbon from NPP pool to account for npp flux into the maintenance pools + ! Allowing only carbon from NPP pool to account for npp flux into the maintenance turnover pools ! ie this does not include any use of storage carbon or balive to make up for missing carbon balance in the transfer - currentCohort%npp_leaf = min(currentCohort%npp_acc_hold*currentCohort%leaf_md/currentCohort%md, & - currentCohort%leaf_md*EDecophyscon%leaf_stor_priority(currentCohort%pft)) - currentCohort%npp_froot = min(currentCohort%npp_acc_hold*currentCohort%root_md/currentCohort%md, & - currentCohort%root_md*EDecophyscon%leaf_stor_priority(currentCohort%pft)) + currentCohort%npp_leaf = max(0.0_r8,min(currentCohort%npp_acc_hold*currentCohort%leaf_md/currentCohort%md, & + currentCohort%leaf_md*EDecophyscon%leaf_stor_priority(currentCohort%pft))) + currentCohort%npp_froot = max(0.0_r8,min(currentCohort%npp_acc_hold*currentCohort%root_md/currentCohort%md, & + currentCohort%root_md*EDecophyscon%leaf_stor_priority(currentCohort%pft))) if (Bleaf(currentCohort) > 0._r8)then @@ -860,19 +860,27 @@ subroutine Growth_Derivatives( currentSite, currentCohort) !what fraction of allocation do we divert to storage? !what is the flux into the store? currentCohort%storage_flux = currentCohort%carbon_balance * f_store - + currentCohort%npp_store = currentCohort%carbon_balance * f_store if ( DEBUG ) write(iulog,*) 'EDphys B ',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 + + ! Note that npp_store only tracks the flux between NPP and storage. Storage can + ! also be drawn down to support some turnover demand. + currentCohort%npp_store = min(0.0_r8,currentCohort%npp_acc_hold) + currentCohort%carbon_balance = 0._r8 endif else - currentCohort%storage_flux = 0._r8 + currentCohort%storage_flux = currentCohort%carbon_balance + ! Note that npp_store only tracks the flux between NPP and storage. Storage can + ! also be drawn down to support some turnover demand. + currentCohort%npp_store = min(0.0_r8,currentCohort%npp_acc_hold) currentCohort%carbon_balance = 0._r8 write(iulog,*) 'ED: no leaf area in gd', currentCohort%indexnumber,currentCohort%n,currentCohort%bdead, & currentCohort%dbh,currentCohort%balive @@ -969,7 +977,6 @@ subroutine Growth_Derivatives( currentSite, currentCohort) endif currentCohort%npp_bseed = currentCohort%seed_prod - currentCohort%npp_store = max(0.0_r8,currentCohort%storage_flux) ! calculate change in diameter and height currentCohort%ddbhdt = currentCohort%dbdeaddt * dDbhdBd(currentCohort) From b3493b84d1e6143cd82063e0932db09ad0c54433 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 4 Jan 2017 13:30:47 -0800 Subject: [PATCH 270/437] CHanged the carbon accounting to when bleaf(cohort)<=0 to a failure. Added some print statements (temporarily). --- biogeochem/EDPhysiologyMod.F90 | 26 ++++++++++++++++++-------- main/ChecksBalancesMod.F90 | 16 ++++++++++++++++ 2 files changed, 34 insertions(+), 8 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 2dd840be..def99add 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -20,6 +20,12 @@ module EDPhysiologyMod use EDTypesMod , only : ncwd, cp_nlevcan, numpft_ed, senes use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type + use shr_log_mod , only : errMsg => shr_log_errMsg + use abortutils , only : endrun + use FatesGlobals , only : fates_log + + + implicit none private @@ -39,7 +45,8 @@ module EDPhysiologyMod public :: flux_into_litter_pools logical, parameter :: DEBUG = .false. ! local debug flag - + character(len=*), parameter, private :: sourcefile = & + __FILE__ ! ============================================================================ contains @@ -877,13 +884,16 @@ subroutine Growth_Derivatives( currentSite, currentCohort) else - currentCohort%storage_flux = currentCohort%carbon_balance - ! Note that npp_store only tracks the flux between NPP and storage. Storage can - ! also be drawn down to support some turnover demand. - currentCohort%npp_store = min(0.0_r8,currentCohort%npp_acc_hold) - currentCohort%carbon_balance = 0._r8 - write(iulog,*) 'ED: no leaf area in gd', currentCohort%indexnumber,currentCohort%n,currentCohort%bdead, & - currentCohort%dbh,currentCohort%balive + write(fates_log(),*) 'No target leaf area in GrowthDerivs? Bleaf(cohort) <= 0?' + call endrun(msg=errMsg(sourcefile, __LINE__)) + +! currentCohort%storage_flux = currentCohort%carbon_balance +! ! Note that npp_store only tracks the flux between NPP and storage. Storage can +! ! also be drawn down to support some turnover demand. +! currentCohort%npp_store = min(0.0_r8,currentCohort%npp_acc_hold) +! currentCohort%carbon_balance = 0._r8 +! write(iulog,*) 'ED: no leaf area in gd', currentCohort%indexnumber,currentCohort%n,currentCohort%bdead, & +! currentCohort%dbh,currentCohort%balive endif diff --git a/main/ChecksBalancesMod.F90 b/main/ChecksBalancesMod.F90 index 91d8d844..fa813b39 100644 --- a/main/ChecksBalancesMod.F90 +++ b/main/ChecksBalancesMod.F90 @@ -119,6 +119,14 @@ subroutine SummarizeNetFluxes( nsites, sites, bc_in, is_beg_day ) sum(currentPatch%seed_decay) + sum(currentPatch%leaf_litter_out) + & sum(currentPatch%root_litter_out)) * & ( currentPatch%area/AREA ) * 1.e3_r8 / ( 365.0_r8*SHR_CONST_CDAY ) + print*,"TS TERMS:", sites(s)%fates_to_bgc_this_ts, & + sum(currentPatch%CWD_AG_out), & + sum(currentPatch%CWD_BG_out), & + sum(currentPatch%seed_decay), & + sum(currentPatch%leaf_litter_out), & + sum(currentPatch%root_litter_out), & + ( currentPatch%area/AREA ) * 1.e3_r8 / ( 365.0_r8*SHR_CONST_CDAY ) + ! sites(s)%tot_seed_rain_flux = sites(s)%tot_seed_rain_flux + & sum(sites(s)%seed_rain_flux) * 1.e3_r8 / ( 365.0_r8*SHR_CONST_CDAY ) @@ -206,6 +214,14 @@ subroutine FATES_BGC_Carbon_Balancecheck(nsites, sites, bc_in, is_beg_day, dtime sites(s)%fire_c_to_atm*SHR_CONST_CDAY) sites(s)%cbal_err_fates = sites(s)%cbal_err_fates / SHR_CONST_CDAY + print*,"ERR TERMS:",sites(s)%totfatesc, & + sites(s)%totfatesc_old, & + sites(s)%npp_timeintegrated, & + sites(s)%tot_seed_rain_flux*SHR_CONST_CDAY, & + sites(s)%fates_to_bgc_this_ts*SHR_CONST_CDAY, & + sites(s)%fire_c_to_atm*SHR_CONST_CDAY, & + sites(s)%cbal_err_fates + sites(s)%cbal_err_bgc = sites(s)%totbgcc - & sites(s)%totbgcc_old - & From 8a373846fd390366ec23be6ec9400804a141f37b Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 6 Jan 2017 12:46:13 -0800 Subject: [PATCH 271/437] Bug fix: in copy cohort, npp_acc was not being copied! Now it is. This was leading to NaNs later on in runs and causing lots of problems. I added some numerical inquiry intrinsics to catch bad values, but I am considering putting them in a different place. --- biogeochem/EDCohortDynamicsMod.F90 | 4 ++- biogeochem/EDPhysiologyMod.F90 | 9 +----- biogeophys/EDAccumulateFluxesMod.F90 | 46 ++++++++++++++++++++++++++-- main/ChecksBalancesMod.F90 | 17 ---------- main/FatesConstantsMod.F90 | 9 ++++++ 5 files changed, 56 insertions(+), 29 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 81143bd5..2ed5d804 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -1038,13 +1038,15 @@ subroutine copy_cohort( currentCohort,copyc ) n%gpp_acc_hold = o%gpp_acc_hold n%gpp_acc = o%gpp_acc n%gpp_tstep = o%gpp_tstep + n%npp_acc_hold = o%npp_acc_hold n%npp_tstep = o%npp_tstep + n%npp_acc = o%npp_acc if ( DEBUG ) write(fates_log(),*) 'EDcohortDyn Ia ',o%npp_acc if ( DEBUG ) write(fates_log(),*) 'EDcohortDyn Ib ',o%resp_acc - n%npp_acc_hold = o%npp_acc_hold + n%resp_tstep = o%resp_tstep n%resp_acc = o%resp_acc n%resp_acc_hold = o%resp_acc_hold diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index def99add..ee269e69 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -873,6 +873,7 @@ subroutine Growth_Derivatives( currentSite, currentCohort) !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 ! Note that npp_store only tracks the flux between NPP and storage. Storage can @@ -887,14 +888,6 @@ subroutine Growth_Derivatives( currentSite, currentCohort) write(fates_log(),*) 'No target leaf area in GrowthDerivs? Bleaf(cohort) <= 0?' call endrun(msg=errMsg(sourcefile, __LINE__)) -! currentCohort%storage_flux = currentCohort%carbon_balance -! ! Note that npp_store only tracks the flux between NPP and storage. Storage can -! ! also be drawn down to support some turnover demand. -! currentCohort%npp_store = min(0.0_r8,currentCohort%npp_acc_hold) -! 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? diff --git a/biogeophys/EDAccumulateFluxesMod.F90 b/biogeophys/EDAccumulateFluxesMod.F90 index 78563a3a..3310207f 100644 --- a/biogeophys/EDAccumulateFluxesMod.F90 +++ b/biogeophys/EDAccumulateFluxesMod.F90 @@ -9,14 +9,19 @@ module EDAccumulateFluxesMod ! Rosie Fisher. March 2014. ! ! !USES: + use abortutils, only : endrun + use shr_log_mod , only : errMsg => shr_log_errMsg + use FatesConstantsMod, only : fates_huge, fates_tiny implicit none private ! public :: AccumulateFluxes_ED logical :: DEBUG = .false. ! for debugging this module - !------------------------------------------------------------------------------ + character(len=*), parameter, private :: sourcefile = & + __FILE__ + contains !------------------------------------------------------------------------------ @@ -33,6 +38,8 @@ subroutine AccumulateFluxes_ED(nsites, sites, bc_in, bc_out, dt_time) use EDTypesMod , only : ed_patch_type, ed_cohort_type, & ed_site_type, AREA use FatesInterfaceMod , only : bc_in_type,bc_out_type + use, intrinsic :: IEEE_ARITHMETIC + ! ! !ARGUMENTS integer, intent(in) :: nsites @@ -67,12 +74,45 @@ subroutine AccumulateFluxes_ED(nsites, sites, bc_in, bc_out, dt_time) ! _tstep fluxes are KgC/indiv/timestep _acc are KgC/indiv/day if ( DEBUG ) then - write(iulog,*) 'EDAccumFlux 64 ',ccohort%npp_acc, & - ccohort%npp_tstep + write(iulog,*) 'EDAccumFlux 64 ',ccohort%npp_tstep write(iulog,*) 'EDAccumFlux 66 ',ccohort%gpp_tstep write(iulog,*) 'EDAccumFlux 67 ',ccohort%resp_tstep endif + + ! Trap invalid values from photosynthesis and resp + ! ----------------------------------------------------------------------- + + if(ieee_is_nan(ccohort%gpp_tstep))then + write(iulog,*)'GPP NaN Trap Triggered',s,ifp,ccohort%gpp_tstep + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if(ieee_is_nan(ccohort%resp_tstep))then + write(iulog,*)'RESP NaN Trap Triggered',s,ifp,ccohort%resp_tstep + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + if(ieee_is_nan(ccohort%npp_tstep))then + write(iulog,*)'NPP NaN Trap Triggered',s,ifp,ccohort%npp_tstep + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if(.not.ieee_is_finite(ccohort%gpp_tstep))then + write(iulog,*)'GPP Infinite Trap Triggered',s,ifp,ccohort%gpp_tstep + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if(.not.ieee_is_finite(ccohort%resp_tstep))then + write(iulog,*)'RESP Infinite Trap Triggered',s,ifp,ccohort%resp_tstep + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if(.not.ieee_is_finite(ccohort%npp_tstep))then + write(iulog,*)'NPP Infinite Trap Triggered',s,ifp,ccohort%npp_tstep + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + ccohort%npp_acc = ccohort%npp_acc + ccohort%npp_tstep ccohort%gpp_acc = ccohort%gpp_acc + ccohort%gpp_tstep ccohort%resp_acc = ccohort%resp_acc + ccohort%resp_tstep diff --git a/main/ChecksBalancesMod.F90 b/main/ChecksBalancesMod.F90 index fa813b39..7a9e3e74 100644 --- a/main/ChecksBalancesMod.F90 +++ b/main/ChecksBalancesMod.F90 @@ -119,14 +119,6 @@ subroutine SummarizeNetFluxes( nsites, sites, bc_in, is_beg_day ) sum(currentPatch%seed_decay) + sum(currentPatch%leaf_litter_out) + & sum(currentPatch%root_litter_out)) * & ( currentPatch%area/AREA ) * 1.e3_r8 / ( 365.0_r8*SHR_CONST_CDAY ) - print*,"TS TERMS:", sites(s)%fates_to_bgc_this_ts, & - sum(currentPatch%CWD_AG_out), & - sum(currentPatch%CWD_BG_out), & - sum(currentPatch%seed_decay), & - sum(currentPatch%leaf_litter_out), & - sum(currentPatch%root_litter_out), & - ( currentPatch%area/AREA ) * 1.e3_r8 / ( 365.0_r8*SHR_CONST_CDAY ) - ! sites(s)%tot_seed_rain_flux = sites(s)%tot_seed_rain_flux + & sum(sites(s)%seed_rain_flux) * 1.e3_r8 / ( 365.0_r8*SHR_CONST_CDAY ) @@ -214,15 +206,6 @@ subroutine FATES_BGC_Carbon_Balancecheck(nsites, sites, bc_in, is_beg_day, dtime sites(s)%fire_c_to_atm*SHR_CONST_CDAY) sites(s)%cbal_err_fates = sites(s)%cbal_err_fates / SHR_CONST_CDAY - print*,"ERR TERMS:",sites(s)%totfatesc, & - sites(s)%totfatesc_old, & - sites(s)%npp_timeintegrated, & - sites(s)%tot_seed_rain_flux*SHR_CONST_CDAY, & - sites(s)%fates_to_bgc_this_ts*SHR_CONST_CDAY, & - sites(s)%fire_c_to_atm*SHR_CONST_CDAY, & - sites(s)%cbal_err_fates - - sites(s)%cbal_err_bgc = sites(s)%totbgcc - & sites(s)%totbgcc_old - & (sites(s)%fates_to_bgc_last_ts*SHR_CONST_CDAY - & diff --git a/main/FatesConstantsMod.F90 b/main/FatesConstantsMod.F90 index 3df36d6b..4368db17 100644 --- a/main/FatesConstantsMod.F90 +++ b/main/FatesConstantsMod.F90 @@ -55,4 +55,13 @@ module FatesConstantsMod real(fates_r8), parameter :: t_water_freeze_k_triple = 273.16_fates_r8 + ! For numerical inquiry + real(fates_r8), parameter :: fates_huge = huge(g_per_kg) + + real(fates_r8), parameter :: fates_tiny = tiny(g_per_kg) + + + + + end module FatesConstantsMod From 195a0b24105c93d485ad296351a2684b22d5c184 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 6 Jan 2017 16:05:00 -0800 Subject: [PATCH 272/437] Initial changes to timing boundary conditions, mostly directed towards the calculation of model-day for phenology. --- biogeochem/EDPhysiologyMod.F90 | 39 +++++++++++++++------------------- main/EDMainMod.F90 | 9 ++++++-- main/EDTypesMod.F90 | 1 + main/FatesInterfaceMod.F90 | 19 +++++++++++++++++ 4 files changed, 44 insertions(+), 24 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index fccd8c08..7ff0274e 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -8,7 +8,7 @@ module EDPhysiologyMod use shr_kind_mod , only : r8 => shr_kind_r8 use clm_varctl , only : iulog - use spmdMod , only : masterproc + use TemperatureType , only : temperature_type use SoilStateType , only : soilstate_type use WaterstateType , only : waterstate_type @@ -240,20 +240,21 @@ subroutine trim_canopy( currentSite ) end subroutine trim_canopy ! ============================================================================ - subroutine phenology( currentSite, temperature_inst, waterstate_inst) + subroutine phenology( currentSite, bc_in, temperature_inst, waterstate_inst) ! ! !DESCRIPTION: ! Phenology. ! ! !USES: use clm_varcon, only : tfrz - use clm_time_manager, only : get_curr_date - use clm_time_manager, only : get_ref_date, timemgr_datediff + use FatesInterfaceMod, only : bc_in_type use EDTypesMod, only : udata - use PatchType , only : patch + use PatchType , only : patch ! ! !ARGUMENTS: - type(ed_site_type) , intent(inout), target :: currentSite + type(ed_site_type), intent(inout), target :: currentSite + type(bc_in_type), intent(in) :: bc_in + type(temperature_type) , intent(in) :: temperature_inst type(waterstate_type) , intent(in) :: waterstate_inst ! @@ -283,8 +284,9 @@ subroutine phenology( currentSite, temperature_inst, waterstate_inst) 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 - real(r8) :: modelday + + real(r8), parameter :: mindayson = 30.0 + !------------------------------------------------------------------------ @@ -294,16 +296,9 @@ subroutine phenology( currentSite, temperature_inst, waterstate_inst) patchi = currentSite%oldest_patch%clm_pno-1 coli = patch%column(patchi) - t_veg24 => temperature_inst%t_veg24_patch ! Input: [real(r8) (:)] avg pft vegetation temperature for last 24 hrs + t_veg24 => temperature_inst%t_veg24_patch ! Input: [real(r8) (:)] avg pft vegetation temperature for last 24 hrs - call get_curr_date(yr, mon, day, sec) - curdate = yr*10000 + mon*100 + day - call get_ref_date(yr, mon, day, sec) - refdate = yr*10000 + mon*100 + day - - call timemgr_datediff(refdate, 0, curdate, sec, modelday) - if ( masterproc ) write(iulog,*) 'modelday',modelday ! Parameter of drought decid leaf loss in mm in top layer...FIX(RF,032414) ! - this is arbitrary and poorly understood. Needs work. ED_ @@ -316,7 +311,7 @@ subroutine phenology( currentSite, temperature_inst, waterstate_inst) c = -0.001_r8 coldday = 5.0_r8 !ed_ph_chiltemp - mindayson = 30 + !Parameters from SDGVM model of senesence ncolddayslim = 5 @@ -372,7 +367,7 @@ subroutine phenology( currentSite, temperature_inst, waterstate_inst) endif - timesinceleafoff = modelday - currentSite%leafoffdate + timesinceleafoff = bc_in%model_day - currentSite%leafoffdate !LEAF ON: COLD DECIDUOUS. Needs to !1) have exceeded the growing degree day threshold !2) The leaves should not be on already @@ -381,14 +376,14 @@ subroutine phenology( currentSite, temperature_inst, waterstate_inst) if (currentSite%status == 1) then if (currentSite%ncd >= 1) then currentSite%status = 2 !alter status of site to 'leaves on' - ! NOTE(bja, 2015-01) should leafondate = modelday to be consistent with leaf off? + ! NOTE(bja, 2015-01) should leafondate = model_day to be consistent with leaf off? currentSite%leafondate = t !record leaf on date if ( DEBUG ) write(iulog,*) 'leaves on' endif !ncd endif !status endif !GDD - timesinceleafon = modelday - currentSite%leafondate + timesinceleafon = bc_in%model_day - currentSite%leafondate !LEAF OFF: COLD THRESHOLD @@ -402,7 +397,7 @@ subroutine phenology( currentSite, temperature_inst, waterstate_inst) if (timesinceleafon > mindayson)then if (currentSite%status == 2)then currentSite%status = 1 !alter status of site to 'leaves on' - currentSite%leafoffdate = modelday !record leaf off date + currentSite%leafoffdate = bc_in%model_day !record leaf off date if ( DEBUG ) write(iulog,*) 'leaves off' endif endif @@ -412,7 +407,7 @@ subroutine phenology( currentSite, temperature_inst, waterstate_inst) if(timesinceleafoff > 400)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 = modelday !record leaf off date + currentSite%leafoffdate = bc_in%model_day !record leaf off date if ( DEBUG ) write(iulog,*) 'leaves off' endif endif diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 9499f93d..f496fb40 100755 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -17,6 +17,8 @@ module EDMainMod use SFMainMod , only : fire_model use EDtypesMod , only : ncwd, numpft_ed, udata use EDtypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type + use FatesInterfaceMod , only : bc_in_type + use spmdMod , only : masterproc implicit none private @@ -39,7 +41,7 @@ module EDMainMod contains !-------------------------------------------------------------------------------! - subroutine ed_ecosystem_dynamics(currentSite, & + subroutine ed_ecosystem_dynamics(currentSite, bc_in, & atm2lnd_inst, & soilstate_inst, temperature_inst, waterstate_inst) ! @@ -48,6 +50,7 @@ subroutine ed_ecosystem_dynamics(currentSite, & ! ! !ARGUMENTS: type(ed_site_type) , intent(inout), target :: currentSite + type(bc_in_type) , intent(in) :: bc_in type(atm2lnd_type) , intent(in) :: atm2lnd_inst type(soilstate_type) , intent(in) :: soilstate_inst type(temperature_type) , intent(in) :: temperature_inst @@ -57,6 +60,8 @@ subroutine ed_ecosystem_dynamics(currentSite, & type(ed_patch_type), pointer :: currentPatch !----------------------------------------------------------------------- + if ( masterproc ) write(iulog,*) 'modelday',bc_in%model_day + !************************************************************************** ! Fire, growth, biogeochemistry. !************************************************************************** @@ -66,7 +71,7 @@ subroutine ed_ecosystem_dynamics(currentSite, & call ed_total_balance_check(currentSite, 0) - call phenology(currentSite, temperature_inst, waterstate_inst) + call phenology(currentSite, bc_in, temperature_inst, waterstate_inst) call fire_model(currentSite, atm2lnd_inst, temperature_inst) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 6de2f1ea..4d80cf31 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -551,6 +551,7 @@ module EDTypesMod 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? + integer :: modelday ! Number of days since reference end type userdata diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 356951bc..46f1268a 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -50,6 +50,18 @@ module FatesInterfaceMod ! The actual number of FATES' ED patches integer :: npatches + ! Timing Variables + integer :: current_year ! Current year + integer :: current_month ! month of year + integer :: current_day ! day of month + integer :: current_tod ! time of day (seconds past 0Z) + integer :: current_date ! time of day (seconds past 0Z) + integer :: reference_date ! YYYYMMDD + real(r8) :: model_day ! elapsed days between current date and reference + ! uses ESMF functions, so prefered to pass it in as + ! argument rather than calculate directly + + ! Radiation variables for calculating sun/shade fractions ! --------------------------------------------------------------------------------- @@ -447,6 +459,13 @@ subroutine zero_bcs(this,s) integer, intent(in) :: s ! Input boundaries + this%bc_in(s)%current_year = 0 + this%bc_in(s)%current_month = 0 + this%bc_in(s)%current_day = 0 + this%bc_in(s)%current_tod = 0 + this%bc_in(s)%current_date = 0 + this%bc_in(s)%reference_date = 0 + this%bc_in(s)%model_day = 0.0_r8 this%bc_in(s)%solad_parb(:,:) = 0.0_r8 this%bc_in(s)%solai_parb(:,:) = 0.0_r8 From 0e9476e373a5180a06c0ccfcb2f3fd0c97d895ea Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Sun, 8 Jan 2017 21:39:55 -0800 Subject: [PATCH 273/437] Converted 24 vegetation temperatures used in phenology to bc_in --- biogeochem/EDPhysiologyMod.F90 | 28 +++++++--------------------- main/EDMainMod.F90 | 2 +- main/FatesInterfaceMod.F90 | 21 +++++++++++++++++++++ 3 files changed, 29 insertions(+), 22 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 7ff0274e..02eedb26 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -240,26 +240,25 @@ subroutine trim_canopy( currentSite ) end subroutine trim_canopy ! ============================================================================ - subroutine phenology( currentSite, bc_in, temperature_inst, waterstate_inst) + subroutine phenology( currentSite, bc_in, waterstate_inst) ! ! !DESCRIPTION: ! Phenology. ! ! !USES: - use clm_varcon, only : tfrz + use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm use FatesInterfaceMod, only : bc_in_type use EDTypesMod, only : udata - use PatchType , only : patch + ! ! !ARGUMENTS: type(ed_site_type), intent(inout), target :: currentSite type(bc_in_type), intent(in) :: bc_in - type(temperature_type) , intent(in) :: temperature_inst type(waterstate_type) , intent(in) :: waterstate_inst ! ! !LOCAL VARIABLES: - real(r8), pointer :: t_veg24(:) + 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 @@ -287,19 +286,6 @@ subroutine phenology( currentSite, bc_in, temperature_inst, waterstate_inst) real(r8), parameter :: mindayson = 30.0 - - !------------------------------------------------------------------------ - - ! INTERF-TODO: THIS IS A BAND-AID, AS I WAS HOPING TO REMOVE CLM_PNO - ! ALREADY REMOVED currentSite%clmcolumn, hence the need for these - - patchi = currentSite%oldest_patch%clm_pno-1 - coli = patch%column(patchi) - - t_veg24 => temperature_inst%t_veg24_patch ! Input: [real(r8) (:)] avg pft vegetation temperature for last 24 hrs - - - ! 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 @@ -318,7 +304,7 @@ subroutine phenology( currentSite, bc_in, temperature_inst, waterstate_inst) cold_t = 7.5_r8 ! ed_ph_coldtemp t = udata%time_period - temp_in_C = t_veg24(patchi) - tfrz + temp_in_C = bc_in%t_veg24_si - tfrz !-----------------Cold Phenology--------------------! @@ -362,8 +348,8 @@ subroutine phenology( currentSite, bc_in, temperature_inst, waterstate_inst) endif ! ! accumulate the GDD using daily mean temperatures - if (t_veg24(patchi) .gt. tfrz) then - currentSite%ED_GDD_site = currentSite%ED_GDD_site + t_veg24(currentSite%oldest_patch%clm_pno-1) - tfrz + if (bc_in%t_veg24_si .gt. tfrz) then + currentSite%ED_GDD_site = currentSite%ED_GDD_site + bc_in%t_veg24_si - tfrz endif diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index f496fb40..ffd7948d 100755 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -71,7 +71,7 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in, & call ed_total_balance_check(currentSite, 0) - call phenology(currentSite, bc_in, temperature_inst, waterstate_inst) + call phenology(currentSite, bc_in, waterstate_inst ) call fire_model(currentSite, atm2lnd_inst, temperature_inst) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 46f1268a..e61a6dda 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -61,6 +61,20 @@ module FatesInterfaceMod ! uses ESMF functions, so prefered to pass it in as ! argument rather than calculate directly + ! Vegetation Dynamics + ! --------------------------------------------------------------------------------- + + ! This 24 hour vegetation temperature is used for various purposes during vegetation + ! dynamics. However, we are currently using the bare-ground patch's value [K] + ! TO-DO: Get some consensus on the correct vegetation temperature used for phenology. + ! It is possible that the bare-ground value is where the average is being stored. + ! (RGK-01-2017) + + real(r8) :: t_veg24_si ! See above [K] + + ! Patch 24 hour vegetation temperature [K] + real(r8),allocatable :: t_veg24_pa(:) + ! Radiation variables for calculating sun/shade fractions ! --------------------------------------------------------------------------------- @@ -357,6 +371,10 @@ subroutine allocate_bcin(bc_in) ! Allocate input boundaries + ! Vegetation Dynamics + allocate(bc_in%t_veg24_pa(numPatchesPerCol)) + + ! Radiation allocate(bc_in%solad_parb(numPatchesPerCol,cp_numSWb)) allocate(bc_in%solai_parb(numPatchesPerCol,cp_numSWb)) @@ -467,6 +485,9 @@ subroutine zero_bcs(this,s) this%bc_in(s)%reference_date = 0 this%bc_in(s)%model_day = 0.0_r8 + this%bc_in(s)%t_veg24_pa(:) = 0.0_r8 + this%bc_in(s)%t_veg24_si = 0.0_r8 + this%bc_in(s)%solad_parb(:,:) = 0.0_r8 this%bc_in(s)%solai_parb(:,:) = 0.0_r8 this%bc_in(s)%smp_gl(:) = 0.0_r8 From 28d782e7c44a2a9237d397fae1599e508eb44489 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 9 Jan 2017 14:06:31 -0800 Subject: [PATCH 274/437] Small bug fix on previous merge conflict. Changed index ordering on temp photosynthesis arrays for performance. Added in a fix currently in another PR to help with testing (npp_acc in copy cohort). --- biogeochem/EDCohortDynamicsMod.F90 | 4 ++- biogeophys/FatesPlantRespPhotosynthMod.F90 | 41 ++++++++++++---------- main/FatesInterfaceMod.F90 | 4 +-- 3 files changed, 28 insertions(+), 21 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 3344cbb9..8d4f4bd5 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -1037,13 +1037,15 @@ subroutine copy_cohort( currentCohort,copyc ) n%gpp_acc_hold = o%gpp_acc_hold n%gpp_acc = o%gpp_acc n%gpp_tstep = o%gpp_tstep + n%npp_acc_hold = o%npp_acc_hold n%npp_tstep = o%npp_tstep if ( DEBUG ) write(fates_log(),*) 'EDcohortDyn Ia ',o%npp_acc if ( DEBUG ) write(fates_log(),*) 'EDcohortDyn Ib ',o%resp_acc - n%npp_acc_hold = o%npp_acc_hold + n%npp_acc = o%npp_acc + n%resp_tstep = o%resp_tstep n%resp_acc = o%resp_acc n%resp_acc_hold = o%resp_acc_hold diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index 2b15e137..73f995df 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -105,20 +105,25 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! allocated for the maximum space of the two cases (numCohortsPerPatch) ! The "_z" suffix indicates these variables are discretized at the "leaf_layer" ! scale. + ! Note: For these temporary arrays, we have the leaf layer dimension first + ! and the canopy layer last. This order is chosen for efficiency. The arrays + ! such as leaf area that are bound to the patch structure DO NOT follow this order + ! as they are used in many other parts of the code with different looping, we + ! are not modifying its order now. ! ----------------------------------------------------------------------------------- ! leaf maintenance (dark) respiration (umol CO2/m**2/s) Double check this - real(r8) :: lmr_z(cp_nclmax,mxpft,cp_nlevcan) + real(r8) :: lmr_z(cp_nlevcan,mxpft,cp_nclmax) ! stomatal resistance s/m - real(r8) :: rs_z(cp_nclmax,mxpft,cp_nlevcan) + real(r8) :: rs_z(cp_nlevcan,mxpft,cp_nclmax) ! net leaf photosynthesis averaged over sun and shade leaves. (umol CO2/m**2/s) - real(r8) :: anet_av_z(cp_nclmax,mxpft,cp_nlevcan) + real(r8) :: anet_av_z(cp_nlevcan,mxpft,cp_nclmax) ! Mask used to determine which leaf-layer biophysical rates have been ! used already - logical :: rate_mask_z(cp_nclmax,mxpft,cp_nlevcan) + logical :: rate_mask_z(cp_nlevcan,mxpft,cp_nclmax) real(r8) :: vcmax_z ! leaf layer maximum rate of carboxylation ! (umol co2/m**2/s) @@ -342,7 +347,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! not been done yet. ! ------------------------------------------------------------ - if ( .not.rate_mask_z(cl,ft,iv) .or. use_fates_plant_hydro ) then + if ( .not.rate_mask_z(iv,ft,cl) .or. use_fates_plant_hydro ) then if (use_fates_plant_hydro) then write(fates_log(),*) 'use_fates_plant_hydro in EDTypes' @@ -375,7 +380,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) nscaler, & ! in ft, & ! in bc_in(s)%t_veg_pa(ifp), & ! in - lmr_z(cl,ft,iv)) ! out + lmr_z(iv,ft,cl)) ! out ! Part VII: Calculate (1) maximum rate of carboxylation (vcmax), ! (2) maximum electron transport rate, (3) triose phosphate @@ -428,12 +433,12 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) mm_kco2, & ! in mm_ko2, & ! in co2_cpoint, & ! in - lmr_z(cl,ft,iv), & ! in + lmr_z(iv,ft,cl), & ! in currentPatch%psn_z(cl,ft,iv), & ! out - rs_z(cl,ft,iv), & ! out - anet_av_z(cl,ft,iv)) ! out + rs_z(iv,ft,cl), & ! out + anet_av_z(iv,ft,cl)) ! out - rate_mask_z(cl,ft,iv) = .true. + rate_mask_z(iv,ft,cl) = .true. end if end do @@ -455,9 +460,9 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) nv = currentCohort%nv call ScaleLeafLayerFluxToCohort(nv, & !in currentPatch%psn_z(cl,ft,1:nv), & !in - lmr_z(cl,ft,1:nv), & !in - rs_z(cl,ft,1:nv), & !in - anet_av_z(cl,ft,1:nv), & !in + lmr_z(1:nv,ft,cl), & !in + rs_z(1:nv,ft,cl), & !in + anet_av_z(1:nv,ft,cl), & !in currentPatch%elai_profile(cl,ft,1:nv), & !in currentCohort%c_area, & !in currentCohort%n, & !in @@ -469,7 +474,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) currentCohort%rdark) !out ! Net Uptake does not need to be scaled, just transfer directly - currentCohort%ts_net_uptake(1:nv) = anet_av_z(cl,ft,1:nv) * umolC_to_kgC + currentCohort%ts_net_uptake(1:nv) = anet_av_z(1:nv,ft,cl) * umolC_to_kgC else @@ -1011,10 +1016,10 @@ end subroutine LeafLayerPhotosynthesis ! ===================================================================================== subroutine ScaleLeafLayerFluxToCohort(nv, & ! in currentCohort%nv - psn_llz, & ! in %psn_z(cl,ft,1:currentCohort%nv) - lmr_llz, & ! in lmr_z(cl,ft,1:currentCohort%nv) - rs_llz, & ! in rs_z(cl,ft,1:currentCohort%nv) - anet_av_llz, & ! in anet_av_z(cl,ft,1:currentCohort%nv) + psn_llz, & ! in %psn_z(1:currentCohort%nv,ft,cl) + lmr_llz, & ! in lmr_z(1:currentCohort%nv,ft,cl) + rs_llz, & ! in rs_z(1:currentCohort%nv,ft,cl) + anet_av_llz, & ! in anet_av_z(1:currentCohort%nv,ft,cl) elai_llz, & ! in %elai_profile(cl,ft,1:currentCohort%nv) c_area, & ! in currentCohort%c_area nplant, & ! in currentCohort%n diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 06e26b37..139dfb7f 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -404,8 +404,8 @@ subroutine allocate_bcout(bc_out) ! Photosynthesis - allocate(bc_out%rssun_pa(numPatchesPerCol)) - allocate(bc_out%rssha_pa(numPatchesPerCol)) + allocate(bc_out%rssun_pa(maxPatchesPerCol)) + allocate(bc_out%rssha_pa(maxPatchesPerCol)) ! Canopy Radiation allocate(bc_out%albd_parb(maxPatchesPerCol,cp_numSWb)) From 34664237e5e7f26db9cda36ca6fa30bba6fc31e2 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 10 Jan 2017 17:23:35 -0800 Subject: [PATCH 275/437] Purging waterstate_inst, soilstate_inst from calls to dynamics and replacing it with bc_in. Temperature_inst for all calls but fire are also purged. Compiles and runs, not regression tested. --- biogeochem/EDPhysiologyMod.F90 | 58 +++++++++++++++------------------- main/EDMainMod.F90 | 18 +++++------ main/FatesInterfaceMod.F90 | 18 +++++++---- 3 files changed, 44 insertions(+), 50 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 02eedb26..9d845078 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -10,10 +10,9 @@ module EDPhysiologyMod 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 FatesInterfaceMod, only : bc_in_type use EDCohortDynamicsMod , only : allocate_live_biomass, zero_cohort use EDCohortDynamicsMod , only : create_cohort, fuse_cohorts, sort_cohorts use EDTypesMod , only : dg_sf, dinc_ed, external_recruitment @@ -72,7 +71,7 @@ subroutine canopy_derivs( currentSite, currentPatch ) end subroutine canopy_derivs ! ============================================================================ - subroutine non_canopy_derivs( currentSite, currentPatch, temperature_inst ) + subroutine non_canopy_derivs( currentSite, currentPatch, bc_in ) ! ! !DESCRIPTION: ! Returns time differentials of the state vector @@ -82,8 +81,9 @@ subroutine non_canopy_derivs( currentSite, currentPatch, temperature_inst ) ! ! !ARGUMENTS type(ed_site_type), intent(inout), target :: currentSite - type(ed_patch_type) , intent(inout) :: currentPatch - type(temperature_type) , intent(in) :: temperature_inst + type(ed_patch_type), intent(inout) :: currentPatch + type(bc_in_type), intent(in) :: bc_in + ! ! !LOCAL VARIABLES: integer c,p @@ -110,7 +110,7 @@ subroutine non_canopy_derivs( currentSite, currentPatch, temperature_inst ) ! update fragmenting pool fluxes call cwd_input(currentPatch) - call cwd_out( currentSite, currentPatch, temperature_inst) + call cwd_out( currentSite, currentPatch, bc_in) do p = 1,numpft_ed currentSite%dseed_dt(p) = currentSite%dseed_dt(p) + & @@ -240,14 +240,13 @@ subroutine trim_canopy( currentSite ) end subroutine trim_canopy ! ============================================================================ - subroutine phenology( currentSite, bc_in, waterstate_inst) + subroutine phenology( currentSite, bc_in ) ! ! !DESCRIPTION: ! Phenology. ! ! !USES: use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm - use FatesInterfaceMod, only : bc_in_type use EDTypesMod, only : udata ! @@ -255,7 +254,6 @@ subroutine phenology( currentSite, bc_in, waterstate_inst) type(ed_site_type), intent(inout), target :: currentSite type(bc_in_type), intent(in) :: bc_in - type(waterstate_type) , intent(in) :: waterstate_inst ! ! !LOCAL VARIABLES: @@ -271,8 +269,6 @@ subroutine phenology( currentSite, bc_in, waterstate_inst) integer :: mon ! month (1, ..., 12) integer :: day ! day of month (1, ..., 31) integer :: sec ! seconds of the day - integer :: patchi ! the first CLM/ALM patch index of the associated column - integer :: coli ! the CLM/ALM column index of the associated site real(r8) :: gdd_threshold real(r8) :: a,b,c ! params of leaf-pn model from botta et al. 2000. @@ -283,7 +279,6 @@ subroutine phenology( currentSite, bc_in, waterstate_inst) 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), parameter :: mindayson = 30.0 ! Parameter of drought decid leaf loss in mm in top layer...FIX(RF,032414) @@ -296,8 +291,6 @@ subroutine phenology( currentSite, bc_in, waterstate_inst) b = 638.0_r8 c = -0.001_r8 coldday = 5.0_r8 !ed_ph_chiltemp - - !Parameters from SDGVM model of senesence ncolddayslim = 5 @@ -426,7 +419,7 @@ subroutine phenology( currentSite, bc_in, waterstate_inst) ! distinction actually matter??).... !Accumulate surface water memory of last 10 days. - currentSite%water_memory(1) = waterstate_inst%h2osoi_vol_col(coli,1) + currentSite%water_memory(1) = bc_in%h2osoi_vol_si !waterstate_inst%h2osoi_vol_col(coli,1) do i = 1,9 !shift memory along one currentSite%water_memory(11-i) = currentSite%water_memory(10-i) enddo @@ -1121,7 +1114,7 @@ subroutine CWD_Input( currentPatch) end subroutine CWD_Input ! ============================================================================ - subroutine fragmentation_scaler( currentPatch, temperature_inst ) + subroutine fragmentation_scaler( currentPatch, bc_in) ! ! !DESCRIPTION: ! Simple CWD fragmentation Model @@ -1133,12 +1126,14 @@ subroutine fragmentation_scaler( currentPatch, temperature_inst ) ! ! !ARGUMENTS - type(ed_patch_type) , intent(inout) :: currentPatch - type(temperature_type) , intent(in) :: temperature_inst + type(ed_patch_type), intent(inout) :: currentPatch + type(bc_in_type), intent(in) :: bc_in + ! ! !LOCAL VARIABLES: logical :: use_century_tfunc = .false. - integer :: p,j + integer :: j + integer :: ifp ! Index of a FATES Patch "ifp" real(r8) :: t_scalar real(r8) :: w_scalar real(r8) :: catanf ! hyperbolic temperature function from CENTURY @@ -1146,16 +1141,12 @@ subroutine fragmentation_scaler( currentPatch, temperature_inst ) 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) - p = currentPatch%clm_pno + ifp = currentPatch%patchno ! set "froz_q10" parameter froz_q10 = EDParamsShareInst%froz_q10 @@ -1164,16 +1155,16 @@ subroutine fragmentation_scaler( currentPatch, temperature_inst ) 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) + if (bc_in%t_veg24_pa(ifp) >= SHR_CONST_TKFRZ) then + t_scalar = Q10**((bc_in%t_veg24_pa(ifp)-(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)) + t_scalar = (Q10**(-25._r8/10._r8))*(froz_q10**((bc_in%t_veg24_pa(ifp)-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) + t_scalar = max(catanf(bc_in%t_veg24_pa(ifp)-SHR_CONST_TKFRZ)/catanf_30,0.01_r8) endif !Moisture Limitations @@ -1186,7 +1177,7 @@ subroutine fragmentation_scaler( currentPatch, temperature_inst ) end subroutine fragmentation_scaler ! ============================================================================ - subroutine cwd_out( currentSite, currentPatch, temperature_inst ) + subroutine cwd_out( currentSite, currentPatch, bc_in ) ! ! !DESCRIPTION: ! Simple CWD fragmentation Model @@ -1198,8 +1189,9 @@ subroutine cwd_out( currentSite, currentPatch, temperature_inst ) ! ! !ARGUMENTS type(ed_site_type), intent(inout), target :: currentSite - type(ed_patch_type) , intent(inout), target :: currentPatch - type(temperature_type) , intent(in) :: temperature_inst + type(ed_patch_type), intent(inout), target :: currentPatch + type(bc_in_type), intent(in) :: bc_in + ! ! !LOCAL VARIABLES: integer :: c,ft @@ -1207,8 +1199,8 @@ subroutine cwd_out( currentSite, currentPatch, temperature_inst ) currentPatch%root_litter_out(:) = 0.0_r8 currentPatch%leaf_litter_out(:) = 0.0_r8 - - call fragmentation_scaler(currentPatch, temperature_inst) + + call fragmentation_scaler(currentPatch, bc_in) !Flux of coarse woody debris into decomposing litter pool. diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index ffd7948d..d43c2be6 100755 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -10,7 +10,6 @@ module EDMainMod 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 @@ -43,7 +42,7 @@ module EDMainMod !-------------------------------------------------------------------------------! subroutine ed_ecosystem_dynamics(currentSite, bc_in, & atm2lnd_inst, & - soilstate_inst, temperature_inst, waterstate_inst) + temperature_inst) ! ! !DESCRIPTION: ! Core of ed model, calling all subsequent vegetation dynamics routines @@ -52,9 +51,7 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in, & type(ed_site_type) , intent(inout), target :: currentSite type(bc_in_type) , intent(in) :: bc_in 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 @@ -71,7 +68,7 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in, & call ed_total_balance_check(currentSite, 0) - call phenology(currentSite, bc_in, waterstate_inst ) + call phenology(currentSite, bc_in ) call fire_model(currentSite, atm2lnd_inst, temperature_inst) @@ -79,7 +76,7 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in, & call disturbance_rates(currentSite) ! Integrate state variables from annual rates to daily timestep - call ed_integrate_state_variables(currentSite, temperature_inst ) + call ed_integrate_state_variables(currentSite, bc_in ) !****************************************************************************** ! Reproduction, Recruitment and Cohort Dynamics : controls cohort organisation @@ -136,7 +133,7 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in, & end subroutine ed_ecosystem_dynamics !-------------------------------------------------------------------------------! - subroutine ed_integrate_state_variables(currentSite, temperature_inst ) + subroutine ed_integrate_state_variables(currentSite, bc_in ) ! ! !DESCRIPTION: ! FIX(SPM,032414) refactor so everything goes through interface @@ -144,8 +141,9 @@ subroutine ed_integrate_state_variables(currentSite, temperature_inst ) ! !USES: ! ! !ARGUMENTS: - type(ed_site_type) , intent(inout) :: currentSite - type(temperature_type) , intent(in) :: temperature_inst + type(ed_site_type) , intent(inout) :: currentSite + type(bc_in_type) , intent(in) :: bc_in + ! ! !LOCAL VARIABLES: type(ed_patch_type) , pointer :: currentPatch @@ -223,7 +221,7 @@ subroutine ed_integrate_state_variables(currentSite, temperature_inst ) write(6,*)'DEBUG18: calling non_canopy_derivs with pno= ',currentPatch%clm_pno endif - call non_canopy_derivs( currentSite, currentPatch, temperature_inst ) + call non_canopy_derivs( currentSite, currentPatch, bc_in) !update state variables simultaneously according to derivatives for this time period. diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index e61a6dda..afc39fcd 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -64,17 +64,21 @@ module FatesInterfaceMod ! Vegetation Dynamics ! --------------------------------------------------------------------------------- - ! This 24 hour vegetation temperature is used for various purposes during vegetation - ! dynamics. However, we are currently using the bare-ground patch's value [K] + ! The site level 24 hour vegetation temperature is used for various purposes during vegetation + ! dynamics. However, we are currently using the bare ground patch's value [K] ! TO-DO: Get some consensus on the correct vegetation temperature used for phenology. ! It is possible that the bare-ground value is where the average is being stored. ! (RGK-01-2017) - - real(r8) :: t_veg24_si ! See above [K] + real(r8) :: t_veg24_si ! Patch 24 hour vegetation temperature [K] real(r8),allocatable :: t_veg24_pa(:) - + + ! NOTE: h2osoi_vol_si is used to update surface water memory + ! CLM/ALM may be using "waterstate%h2osoi_vol_col" on the first index (coli,1) + ! to inform this. I think this should be re-evaluated (RGK 01/2017) + ! Site volumetric soil water (0<=h2osoi_vol<=watsat) [m3/m3] + real(r8) :: h2osoi_vol_si ! Radiation variables for calculating sun/shade fractions ! --------------------------------------------------------------------------------- @@ -484,9 +488,9 @@ subroutine zero_bcs(this,s) this%bc_in(s)%current_date = 0 this%bc_in(s)%reference_date = 0 this%bc_in(s)%model_day = 0.0_r8 - - this%bc_in(s)%t_veg24_pa(:) = 0.0_r8 this%bc_in(s)%t_veg24_si = 0.0_r8 + this%bc_in(s)%t_veg24_pa(:) = 0.0_r8 + this%bc_in(s)%h2osoi_vol_si = 0.0_r8 this%bc_in(s)%solad_parb(:,:) = 0.0_r8 this%bc_in(s)%solai_parb(:,:) = 0.0_r8 From 39d59b27978ae4be6494cf35960276b5ebdc620a Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 11 Jan 2017 14:26:36 -0800 Subject: [PATCH 276/437] Clean up of globals in EDPhysiology --- biogeochem/EDPhysiologyMod.F90 | 183 +++++++++++++++++---------------- main/FatesConstantsMod.F90 | 11 +- 2 files changed, 104 insertions(+), 90 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 9d845078..91806580 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -6,10 +6,8 @@ module EDPhysiologyMod ! 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 FatesGlobals, only : fates_log + use FatesConstantsMod, only : r8 => fates_r8 use pftconMod , only : pftcon use EDEcophysContype , only : EDecophyscon use FatesInterfaceMod, only : bc_in_type @@ -114,7 +112,8 @@ subroutine non_canopy_derivs( currentSite, currentPatch, bc_in ) do p = 1,numpft_ed currentSite%dseed_dt(p) = currentSite%dseed_dt(p) + & - (currentPatch%seeds_in(p) - currentPatch%seed_decay(p) - currentPatch%seed_germination(p)) * currentPatch%area/AREA + (currentPatch%seeds_in(p) - currentPatch%seed_decay(p) - & + currentPatch%seed_germination(p)) * currentPatch%area/AREA enddo do c = 1,ncwd @@ -123,19 +122,12 @@ subroutine non_canopy_derivs( currentSite, currentPatch, bc_in ) 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) + 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 ! ============================================================================ @@ -176,7 +168,7 @@ subroutine trim_canopy( currentSite ) currentCohort%treelai = tree_lai(currentCohort) currentCohort%nv = ceiling((currentCohort%treelai+currentCohort%treesai)/dinc_ed) if (currentCohort%nv > cp_nlevcan)then - write(iulog,*) 'nv > cp_nlevcan',currentCohort%nv,currentCohort%treelai,currentCohort%treesai, & + write(fates_log(),*) 'nv > cp_nlevcan',currentCohort%nv,currentCohort%treelai,currentCohort%treesai, & currentCohort%c_area,currentCohort%n,currentCohort%bl endif @@ -201,7 +193,7 @@ subroutine trim_canopy( currentSite ) if (currentCohort%canopy_trim > trim_limit)then if ( DEBUG ) then - write(iulog,*) 'trimming leaves',currentCohort%canopy_trim,currentCohort%leaf_cost + write(fates_log(),*) 'trimming leaves',currentCohort%canopy_trim,currentCohort%leaf_cost endif ! keep trimming until none of the canopy is in negative carbon balance. @@ -219,7 +211,7 @@ subroutine trim_canopy( currentSite ) if (currentCohort%NV.gt.2)then ! leaf_cost may be uninitialized, removing its diagnostic from the log ! to allow checking with fpe_traps (RGK) - write(iulog,*) 'nv>4',currentCohort%year_net_uptake(1:6),currentCohort%canopy_trim + write(fates_log(),*) 'nv>4',currentCohort%year_net_uptake(1:6),currentCohort%canopy_trim endif currentCohort%year_net_uptake(:) = 999.0_r8 @@ -228,7 +220,7 @@ subroutine trim_canopy( currentSite ) endif if ( DEBUG ) then - write(iulog,*) 'trimming',currentCohort%canopy_trim + write(fates_log(),*) 'trimming',currentCohort%canopy_trim endif ! currentCohort%canopy_trim = 1.0_r8 !FIX(RF,032414) this turns off ctrim for now. @@ -357,7 +349,7 @@ subroutine phenology( currentSite, bc_in ) currentSite%status = 2 !alter status of site to 'leaves on' ! NOTE(bja, 2015-01) should leafondate = model_day to be consistent with leaf off? currentSite%leafondate = t !record leaf on date - if ( DEBUG ) write(iulog,*) 'leaves on' + if ( DEBUG ) write(fates_log(),*) 'leaves on' endif !ncd endif !status endif !GDD @@ -377,7 +369,7 @@ subroutine phenology( currentSite, bc_in ) if (currentSite%status == 2)then currentSite%status = 1 !alter status of site to 'leaves on' currentSite%leafoffdate = bc_in%model_day !record leaf off date - if ( DEBUG ) write(iulog,*) 'leaves off' + if ( DEBUG ) write(fates_log(),*) 'leaves off' endif endif endif @@ -387,7 +379,7 @@ subroutine phenology( currentSite, bc_in ) if(currentSite%status == 2)then currentSite%status = 1 !alter status of site to 'leaves on' currentSite%leafoffdate = bc_in%model_day !record leaf off date - if ( DEBUG ) write(iulog,*) 'leaves off' + if ( DEBUG ) write(fates_log(),*) 'leaves off' endif endif @@ -503,7 +495,8 @@ subroutine phenology_leafonoff(currentSite) type(ed_patch_type) , pointer :: currentPatch type(ed_cohort_type), pointer :: currentCohort - real(r8) :: store_output ! the amount of the store to put into leaves - is a barrier against negative storage and C starvation. + real(r8) :: store_output ! the amount of the store to put into leaves - + ! is a barrier against negative storage and C starvation. !------------------------------------------------------------------------ @@ -532,11 +525,11 @@ subroutine phenology_leafonoff(currentSite) ! Add deployed carbon to alive biomass pool currentCohort%balive = currentCohort%balive + currentCohort%bl - if ( DEBUG ) write(iulog,*) 'EDPhysMod 1 ',currentCohort%bstore + if ( DEBUG ) write(fates_log(),*) 'EDPhysMod 1 ',currentCohort%bstore currentCohort%bstore = currentCohort%bstore - currentCohort%bl ! Drain store - if ( DEBUG ) write(iulog,*) 'EDPhysMod 2 ',currentCohort%bstore + if ( DEBUG ) write(fates_log(),*) 'EDPhysMod 2 ',currentCohort%bstore currentCohort%laimemory = 0.0_r8 @@ -571,11 +564,11 @@ subroutine phenology_leafonoff(currentSite) endif currentCohort%balive = currentCohort%balive + currentCohort%bl - if ( DEBUG ) write(iulog,*) 'EDPhysMod 3 ',currentCohort%bstore + if ( DEBUG ) write(fates_log(),*) 'EDPhysMod 3 ',currentCohort%bstore currentCohort%bstore = currentCohort%bstore - currentCohort%bl ! empty store - if ( DEBUG ) write(iulog,*) 'EDPhysMod 4 ',currentCohort%bstore + if ( DEBUG ) write(fates_log(),*) 'EDPhysMod 4 ',currentCohort%bstore currentCohort%laimemory = 0.0_r8 @@ -633,7 +626,8 @@ subroutine seeds_in( currentSite, cp_pnt ) 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 + currentPatch%seeds_in(p) = currentPatch%seeds_in(p) + & + currentCohort%seed_prod * currentCohort%n/currentPatch%area currentCohort => currentCohort%shorter enddo !cohort loop @@ -642,8 +636,10 @@ subroutine seeds_in( currentSite, cp_pnt ) 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 - currentSite%seed_rain_flux(p) = currentSite%seed_rain_flux(p) + EDecophyscon%seed_rain(p) * currentPatch%area/AREA !KgC/m2/year + currentPatch%seeds_in(p) = currentPatch%seeds_in(p) + & + EDecophyscon%seed_rain(p) !KgC/m2/year + currentSite%seed_rain_flux(p) = currentSite%seed_rain_flux(p) + & + EDecophyscon%seed_rain(p) * currentPatch%area/AREA !KgC/m2/year enddo endif currentPatch => currentPatch%younger @@ -699,7 +695,8 @@ subroutine seed_germination( currentSite, currentPatch ) max_germination = 1.0_r8 !this is arbitrary do p = 1,numpft_ed - currentPatch%seed_germination(p) = min(currentSite%seed_bank(p) * germination_timescale,max_germination) + currentPatch%seed_germination(p) = min(currentSite%seed_bank(p) * & + germination_timescale,max_germination) enddo end subroutine seed_germination @@ -761,7 +758,7 @@ subroutine Growth_Derivatives( currentSite, currentCohort) endif ! NPP - if ( DEBUG ) write(iulog,*) 'EDphys 716 ',currentCohort%npp_acc + if ( DEBUG ) write(fates_log(),*) 'EDphys 716 ',currentCohort%npp_acc currentCohort%npp_acc_hold = currentCohort%npp_acc * udata%n_sub ! convert from kgC/indiv/day into kgC/indiv/year currentCohort%gpp_acc_hold = currentCohort%gpp_acc * udata%n_sub ! convert from kgC/indiv/day into kgC/indiv/year @@ -795,7 +792,7 @@ subroutine Growth_Derivatives( currentSite, currentCohort) 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), & + write(fates_log(),*) 'problem with phenology definitions',currentCohort%pft,pftcon%stress_decid(currentCohort%pft), & pftcon%season_decid(currentCohort%pft),pftcon%evergreen(currentCohort%pft) endif @@ -807,7 +804,7 @@ subroutine Growth_Derivatives( currentSite, currentCohort) ! Calculate carbon balance ! this is the fraction of maintenance demand we -have- to do... - if ( DEBUG ) write(iulog,*) 'EDphys 760 ',currentCohort%npp_acc_hold, currentCohort%md, & + if ( DEBUG ) write(fates_log(),*) 'EDphys 760 ',currentCohort%npp_acc_hold, currentCohort%md, & EDecophyscon%leaf_stor_priority(currentCohort%pft) currentCohort%carbon_balance = currentCohort%npp_acc_hold - & @@ -823,7 +820,7 @@ subroutine Growth_Derivatives( currentSite, currentCohort) if (Bleaf(currentCohort) > 0._r8)then - if ( DEBUG ) write(iulog,*) 'EDphys A ',currentCohort%carbon_balance + if ( DEBUG ) write(fates_log(),*) 'EDphys A ',currentCohort%carbon_balance if (currentCohort%carbon_balance > 0._r8)then !spend C on growing and storing @@ -835,7 +832,7 @@ subroutine Growth_Derivatives( currentSite, currentCohort) !what is the flux into the store? currentCohort%storage_flux = currentCohort%carbon_balance * f_store - if ( DEBUG ) write(iulog,*) 'EDphys B ',f_store + if ( DEBUG ) write(fates_log(),*) 'EDphys B ',f_store !what is the tax on the carbon available for growth? currentCohort%carbon_balance = currentCohort%carbon_balance * (1.0_r8 - f_store) @@ -848,7 +845,7 @@ subroutine Growth_Derivatives( currentSite, currentCohort) currentCohort%storage_flux = 0._r8 currentCohort%carbon_balance = 0._r8 - write(iulog,*) 'ED: no leaf area in gd', currentCohort%indexnumber,currentCohort%n,currentCohort%bdead, & + write(fates_log(),*) 'ED: no leaf area in gd', currentCohort%indexnumber,currentCohort%n,currentCohort%bdead, & currentCohort%dbh,currentCohort%balive endif @@ -902,7 +899,7 @@ subroutine Growth_Derivatives( currentSite, currentCohort) !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 + write(fates_log(),*) 'using high bl cap',target_balive,currentCohort%balive endif else @@ -916,28 +913,28 @@ subroutine Growth_Derivatives( currentSite, currentCohort) currentCohort%dbdeaddt = gr_fract * vs * currentCohort%carbon_balance currentCohort%dbstoredt = currentCohort%storage_flux - if ( DEBUG ) write(iulog,*) 'EDPhys dbstoredt I ',currentCohort%dbstoredt + if ( DEBUG ) write(fates_log(),*) 'EDPhys dbstoredt I ',currentCohort%dbstoredt currentCohort%seed_prod = (1.0_r8 - gr_fract) * currentCohort%carbon_balance if (abs(currentCohort%npp_acc_hold-(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_acc_hold- & + write(fates_log(),*) 'error in carbon check growth derivs',currentCohort%npp_acc_hold- & (currentCohort%dbalivedt+currentCohort%dbdeaddt+currentCohort%dbstoredt+currentCohort%seed_prod+currentCohort%md) - write(iulog,*) 'cohort fluxes',currentCohort%pft,currentCohort%canopy_layer,currentCohort%n, & + write(fates_log(),*) 'cohort fluxes',currentCohort%pft,currentCohort%canopy_layer,currentCohort%n, & currentCohort%npp_acc_hold,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 + write(fates_log(),*) '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, & + write(fates_log(),*) 'using non-neg leaf mass cap',currentCohort%balive , currentCohort%dbalivedt,currentCohort%dbstoredt, & currentCohort%carbon_balance currentCohort%dbstoredt = currentCohort%dbstoredt + currentCohort%dbalivedt - if ( DEBUG ) write(iulog,*) 'EDPhys dbstoredt II ',currentCohort%dbstoredt + if ( DEBUG ) write(fates_log(),*) 'EDPhys dbstoredt II ',currentCohort%dbstoredt currentCohort%dbalivedt = 0._r8 endif @@ -993,10 +990,10 @@ subroutine recruitment( t, currentSite, currentPatch ) / (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', & + write(fates_log(),*) '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 + write(fates_log(),*) 'cohort n',ft,temp_cohort%n endif temp_cohort%laimemory = 0.0_r8 @@ -1015,7 +1012,7 @@ subroutine recruitment( t, currentSite, currentPatch ) endif if (temp_cohort%n > 0.0_r8 )then - if ( DEBUG ) write(iulog,*) 'EDPhysiologyMod.F90 call create_cohort ' + if ( DEBUG ) write(fates_log(),*) 'EDPhysiologyMod.F90 call create_cohort ' 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) @@ -1096,7 +1093,7 @@ subroutine CWD_Input( currentPatch) 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), & + write(fates_log(),*) 'negative CWD in flux',currentPatch%cwd_AG_in(c), & (currentCohort%bdead+currentCohort%bsw), dead_n endif enddo @@ -1118,12 +1115,14 @@ subroutine fragmentation_scaler( currentPatch, bc_in) ! ! !DESCRIPTION: ! Simple CWD fragmentation Model - ! FIX(SPM, 091914) this should be a function as it returns a value in currentPatch%fragmentation_scaler + ! 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 + use EDSharedParamsMod , only : EDParamsShareInst + use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm + use FatesConstantsMod, only : pi => pi_const ! ! !ARGUMENTS type(ed_patch_type), intent(inout) :: currentPatch @@ -1140,10 +1139,11 @@ subroutine fragmentation_scaler( currentPatch, bc_in) 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) :: froz_q10 ! separate q10 for frozen soil respiration rates. + ! default to same as above zero rates !---------------------------------------------------------------------- - catanf(t1) = 11.75_r8 +(29.7_r8 / SHR_CONST_PI) * atan( SHR_CONST_PI * 0.031_r8 * ( t1 - 15.4_r8 )) + catanf(t1) = 11.75_r8 +(29.7_r8 / pi) * atan( pi * 0.031_r8 * ( t1 - 15.4_r8 )) catanf_30 = catanf(30._r8) ifp = currentPatch%patchno @@ -1155,20 +1155,22 @@ subroutine fragmentation_scaler( currentPatch, bc_in) if ( .not. use_century_tfunc ) then !calculate rate constant scalar for soil temperature,assuming that the base rate constants !are assigned for non-moisture limiting conditions at 25C. - if (bc_in%t_veg24_pa(ifp) >= SHR_CONST_TKFRZ) then - t_scalar = Q10**((bc_in%t_veg24_pa(ifp)-(SHR_CONST_TKFRZ+25._r8))/10._r8) - ! Q10**((t_soisno(c,j)-(SHR_CONST_TKFRZ+25._r8))/10._r8) + if (bc_in%t_veg24_pa(ifp) >= tfrz) then + t_scalar = Q10**((bc_in%t_veg24_pa(ifp)-(tfrz+25._r8))/10._r8) + ! Q10**((t_soisno(c,j)-(tfrz+25._r8))/10._r8) else - t_scalar = (Q10**(-25._r8/10._r8))*(froz_q10**((bc_in%t_veg24_pa(ifp)-SHR_CONST_TKFRZ)/10._r8)) - !Q10**(-25._r8/10._r8))*(froz_q10**((t_soisno(c,j)-SHR_CONST_TKFRZ)/10._r8) + t_scalar = (Q10**(-25._r8/10._r8))*(froz_q10**((bc_in%t_veg24_pa(ifp)-tfrz)/10._r8)) + !Q10**(-25._r8/10._r8))*(froz_q10**((t_soisno(c,j)-tfrz)/10._r8) endif else - ! original century uses an arctangent function to calculate the temperature dependence of decomposition - t_scalar = max(catanf(bc_in%t_veg24_pa(ifp)-SHR_CONST_TKFRZ)/catanf_30,0.01_r8) + ! original century uses an arctangent function to calculate the + ! temperature dependence of decomposition + t_scalar = max(catanf(bc_in%t_veg24_pa(ifp)-tfrz)/catanf_30,0.01_r8) endif !Moisture Limitations - !BTRAN APPROACH - is quite simple, but max's out decomp at all unstressed soil moisture values, which is not realistic. + !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 @@ -1227,7 +1229,7 @@ subroutine cwd_out( currentSite, currentPatch, bc_in ) 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 + write(fates_log(),*) 'root or leaf out is negative?',SF_val_max_decomp(dg_sf),currentPatch%fragmentation_scaler endif enddo @@ -1268,14 +1270,15 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) !use EDCLMLinkMod, only: cwd_fcel_ed, cwd_flig use pftconMod, only : pftcon - use shr_const_mod, only: SHR_CONST_CDAY + use FatesConstantsMod, only : sec_per_day use clm_varcon, only : zisoi, dzsoi_decomp, zsoi use EDParamsMod, only : ED_val_ag_biomass use FatesInterfaceMod, only : bc_in_type, bc_out_type use clm_varctl, only : use_vertsoilc use abortutils , only : endrun - ! INTERF-TODO: remove the control parameters: exponential_rooting_profile, pftspecific_rootingprofile, rootprof_exp, surfprof_exp, zisoi, dzsoi_decomp, zsoi + ! INTERF-TODO: remove the control parameters: exponential_rooting_profile, + ! pftspecific_rootingprofile, rootprof_exp, surfprof_exp, zisoi, dzsoi_decomp, zsoi ! implicit none ! @@ -1334,7 +1337,7 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) delta = 0.001_r8 !no of seconds in a year. - time_convert = 365.0_r8*SHR_CONST_CDAY + time_convert = 365.0_r8*sec_per_day ! number of grams in a kilogram mass_convert = 1000._r8 @@ -1343,8 +1346,10 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! first calculate vertical profiles ! define two types of profiles: - ! (1) a surface profile, for leaves and stem inputs, which is the same for each pft but differs from one site to the next to avoid inputting any C into permafrost or bedrock - ! (2) a fine root profile, which is indexed by both site and pft, differs for each pft and also from one site to the next to avoid inputting any C into permafrost or bedrock + ! (1) a surface profile, for leaves and stem inputs, which is the same for each + ! pft but differs from one site to the next to avoid inputting any C into permafrost or bedrock + ! (2) a fine root profile, which is indexed by both site and pft, differs for + ! each pft and also from one site to the next to avoid inputting any C into permafrost or bedrock ! (3) a coarse root profile, which is the root-biomass=weighted average of the fine root profiles !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -1468,13 +1473,13 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) stem_prof_sum = stem_prof_sum + stem_prof(s,j) * dzsoi_decomp(j) end do if ( ( abs(stem_prof_sum - 1._r8) > delta ) .or. ( abs(leaf_prof_sum - 1._r8) > delta ) ) then - write(iulog, *) 'profile sums: ', leaf_prof_sum, stem_prof_sum - write(iulog, *) 'surface_prof: ', surface_prof - write(iulog, *) 'surface_prof_tot: ', surface_prof_tot - write(iulog, *) 'leaf_prof: ', leaf_prof(s,:) - write(iulog, *) 'stem_prof: ', stem_prof(s,:) - write(iulog, *) 'max_rooting_depth_index_col: ', bc_in(s)%max_rooting_depth_index_col - write(iulog, *) 'dzsoi_decomp: ', dzsoi_decomp + write(fates_log(), *) 'profile sums: ', leaf_prof_sum, stem_prof_sum + write(fates_log(), *) 'surface_prof: ', surface_prof + write(fates_log(), *) 'surface_prof_tot: ', surface_prof_tot + write(fates_log(), *) 'leaf_prof: ', leaf_prof(s,:) + write(fates_log(), *) 'stem_prof: ', stem_prof(s,:) + write(fates_log(), *) 'max_rooting_depth_index_col: ', bc_in(s)%max_rooting_depth_index_col + write(fates_log(), *) 'dzsoi_decomp: ', dzsoi_decomp call endrun() endif ! now check each fine root profile @@ -1484,7 +1489,7 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) froot_prof_sum = froot_prof_sum + froot_prof(s,ft,j) * dzsoi_decomp(j) end do if ( ( abs(froot_prof_sum - 1._r8) > delta ) ) then - write(iulog, *) 'profile sums: ', froot_prof_sum + write(fates_log(), *) 'profile sums: ', froot_prof_sum call endrun() endif end do @@ -1552,12 +1557,12 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) ! now disaggregate, vertically and by decomposition substrate type, the actual fluxes from CWD and litter pools ! ! do c = 1, ncwd - ! write(iulog,*)'cdk CWD_AG_out', c, currentpatch%CWD_AG_out(c), cwd_fcel, currentpatch%area/AREA - ! write(iulog,*)'cdk CWD_BG_out', c, currentpatch%CWD_BG_out(c), cwd_fcel, currentpatch%area/AREA + ! write(fates_log(),*)'cdk CWD_AG_out', c, currentpatch%CWD_AG_out(c), cwd_fcel, currentpatch%area/AREA + ! write(fates_log(),*)'cdk CWD_BG_out', c, currentpatch%CWD_BG_out(c), cwd_fcel, currentpatch%area/AREA ! end do ! do ft = 1,numpft_ed - ! write(iulog,*)'cdk leaf_litter_out', ft, currentpatch%leaf_litter_out(ft), cwd_fcel, currentpatch%area/AREA - ! write(iulog,*)'cdk root_litter_out', ft, currentpatch%root_litter_out(ft), cwd_fcel, currentpatch%area/AREA + ! write(fates_log(),*)'cdk leaf_litter_out', ft, currentpatch%leaf_litter_out(ft), cwd_fcel, currentpatch%area/AREA + ! write(fates_log(),*)'cdk root_litter_out', ft, currentpatch%root_litter_out(ft), cwd_fcel, currentpatch%area/AREA ! end do ! ! ! CWD pools fragmenting into decomposing litter pools. @@ -1618,15 +1623,15 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) end do end do - ! write(iulog,*)'cdk FATES_c_to_litr_lab_c: ', FATES_c_to_litr_lab_c - ! write_col(iulog,*)'cdk FATES_c_to_litr_cel_c: ', FATES_c_to_litr_cel_c - ! write_col(iulog,*)'cdk FATES_c_to_litr_lig_c: ', FATES_c_to_litr_lig_c - ! write_col(iulog,*)'cdk cp_numlevdecomp_full, bounds%begc, bounds%endc: ', cp_numlevdecomp_full, bounds%begc, bounds%endc - ! write(iulog,*)'cdk leaf_prof: ', leaf_prof - ! write(iulog,*)'cdk stem_prof: ', stem_prof - ! write(iulog,*)'cdk froot_prof: ', froot_prof - ! write(iulog,*)'cdk croot_prof_perpatch: ', croot_prof_perpatch - ! write(iulog,*)'cdk croot_prof: ', croot_prof + ! write(fates_log(),*)'cdk FATES_c_to_litr_lab_c: ', FATES_c_to_litr_lab_c + ! write_col(fates_log(),*)'cdk FATES_c_to_litr_cel_c: ', FATES_c_to_litr_cel_c + ! write_col(fates_log(),*)'cdk FATES_c_to_litr_lig_c: ', FATES_c_to_litr_lig_c + ! write_col(fates_log(),*)'cdk cp_numlevdecomp_full, bounds%begc, bounds%endc: ', cp_numlevdecomp_full, bounds%begc, bounds%endc + ! write(fates_log(),*)'cdk leaf_prof: ', leaf_prof + ! write(fates_log(),*)'cdk stem_prof: ', stem_prof + ! write(fates_log(),*)'cdk froot_prof: ', froot_prof + ! write(fates_log(),*)'cdk croot_prof_perpatch: ', croot_prof_perpatch + ! write(fates_log(),*)'cdk croot_prof: ', croot_prof end subroutine flux_into_litter_pools diff --git a/main/FatesConstantsMod.F90 b/main/FatesConstantsMod.F90 index 3df36d6b..b7bf5edb 100644 --- a/main/FatesConstantsMod.F90 +++ b/main/FatesConstantsMod.F90 @@ -39,8 +39,11 @@ module FatesConstantsMod real(fates_r8), parameter :: umol_per_mol = 1.0E6_fates_r8 - ! Conversion: secons per minute + ! Conversion: seconds per minute real(fates_r8), parameter :: sec_per_min = 60.0_fates_r8 + + ! Conversion: seconds per day + real(fates_r8), parameter :: sec_per_day = 86400.0_fates_r8 ! Physical constants @@ -55,4 +58,10 @@ module FatesConstantsMod real(fates_r8), parameter :: t_water_freeze_k_triple = 273.16_fates_r8 + ! Geometric Constants + + ! PI + real(fates_r8), parameter :: pi_const = 3.14159265359_fates_r8 + + end module FatesConstantsMod From f7a2c16969275bc21925cf792ab8657d2fd2eee2 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 11 Jan 2017 15:13:44 -0800 Subject: [PATCH 277/437] Removal of CLM boundary conditions to fire model and some CLM globals. ldomain%area(g) is still called in fire model, as well as masterproc and use_spitfire. --- fire/SFMainMod.F90 | 210 +++++++++++++++++++------------------ main/EDMainMod.F90 | 8 +- main/FatesInterfaceMod.F90 | 18 ++++ 3 files changed, 128 insertions(+), 108 deletions(-) diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index be53100a..1f5f14f2 100755 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -5,15 +5,24 @@ module SFMainMod ! 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 FatesConstantsMod , only : r8 => fates_r8 + use spmdMod , only : masterproc - use clm_varctl , only : iulog - use atm2lndType , only : atm2lnd_type - use TemperatureType , only : temperature_type + use FatesGlobals , only : fates_log + + use FatesInterfaceMod , only : bc_in_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 + use EDtypesMod , only : ed_site_type + use EDtypesMod , only : ed_patch_type + use EDtypesMod , only : ed_cohort_type + use EDtypesMod , only : AREA + use EDtypesMod , only : DG_SF + use EDtypesMod , only : FIRE_THRESHOLD + use EDtypesMod , only : LB_SF + use EDtypesMod , only : LG_SF + use EDtypesMod , only : NCWD + use EDtypesMod , only : TR_SF implicit none private @@ -42,13 +51,13 @@ module SFMainMod ! ============================================================================ ! Area of site burned by fire ! ============================================================================ - subroutine fire_model( currentSite, atm2lnd_inst, temperature_inst) + subroutine fire_model( currentSite, bc_in) 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(bc_in_type) , intent(in) :: bc_in + type (ed_patch_type), pointer :: currentPatch @@ -62,12 +71,12 @@ subroutine fire_model( currentSite, atm2lnd_inst, temperature_inst) enddo if(write_SF==1)then - write(iulog,*) 'use_ed_spit_fire',use_ed_spit_fire + write(fates_log(),*) 'use_ed_spit_fire',use_ed_spit_fire endif if(use_ed_spit_fire)then - call fire_danger_index(currentSite, temperature_inst, atm2lnd_inst) - call wind_effect(currentSite, atm2lnd_inst) + call fire_danger_index(currentSite, bc_in) + call wind_effect(currentSite, bc_in) call charecteristics_of_fuel(currentSite) call rate_of_spread(currentSite) call ground_fuel_consumption(currentSite) @@ -81,20 +90,19 @@ subroutine fire_model( currentSite, atm2lnd_inst, temperature_inst) end subroutine fire_model - !***************************************************************** - subroutine fire_danger_index ( currentSite, temperature_inst, atm2lnd_inst) + !***************************************************************** + subroutine fire_danger_index ( currentSite, bc_in) - !***************************************************************** + !***************************************************************** ! 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 - + use FatesConstantsMod , only : tfrz => t_water_freeze_k_1atm + use FatesConstantsMod , only : sec_per_day + type(ed_site_type) , intent(inout), target :: currentSite - type(temperature_type) , intent(in) :: temperature_inst - type(atm2lnd_type) , intent(in) :: atm2lnd_inst - + type(bc_in_type) , intent(in) :: bc_in + real(r8) :: temp_in_C ! daily averaged temperature in celcius real(r8) :: rainfall ! daily precip real(r8) :: rh ! daily rh @@ -102,35 +110,31 @@ subroutine fire_danger_index ( currentSite, temperature_inst, atm2lnd_inst) real yipsolon; !intermediate varable for dewpoint calculation real dewpoint; !dewpoint in K real d_NI; !daily change in Nesterov Index. C^2 + integer :: iofp ! index of oldest the fates patch - 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 + ! NOTE that the boundary conditions of temperature, precipitation and relative humidity + ! are available at the patch level. We are currently using a simplification where the whole site + ! is simply using the values associated with the first patch. + ! which probably won't have much inpact, unless we decide to ever calculated the NI for each patch. + + iofp = currentSite%oldest_patch%patchno + + temp_in_C = bc_in%t_veg24_pa(iofp) - tfrz + rainfall = bc_in%precip24_pa(iofp)*sec_per_day + rh = bc_in%relhumid24_pa(iofp) + + 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 subroutine fire_danger_index @@ -179,15 +183,15 @@ subroutine charecteristics_of_fuel ( currentSite ) 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 + if (masterproc) write(fates_log(),*) ' leaf_litter1 ',currentPatch%leaf_litter + if (masterproc) write(fates_log(),*) ' leaf_litter2 ',sum(currentPatch%CWD_AG) + if (masterproc) write(fates_log(),*) ' leaf_litter3 ',currentPatch%livegrass + if (masterproc) write(fates_log(),*) ' 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 + if (masterproc) write(fates_log(),*) 'sum fuel', currentPatch%sum_fuel,currentPatch%area endif ! =============================================== ! Average moisture, bulk density, surface area-volume and moisture extinction of fuel @@ -199,9 +203,9 @@ subroutine charecteristics_of_fuel ( currentSite ) 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 + if (masterproc) write(fates_log(),*) 'ff1 ',currentPatch%fuel_frac + if (masterproc) write(fates_log(),*) 'ff2 ',currentPatch%fuel_frac + if (masterproc) write(fates_log(),*) 'ff2a ',lg_sf,currentPatch%livegrass,currentPatch%sum_fuel endif currentPatch%fuel_frac(lg_sf) = currentPatch%livegrass / currentPatch%sum_fuel @@ -210,10 +214,10 @@ subroutine charecteristics_of_fuel ( currentSite ) !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 + if (masterproc) write(fates_log(),*) 'ff3 ',currentPatch%fuel_frac + if (masterproc) write(fates_log(),*) 'fm ',fuel_moisture + if (masterproc) write(fates_log(),*) 'csa ',currentSite%acc_NI + if (masterproc) write(fates_log(),*) 'sfv ',SF_val_alpha_FMC endif ! FIX(RF,032414): needs refactoring. ! average water content !is this the correct metric? @@ -227,7 +231,7 @@ subroutine charecteristics_of_fuel ( currentSite ) 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 + if (masterproc) write(fates_log(),*) '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) @@ -254,14 +258,14 @@ subroutine charecteristics_of_fuel ( currentSite ) if(write_SF == 1)then - if (masterproc) write(iulog,*) 'no litter fuel at all',currentPatch%patchno, & + if (masterproc) write(fates_log(),*) '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' + if (masterproc) write(fates_log(),*) 'problem with spitfire fuel averaging' ! FIX(SPM,032414) refactor...should not have 0 fuel unless everything is burnt ! off. @@ -277,7 +281,7 @@ subroutine charecteristics_of_fuel ( currentSite ) ! 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' + if (masterproc) write(fates_log(),*) 'problem with spitfire fuel averaging' endif currentPatch => currentPatch%younger @@ -288,33 +292,35 @@ end subroutine charecteristics_of_fuel !***************************************************************** - subroutine wind_effect ( currentSite, atm2lnd_inst) + subroutine wind_effect ( currentSite, bc_in) !*****************************************************************. ! Routine called daily from within ED within a site loop. ! Calculates the effective windspeed based on vegetation charecteristics. + use FatesConstantsMod, only : sec_per_min + type(ed_site_type) , intent(inout), target :: currentSite - type(atm2lnd_type) , intent(in) :: atm2lnd_inst + type(bc_in_type) , intent(in) :: bc_in 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 + integer :: iofp ! index of oldest fates patch - wind24 => atm2lnd_inst%wind24_patch ! Input: [real(r8) (:)] avg pft windspeed (m/s) + ! note - this is a patch level temperature, which probably won't have much inpact, + ! unless we decide to ever calculated the NI for each patch. + + iofp = currentSite%oldest_patch%patchno + wind = bc_in%wind24_pa(iofp) * sec_per_min ! Convert to m/min for SPITFIRE units. - 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) + if (masterproc) write(fates_log(),*) 'wind24', wind endif ! --- influence of wind speed, corrected for surface roughness---- ! --- averaged over the whole grid cell to prevent extreme divergence @@ -328,7 +334,7 @@ subroutine wind_effect ( currentSite, atm2lnd_inst) currentCohort => currentPatch%tallest do while(associated(currentCohort)) - write(iulog,*) 'SF currentCohort%c_area ',currentCohort%c_area + write(fates_log(),*) '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 @@ -340,10 +346,10 @@ subroutine wind_effect ( currentSite, atm2lnd_inst) 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 + !write(fates_log(),*) 'SF currentPatch%area ',currentPatch%area + !write(fates_log(),*) 'SF currentPatch%total_area ',currentPatch%total_tree_area + !write(fates_log(),*) 'SF total_grass_area ',tree_fraction,grass_fraction + !write(fates_log(),*) 'SF AREA ',AREA endif currentPatch => currentPatch%younger @@ -353,7 +359,7 @@ subroutine wind_effect ( currentSite, atm2lnd_inst) 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 + if (masterproc) write(fates_log(),*) 'grass, trees, bare',grass_fraction, tree_fraction, bare_fraction endif currentPatch=>currentSite%oldest_patch; @@ -403,18 +409,18 @@ subroutine rate_of_spread ( currentSite ) 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 + if (masterproc.and.DEBUG) write(fates_log(),*) 'SF - currentPatch%fuel_bulkd ',currentPatch%fuel_bulkd + if (masterproc.and.DEBUG) write(fates_log(),*) '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 + if (masterproc.and.DEBUG) write(fates_log(),*) 'SF - beta ',beta + if (masterproc.and.DEBUG) write(fates_log(),*) 'SF - beta_op ',beta_op bet = beta/beta_op if(write_sf == 1)then - if (masterproc) write(iulog,*) 'esf ',currentPatch%fuel_eff_moist + if (masterproc) write(fates_log(),*) 'esf ',currentPatch%fuel_eff_moist endif ! ---heat of pre-ignition--- ! Equation A4 in Thonicke et al. 2010 @@ -432,11 +438,11 @@ subroutine rate_of_spread ( currentSite ) ! 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 + if (masterproc.and.DEBUG) write(fates_log(),*) 'SF - c ',c + if (masterproc.and.DEBUG) write(fates_log(),*) 'SF - currentPatch%effect_wspeed ',currentPatch%effect_wspeed + if (masterproc.and.DEBUG) write(fates_log(),*) 'SF - b ',b + if (masterproc.and.DEBUG) write(fates_log(),*) 'SF - bet ',bet + if (masterproc.and.DEBUG) write(fates_log(),*) 'SF - e ',e endif ! convert from m/min to ft/min for Rothermel ROS eqn @@ -464,18 +470,18 @@ subroutine rate_of_spread ( currentSite ) ! 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 + ! write(fates_log(),*) '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 + ! write(fates_log(),*) '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 + ! write(fates_log(),*) 'ROS',currentPatch%ROS_front,phi_wind,currentPatch%effect_wspeed + ! write(fates_log(),*) 'ros calcs',currentPatch%fuel_bulkd,ir,xi,eps,q_ig endif ! Equation 10 in Thonicke et al. 2010 ! Can FBP System in m/min @@ -598,7 +604,7 @@ subroutine fire_intensity ( currentSite ) 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 + if(masterproc) write(fates_log(),*) '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 @@ -609,7 +615,7 @@ subroutine fire_intensity ( currentSite ) ! 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 + if (masterproc) write(fates_log(),*) '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 @@ -684,7 +690,7 @@ subroutine area_burnt ( currentSite ) p = currentPatch%clm_pno g = patch%gridcell(p) - ! g = currentSite%clmgcell (DEPRECATED VARIABLE) + ! INTERF-TODO: ! THIS SHOULD HAVE THE COLUMN AND LU AREA WEIGHT ALSO, NO? @@ -703,18 +709,18 @@ subroutine area_burnt ( currentSite ) 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, & + if (masterproc) write(fates_log(),*) '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, & + if (masterproc) write(fates_log(),*) '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 + if (masterproc) write(fates_log(),*) '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 + if (masterproc) write(fates_log(),*) 'frac_burnt',currentPatch%frac_burnt endif endif endif! fire @@ -771,7 +777,7 @@ subroutine crown_scorching ( currentSite ) 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 + if (masterproc) write(fates_log(),*) '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) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index d43c2be6..81c7fac4 100755 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -40,9 +40,7 @@ module EDMainMod contains !-------------------------------------------------------------------------------! - subroutine ed_ecosystem_dynamics(currentSite, bc_in, & - atm2lnd_inst, & - temperature_inst) + subroutine ed_ecosystem_dynamics(currentSite, bc_in) ! ! !DESCRIPTION: ! Core of ed model, calling all subsequent vegetation dynamics routines @@ -50,8 +48,6 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in, & ! !ARGUMENTS: type(ed_site_type) , intent(inout), target :: currentSite type(bc_in_type) , intent(in) :: bc_in - type(atm2lnd_type) , intent(in) :: atm2lnd_inst - type(temperature_type) , intent(in) :: temperature_inst ! ! !LOCAL VARIABLES: type(ed_patch_type), pointer :: currentPatch @@ -70,7 +66,7 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in, & call phenology(currentSite, bc_in ) - call fire_model(currentSite, atm2lnd_inst, temperature_inst) + call fire_model(currentSite, bc_in) ! Calculate disturbance and mortality based on previous timestep vegetation. call disturbance_rates(currentSite) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index afc39fcd..210aece1 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -80,6 +80,18 @@ module FatesInterfaceMod ! Site volumetric soil water (0<=h2osoi_vol<=watsat) [m3/m3] real(r8) :: h2osoi_vol_si + ! Fire Model + + ! Average precipitation over the last 24 hours [mm/s] + real(r8), allocatable :: precip24_pa(:) + + ! Average relative humidity over past 24 hours [-] + real(r8), allocatable :: relhumid24_pa(:) + + ! Patch 24-hour running mean of wind (m/s ?) + real(r8), allocatable :: wind24_pa(:) + + ! Radiation variables for calculating sun/shade fractions ! --------------------------------------------------------------------------------- @@ -378,6 +390,9 @@ subroutine allocate_bcin(bc_in) ! Vegetation Dynamics allocate(bc_in%t_veg24_pa(numPatchesPerCol)) + allocate(bc_in%wind24_pa(numPatchesPerCol)) + allocate(bc_in%relhumid24_pa(numPatchesPerCol)) + allocate(bc_in%precip24_pa(numPatchesPerCol)) ! Radiation allocate(bc_in%solad_parb(numPatchesPerCol,cp_numSWb)) @@ -491,6 +506,9 @@ subroutine zero_bcs(this,s) this%bc_in(s)%t_veg24_si = 0.0_r8 this%bc_in(s)%t_veg24_pa(:) = 0.0_r8 this%bc_in(s)%h2osoi_vol_si = 0.0_r8 + this%bc_in(s)%precip24_pa(:) = 0.0_r8 + this%bc_in(s)%relhumid24_pa(:) = 0.0_r8 + this%bc_in(s)%wind24_pa(:) = 0.0_r8 this%bc_in(s)%solad_parb(:,:) = 0.0_r8 this%bc_in(s)%solai_parb(:,:) = 0.0_r8 From d7f4066da05ac4ca5fa0f006c1f401950f494cfb Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 11 Jan 2017 17:15:18 -0800 Subject: [PATCH 278/437] Added masterproc (used in firemod for log messaging) to the control parameters passed during initialization. Tracked down other instances of use, and also fixed calls to clm version of r8 or iulog when found. --- fire/SFMainMod.F90 | 74 +++++++++++++++++++------------------- main/EDInitMod.F90 | 12 +++---- main/EDMainMod.F90 | 4 +-- main/EDTypesMod.F90 | 6 ++++ main/FatesInterfaceMod.F90 | 51 +++++++++++++++----------- 5 files changed, 81 insertions(+), 66 deletions(-) diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index 1f5f14f2..e5557d1f 100755 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -7,7 +7,8 @@ module SFMainMod use FatesConstantsMod , only : r8 => fates_r8 - use spmdMod , only : masterproc +! use spmdMod , only : masterproc + use EDTypesMod , only : cp_masterproc ! 1= master process, 0=not master process use FatesGlobals , only : fates_log use FatesInterfaceMod , only : bc_in_type @@ -183,15 +184,15 @@ subroutine charecteristics_of_fuel ( currentSite ) currentPatch%fuel_frac = 0.0_r8 if(write_sf == 1)then - if (masterproc) write(fates_log(),*) ' leaf_litter1 ',currentPatch%leaf_litter - if (masterproc) write(fates_log(),*) ' leaf_litter2 ',sum(currentPatch%CWD_AG) - if (masterproc) write(fates_log(),*) ' leaf_litter3 ',currentPatch%livegrass - if (masterproc) write(fates_log(),*) ' sum fuel', currentPatch%sum_fuel + if ( cp_masterproc == 1 ) write(fates_log(),*) ' leaf_litter1 ',currentPatch%leaf_litter + if ( cp_masterproc == 1 ) write(fates_log(),*) ' leaf_litter2 ',sum(currentPatch%CWD_AG) + if ( cp_masterproc == 1 ) write(fates_log(),*) ' leaf_litter3 ',currentPatch%livegrass + if ( cp_masterproc == 1 ) write(fates_log(),*) ' 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(fates_log(),*) 'sum fuel', currentPatch%sum_fuel,currentPatch%area + if ( cp_masterproc == 1 ) write(fates_log(),*) 'sum fuel', currentPatch%sum_fuel,currentPatch%area endif ! =============================================== ! Average moisture, bulk density, surface area-volume and moisture extinction of fuel @@ -203,9 +204,9 @@ subroutine charecteristics_of_fuel ( currentSite ) currentPatch%fuel_frac(dg_sf+1:tr_sf) = currentPatch%CWD_AG / currentPatch%sum_fuel if(write_sf == 1)then - if (masterproc) write(fates_log(),*) 'ff1 ',currentPatch%fuel_frac - if (masterproc) write(fates_log(),*) 'ff2 ',currentPatch%fuel_frac - if (masterproc) write(fates_log(),*) 'ff2a ',lg_sf,currentPatch%livegrass,currentPatch%sum_fuel + if ( cp_masterproc == 1 ) write(fates_log(),*) 'ff1 ',currentPatch%fuel_frac + if ( cp_masterproc == 1 ) write(fates_log(),*) 'ff2 ',currentPatch%fuel_frac + if ( cp_masterproc == 1 ) write(fates_log(),*) 'ff2a ',lg_sf,currentPatch%livegrass,currentPatch%sum_fuel endif currentPatch%fuel_frac(lg_sf) = currentPatch%livegrass / currentPatch%sum_fuel @@ -214,10 +215,10 @@ subroutine charecteristics_of_fuel ( currentSite ) !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(fates_log(),*) 'ff3 ',currentPatch%fuel_frac - if (masterproc) write(fates_log(),*) 'fm ',fuel_moisture - if (masterproc) write(fates_log(),*) 'csa ',currentSite%acc_NI - if (masterproc) write(fates_log(),*) 'sfv ',SF_val_alpha_FMC + if ( cp_masterproc == 1 ) write(fates_log(),*) 'ff3 ',currentPatch%fuel_frac + if ( cp_masterproc == 1 ) write(fates_log(),*) 'fm ',fuel_moisture + if ( cp_masterproc == 1 ) write(fates_log(),*) 'csa ',currentSite%acc_NI + if ( cp_masterproc == 1 ) write(fates_log(),*) 'sfv ',SF_val_alpha_FMC endif ! FIX(RF,032414): needs refactoring. ! average water content !is this the correct metric? @@ -231,7 +232,7 @@ subroutine charecteristics_of_fuel ( currentSite ) 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(fates_log(),*) 'ff4 ',currentPatch%fuel_eff_moist + if ( cp_masterproc == 1 ) write(fates_log(),*) '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) @@ -258,14 +259,14 @@ subroutine charecteristics_of_fuel ( currentSite ) if(write_SF == 1)then - if (masterproc) write(fates_log(),*) 'no litter fuel at all',currentPatch%patchno, & + if ( cp_masterproc == 1 ) write(fates_log(),*) '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(fates_log(),*) 'problem with spitfire fuel averaging' + if ( cp_masterproc == 1 ) write(fates_log(),*) 'problem with spitfire fuel averaging' ! FIX(SPM,032414) refactor...should not have 0 fuel unless everything is burnt ! off. @@ -281,7 +282,7 @@ subroutine charecteristics_of_fuel ( currentSite ) ! 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(fates_log(),*) 'problem with spitfire fuel averaging' + if ( cp_masterproc == 1 ) write(fates_log(),*) 'problem with spitfire fuel averaging' endif currentPatch => currentPatch%younger @@ -320,7 +321,7 @@ subroutine wind_effect ( currentSite, bc_in) wind = bc_in%wind24_pa(iofp) * sec_per_min ! Convert to m/min for SPITFIRE units. if(write_SF == 1)then - if (masterproc) write(fates_log(),*) 'wind24', wind + if ( cp_masterproc == 1 ) write(fates_log(),*) 'wind24', wind endif ! --- influence of wind speed, corrected for surface roughness---- ! --- averaged over the whole grid cell to prevent extreme divergence @@ -359,7 +360,7 @@ subroutine wind_effect ( currentSite, bc_in) 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(fates_log(),*) 'grass, trees, bare',grass_fraction, tree_fraction, bare_fraction + if ( cp_masterproc == 1 ) write(fates_log(),*) 'grass, trees, bare',grass_fraction, tree_fraction, bare_fraction endif currentPatch=>currentSite%oldest_patch; @@ -409,18 +410,18 @@ subroutine rate_of_spread ( currentSite ) currentPatch%sum_fuel = currentPatch%sum_fuel * (1.0_r8 - SF_val_miner_total) !net of minerals ! ----start spreading--- - if (masterproc.and.DEBUG) write(fates_log(),*) 'SF - currentPatch%fuel_bulkd ',currentPatch%fuel_bulkd - if (masterproc.and.DEBUG) write(fates_log(),*) 'SF - SF_val_part_dens ',SF_val_part_dens + if ( cp_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - currentPatch%fuel_bulkd ',currentPatch%fuel_bulkd + if ( cp_masterproc == 1 .and.DEBUG) write(fates_log(),*) '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(fates_log(),*) 'SF - beta ',beta - if (masterproc.and.DEBUG) write(fates_log(),*) 'SF - beta_op ',beta_op + if ( cp_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - beta ',beta + if ( cp_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - beta_op ',beta_op bet = beta/beta_op if(write_sf == 1)then - if (masterproc) write(fates_log(),*) 'esf ',currentPatch%fuel_eff_moist + if ( cp_masterproc == 1 ) write(fates_log(),*) 'esf ',currentPatch%fuel_eff_moist endif ! ---heat of pre-ignition--- ! Equation A4 in Thonicke et al. 2010 @@ -438,11 +439,11 @@ subroutine rate_of_spread ( currentSite ) ! Equation A5 in Thonicke et al. 2010 if (DEBUG) then - if (masterproc.and.DEBUG) write(fates_log(),*) 'SF - c ',c - if (masterproc.and.DEBUG) write(fates_log(),*) 'SF - currentPatch%effect_wspeed ',currentPatch%effect_wspeed - if (masterproc.and.DEBUG) write(fates_log(),*) 'SF - b ',b - if (masterproc.and.DEBUG) write(fates_log(),*) 'SF - bet ',bet - if (masterproc.and.DEBUG) write(fates_log(),*) 'SF - e ',e + if ( cp_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - c ',c + if ( cp_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - currentPatch%effect_wspeed ',currentPatch%effect_wspeed + if ( cp_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - b ',b + if ( cp_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - bet ',bet + if ( cp_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - e ',e endif ! convert from m/min to ft/min for Rothermel ROS eqn @@ -604,7 +605,7 @@ subroutine fire_intensity ( currentSite ) 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(fates_log(),*) 'fire_intensity',currentPatch%fi,W,currentPatch%ROS_front + if( cp_masterproc == 1 ) write(fates_log(),*) '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 @@ -615,7 +616,7 @@ subroutine fire_intensity ( currentSite ) ! 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(fates_log(),*) 'fire duration minutes',currentPatch%fd + if ( cp_masterproc == 1 ) write(fates_log(),*) '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 @@ -709,18 +710,19 @@ subroutine area_burnt ( currentSite ) currentPatch%AB = size_of_fire * currentPatch%nf if (currentPatch%AB > gridarea*currentPatch%area/area) then !all of patch burnt. - if (masterproc) write(fates_log(),*) 'burnt all of patch',currentPatch%patchno, & + if ( cp_masterproc == 1 ) write(fates_log(),*) 'burnt all of patch',currentPatch%patchno, & currentPatch%area/area,currentPatch%ab,currentPatch%area/area*gridarea - if (masterproc) write(fates_log(),*) 'ros',currentPatch%ROS_front,currentPatch%FD, & + if ( cp_masterproc == 1 ) write(fates_log(),*) 'ros',currentPatch%ROS_front,currentPatch%FD, & currentPatch%NF,currentPatch%FI,size_of_fire - if (masterproc) write(fates_log(),*) 'litter',currentPatch%sum_fuel,currentPatch%CWD_AG,currentPatch%leaf_litter + if ( cp_masterproc == 1 ) write(fates_log(),*) '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(fates_log(),*) 'frac_burnt',currentPatch%frac_burnt + if ( cp_masterproc == 1 ) write(fates_log(),*) 'frac_burnt',currentPatch%frac_burnt endif endif endif! fire @@ -777,7 +779,7 @@ subroutine crown_scorching ( currentSite ) currentCohort%bdead))*currentCohort%n)/tree_ag_biomass !equation 16 in Thonicke et al. 2010 if(write_SF == 1)then - if (masterproc) write(fates_log(),*) 'currentPatch%SH',currentPatch%SH,f_ag_bmass + if ( cp_masterproc == 1 ) write(fates_log(),*) '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) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 18a52c16..0b8f0ef6 100755 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -4,16 +4,12 @@ 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 FatesConstantsMod , only : r8 => fates_r8 use abortutils , only : endrun use EDTypesMod , only : cp_nclmax - use clm_varctl , only : iulog, use_ed_spit_fire + use FatesGlobals , only : fates_log + use clm_varctl , only : 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 EDEcophysConType , only : EDecophyscon use EDGrowthFunctionsMod , only : bdead, bleaf, dbh @@ -285,7 +281,7 @@ subroutine init_cohorts( patch_in ) cstatus = patch_in%siteptr%dstatus endif - if ( DEBUG ) write(iulog,*) 'EDInitMod.F90 call create_cohort ' + if ( DEBUG ) write(fates_log(),*) 'EDInitMod.F90 call create_cohort ' call create_cohort(patch_in, pft, temp_cohort%n, temp_cohort%hite, temp_cohort%dbh, & temp_cohort%balive, temp_cohort%bdead, temp_cohort%bstore, & diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 81c7fac4..e82dc7b5 100755 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -17,7 +17,7 @@ module EDMainMod use EDtypesMod , only : ncwd, numpft_ed, udata use EDtypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type use FatesInterfaceMod , only : bc_in_type - use spmdMod , only : masterproc + use EDTypesMod , only : cp_masterproc implicit none private @@ -53,7 +53,7 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) type(ed_patch_type), pointer :: currentPatch !----------------------------------------------------------------------- - if ( masterproc ) write(iulog,*) 'modelday',bc_in%model_day + if ( cp_masterproc==1 ) write(iulog,*) 'modelday',bc_in%model_day !************************************************************************** ! Fire, growth, biogeochemistry. diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 4d80cf31..842e5a8a 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -149,6 +149,12 @@ module EDTypesMod ! HLM will interpret that the value should not be included in the average. real(r8) :: cp_hio_ignore_val + + ! Is this the master processor, typically useful for knowing if + ! the current machine should be printing out messages to the logs or terminals + ! 1 = TRUE (is master) 0 = FALSE (is not master) + integer :: cp_masterproc + !************************************ !** COHORT type structure ** !************************************ diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 210aece1..ed66e4f9 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -15,20 +15,19 @@ module FatesInterfaceMod ! PUBLIC API!!!! ! ------------------------------------------------------------------------------------ - use EDtypesMod , only : ed_site_type, & - numPatchesPerCol, & - cp_nclmax, & - cp_numSWb, & - cp_numlevgrnd, & - cp_maxSWb, & - cp_numlevdecomp, & - cp_numlevdecomp_full, & - cp_hlm_name, & - cp_hio_ignore_val, & - cp_numlevsoil - - use shr_kind_mod , only : r8 => shr_kind_r8 ! INTERF-TODO: REMOVE THIS - + use EDtypesMod , only : ed_site_type + use EDtypesMod , only : numPatchesPerCol + use EDtypesMod , only : cp_nclmax + use EDtypesMod , only : cp_numSWb + use EDtypesMod , only : cp_numlevgrnd + use EDtypesMod , only : cp_maxSWb + use EDtypesMod , only : cp_numlevdecomp + use EDtypesMod , only : cp_numlevdecomp_full + use EDtypesMod , only : cp_hlm_name + use EDtypesMod , only : cp_hio_ignore_val + use EDtypesMod , only : cp_numlevsoil + use EDtypesMod , only : cp_masterproc + use FatesConstantsMod , only : r8 => fates_r8 implicit none @@ -41,6 +40,7 @@ module FatesInterfaceMod ! (Intel-Forum Post), ALLOCATABLES are better perfomance wise as long as they point ! to contiguous memory spaces and do not alias other variables, the case here. ! Naming conventions: _gl means ground layer dimensions + ! _si means site dimensions (scalar in that case) ! _pa means patch dimensions ! _rb means radiation band ! ------------------------------------------------------------------------------------ @@ -620,6 +620,7 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) cp_numlevdecomp = unset_int cp_hlm_name = 'unset' cp_hio_ignore_val = unset_double + cp_masterproc = unset_int case('check_allset') @@ -631,6 +632,14 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) ! end_run('MESSAGE') end if + if(cp_masterproc .eq. unset_int) then + if (fates_global_verbose()) then + write(fates_log(), *) 'FATES parameter unset: cp_masterproc' + end if + ! INTERF-TODO: FATES NEEDS INTERNAL end_run + ! end_run('MESSAGE') + end if + if(cp_numSWb > cp_maxSWb) then if (fates_global_verbose()) then write(fates_log(), *) 'FATES sets a maximum number of shortwave bands' @@ -701,36 +710,38 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) if(present(ival))then select case (trim(tag)) - - case('num_sw_bbands') + case('masterproc') + cp_masterproc = ival + if (fates_global_verbose()) then + write(fates_log(),*) 'Transfering masterproc = ',ival,' to FATES' + end if + + case('num_sw_bbands') cp_numSwb = ival if (fates_global_verbose()) then write(fates_log(),*) 'Transfering num_sw_bbands = ',ival,' to FATES' end if case('num_lev_ground') - cp_numlevgrnd = ival if (fates_global_verbose()) then write(fates_log(),*) 'Transfering num_lev_ground = ',ival,' to FATES' end if + case('num_lev_soil') - cp_numlevsoil = ival if (fates_global_verbose()) then write(fates_log(),*) 'Transfering num_lev_ground = ',ival,' to FATES' end if case('num_levdecomp_full') - cp_numlevdecomp_full = ival if (fates_global_verbose()) then write(fates_log(),*) 'Transfering num_levdecomp_full = ',ival,' to FATES' end if case('num_levdecomp') - cp_numlevdecomp = ival if (fates_global_verbose()) then write(fates_log(),*) 'Transfering num_levdecomp = ',ival,' to FATES' From 55817d1c292ec979ff2748d2fd108b84a025a441 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 11 Jan 2017 17:25:50 -0800 Subject: [PATCH 279/437] Missed a fix on the merge with master: in FatesInterfaceMod, allocation of boundary conditions was using numPatchesPerCohort while master changed that to maxPatchesPerCohort. --- main/FatesInterfaceMod.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index ec9ae4ac..a8bf0cc6 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -388,11 +388,11 @@ subroutine allocate_bcin(bc_in) ! Allocate input boundaries ! Vegetation Dynamics - allocate(bc_in%t_veg24_pa(numPatchesPerCol)) + allocate(bc_in%t_veg24_pa(maxPatchesPerCol)) - allocate(bc_in%wind24_pa(numPatchesPerCol)) - allocate(bc_in%relhumid24_pa(numPatchesPerCol)) - allocate(bc_in%precip24_pa(numPatchesPerCol)) + allocate(bc_in%wind24_pa(maxPatchesPerCol)) + allocate(bc_in%relhumid24_pa(maxPatchesPerCol)) + allocate(bc_in%precip24_pa(maxPatchesPerCol)) ! Radiation allocate(bc_in%solad_parb(maxPatchesPerCol,cp_numSWb)) From 5730ebe63b6ec8674ed8c702d7b6cef6c67661f4 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 11 Jan 2017 19:04:35 -0800 Subject: [PATCH 280/437] Partial re-working of time-control from host to FATES. --- biogeochem/EDCanopyStructureMod.F90 | 6 ++-- biogeochem/EDCohortDynamicsMod.F90 | 10 +++--- biogeochem/EDGrowthFunctionsMod.F90 | 34 +++++++++--------- biogeochem/EDPhysiologyMod.F90 | 18 ++++++---- main/EDMainMod.F90 | 55 +++++++++++++++++------------ main/EDTypesMod.F90 | 3 +- main/FatesInterfaceMod.F90 | 10 +++++- 7 files changed, 78 insertions(+), 58 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index f5419ced..00a969a7 100755 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -465,12 +465,12 @@ subroutine canopy_structure( currentSite ) endif !call terminate_cohorts(currentPatch) if(promswitch == 1)then - ! write(fates_log(),*) 'cohort loop',currentCohort%pft,currentCohort%indexnumber,currentPatch%patchno + ! write(fates_log(),*) 'cohort loop',currentCohort%pft,currentPatch%patchno endif !----------- End of cohort splitting ------------------------------! else if(promswitch == 1)then - ! write(fates_log(),*) 'cohort list',currentCohort%pft,currentCohort%indexnumber, & + ! write(fates_log(),*) 'cohort list',currentCohort%pft, & ! currentCohort%canopy_layer,currentCohort%c_area endif endif @@ -485,7 +485,7 @@ subroutine canopy_structure( currentSite ) !currentPatch%patchno,z,i,lower_cohort_switch endif if(promswitch == 1.and.associated(currentPatch%tallest))then - ! write(fates_log(),*) 'cohorts',currentCohort%pft,currentCohort%indexnumber,currentPatch%patchno, & + ! write(fates_log(),*) 'cohorts',currentCohort%pft,currentPatch%patchno, & !currentCohort%c_area endif enddo !arealayer loop diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 2ccea2ca..70b00c33 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -7,6 +7,7 @@ module EDCohortDynamicsMod use abortutils , only : endrun use FatesGlobals , only : fates_log use FatesConstantsMod , only : r8 => fates_r8 + use FatesConstantsMod , only : fates_unset_int use shr_log_mod , only : errMsg => shr_log_errMsg use pftconMod , only : pftcon use EDEcophysContype , only : EDecophyscon @@ -73,7 +74,6 @@ subroutine create_cohort(patchptr, pft, nn, hite, dbh, & !---------------------------------------------------------------------- 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. @@ -82,7 +82,8 @@ subroutine create_cohort(patchptr, pft, nn, hite, dbh, & ! Define cohort state variable !**********************/ - new_cohort%indexnumber = udata%cohort_number + new_cohort%indexnumber = fates_unset_int ! Cohort indexing was not thread-safe, setting + ! bogus value for the time being (RGK-012017) new_cohort%siteptr => patchptr%siteptr new_cohort%patchptr => patchptr new_cohort%pft = pft @@ -109,7 +110,7 @@ subroutine create_cohort(patchptr, pft, nn, hite, dbh, & if (new_cohort%dbh <= 0.0_r8 .or. new_cohort%n == 0._r8 .or. new_cohort%pft == 0 ) then write(fates_log(),*) 'ED: something is zero in create_cohort', & - new_cohort%indexnumber,new_cohort%dbh,new_cohort%n, & + new_cohort%dbh,new_cohort%n, & new_cohort%pft call endrun(msg=errMsg(sourcefile, __LINE__)) endif @@ -1006,8 +1007,7 @@ subroutine copy_cohort( currentCohort,copyc ) o => currentCohort n => copyc - udata%cohort_number = udata%cohort_number + 1 - n%indexnumber = udata%cohort_number + n%indexnumber = fates_unset_int ! VEGETATION STRUCTURE n%pft = o%pft diff --git a/biogeochem/EDGrowthFunctionsMod.F90 b/biogeochem/EDGrowthFunctionsMod.F90 index a400f46a..12a46c79 100755 --- a/biogeochem/EDGrowthFunctionsMod.F90 +++ b/biogeochem/EDGrowthFunctionsMod.F90 @@ -7,7 +7,7 @@ module EDGrowthFunctionsMod ! ============================================================================ use shr_kind_mod , only : r8 => shr_kind_r8 - use clm_varctl , only : iulog + use FatesGlobals , only : fates_log use pftconMod , only : pftcon use EDEcophysContype , only : EDecophyscon use EDTypesMod , only : ed_cohort_type, cp_nlevcan, dinc_ed @@ -76,7 +76,7 @@ real(r8) function Hite( cohort_in ) c = 0.37_r8 if(cohort_in%dbh <= 0._r8)then - write(iulog,*) 'ED: dbh less than zero problem!',cohort_in%indexnumber + write(fates_log(),*) 'ED: dbh less than zero problem!' cohort_in%dbh = 0.1_r8 endif @@ -106,7 +106,7 @@ real(r8) function Bleaf( cohort_in ) real(r8) :: slascaler ! changes the target biomass according to the SLA 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 + write(fates_log(),*) 'problems in bleaf',cohort_in%dbh,cohort_in%pft endif if(cohort_in%dbh <= EDecophyscon%max_dbh(cohort_in%pft))then @@ -117,7 +117,7 @@ real(r8) function Bleaf( cohort_in ) slascaler = 0.03_r8/pftcon%slatop(cohort_in%pft) bleaf = bleaf * slascaler - !write(iulog,*) 'bleaf',bleaf, slascaler,cohort_in%pft + !write(fates_log(),*) 'bleaf',bleaf, slascaler,cohort_in%pft !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 @@ -141,7 +141,7 @@ real(r8) function tree_lai( cohort_in ) 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 + write(fates_log(),*) 'problem in treelai',cohort_in%bl,cohort_in%pft endif if( cohort_in%status_coh == 2 ) then ! are the leaves on? @@ -162,7 +162,7 @@ real(r8) function tree_lai( cohort_in ) ! at the moments cp_nlevcan default is 40, which is very large, so exceeding this would clearly illustrate a ! huge error if(cohort_in%treelai > cp_nlevcan*dinc_ed)then - write(iulog,*) 'too much lai' , cohort_in%treelai , cohort_in%pft , cp_nlevcan * dinc_ed + write(fates_log(),*) 'too much lai' , cohort_in%treelai , cohort_in%pft , cp_nlevcan * dinc_ed endif return @@ -186,7 +186,7 @@ real(r8) function tree_sai( cohort_in ) 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 + write(fates_log(),*) 'problem in treesai',cohort_in%bdead,cohort_in%pft endif cohort_in%c_area = c_area(cohort_in) ! call the tree area @@ -199,7 +199,7 @@ real(r8) function tree_sai( cohort_in ) ! at the moments cp_nlevcan default is 40, which is very large, so exceeding this would clearly illustrate a ! huge error if(cohort_in%treesai > cp_nlevcan*dinc_ed)then - write(iulog,*) 'too much sai' , cohort_in%treesai , cohort_in%pft , cp_nlevcan * dinc_ed + write(fates_log(),*) 'too much sai' , cohort_in%treesai , cohort_in%pft , cp_nlevcan * dinc_ed endif return @@ -223,13 +223,13 @@ real(r8) function c_area( 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 + write(fates_log(),*) 'z_area 1',cohort_in%dbh,cohort_in%pft + write(fates_log(),*) 'z_area 2',EDecophyscon%max_dbh + write(fates_log(),*) 'z_area 3',pftcon%woody + write(fates_log(),*) 'z_area 4',cohort_in%n + write(fates_log(),*) 'z_area 5',cohort_in%patchptr%spread + write(fates_log(),*) 'z_area 6',cohort_in%canopy_layer + write(fates_log(),*) 'z_area 7',ED_val_grass_spread end if dbh = min(cohort_in%dbh,EDecophyscon%max_dbh(cohort_in%pft)) @@ -371,8 +371,8 @@ subroutine mortality_rates( cohort_in,cmort,hmort,bmort ) 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 + write(fates_log(),*) 'dbh problem in mortality_rates', & + cohort_in%dbh,cohort_in%pft,cohort_in%n,cohort_in%canopy_layer endif !mortality_rates = bmort + hmort + cmort diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 91806580..b771c890 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -42,7 +42,7 @@ module EDPhysiologyMod contains ! ============================================================================ - subroutine canopy_derivs( currentSite, currentPatch ) + subroutine canopy_derivs( currentSite, currentPatch, bc_in ) ! ! !DESCRIPTION: ! spawn new cohorts of juveniles of each PFT @@ -52,6 +52,7 @@ subroutine canopy_derivs( currentSite, currentPatch ) ! !ARGUMENTS type(ed_site_type), intent(inout), target :: currentSite type(ed_patch_type) , intent(inout), target :: currentPatch + type(bc_in_type), intent(in) :: bc_in ! ! !LOCAL VARIABLES: type(ed_cohort_type), pointer ::currentCohort @@ -62,7 +63,7 @@ subroutine canopy_derivs( currentSite, currentPatch ) currentCohort => currentPatch%shortest do while(associated(currentCohort)) - call Growth_Derivatives(currentSite, currentCohort) + call Growth_Derivatives(currentSite, currentCohort, bc_in ) currentCohort => currentCohort%taller enddo @@ -702,7 +703,7 @@ subroutine seed_germination( currentSite, currentPatch ) end subroutine seed_germination ! ============================================================================ - subroutine Growth_Derivatives( currentSite, currentCohort) + subroutine Growth_Derivatives( currentSite, currentCohort, bc_in) ! ! !DESCRIPTION: ! Main subroutine controlling growth and allocation derivatives @@ -714,6 +715,7 @@ subroutine Growth_Derivatives( currentSite, currentCohort) ! !ARGUMENTS type(ed_site_type), intent(inout), target :: currentSite type(ed_cohort_type),intent(inout), target :: currentCohort + type(bc_in_type), intent(in) :: bc_in ! ! !LOCAL VARIABLES: real(r8) :: dbldbd !rate of change of dead biomass per unit dbh @@ -760,9 +762,11 @@ subroutine Growth_Derivatives( currentSite, currentCohort) ! NPP if ( DEBUG ) write(fates_log(),*) 'EDphys 716 ',currentCohort%npp_acc - currentCohort%npp_acc_hold = currentCohort%npp_acc * udata%n_sub ! convert from kgC/indiv/day into kgC/indiv/year - currentCohort%gpp_acc_hold = currentCohort%gpp_acc * udata%n_sub ! convert from kgC/indiv/day into kgC/indiv/year - currentCohort%resp_acc_hold = currentCohort%resp_acc * udata%n_sub ! convert from kgC/indiv/day into kgC/indiv/year + ! convert from kgC/indiv/day into kgC/indiv/year + ! TODO: CONVERT DAYS_PER_YEAR TO DBLE (HOLDING FOR B4B COMPARISONS, RGK-01-2017) + currentCohort%npp_acc_hold = currentCohort%npp_acc * bc_in%days_per_year + currentCohort%gpp_acc_hold = currentCohort%gpp_acc * bc_in%days_per_year + currentCohort%resp_acc_hold = currentCohort%resp_acc * bc_in%days_per_year currentSite%flux_in = currentSite%flux_in + currentCohort%npp_acc * currentCohort%n @@ -845,7 +849,7 @@ subroutine Growth_Derivatives( currentSite, currentCohort) currentCohort%storage_flux = 0._r8 currentCohort%carbon_balance = 0._r8 - write(fates_log(),*) 'ED: no leaf area in gd', currentCohort%indexnumber,currentCohort%n,currentCohort%bdead, & + write(fates_log(),*) 'ED: no leaf area in gd',currentCohort%n,currentCohort%bdead, & currentCohort%dbh,currentCohort%balive endif diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index e82dc7b5..e18676e2 100755 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -6,7 +6,7 @@ module EDMainMod use shr_kind_mod , only : r8 => shr_kind_r8 - use clm_varctl , only : iulog + use FatesGlobals , only : fates_log use atm2lndType , only : atm2lnd_type use SoilStateType , only : soilstate_type use TemperatureType , only : temperature_type @@ -53,7 +53,8 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) type(ed_patch_type), pointer :: currentPatch !----------------------------------------------------------------------- - if ( cp_masterproc==1 ) write(iulog,*) 'modelday',bc_in%model_day + if ( cp_masterproc==1 ) write(fates_log(),'(A,I4,A,I2.2,A,I2.2)') 'FATES Dynamics: ',& + bc_in%current_year,'-',bc_in%current_month,'-',bc_in%current_day !************************************************************************** ! Fire, growth, biogeochemistry. @@ -165,12 +166,12 @@ subroutine ed_integrate_state_variables(currentSite, bc_in ) 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?',currentPatch%age, & + write(fates_log(),*) 'negative patch age?',currentPatch%age, & currentPatch%patchno,currentPatch%area endif ! Find the derivatives of the growth and litter processes. - call canopy_derivs(currentSite, currentPatch) + call canopy_derivs(currentSite, currentPatch, bc_in) ! Update Canopy Biomass Pools currentCohort => currentPatch%shortest @@ -181,23 +182,23 @@ subroutine ed_integrate_state_variables(currentSite, bc_in ) currentCohort%balive = currentCohort%balive + currentCohort%dbalivedt * udata%deltat currentCohort%bdead = max(small_no,currentCohort%bdead + currentCohort%dbdeaddt * udata%deltat ) if ( DEBUG ) then - write(iulog,*) 'EDMainMod dbstoredt I ',currentCohort%bstore, & + write(fates_log(),*) 'EDMainMod dbstoredt I ',currentCohort%bstore, & currentCohort%dbstoredt,udata%deltat end if currentCohort%bstore = currentCohort%bstore + currentCohort%dbstoredt * udata%deltat if ( DEBUG ) then - write(iulog,*) 'EDMainMod dbstoredt II ',currentCohort%bstore, & + write(fates_log(),*) 'EDMainMod dbstoredt II ',currentCohort%bstore, & currentCohort%dbstoredt,udata%deltat end if if( (currentCohort%balive+currentCohort%bdead+currentCohort%bstore)*currentCohort%n<0._r8)then - write(iulog,*) 'biomass is negative', currentCohort%n,currentCohort%balive, & + write(fates_log(),*) '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+ & + write(fates_log(),*) '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 @@ -234,23 +235,25 @@ subroutine ed_integrate_state_variables(currentSite, bc_in ) do c = 1,ncwd if(currentPatch%cwd_ag(c) currentPatch%younger @@ -343,8 +347,13 @@ subroutine ed_update_site( currentSite ) enddo ! FIX(RF,032414). This needs to be monthly, not annual - if((udata%time_period == udata%n_sub-1))then - write(iulog,*) 'calling trim canopy' +! if((udata%time_period == udata%n_sub-1))then + + ! If this is the second to last day of the year, then perform trimming + + if( bc_in%day_of_year == bc_in%days_per_year-1) then + + write(fates_log(),*) 'calling trim canopy' call trim_canopy(currentSite) endif @@ -414,14 +423,14 @@ subroutine ed_total_balance_check (currentSite, call_index ) error = abs(net_flux - change_in_stock) if ( abs(error) > 10e-6 ) then - write(iulog,*) 'total error: call index: ',call_index, & + write(fates_log(),*) 'total error: call index: ',call_index, & 'in: ',currentSite%flux_in, & 'out: ',currentSite%flux_out, & 'net: ',net_flux, & 'dstock: ',change_in_stock, & 'error=net_flux-dstock:', error - write(iulog,*) 'biomass,litter,seeds', biomass_stock,litter_stock,seed_stock - write(iulog,*) 'lat lon',currentSite%lat,currentSite%lon + write(fates_log(),*) 'biomass,litter,seeds', biomass_stock,litter_stock,seed_stock + write(fates_log(),*) 'lat lon',currentSite%lat,currentSite%lon endif currentSite%flux_in = 0.0_r8 diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 821ed08b..ec47eba0 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -552,12 +552,11 @@ module EDTypesMod !************************************ type userdata - integer :: cohort_number ! Counts up the number of cohorts which have been made. +! integer :: cohort_number ! Counts up the number of cohorts which have been made. integer :: n_sub ! num of substeps in year 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? - integer :: modelday ! Number of days since reference end type userdata diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index a8bf0cc6..f24a415e 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -60,7 +60,15 @@ module FatesInterfaceMod real(r8) :: model_day ! elapsed days between current date and reference ! uses ESMF functions, so prefered to pass it in as ! argument rather than calculate directly - + integer :: day_of_year ! The integer day of the year + integer :: days_per_year ! The HLM controls time, some HLMs may include a leap + ! day, some actually don't. This is the number of + ! days in the current year + real(r8) :: deltat_day ! fraction of year for each time-step (1/days_per_year) + + + + ! Vegetation Dynamics ! --------------------------------------------------------------------------------- From 1307cd56cfbea6a6d1d9f676db581ae5475c656b Mon Sep 17 00:00:00 2001 From: ckoven Date: Wed, 11 Jan 2017 20:48:17 -0800 Subject: [PATCH 281/437] added size class only dimension and a basal area variable on that dimension --- main/FatesHistoryInterfaceMod.F90 | 66 ++++++++++++++++++++++++++++--- main/FatesHistoryVariableType.F90 | 9 ++++- main/FatesIODimensionsMod.F90 | 6 +++ main/FatesIOVariableKindMod.F90 | 2 + 4 files changed, 76 insertions(+), 7 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index b2b090b2..abf4b0a9 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -134,10 +134,12 @@ module FatesHistoryInterfaceMod integer, private :: ih_ar_crootm_si_scpf integer, private :: ih_ar_frootm_si_scpf + ! indices to (site x scls) variables + integer, private :: ih_ba_si_scls ! The number of variable dim/kind types we have defined (static) - integer, parameter :: fates_history_num_dimensions = 4 - integer, parameter :: fates_history_num_dim_kinds = 6 + integer, parameter :: fates_history_num_dimensions = 5 + integer, parameter :: fates_history_num_dim_kinds = 8 @@ -170,7 +172,7 @@ module FatesHistoryInterfaceMod type(iovar_map_type), pointer :: iovar_map(:) - integer, private :: patch_index_, column_index_, levgrnd_index_, levscpf_index_ + integer, private :: patch_index_, column_index_, levgrnd_index_, levscpf_index_, levscls_index_ contains procedure, public :: Init @@ -188,6 +190,7 @@ module FatesHistoryInterfaceMod procedure, public :: column_index procedure, public :: levgrnd_index procedure, public :: levscpf_index + procedure, public :: levscls_index ! private work functions procedure, private :: define_history_vars @@ -200,6 +203,7 @@ module FatesHistoryInterfaceMod procedure, private :: set_column_index procedure, private :: set_levgrnd_index procedure, private :: set_levscpf_index + procedure, private :: set_levscls_index end type fates_history_interface_type @@ -211,7 +215,7 @@ module FatesHistoryInterfaceMod subroutine Init(this, num_threads, fates_bounds) - use FatesIODimensionsMod, only : patch, column, levgrnd, levscpf + use FatesIODimensionsMod, only : patch, column, levgrnd, levscpf, levscls use FatesIODimensionsMod, only : fates_bounds_type implicit none @@ -241,6 +245,11 @@ subroutine Init(this, num_threads, fates_bounds) call this%set_levscpf_index(dim_count) call this%dim_bounds(dim_count)%Init(levscpf, num_threads, & fates_bounds%pft_class_begin, fates_bounds%pft_class_end) + + dim_count = dim_count + 1 + call this%set_levscls_index(dim_count) + call this%dim_bounds(dim_count)%Init(levscls, num_threads, & + fates_bounds%size_class_begin, fates_bounds%size_class_end) ! FIXME(bja, 2016-10) assert(dim_count == FatesHistorydimensionmod::num_dimension_types) ! Allocate the mapping between FATES indices and the IO indices @@ -277,6 +286,10 @@ subroutine SetThreadBoundsEach(this, thread_index, thread_bounds) index = this%levscpf_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%pft_class_begin, thread_bounds%pft_class_end) + + index = this%levscls_index() + call this%dim_bounds(index)%SetThreadBounds(thread_index, & + thread_bounds%size_class_begin, thread_bounds%size_class_end) end subroutine SetThreadBoundsEach @@ -285,6 +298,7 @@ subroutine assemble_history_output_types(this) use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8 + use FatesIOVariableKindMod, only : patch_size_r8, site_size_r8 implicit none @@ -308,6 +322,12 @@ subroutine assemble_history_output_types(this) call this%set_dim_indices(site_size_pft_r8, 1, this%column_index()) call this%set_dim_indices(site_size_pft_r8, 2, this%levscpf_index()) + call this%set_dim_indices(patch_size_r8, 1, this%patch_index()) + call this%set_dim_indices(patch_size_r8, 2, this%levscls_index()) + + call this%set_dim_indices(site_size_r8, 1, this%column_index()) + call this%set_dim_indices(site_size_r8, 2, this%levscls_index()) + end subroutine assemble_history_output_types ! =================================================================================== @@ -407,6 +427,20 @@ integer function levscpf_index(this) levscpf_index = this%levscpf_index_ end function levscpf_index + ! ======================================================================= + subroutine set_levscls_index(this, index) + implicit none + class(fates_history_interface_type), intent(inout) :: this + integer, intent(in) :: index + this%levscls_index_ = index + end subroutine set_levscls_index + + integer function levscls_index(this) + implicit none + class(fates_history_interface_type), intent(in) :: this + levscls_index = this%levscls_index_ + end function levscls_index + ! ====================================================================================== subroutine flush_hvars(this,nc,upfreq_in) @@ -500,6 +534,7 @@ subroutine init_dim_kinds_maps(this) ! ---------------------------------------------------------------------------------- use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8 + use FatesIOVariableKindMod, only : patch_size_r8, site_size_r8 implicit none @@ -533,6 +568,14 @@ subroutine init_dim_kinds_maps(this) index = index + 1 call this%dim_kinds(index)%Init(site_size_pft_r8, 2) + ! patch x size-class + index = index + 1 + call this%dim_kinds(index)%Init(patch_size_r8, 2) + + ! site x size-class + index = index + 1 + call this%dim_kinds(index)%Init(site_size_r8, 2) + ! FIXME(bja, 2016-10) assert(index == fates_history_num_dim_kinds) end subroutine init_dim_kinds_maps @@ -688,7 +731,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_m2_si_scpf => this%hvars(ih_m2_si_scpf)%r82d, & hio_m3_si_scpf => this%hvars(ih_m3_si_scpf)%r82d, & hio_m4_si_scpf => this%hvars(ih_m4_si_scpf)%r82d, & - hio_m5_si_scpf => this%hvars(ih_m5_si_scpf)%r82d ) + hio_m5_si_scpf => this%hvars(ih_m5_si_scpf)%r82d, & + hio_ba_si_scls => this%hvars(ih_ba_si_scls)%r82d ) ! --------------------------------------------------------------------------------- ! Flush arrays to values defined by %flushval (see registry entry in @@ -789,7 +833,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! have any meaning, otherwise they are just inialization values if( .not.(ccohort%isnew) ) then - associate( scpf => ccohort%size_by_pft_class ) + associate( scpf => ccohort%size_by_pft_class, & + scls => ccohort%size_class ) hio_gpp_si_scpf(io_si,scpf) = hio_gpp_si_scpf(io_si,scpf) + & n_perm2*ccohort%gpp_acc_hold ! [kgC/m2/yr] @@ -840,6 +885,9 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! basal area [m2/ha] hio_ba_si_scpf(io_si,scpf) = hio_ba_si_scpf(io_si,scpf) + & 0.25_r8*3.14159_r8*((dbh/100.0_r8)**2.0_r8)*n_perm2*AREA + ! also by size class only + hio_ba_si_scls(io_si,scls) = hio_ba_si_scls(io_si,scls) + & + 0.25_r8*3.14159_r8*((dbh/100.0_r8)**2.0_r8)*n_perm2*AREA ! number density [/ha] hio_nplant_si_scpf(io_si,scpf) = hio_nplant_si_scpf(io_si,scpf) + AREA*n_perm2 @@ -1124,6 +1172,7 @@ subroutine define_history_vars(this, initialize_variables) use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8 + use FatesIOVariableKindMod, only : patch_size_r8, site_size_r8 implicit none class(fates_history_interface_type), intent(inout) :: this @@ -1474,6 +1523,11 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_ar_frootm_si_scpf ) + ! size-class only variables + call this%set_history_var(vname='BA_SCLS', units = 'm2/ha', & + long='basal area by size class', use_default='active', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ba_si_scls ) ! CARBON BALANCE VARIABLES THAT DEPEND ON HLM BGC INPUTS diff --git a/main/FatesHistoryVariableType.F90 b/main/FatesHistoryVariableType.F90 index 44d64586..7829c803 100644 --- a/main/FatesHistoryVariableType.F90 +++ b/main/FatesHistoryVariableType.F90 @@ -44,7 +44,7 @@ subroutine Init(this, vname, units, long, use_default, & use FatesIODimensionsMod, only : fates_io_dimension_type use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 - use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8 + use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8, site_size_r8 use FatesIOVariableKindMod, only : iotype_index implicit none @@ -118,6 +118,10 @@ subroutine Init(this, vname, units, long, use_default, & allocate(this%r82d(lb1:ub1, lb2:ub2)) this%r82d(:,:) = flushval + case(site_size_r8) + allocate(this%r82d(lb1:ub1, lb2:ub2)) + this%r82d(:,:) = flushval + case default write(fates_log(),*) 'Incompatible vtype passed to set_history_var' write(fates_log(),*) 'vtype = ',trim(vtype),' ?' @@ -183,6 +187,7 @@ subroutine Flush(this, thread, dim_bounds, dim_kinds) use FatesIODimensionsMod, only : fates_io_dimension_type use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8, patch_int + use FatesIOVariableKindMod, only : site_size_r8 implicit none @@ -208,6 +213,8 @@ subroutine Flush(this, thread, dim_bounds, dim_kinds) this%r82d(lb1:ub1, lb2:ub2) = this%flushval case(site_size_pft_r8) this%r82d(lb1:ub1, lb2:ub2) = this%flushval + case(site_size_r8) + this%r82d(lb1:ub1, lb2:ub2) = this%flushval case(patch_int) this%int1d(lb1:ub1) = nint(this%flushval) case default diff --git a/main/FatesIODimensionsMod.F90 b/main/FatesIODimensionsMod.F90 index 84c082e7..b73755e0 100644 --- a/main/FatesIODimensionsMod.F90 +++ b/main/FatesIODimensionsMod.F90 @@ -9,6 +9,7 @@ module FatesIODimensionsMod character(*), parameter :: column = 'column' character(*), parameter :: levgrnd = 'levgrnd' character(*), parameter :: levscpf = 'levscpf' + character(*), parameter :: levscls = 'levscls' ! patch = This is a structure that records where FATES patch boundaries ! on each thread point to in the host IO array, this structure @@ -24,6 +25,9 @@ module FatesIODimensionsMod ! levscpf = This is a structure that records the boundaries for the ! number of size-class x pft dimension + ! levscls = This is a structure that records the boundaries for the + ! number of size-class dimension + type, public :: fates_bounds_type integer :: patch_begin @@ -36,6 +40,8 @@ module FatesIODimensionsMod integer :: ground_end integer :: pft_class_begin integer :: pft_class_end + integer :: size_class_begin + integer :: size_class_end end type fates_bounds_type diff --git a/main/FatesIOVariableKindMod.F90 b/main/FatesIOVariableKindMod.F90 index 343d3b43..77371a3a 100644 --- a/main/FatesIOVariableKindMod.F90 +++ b/main/FatesIOVariableKindMod.F90 @@ -12,10 +12,12 @@ module FatesIOVariableKindMod character(*), parameter :: patch_r8 = 'PA_R8' character(*), parameter :: patch_ground_r8 = 'PA_GRND_R8' character(*), parameter :: patch_size_pft_r8 = 'PA_SCPF_R8' + character(*), parameter :: patch_size_r8 = 'PA_SCLS_R8' character(*), parameter :: site_r8 = 'SI_R8' character(*), parameter :: site_int = 'SI_INT' character(*), parameter :: site_ground_r8 = 'SI_GRND_R8' character(*), parameter :: site_size_pft_r8 = 'SI_SCPF_R8' + character(*), parameter :: site_size_r8 = 'SI_SCLS_R8' character(*), parameter :: patch_int = 'PA_INT' character(*), parameter :: cohort_r8 = 'CO_R8' character(*), parameter :: cohort_int = 'CO_INT' From 03375f4eddc9f8e980f5b6f2baf51b96aec628e1 Mon Sep 17 00:00:00 2001 From: ckoven Date: Thu, 12 Jan 2017 15:52:35 -0800 Subject: [PATCH 282/437] added age and pft dimensions to history; however it is crashing in subgridAveMod.F90 --- biogeochem/EDPatchDynamicsMod.F90 | 4 + main/EDMainMod.F90 | 4 + main/EDTypesMod.F90 | 19 ++++- main/FatesHistoryInterfaceMod.F90 | 117 ++++++++++++++++++++++++++---- main/FatesHistoryVariableType.F90 | 17 ++++- main/FatesIODimensionsMod.F90 | 16 +++- main/FatesIOVariableKindMod.F90 | 3 + 7 files changed, 161 insertions(+), 19 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 5fae1a78..b54f7812 100755 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -831,6 +831,7 @@ subroutine create_patch(currentSite, new_patch, age, areap, spread_local,cwd_ag_ new_patch%siteptr => currentSite new_patch%age = age + new_patch%age_class = 1 new_patch%area = areap new_patch%spread = spread_local new_patch%cwd_ag = cwd_ag_local @@ -899,6 +900,7 @@ subroutine zero_patch(cp_p) currentPatch%clm_pno = 999 currentPatch%age = nan + currentPatch%age_class = 1 currentPatch%area = nan currentPatch%canopy_layer_lai(:) = nan currentPatch%total_canopy_area = nan @@ -1150,6 +1152,7 @@ subroutine fuse_2_patches(dp, rp) ! associated with the secnd patch ! ! !USES: + use EDTypesMod, only: pageclass_ed ! ! !ARGUMENTS: type (ed_patch_type) , intent(inout), pointer :: dp ! Donor Patch @@ -1169,6 +1172,7 @@ subroutine fuse_2_patches(dp, rp) !area weighted average of ages & litter rp%age = (dp%age * dp%area + rp%age * rp%area)/(dp%area + rp%area) + rp%age_class = max(1,count(rp%age-pageclass_ed.ge.0.0_r8)) do p = 1,numpft_ed rp%seeds_in(p) = (rp%seeds_in(p)*rp%area + dp%seeds_in(p)*dp%area)/(rp%area + dp%area) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 9499f93d..f43cbbb5 100755 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -137,6 +137,7 @@ subroutine ed_integrate_state_variables(currentSite, temperature_inst ) ! FIX(SPM,032414) refactor so everything goes through interface ! ! !USES: + use EDTypesMod, only : pageclass_ed ! ! !ARGUMENTS: type(ed_site_type) , intent(inout) :: currentSite @@ -170,6 +171,9 @@ subroutine ed_integrate_state_variables(currentSite, temperature_inst ) currentPatch%patchno,currentPatch%area endif + ! check to see if the patch has moved to the next age class + currentPatch%age_class = count(currentPatch%age-pageclass_ed.ge.0.0_r8) + ! Find the derivatives of the growth and litter processes. call canopy_derivs(currentSite, currentPatch) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 3419386a..d4731bfc 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -83,9 +83,12 @@ module EDTypesMod ! real(r8), parameter, dimension(16) :: sclass_ed = (/0.0_r8,1.0_r8,2.0_r8,3.0_r8,4.0_r8,5.0_r8,10.0_r8,20.0_r8,30.0_r8,40.0_r8, & ! 50.0_r8,60.0_r8,70.0_r8,80.0_r8,90.0_r8,100.0_r8/) - real(r8), parameter, dimension(13) :: sclass_ed = (/0.0_r8,5.0_r8,10.0_r8,15.0_r8,20.0_r8,30.0_r8,40.0_r8, & + real(r8), parameter, dimension(nlevsclass_ed) :: sclass_ed = (/0.0_r8,5.0_r8,10.0_r8,15.0_r8,20.0_r8,30.0_r8,40.0_r8, & 50.0_r8,60.0_r8,70.0_r8,80.0_r8,90.0_r8,100.0_r8/) + integer, parameter :: nlevpage_ed = 7 ! Number of patch-age classes for age structured analyses + real(r8), parameter, dimension(nlevpage_ed) :: pageclass_ed = (/0.0_r8,1.0_r8,2._r8,5.0_r8,10.0_r8,20.0_r8,50.0_r8/) + ! integer, parameter :: nlevsclass_ed = 17 ! real(r8), parameter, dimension(17) :: sclass_ed = (/0.1_r8, 5.0_r8,10.0_r8,15.0_r8,20.0_r8,25.0_r8, & @@ -99,13 +102,15 @@ module EDTypesMod character(len = 10), parameter,dimension(5) :: char_list = (/"background","hydraulic ","carbon ","impact ","fire "/) - ! These three vectors are used for history output mapping + ! These vectors are used for history output mapping real(r8) ,allocatable :: levsclass_ed(:) ! The lower bound on size classes for ED trees. This ! is used really for IO into the ! history tapes. It gets copied from ! the parameter array sclass_ed. integer , allocatable :: pft_levscpf_ed(:) integer , allocatable :: scls_levscpf_ed(:) + real(r8), allocatable :: levpage_ed(:) + integer , allocatable :: levpft_ed(:) ! Control Parameters (cp_) @@ -313,6 +318,7 @@ module EDTypesMod ! PATCH INFO real(r8) :: age ! average patch age: years + integer :: age_class ! age class of the patch for history binning purposes real(r8) :: area ! patch area: m2 integer :: countcohorts ! Number of cohorts in patch integer :: ncl_p ! Number of occupied canopy layers @@ -575,11 +581,20 @@ subroutine ed_hist_scpfmaps allocate( levsclass_ed(1:nlevsclass_ed )) allocate( pft_levscpf_ed(1:nlevsclass_ed*mxpft)) allocate(scls_levscpf_ed(1:nlevsclass_ed*mxpft)) + allocate( levpft_ed(1:mxpft )) + allocate( levpage_ed(1:nlevpage_ed )) ! Fill the IO array of plant size classes ! For some reason the history files did not like ! a hard allocation of sclass_ed levsclass_ed(:) = sclass_ed(:) + + levpage_ed(:) = pageclass_ed(:) + + ! make pft array + do ipft=1,mxpft + levpft_ed(ipft) = ipft + end do ! Fill the IO arrays that match pft and size class to their combined array i=0 diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index abf4b0a9..0ef6cc11 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -64,15 +64,13 @@ module FatesHistoryInterfaceMod integer, private :: ih_growth_resp_pa ! Indices to (patch x pft) variables (using nlevgrnd as surrogate) - + !+++cdk+++ leaving these as-is for now to preserve b4b, but once established, need to move these to actual pft dimension integer, private :: ih_biomass_pa_pft integer, private :: ih_leafbiomass_pa_pft integer, private :: ih_storebiomass_pa_pft integer, private :: ih_nindivs_pa_pft ! Indices to (site) variables - - integer, private :: ih_nep_si integer, private :: ih_nep_timeintegrated_si integer, private :: ih_npp_timeintegrated_si @@ -137,9 +135,15 @@ module FatesHistoryInterfaceMod ! indices to (site x scls) variables integer, private :: ih_ba_si_scls + ! indices to (site x pft) variables + integer, private :: ih_biomass_si_pft + + ! indices to (site x patch-age) variables + integer, private :: ih_area_si_page + ! The number of variable dim/kind types we have defined (static) - integer, parameter :: fates_history_num_dimensions = 5 - integer, parameter :: fates_history_num_dim_kinds = 8 + integer, parameter :: fates_history_num_dimensions = 7 + integer, parameter :: fates_history_num_dim_kinds = 10 @@ -172,7 +176,8 @@ module FatesHistoryInterfaceMod type(iovar_map_type), pointer :: iovar_map(:) - integer, private :: patch_index_, column_index_, levgrnd_index_, levscpf_index_, levscls_index_ + integer, private :: patch_index_, column_index_, levgrnd_index_, levscpf_index_ + integer, private :: levscls_index_, levpft_index_, levpage_index_ contains procedure, public :: Init @@ -191,6 +196,8 @@ module FatesHistoryInterfaceMod procedure, public :: levgrnd_index procedure, public :: levscpf_index procedure, public :: levscls_index + procedure, public :: levpft_index + procedure, public :: levpage_index ! private work functions procedure, private :: define_history_vars @@ -204,6 +211,8 @@ module FatesHistoryInterfaceMod procedure, private :: set_levgrnd_index procedure, private :: set_levscpf_index procedure, private :: set_levscls_index + procedure, private :: set_levpft_index + procedure, private :: set_levpage_index end type fates_history_interface_type @@ -215,7 +224,8 @@ module FatesHistoryInterfaceMod subroutine Init(this, num_threads, fates_bounds) - use FatesIODimensionsMod, only : patch, column, levgrnd, levscpf, levscls + use FatesIODimensionsMod, only : patch, column, levgrnd, levscpf + use FatesIODimensionsMod, only : levscls, levpft, levpage use FatesIODimensionsMod, only : fates_bounds_type implicit none @@ -244,12 +254,22 @@ subroutine Init(this, num_threads, fates_bounds) dim_count = dim_count + 1 call this%set_levscpf_index(dim_count) call this%dim_bounds(dim_count)%Init(levscpf, num_threads, & - fates_bounds%pft_class_begin, fates_bounds%pft_class_end) + fates_bounds%sizepft_class_begin, fates_bounds%sizepft_class_end) dim_count = dim_count + 1 call this%set_levscls_index(dim_count) call this%dim_bounds(dim_count)%Init(levscls, num_threads, & fates_bounds%size_class_begin, fates_bounds%size_class_end) + + dim_count = dim_count + 1 + call this%set_levpft_index(dim_count) + call this%dim_bounds(dim_count)%Init(levpft, num_threads, & + fates_bounds%pft_class_begin, fates_bounds%pft_class_end) + + dim_count = dim_count + 1 + call this%set_levpage_index(dim_count) + call this%dim_bounds(dim_count)%Init(levpage, num_threads, & + fates_bounds%page_class_begin, fates_bounds%page_class_end) ! FIXME(bja, 2016-10) assert(dim_count == FatesHistorydimensionmod::num_dimension_types) ! Allocate the mapping between FATES indices and the IO indices @@ -285,11 +305,15 @@ subroutine SetThreadBoundsEach(this, thread_index, thread_bounds) index = this%levscpf_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & - thread_bounds%pft_class_begin, thread_bounds%pft_class_end) + thread_bounds%sizepft_class_begin, thread_bounds%sizepft_class_end) - index = this%levscls_index() + index = this%levpft_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & - thread_bounds%size_class_begin, thread_bounds%size_class_end) + thread_bounds%pft_class_begin, thread_bounds%pft_class_end) + + index = this%levpage_index() + call this%dim_bounds(index)%SetThreadBounds(thread_index, & + thread_bounds%page_class_begin, thread_bounds%page_class_end) end subroutine SetThreadBoundsEach @@ -299,6 +323,7 @@ subroutine assemble_history_output_types(this) use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8 use FatesIOVariableKindMod, only : patch_size_r8, site_size_r8 + use FatesIOVariableKindMod, only : site_pft_r8, site_page_r8 implicit none @@ -328,6 +353,12 @@ subroutine assemble_history_output_types(this) call this%set_dim_indices(site_size_r8, 1, this%column_index()) call this%set_dim_indices(site_size_r8, 2, this%levscls_index()) + call this%set_dim_indices(site_pft_r8, 1, this%column_index()) + call this%set_dim_indices(site_pft_r8, 2, this%levpft_index()) + + call this%set_dim_indices(site_page_r8, 1, this%column_index()) + call this%set_dim_indices(site_page_r8, 2, this%levpage_index()) + end subroutine assemble_history_output_types ! =================================================================================== @@ -441,6 +472,34 @@ integer function levscls_index(this) levscls_index = this%levscls_index_ end function levscls_index + ! ======================================================================= + subroutine set_levpft_index(this, index) + implicit none + class(fates_history_interface_type), intent(inout) :: this + integer, intent(in) :: index + this%levpft_index_ = index + end subroutine set_levpft_index + + integer function levpft_index(this) + implicit none + class(fates_history_interface_type), intent(in) :: this + levpft_index = this%levpft_index_ + end function levpft_index + + ! ======================================================================= + subroutine set_levpage_index(this, index) + implicit none + class(fates_history_interface_type), intent(inout) :: this + integer, intent(in) :: index + this%levpage_index_ = index + end subroutine set_levpage_index + + integer function levpage_index(this) + implicit none + class(fates_history_interface_type), intent(in) :: this + levpage_index = this%levpage_index_ + end function levpage_index + ! ====================================================================================== subroutine flush_hvars(this,nc,upfreq_in) @@ -535,6 +594,7 @@ subroutine init_dim_kinds_maps(this) use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8 use FatesIOVariableKindMod, only : patch_size_r8, site_size_r8 + use FatesIOVariableKindMod, only : site_pft_r8, site_page_r8 implicit none @@ -576,6 +636,14 @@ subroutine init_dim_kinds_maps(this) index = index + 1 call this%dim_kinds(index)%Init(site_size_r8, 2) + ! site x pft + index = index + 1 + call this%dim_kinds(index)%Init(site_pft_r8, 2) + + ! site x patch-age clase + index = index + 1 + call this%dim_kinds(index)%Init(site_page_r8, 2) + ! FIXME(bja, 2016-10) assert(index == fates_history_num_dim_kinds) end subroutine init_dim_kinds_maps @@ -649,7 +717,10 @@ subroutine update_history_dyn(this,nc,nsites,sites) ed_patch_type, & AREA, & sclass_ed, & - nlevsclass_ed + nlevsclass_ed, & + levpage_ed, & + nlevpage_ed, & + levpft_ed use EDParamsMod , only : ED_val_ag_biomass ! Arguments @@ -732,7 +803,9 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_m3_si_scpf => this%hvars(ih_m3_si_scpf)%r82d, & hio_m4_si_scpf => this%hvars(ih_m4_si_scpf)%r82d, & hio_m5_si_scpf => this%hvars(ih_m5_si_scpf)%r82d, & - hio_ba_si_scls => this%hvars(ih_ba_si_scls)%r82d ) + hio_ba_si_scls => this%hvars(ih_ba_si_scls)%r82d)!, & +! hio_biomass_si_pft => this%hvars(ih_biomass_si_pft)%r82d, & +! hio_area_si_page => this%hvars(ih_area_si_page)%r82d) ! --------------------------------------------------------------------------------- ! Flush arrays to values defined by %flushval (see registry entry in @@ -764,6 +837,10 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! Increment the number of patches per site hio_npatches_si(io_si) = hio_npatches_si(io_si) + 1._r8 + + ! report the fractional area in each age class bin + ! hio_area_si_page(io_si,cpatch%age_class) = hio_area_si_page(io_si,cpatch%age_class) & + ! + cpatch%area/AREA ccohort => cpatch%shortest do while(associated(ccohort)) @@ -824,6 +901,9 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_nindivs_pa_pft(io_pa,ft) = hio_nindivs_pa_pft(io_pa,ft) + & ccohort%n + ! hio_biomass_si_pft(io_si, ft) = hio_biomass_si_pft(io_si, ft) + & + ! n_density * ccohort%b * 1.e3_r8 + ! Site by Size-Class x PFT (SCPF) ! ------------------------------------------------------------------------ @@ -1173,6 +1253,7 @@ subroutine define_history_vars(this, initialize_variables) use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8 use FatesIOVariableKindMod, only : patch_size_r8, site_size_r8 + use FatesIOVariableKindMod, only : site_pft_r8, site_page_r8 implicit none class(fates_history_interface_type), intent(inout) :: this @@ -1236,6 +1317,16 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=patch_ground_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_nindivs_pa_pft ) + ! call this%set_history_var(vname='PFT_biomass', units='gC/m2', & + ! long='total PFT level biomass -- on actual PFT dimension', use_default='active',& + ! avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ! ivar=ivar, initialize=initialize_variables, index = ih_biomass_si_pft ) + + ! call this%set_history_var(vname='patch_area_by_age', units='m2/m2', & + ! long='patch area by age bin', use_default='active', & + ! avgflag='A', vtype=site_page_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ! ivar=ivar, initialize=initialize_variables, index = ih_area_si_page ) + ! Fire Variables call this%set_history_var(vname='FIRE_NESTEROV_INDEX', units='none', & diff --git a/main/FatesHistoryVariableType.F90 b/main/FatesHistoryVariableType.F90 index 7829c803..24f4616e 100644 --- a/main/FatesHistoryVariableType.F90 +++ b/main/FatesHistoryVariableType.F90 @@ -44,7 +44,8 @@ subroutine Init(this, vname, units, long, use_default, & use FatesIODimensionsMod, only : fates_io_dimension_type use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 - use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8, site_size_r8 + use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8 + use FatesIOVariableKindMod, only : site_size_r8, site_pft_r8, site_page_r8 use FatesIOVariableKindMod, only : iotype_index implicit none @@ -122,6 +123,14 @@ subroutine Init(this, vname, units, long, use_default, & allocate(this%r82d(lb1:ub1, lb2:ub2)) this%r82d(:,:) = flushval + case(site_pft_r8) + allocate(this%r82d(lb1:ub1, lb2:ub2)) + this%r82d(:,:) = flushval + + case(site_page_r8) + allocate(this%r82d(lb1:ub1, lb2:ub2)) + this%r82d(:,:) = flushval + case default write(fates_log(),*) 'Incompatible vtype passed to set_history_var' write(fates_log(),*) 'vtype = ',trim(vtype),' ?' @@ -187,7 +196,7 @@ subroutine Flush(this, thread, dim_bounds, dim_kinds) use FatesIODimensionsMod, only : fates_io_dimension_type use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8, patch_int - use FatesIOVariableKindMod, only : site_size_r8 + use FatesIOVariableKindMod, only : site_size_r8, site_pft_r8, site_page_r8 implicit none @@ -215,6 +224,10 @@ subroutine Flush(this, thread, dim_bounds, dim_kinds) this%r82d(lb1:ub1, lb2:ub2) = this%flushval case(site_size_r8) this%r82d(lb1:ub1, lb2:ub2) = this%flushval + case(site_pft_r8) + this%r82d(lb1:ub1, lb2:ub2) = this%flushval + case(site_page_r8) + this%r82d(lb1:ub1, lb2:ub2) = this%flushval case(patch_int) this%int1d(lb1:ub1) = nint(this%flushval) case default diff --git a/main/FatesIODimensionsMod.F90 b/main/FatesIODimensionsMod.F90 index b73755e0..80973f2e 100644 --- a/main/FatesIODimensionsMod.F90 +++ b/main/FatesIODimensionsMod.F90 @@ -10,6 +10,8 @@ module FatesIODimensionsMod character(*), parameter :: levgrnd = 'levgrnd' character(*), parameter :: levscpf = 'levscpf' character(*), parameter :: levscls = 'levscls' + character(*), parameter :: levpft = 'levpft' + character(*), parameter :: levpage = 'levpage' ! patch = This is a structure that records where FATES patch boundaries ! on each thread point to in the host IO array, this structure @@ -28,6 +30,12 @@ module FatesIODimensionsMod ! levscls = This is a structure that records the boundaries for the ! number of size-class dimension + ! levpft = This is a structure that records the boundaries for the + ! number of pft dimension + + ! levpage = This is a structure that records the boundaries for the + ! number of patch-age-class dimension + type, public :: fates_bounds_type integer :: patch_begin @@ -38,10 +46,14 @@ module FatesIODimensionsMod integer :: column_end ! we call this a "site" (rgk 11-2016) integer :: ground_begin integer :: ground_end - integer :: pft_class_begin - integer :: pft_class_end + integer :: sizepft_class_begin + integer :: sizepft_class_end integer :: size_class_begin integer :: size_class_end + integer :: pft_class_begin + integer :: pft_class_end + integer :: page_class_begin + integer :: page_class_end end type fates_bounds_type diff --git a/main/FatesIOVariableKindMod.F90 b/main/FatesIOVariableKindMod.F90 index 77371a3a..79305f0b 100644 --- a/main/FatesIOVariableKindMod.F90 +++ b/main/FatesIOVariableKindMod.F90 @@ -21,6 +21,9 @@ module FatesIOVariableKindMod character(*), parameter :: patch_int = 'PA_INT' character(*), parameter :: cohort_r8 = 'CO_R8' character(*), parameter :: cohort_int = 'CO_INT' + character(*), parameter :: site_pft_r8 = 'SI_PFT_R8' + character(*), parameter :: site_page_r8 = 'SI_PAGE_R8' + ! NOTE(RGK, 2016) %active is not used yet. Was intended as a check on the HLM->FATES ! control parameter passing to ensure all active dimension types received all From 8c82daffc08e003a09390d2eac63d76ed1355841 Mon Sep 17 00:00:00 2001 From: ckoven Date: Thu, 12 Jan 2017 16:10:21 -0800 Subject: [PATCH 283/437] fixed one bug but still crashing --- main/FatesHistoryInterfaceMod.F90 | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 0ef6cc11..069ce30e 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -307,6 +307,10 @@ subroutine SetThreadBoundsEach(this, thread_index, thread_bounds) call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%sizepft_class_begin, thread_bounds%sizepft_class_end) + index = this%levscls_index() + call this%dim_bounds(index)%SetThreadBounds(thread_index, & + thread_bounds%size_class_begin, thread_bounds%size_class_end) + index = this%levpft_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%pft_class_begin, thread_bounds%pft_class_end) From ecff740377a4b7d02ee2357b9f7dc65965086d1d Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 12 Jan 2017 16:35:04 -0800 Subject: [PATCH 284/437] Finished first pass of time-control refactor. --- biogeochem/EDCohortDynamicsMod.F90 | 13 ++++--- biogeochem/EDPatchDynamicsMod.F90 | 14 +++---- biogeochem/EDPhysiologyMod.F90 | 44 +++++++++++---------- main/EDInitMod.F90 | 2 +- main/EDMainMod.F90 | 48 ++++++++++++----------- main/EDTypesMod.F90 | 16 ++++---- main/FatesGlobals.F90 | 61 +++++++++++++++++++++++++++++- main/FatesInterfaceMod.F90 | 36 ++---------------- 8 files changed, 134 insertions(+), 100 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 70b00c33..7b40aa42 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -6,6 +6,7 @@ module EDCohortDynamicsMod ! !USES: use abortutils , only : endrun use FatesGlobals , only : fates_log + use FatesGlobals , only : freq_day use FatesConstantsMod , only : r8 => fates_r8 use FatesConstantsMod , only : fates_unset_int use shr_log_mod , only : errMsg => shr_log_errMsg @@ -14,7 +15,7 @@ module EDCohortDynamicsMod use EDGrowthFunctionsMod , only : c_area, tree_lai use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type use EDTypesMod , only : fusetol, cp_nclmax - use EDtypesMod , only : ncwd, maxcohortsperpatch, udata + use EDtypesMod , only : ncwd, maxcohortsperpatch use EDtypesMod , only : sclass_ed,nlevsclass_ed,AREA use EDtypesMod , only : min_npm2, min_nppatch, min_n_safemath ! @@ -223,7 +224,7 @@ subroutine allocate_live_biomass(cc_p,mode) if(mode==1)then ! it will not be able to put out as many leaves as it had previous timestep currentcohort%npp_leaf = currentcohort%npp_leaf + & - max(0.0_r8,currentcohort%balive*leaf_frac - currentcohort%bl)/udata%deltat + max(0.0_r8,currentcohort%balive*leaf_frac - currentcohort%bl)/freq_day end if currentcohort%bl = currentcohort%balive*leaf_frac @@ -234,10 +235,10 @@ subroutine allocate_live_biomass(cc_p,mode) currentcohort%npp_froot = currentcohort%npp_froot + & max(0._r8,pftcon%froot_leaf(ft)*(currentcohort%balive+currentcohort%laimemory)*leaf_frac - currentcohort%br) / & - udata%deltat + freq_day currentcohort%npp_bsw = max(0._r8,EDecophyscon%sapwood_ratio(ft) * currentcohort%hite *(currentcohort%balive + & - currentcohort%laimemory)*leaf_frac - currentcohort%bsw)/udata%deltat + currentcohort%laimemory)*leaf_frac - currentcohort%bsw)/freq_day currentcohort%npp_bdead = currentCohort%dbdeaddt @@ -273,10 +274,10 @@ subroutine allocate_live_biomass(cc_p,mode) currentcohort%npp_froot = currentcohort%npp_froot + & max(0.0_r8,pftcon%froot_leaf(ft)*(ideal_balive + & - currentcohort%laimemory)*leaf_frac*ratio_balive-currentcohort%br)/udata%deltat + currentcohort%laimemory)*leaf_frac*ratio_balive-currentcohort%br)/freq_day currentcohort%npp_bsw = max(0.0_r8,EDecophyscon%sapwood_ratio(ft) * currentcohort%hite *(ideal_balive + & - currentcohort%laimemory)*leaf_frac*ratio_balive - currentcohort%bsw)/udata%deltat + currentcohort%laimemory)*leaf_frac*ratio_balive - currentcohort%bsw)/freq_day currentcohort%npp_bdead = currentCohort%dbdeaddt diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 5fae1a78..6d7c84eb 100755 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -7,10 +7,11 @@ module EDPatchDynamicsMod use shr_kind_mod , only : r8 => shr_kind_r8; use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) use clm_varctl , only : iulog + use FatesGlobals , only : freq_day 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, maxPatchesPerCol - use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type, udata + use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type use EDTypesMod , only : min_patch_area, cp_numlevgrnd, cp_numSWb ! implicit none @@ -45,7 +46,6 @@ subroutine disturbance_rates( site_in) ! ! !USES: use EDGrowthFunctionsMod , only : c_area, mortality_rates - use EDTypesMod , only : udata ! ! !ARGUMENTS: type(ed_site_type) , intent(inout), target :: site_in @@ -85,7 +85,7 @@ subroutine disturbance_rates( site_in) 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 + min(1.0_r8,currentCohort%dmort)*freq_day*currentCohort%c_area/currentPatch%area endif @@ -271,7 +271,7 @@ subroutine spawn_patches( currentSite ) ! because this is the part of the original patch where no trees have actually fallen ! The diagnostic cmort,bmort and hmort rates have already been saved - currentCohort%n = currentCohort%n * (1.0_r8 - min(1.0_r8,currentCohort%dmort * udata%deltat)) + currentCohort%n = currentCohort%n * (1.0_r8 - min(1.0_r8,currentCohort%dmort * freq_day)) nc%n = 0.0_r8 ! kill all of the trees who caused the disturbance. nc%cmort = nan ! The mortality diagnostics are set to nan because the cohort should dissappear @@ -298,7 +298,7 @@ subroutine spawn_patches( currentSite ) ! so with the number density must come the effective mortality rates. nc%fmort = 0.0_r8 ! Should had also been zero in the donor - nc%imort = ED_val_understorey_death/udata%deltat ! This was zero in the donor + nc%imort = ED_val_understorey_death/freq_day ! This was zero in the donor nc%cmort = currentCohort%cmort nc%hmort = currentCohort%hmort nc%bmort = currentCohort%bmort @@ -336,7 +336,7 @@ subroutine spawn_patches( currentSite ) ! loss of individual from fire in new patch. nc%n = nc%n * (1.0_r8 - currentCohort%fire_mort) - nc%fmort = currentCohort%fire_mort/udata%deltat + nc%fmort = currentCohort%fire_mort/freq_day nc%imort = 0.0_r8 nc%cmort = currentCohort%cmort nc%hmort = currentCohort%hmort @@ -716,7 +716,7 @@ subroutine mortality_litter_fluxes(cp_target, new_patch_target, patch_site_aread !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) + canopy_dead = currentCohort%n * min(1.0_r8,currentCohort%dmort * freq_day) currentPatch%canopy_mortality_woody_litter = currentPatch%canopy_mortality_woody_litter + & canopy_dead*(currentCohort%bdead+currentCohort%bsw) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index b771c890..a4967670 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -7,6 +7,10 @@ module EDPhysiologyMod ! ============================================================================ use FatesGlobals, only : fates_log + use FatesGlobals, only : days_per_year + use FatesGlobals, only : model_day + use FatesGlobals, only : freq_day + use FatesGlobals, only : day_of_year use FatesConstantsMod, only : r8 => fates_r8 use pftconMod , only : pftcon use EDEcophysContype , only : EDecophyscon @@ -240,7 +244,6 @@ subroutine phenology( currentSite, bc_in ) ! ! !USES: use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm - use EDTypesMod, only : udata ! ! !ARGUMENTS: @@ -289,7 +292,7 @@ subroutine phenology( currentSite, bc_in ) ncolddayslim = 5 cold_t = 7.5_r8 ! ed_ph_coldtemp - t = udata%time_period + t = day_of_year temp_in_C = bc_in%t_veg24_si - tfrz !-----------------Cold Phenology--------------------! @@ -339,7 +342,7 @@ subroutine phenology( currentSite, bc_in ) endif - timesinceleafoff = bc_in%model_day - currentSite%leafoffdate + timesinceleafoff = model_day - currentSite%leafoffdate !LEAF ON: COLD DECIDUOUS. Needs to !1) have exceeded the growing degree day threshold !2) The leaves should not be on already @@ -355,7 +358,7 @@ subroutine phenology( currentSite, bc_in ) endif !status endif !GDD - timesinceleafon = bc_in%model_day - currentSite%leafondate + timesinceleafon = model_day - currentSite%leafondate !LEAF OFF: COLD THRESHOLD @@ -369,7 +372,7 @@ subroutine phenology( currentSite, bc_in ) if (timesinceleafon > mindayson)then if (currentSite%status == 2)then currentSite%status = 1 !alter status of site to 'leaves on' - currentSite%leafoffdate = bc_in%model_day !record leaf off date + currentSite%leafoffdate = model_day !record leaf off date if ( DEBUG ) write(fates_log(),*) 'leaves off' endif endif @@ -379,7 +382,7 @@ subroutine phenology( currentSite, bc_in ) if(timesinceleafoff > 400)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 = bc_in%model_day !record leaf off date + currentSite%leafoffdate = model_day !record leaf off date if ( DEBUG ) write(fates_log(),*) 'leaves off' endif endif @@ -710,7 +713,7 @@ subroutine Growth_Derivatives( currentSite, currentCohort, bc_in) ! ! !USES: use EDGrowthFunctionsMod , only : Bleaf, dDbhdBd, dhdbd, hite, mortality_rates,dDbhdBl - use EDTypesMod , only : udata + ! ! !ARGUMENTS type(ed_site_type), intent(inout), target :: currentSite @@ -764,9 +767,9 @@ subroutine Growth_Derivatives( currentSite, currentCohort, bc_in) ! convert from kgC/indiv/day into kgC/indiv/year ! TODO: CONVERT DAYS_PER_YEAR TO DBLE (HOLDING FOR B4B COMPARISONS, RGK-01-2017) - currentCohort%npp_acc_hold = currentCohort%npp_acc * bc_in%days_per_year - currentCohort%gpp_acc_hold = currentCohort%gpp_acc * bc_in%days_per_year - currentCohort%resp_acc_hold = currentCohort%resp_acc * bc_in%days_per_year + currentCohort%npp_acc_hold = currentCohort%npp_acc * days_per_year + currentCohort%gpp_acc_hold = currentCohort%gpp_acc * days_per_year + currentCohort%resp_acc_hold = currentCohort%resp_acc * days_per_year currentSite%flux_in = currentSite%flux_in + currentCohort%npp_acc * currentCohort%n @@ -933,7 +936,7 @@ subroutine Growth_Derivatives( currentSite, currentCohort, bc_in) ! 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 + if (-1.0_r8*currentCohort%dbalivedt * freq_day > currentCohort%balive*0.99)then write(fates_log(),*) 'using non-neg leaf mass cap',currentCohort%balive , currentCohort%dbalivedt,currentCohort%dbstoredt, & currentCohort%carbon_balance currentCohort%dbstoredt = currentCohort%dbstoredt + currentCohort%dbalivedt @@ -963,7 +966,6 @@ subroutine recruitment( t, currentSite, currentPatch ) ! ! !USES: use EDGrowthFunctionsMod, only : bdead,dbh, Bleaf - use EDTypesMod, only : udata ! ! !ARGUMENTS integer, intent(in) :: t @@ -990,7 +992,7 @@ subroutine recruitment( t, currentSite, currentPatch ) + 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%n = currentPatch%area * currentPatch%seed_germination(ft)*freq_day & / (temp_cohort%bdead+temp_cohort%balive+temp_cohort%bstore) if (t == 1)then @@ -1037,7 +1039,7 @@ subroutine CWD_Input( currentPatch) ! !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 @@ -1067,7 +1069,7 @@ subroutine CWD_Input( currentPatch) 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 + currentCohort%leaf_litter * currentCohort%n/currentPatch%area/freq_day !daily leaf loss needs to be scaled up to the annual scale here. @@ -1086,7 +1088,7 @@ subroutine CWD_Input( currentPatch) 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 + (currentCohort%bl+currentCohort%leaf_litter/freq_day)* dead_n currentPatch%root_litter_in(pft) = currentPatch%root_litter_in(pft) + & (currentCohort%br+currentCohort%bstore) * dead_n @@ -1191,7 +1193,7 @@ subroutine cwd_out( currentSite, currentPatch, bc_in ) ! ! !USES: use SFParamsMod, only : SF_val_max_decomp - use EDTypesMod , only : udata + ! ! !ARGUMENTS type(ed_site_type), intent(inout), target :: currentSite @@ -1239,13 +1241,13 @@ subroutine cwd_out( currentSite, currentPatch, bc_in ) !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 + currentPatch%area *freq_day!kgC/site/day currentSite%flux_out = currentSite%flux_out + sum(currentPatch%root_litter_out) * & - currentPatch%area *udata%deltat!kgC/site/day + currentPatch%area *freq_day!kgC/site/day currentSite%flux_out = currentSite%flux_out + sum(currentPatch%cwd_ag_out) * & - currentPatch%area *udata%deltat!kgC/site/day + currentPatch%area *freq_day!kgC/site/day currentSite%flux_out = currentSite%flux_out + sum(currentPatch%cwd_bg_out) * & - currentPatch%area *udata%deltat!kgC/site/day + currentPatch%area *freq_day!kgC/site/day end subroutine cwd_out diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 55a0fd8a..76bc5ed9 100755 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -16,7 +16,7 @@ module EDInitMod use EDCohortDynamicsMod , only : create_cohort, fuse_cohorts, sort_cohorts use EDPatchDynamicsMod , only : create_patch use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type, area - use EDTypesMod , only : cohorts_per_col, ncwd, numpft_ed, udata + use EDTypesMod , only : cohorts_per_col, ncwd, numpft_ed implicit none private diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index e18676e2..6882222f 100755 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -7,6 +7,12 @@ module EDMainMod use shr_kind_mod , only : r8 => shr_kind_r8 use FatesGlobals , only : fates_log + use FatesGlobals , only : freq_day + use FatesGlobals , only : day_of_year + use FatesGlobals , only : days_per_year + use FatesGlobals , only : current_year + use FatesGlobals , only : current_month + use FatesGlobals , only : current_day use atm2lndType , only : atm2lnd_type use SoilStateType , only : soilstate_type use TemperatureType , only : temperature_type @@ -14,10 +20,11 @@ module EDMainMod 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, numpft_ed, udata + use EDtypesMod , only : ncwd, numpft_ed use EDtypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type use FatesInterfaceMod , only : bc_in_type use EDTypesMod , only : cp_masterproc + implicit none private @@ -54,7 +61,7 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) !----------------------------------------------------------------------- if ( cp_masterproc==1 ) write(fates_log(),'(A,I4,A,I2.2,A,I2.2)') 'FATES Dynamics: ',& - bc_in%current_year,'-',bc_in%current_month,'-',bc_in%current_day + current_year,'-',current_month,'-',current_day !************************************************************************** ! Fire, growth, biogeochemistry. @@ -163,7 +170,7 @@ subroutine ed_integrate_state_variables(currentSite, bc_in ) do while(associated(currentPatch)) - currentPatch%age = currentPatch%age + udata%deltat + currentPatch%age = currentPatch%age + freq_day ! FIX(SPM,032414) valgrind 'Conditional jump or move depends on uninitialised value' if( currentPatch%age < 0._r8 )then write(fates_log(),*) 'negative patch age?',currentPatch%age, & @@ -178,17 +185,17 @@ subroutine ed_integrate_state_variables(currentSite, bc_in ) 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%dbh = max(small_no,currentCohort%dbh + currentCohort%ddbhdt * freq_day ) + currentCohort%balive = currentCohort%balive + currentCohort%dbalivedt * freq_day + currentCohort%bdead = max(small_no,currentCohort%bdead + currentCohort%dbdeaddt * freq_day ) if ( DEBUG ) then write(fates_log(),*) 'EDMainMod dbstoredt I ',currentCohort%bstore, & - currentCohort%dbstoredt,udata%deltat + currentCohort%dbstoredt,freq_day end if - currentCohort%bstore = currentCohort%bstore + currentCohort%dbstoredt * udata%deltat + currentCohort%bstore = currentCohort%bstore + currentCohort%dbstoredt * freq_day if ( DEBUG ) then write(fates_log(),*) 'EDMainMod dbstoredt II ',currentCohort%bstore, & - currentCohort%dbstoredt,udata%deltat + currentCohort%dbstoredt,freq_day end if if( (currentCohort%balive+currentCohort%bdead+currentCohort%bstore)*currentCohort%n<0._r8)then @@ -196,10 +203,10 @@ subroutine ed_integrate_state_variables(currentSite, bc_in ) currentCohort%bdead,currentCohort%bstore endif - if(abs((currentCohort%balive+currentCohort%bdead+currentCohort%bstore+udata%deltat*(currentCohort%md+ & + if(abs((currentCohort%balive+currentCohort%bdead+currentCohort%bstore+freq_day*(currentCohort%md+ & currentCohort%seed_prod)-cohort_biomass_store)-currentCohort%npp_acc) > 1e-8_r8)then write(fates_log(),*) 'issue with c balance in integration', abs(currentCohort%balive+currentCohort%bdead+ & - currentCohort%bstore+udata%deltat* & + currentCohort%bstore+freq_day* & (currentCohort%md+currentCohort%seed_prod)-cohort_biomass_store-currentCohort%npp_acc) endif @@ -224,13 +231,13 @@ subroutine ed_integrate_state_variables(currentSite, bc_in ) ! first update the litter variables that are tracked at the patch level 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 + currentPatch%cwd_ag(c) = currentPatch%cwd_ag(c) + currentPatch%dcwd_ag_dt(c)* freq_day + currentPatch%cwd_bg(c) = currentPatch%cwd_bg(c) + currentPatch%dcwd_bg_dt(c)* freq_day enddo do ft = 1,numpft_ed - currentPatch%leaf_litter(ft) = currentPatch%leaf_litter(ft) + currentPatch%dleaf_litter_dt(ft)* udata%deltat - currentPatch%root_litter(ft) = currentPatch%root_litter(ft) + currentPatch%droot_litter_dt(ft)* udata%deltat + currentPatch%leaf_litter(ft) = currentPatch%leaf_litter(ft) + currentPatch%dleaf_litter_dt(ft)* freq_day + currentPatch%root_litter(ft) = currentPatch%root_litter(ft) + currentPatch%droot_litter_dt(ft)* freq_day enddo do c = 1,ncwd @@ -254,7 +261,7 @@ subroutine ed_integrate_state_variables(currentSite, bc_in ) endif if(currentPatch%root_litter(ft) currentPatch%shortest do while(associated(currentCohort)) - currentCohort%n = max(small_no,currentCohort%n + currentCohort%dndt * udata%deltat ) + currentCohort%n = max(small_no,currentCohort%n + currentCohort%dndt * freq_day ) currentCohort => currentCohort%taller enddo @@ -275,7 +282,7 @@ subroutine ed_integrate_state_variables(currentSite, bc_in ) ! at the site level, update the seed bank mass do ft = 1,numpft_ed - currentSite%seed_bank(ft) = currentSite%seed_bank(ft) + currentSite%dseed_dt(ft)*udata%deltat + currentSite%seed_bank(ft) = currentSite%seed_bank(ft) + currentSite%dseed_dt(ft)*freq_day enddo ! Check for negative values. Write out warning to show carbon balance. @@ -347,11 +354,8 @@ subroutine ed_update_site( currentSite, bc_in ) enddo ! FIX(RF,032414). This needs to be monthly, not annual -! if((udata%time_period == udata%n_sub-1))then - ! If this is the second to last day of the year, then perform trimming - - if( bc_in%day_of_year == bc_in%days_per_year-1) then + if( day_of_year == days_per_year-1) then write(fates_log(),*) 'calling trim canopy' call trim_canopy(currentSite) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index ec47eba0..a6a34ba7 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -551,16 +551,14 @@ module EDTypesMod !** Userdata type structure ** !************************************ - type userdata +! type userdata ! integer :: cohort_number ! Counts up the number of cohorts which have been made. - integer :: n_sub ! num of substeps in year - 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 ! THIS WAS NOT THREADSAFE +! integer :: n_sub ! num of substeps in year +! 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 ! THIS WAS NOT THREADSAFE !-------------------------------------------------------------------------------------! public :: ed_hist_scpfmaps diff --git a/main/FatesGlobals.F90 b/main/FatesGlobals.F90 index 9ae06e20..0b4e11e7 100644 --- a/main/FatesGlobals.F90 +++ b/main/FatesGlobals.F90 @@ -4,14 +4,36 @@ module FatesGlobals ! global data that needs to be dealt with, but doesn't have an ! immediately obvious home. + use FatesConstantsMod , only : r8 => fates_r8 + implicit none - integer, private :: fates_log_ - logical, private :: fates_global_verbose_ + public :: FatesGlobalsInit public :: fates_log public :: fates_global_verbose + public :: SetFatesTime + + ! ------------------------------------------------------------------------------------- + ! Timing Variables + ! It is assumed that all of the sites on a given machine will be synchronous. + ! It is also assumed that the HLM will control time. + ! ------------------------------------------------------------------------------------- + integer, protected :: current_year ! Current year + integer, protected :: current_month ! month of year + integer, protected :: current_day ! day of month + integer, protected :: current_tod ! time of day (seconds past 0Z) + integer, protected :: current_date ! time of day (seconds past 0Z) + integer, protected :: reference_date ! YYYYMMDD + real(r8), protected :: model_day ! elapsed days between current date and reference + integer, protected :: day_of_year ! The integer day of the year + integer, protected :: days_per_year ! The HLM controls time, some HLMs may include a leap + real(r8), protected :: freq_day ! fraction of year for daily time-step (1/days_per_year) + ! this is a frequency + + integer, private :: fates_log_ + logical, private :: fates_global_verbose_ contains @@ -35,4 +57,39 @@ logical function fates_global_verbose() fates_global_verbose = fates_global_verbose_ end function fates_global_verbose + ! ===================================================================================== + + subroutine SetFatesTime(current_year_in, current_month_in, & + current_day_in, current_tod_in, & + current_date_in, reference_date_in, & + model_day_in, day_of_year_in, & + days_per_year_in, freq_day_in) + + ! This subroutine should be called directly from the HLM + + integer, intent(in) :: current_year_in + integer, intent(in) :: current_month_in + integer, intent(in) :: current_day_in + integer, intent(in) :: current_tod_in + integer, intent(in) :: current_date_in + integer, intent(in) :: reference_date_in + real(r8), intent(in) :: model_day_in + integer, intent(in) :: day_of_year_in + integer, intent(in) :: days_per_year_in + real(r8), intent(in) :: freq_day_in + + current_year = current_year_in + current_month = current_month_in + current_day = current_day_in + current_tod = current_tod_in + current_date = current_date_in + reference_date = reference_date_in + model_day = model_day_in + day_of_year = day_of_year_in + days_per_year = days_per_year_in + freq_day = freq_day_in + + end subroutine SetFatesTime + + end module FatesGlobals diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index f24a415e..0d44975b 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -9,12 +9,6 @@ module FatesInterfaceMod ! which is allocated by thread ! ------------------------------------------------------------------------------------ - ! ------------------------------------------------------------------------------------ - ! Used CLM Modules - ! INTERF-TODO: NO CLM MODULES SHOULD BE ACCESSIBLE BY THE FATES - ! PUBLIC API!!!! - ! ------------------------------------------------------------------------------------ - use EDtypesMod , only : ed_site_type use EDtypesMod , only : maxPatchesPerCol use EDtypesMod , only : cp_nclmax @@ -45,30 +39,14 @@ module FatesInterfaceMod ! _rb means radiation band ! ------------------------------------------------------------------------------------ + + + type, public :: bc_in_type ! The actual number of FATES' ED patches integer :: npatches - ! Timing Variables - integer :: current_year ! Current year - integer :: current_month ! month of year - integer :: current_day ! day of month - integer :: current_tod ! time of day (seconds past 0Z) - integer :: current_date ! time of day (seconds past 0Z) - integer :: reference_date ! YYYYMMDD - real(r8) :: model_day ! elapsed days between current date and reference - ! uses ESMF functions, so prefered to pass it in as - ! argument rather than calculate directly - integer :: day_of_year ! The integer day of the year - integer :: days_per_year ! The HLM controls time, some HLMs may include a leap - ! day, some actually don't. This is the number of - ! days in the current year - real(r8) :: deltat_day ! fraction of year for each time-step (1/days_per_year) - - - - ! Vegetation Dynamics ! --------------------------------------------------------------------------------- @@ -504,13 +482,7 @@ subroutine zero_bcs(this,s) integer, intent(in) :: s ! Input boundaries - this%bc_in(s)%current_year = 0 - this%bc_in(s)%current_month = 0 - this%bc_in(s)%current_day = 0 - this%bc_in(s)%current_tod = 0 - this%bc_in(s)%current_date = 0 - this%bc_in(s)%reference_date = 0 - this%bc_in(s)%model_day = 0.0_r8 + this%bc_in(s)%t_veg24_si = 0.0_r8 this%bc_in(s)%t_veg24_pa(:) = 0.0_r8 this%bc_in(s)%h2osoi_vol_si = 0.0_r8 From 6f76add8d91dbeae80d01bb1c77d165a7fef189b Mon Sep 17 00:00:00 2001 From: ckoven Date: Thu, 12 Jan 2017 17:20:27 -0800 Subject: [PATCH 285/437] actually with debug off it doesn't crash. reinstating new variables. --- main/FatesHistoryInterfaceMod.F90 | 30 +++++++++++++++--------------- 1 file changed, 15 insertions(+), 15 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 069ce30e..b777f8a8 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -807,9 +807,9 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_m3_si_scpf => this%hvars(ih_m3_si_scpf)%r82d, & hio_m4_si_scpf => this%hvars(ih_m4_si_scpf)%r82d, & hio_m5_si_scpf => this%hvars(ih_m5_si_scpf)%r82d, & - hio_ba_si_scls => this%hvars(ih_ba_si_scls)%r82d)!, & -! hio_biomass_si_pft => this%hvars(ih_biomass_si_pft)%r82d, & -! hio_area_si_page => this%hvars(ih_area_si_page)%r82d) + hio_ba_si_scls => this%hvars(ih_ba_si_scls)%r82d, & + hio_biomass_si_pft => this%hvars(ih_biomass_si_pft)%r82d, & + hio_area_si_page => this%hvars(ih_area_si_page)%r82d) ! --------------------------------------------------------------------------------- ! Flush arrays to values defined by %flushval (see registry entry in @@ -843,8 +843,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_npatches_si(io_si) = hio_npatches_si(io_si) + 1._r8 ! report the fractional area in each age class bin - ! hio_area_si_page(io_si,cpatch%age_class) = hio_area_si_page(io_si,cpatch%age_class) & - ! + cpatch%area/AREA + hio_area_si_page(io_si,cpatch%age_class) = hio_area_si_page(io_si,cpatch%age_class) & + + cpatch%area/AREA ccohort => cpatch%shortest do while(associated(ccohort)) @@ -905,8 +905,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_nindivs_pa_pft(io_pa,ft) = hio_nindivs_pa_pft(io_pa,ft) + & ccohort%n - ! hio_biomass_si_pft(io_si, ft) = hio_biomass_si_pft(io_si, ft) + & - ! n_density * ccohort%b * 1.e3_r8 + hio_biomass_si_pft(io_si, ft) = hio_biomass_si_pft(io_si, ft) + & + n_density * ccohort%b * 1.e3_r8 ! Site by Size-Class x PFT (SCPF) ! ------------------------------------------------------------------------ @@ -1321,15 +1321,15 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=patch_ground_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_nindivs_pa_pft ) - ! call this%set_history_var(vname='PFT_biomass', units='gC/m2', & - ! long='total PFT level biomass -- on actual PFT dimension', use_default='active',& - ! avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ! ivar=ivar, initialize=initialize_variables, index = ih_biomass_si_pft ) + call this%set_history_var(vname='PFT_biomass', units='gC/m2', & + long='total PFT level biomass -- on actual PFT dimension', use_default='active',& + avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_biomass_si_pft ) - ! call this%set_history_var(vname='patch_area_by_age', units='m2/m2', & - ! long='patch area by age bin', use_default='active', & - ! avgflag='A', vtype=site_page_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ! ivar=ivar, initialize=initialize_variables, index = ih_area_si_page ) + call this%set_history_var(vname='patch_area_by_age', units='m2/m2', & + long='patch area by age bin', use_default='active', & + avgflag='A', vtype=site_page_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_area_si_page ) ! Fire Variables From 84f0d13cd64f74ac2ec054852bb836f12fe73f5a Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 12 Jan 2017 17:30:34 -0800 Subject: [PATCH 286/437] Removed the use of the HLMs grid area global ldomain(g)%area from SF. --- fire/SFMainMod.F90 | 13 +++---------- 1 file changed, 3 insertions(+), 10 deletions(-) diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index e5557d1f..b6ff07c7 100755 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -642,12 +642,9 @@ 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 - use PatchType, only : patch type(ed_site_type), intent(inout), target :: currentSite - type(ed_patch_type), pointer :: currentPatch real lb !length to breadth ratio of fire ellipse @@ -689,15 +686,11 @@ subroutine area_burnt ( currentSite ) ! --- calculate area burnt--- if(lb > 0.0_r8) then - p = currentPatch%clm_pno - g = patch%gridcell(p) - - ! INTERF-TODO: ! THIS SHOULD HAVE THE COLUMN AND LU AREA WEIGHT ALSO, NO? - gridarea = ldomain%area(g) *1000000.0_r8 !convert from km2 into m2 - currentPatch%NF = ldomain%area(g) * ED_val_nfires * currentPatch%area/area /365 + gridarea = 1000000.0_r8 ! 1M m2 in a km2 + currentPatch%NF = 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. @@ -728,7 +721,7 @@ subroutine area_burnt ( currentSite ) endif! fire currentSite%frac_burnt = currentSite%frac_burnt + currentPatch%frac_burnt - currentPatch => currentPatch%younger; + currentPatch => currentPatch%younger enddo !end patch loop From d8a81915e2da439a7c6e30e1b15d872b1aaaa37f Mon Sep 17 00:00:00 2001 From: ckoven Date: Fri, 13 Jan 2017 15:39:36 -0800 Subject: [PATCH 287/437] changed page to age throughout to clarify meaning --- biogeochem/EDPatchDynamicsMod.F90 | 4 +-- main/EDMainMod.F90 | 4 +-- main/EDTypesMod.F90 | 10 +++--- main/FatesHistoryInterfaceMod.F90 | 56 +++++++++++++++---------------- main/FatesHistoryVariableType.F90 | 8 ++--- main/FatesIODimensionsMod.F90 | 8 ++--- main/FatesIOVariableKindMod.F90 | 2 +- 7 files changed, 46 insertions(+), 46 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index b54f7812..0cb9434b 100755 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -1152,7 +1152,7 @@ subroutine fuse_2_patches(dp, rp) ! associated with the secnd patch ! ! !USES: - use EDTypesMod, only: pageclass_ed + use EDTypesMod, only: ageclass_ed ! ! !ARGUMENTS: type (ed_patch_type) , intent(inout), pointer :: dp ! Donor Patch @@ -1172,7 +1172,7 @@ subroutine fuse_2_patches(dp, rp) !area weighted average of ages & litter rp%age = (dp%age * dp%area + rp%age * rp%area)/(dp%area + rp%area) - rp%age_class = max(1,count(rp%age-pageclass_ed.ge.0.0_r8)) + rp%age_class = max(1,count(rp%age-ageclass_ed.ge.0.0_r8)) do p = 1,numpft_ed rp%seeds_in(p) = (rp%seeds_in(p)*rp%area + dp%seeds_in(p)*dp%area)/(rp%area + dp%area) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index f43cbbb5..69889f1b 100755 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -137,7 +137,7 @@ subroutine ed_integrate_state_variables(currentSite, temperature_inst ) ! FIX(SPM,032414) refactor so everything goes through interface ! ! !USES: - use EDTypesMod, only : pageclass_ed + use EDTypesMod, only : ageclass_ed ! ! !ARGUMENTS: type(ed_site_type) , intent(inout) :: currentSite @@ -172,7 +172,7 @@ subroutine ed_integrate_state_variables(currentSite, temperature_inst ) endif ! check to see if the patch has moved to the next age class - currentPatch%age_class = count(currentPatch%age-pageclass_ed.ge.0.0_r8) + currentPatch%age_class = count(currentPatch%age-ageclass_ed.ge.0.0_r8) ! Find the derivatives of the growth and litter processes. call canopy_derivs(currentSite, currentPatch) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index d4731bfc..d1d973a8 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -86,8 +86,8 @@ module EDTypesMod real(r8), parameter, dimension(nlevsclass_ed) :: sclass_ed = (/0.0_r8,5.0_r8,10.0_r8,15.0_r8,20.0_r8,30.0_r8,40.0_r8, & 50.0_r8,60.0_r8,70.0_r8,80.0_r8,90.0_r8,100.0_r8/) - integer, parameter :: nlevpage_ed = 7 ! Number of patch-age classes for age structured analyses - real(r8), parameter, dimension(nlevpage_ed) :: pageclass_ed = (/0.0_r8,1.0_r8,2._r8,5.0_r8,10.0_r8,20.0_r8,50.0_r8/) + integer, parameter :: nlevage_ed = 7 ! Number of patch-age classes for age structured analyses + real(r8), parameter, dimension(nlevage_ed) :: ageclass_ed = (/0.0_r8,1.0_r8,2._r8,5.0_r8,10.0_r8,20.0_r8,50.0_r8/) ! integer, parameter :: nlevsclass_ed = 17 @@ -109,7 +109,7 @@ module EDTypesMod ! the parameter array sclass_ed. integer , allocatable :: pft_levscpf_ed(:) integer , allocatable :: scls_levscpf_ed(:) - real(r8), allocatable :: levpage_ed(:) + real(r8), allocatable :: levage_ed(:) integer , allocatable :: levpft_ed(:) @@ -582,14 +582,14 @@ subroutine ed_hist_scpfmaps allocate( pft_levscpf_ed(1:nlevsclass_ed*mxpft)) allocate(scls_levscpf_ed(1:nlevsclass_ed*mxpft)) allocate( levpft_ed(1:mxpft )) - allocate( levpage_ed(1:nlevpage_ed )) + allocate( levage_ed(1:nlevage_ed )) ! Fill the IO array of plant size classes ! For some reason the history files did not like ! a hard allocation of sclass_ed levsclass_ed(:) = sclass_ed(:) - levpage_ed(:) = pageclass_ed(:) + levage_ed(:) = ageclass_ed(:) ! make pft array do ipft=1,mxpft diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index b777f8a8..1495baa6 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -139,7 +139,7 @@ module FatesHistoryInterfaceMod integer, private :: ih_biomass_si_pft ! indices to (site x patch-age) variables - integer, private :: ih_area_si_page + integer, private :: ih_area_si_age ! The number of variable dim/kind types we have defined (static) integer, parameter :: fates_history_num_dimensions = 7 @@ -177,7 +177,7 @@ module FatesHistoryInterfaceMod type(iovar_map_type), pointer :: iovar_map(:) integer, private :: patch_index_, column_index_, levgrnd_index_, levscpf_index_ - integer, private :: levscls_index_, levpft_index_, levpage_index_ + integer, private :: levscls_index_, levpft_index_, levage_index_ contains procedure, public :: Init @@ -197,7 +197,7 @@ module FatesHistoryInterfaceMod procedure, public :: levscpf_index procedure, public :: levscls_index procedure, public :: levpft_index - procedure, public :: levpage_index + procedure, public :: levage_index ! private work functions procedure, private :: define_history_vars @@ -212,7 +212,7 @@ module FatesHistoryInterfaceMod procedure, private :: set_levscpf_index procedure, private :: set_levscls_index procedure, private :: set_levpft_index - procedure, private :: set_levpage_index + procedure, private :: set_levage_index end type fates_history_interface_type @@ -225,7 +225,7 @@ module FatesHistoryInterfaceMod subroutine Init(this, num_threads, fates_bounds) use FatesIODimensionsMod, only : patch, column, levgrnd, levscpf - use FatesIODimensionsMod, only : levscls, levpft, levpage + use FatesIODimensionsMod, only : levscls, levpft, levage use FatesIODimensionsMod, only : fates_bounds_type implicit none @@ -267,9 +267,9 @@ subroutine Init(this, num_threads, fates_bounds) fates_bounds%pft_class_begin, fates_bounds%pft_class_end) dim_count = dim_count + 1 - call this%set_levpage_index(dim_count) - call this%dim_bounds(dim_count)%Init(levpage, num_threads, & - fates_bounds%page_class_begin, fates_bounds%page_class_end) + call this%set_levage_index(dim_count) + call this%dim_bounds(dim_count)%Init(levage, num_threads, & + fates_bounds%age_class_begin, fates_bounds%age_class_end) ! FIXME(bja, 2016-10) assert(dim_count == FatesHistorydimensionmod::num_dimension_types) ! Allocate the mapping between FATES indices and the IO indices @@ -315,9 +315,9 @@ subroutine SetThreadBoundsEach(this, thread_index, thread_bounds) call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%pft_class_begin, thread_bounds%pft_class_end) - index = this%levpage_index() + index = this%levage_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & - thread_bounds%page_class_begin, thread_bounds%page_class_end) + thread_bounds%age_class_begin, thread_bounds%age_class_end) end subroutine SetThreadBoundsEach @@ -327,7 +327,7 @@ subroutine assemble_history_output_types(this) use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8 use FatesIOVariableKindMod, only : patch_size_r8, site_size_r8 - use FatesIOVariableKindMod, only : site_pft_r8, site_page_r8 + use FatesIOVariableKindMod, only : site_pft_r8, site_age_r8 implicit none @@ -360,8 +360,8 @@ subroutine assemble_history_output_types(this) call this%set_dim_indices(site_pft_r8, 1, this%column_index()) call this%set_dim_indices(site_pft_r8, 2, this%levpft_index()) - call this%set_dim_indices(site_page_r8, 1, this%column_index()) - call this%set_dim_indices(site_page_r8, 2, this%levpage_index()) + call this%set_dim_indices(site_age_r8, 1, this%column_index()) + call this%set_dim_indices(site_age_r8, 2, this%levage_index()) end subroutine assemble_history_output_types @@ -491,18 +491,18 @@ integer function levpft_index(this) end function levpft_index ! ======================================================================= - subroutine set_levpage_index(this, index) + subroutine set_levage_index(this, index) implicit none class(fates_history_interface_type), intent(inout) :: this integer, intent(in) :: index - this%levpage_index_ = index - end subroutine set_levpage_index + this%levage_index_ = index + end subroutine set_levage_index - integer function levpage_index(this) + integer function levage_index(this) implicit none class(fates_history_interface_type), intent(in) :: this - levpage_index = this%levpage_index_ - end function levpage_index + levage_index = this%levage_index_ + end function levage_index ! ====================================================================================== @@ -598,7 +598,7 @@ subroutine init_dim_kinds_maps(this) use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8 use FatesIOVariableKindMod, only : patch_size_r8, site_size_r8 - use FatesIOVariableKindMod, only : site_pft_r8, site_page_r8 + use FatesIOVariableKindMod, only : site_pft_r8, site_age_r8 implicit none @@ -646,7 +646,7 @@ subroutine init_dim_kinds_maps(this) ! site x patch-age clase index = index + 1 - call this%dim_kinds(index)%Init(site_page_r8, 2) + call this%dim_kinds(index)%Init(site_age_r8, 2) ! FIXME(bja, 2016-10) assert(index == fates_history_num_dim_kinds) end subroutine init_dim_kinds_maps @@ -722,8 +722,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) AREA, & sclass_ed, & nlevsclass_ed, & - levpage_ed, & - nlevpage_ed, & + levage_ed, & + nlevage_ed, & levpft_ed use EDParamsMod , only : ED_val_ag_biomass @@ -809,7 +809,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_m5_si_scpf => this%hvars(ih_m5_si_scpf)%r82d, & hio_ba_si_scls => this%hvars(ih_ba_si_scls)%r82d, & hio_biomass_si_pft => this%hvars(ih_biomass_si_pft)%r82d, & - hio_area_si_page => this%hvars(ih_area_si_page)%r82d) + hio_area_si_age => this%hvars(ih_area_si_age)%r82d) ! --------------------------------------------------------------------------------- ! Flush arrays to values defined by %flushval (see registry entry in @@ -843,7 +843,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_npatches_si(io_si) = hio_npatches_si(io_si) + 1._r8 ! report the fractional area in each age class bin - hio_area_si_page(io_si,cpatch%age_class) = hio_area_si_page(io_si,cpatch%age_class) & + hio_area_si_age(io_si,cpatch%age_class) = hio_area_si_age(io_si,cpatch%age_class) & + cpatch%area/AREA ccohort => cpatch%shortest @@ -1257,7 +1257,7 @@ subroutine define_history_vars(this, initialize_variables) use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8 use FatesIOVariableKindMod, only : patch_size_r8, site_size_r8 - use FatesIOVariableKindMod, only : site_pft_r8, site_page_r8 + use FatesIOVariableKindMod, only : site_pft_r8, site_age_r8 implicit none class(fates_history_interface_type), intent(inout) :: this @@ -1328,8 +1328,8 @@ subroutine define_history_vars(this, initialize_variables) call this%set_history_var(vname='patch_area_by_age', units='m2/m2', & long='patch area by age bin', use_default='active', & - avgflag='A', vtype=site_page_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_area_si_page ) + avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_area_si_age ) ! Fire Variables diff --git a/main/FatesHistoryVariableType.F90 b/main/FatesHistoryVariableType.F90 index 24f4616e..20abd41f 100644 --- a/main/FatesHistoryVariableType.F90 +++ b/main/FatesHistoryVariableType.F90 @@ -45,7 +45,7 @@ subroutine Init(this, vname, units, long, use_default, & use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8 - use FatesIOVariableKindMod, only : site_size_r8, site_pft_r8, site_page_r8 + use FatesIOVariableKindMod, only : site_size_r8, site_pft_r8, site_age_r8 use FatesIOVariableKindMod, only : iotype_index implicit none @@ -127,7 +127,7 @@ subroutine Init(this, vname, units, long, use_default, & allocate(this%r82d(lb1:ub1, lb2:ub2)) this%r82d(:,:) = flushval - case(site_page_r8) + case(site_age_r8) allocate(this%r82d(lb1:ub1, lb2:ub2)) this%r82d(:,:) = flushval @@ -196,7 +196,7 @@ subroutine Flush(this, thread, dim_bounds, dim_kinds) use FatesIODimensionsMod, only : fates_io_dimension_type use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8, patch_int - use FatesIOVariableKindMod, only : site_size_r8, site_pft_r8, site_page_r8 + use FatesIOVariableKindMod, only : site_size_r8, site_pft_r8, site_age_r8 implicit none @@ -226,7 +226,7 @@ subroutine Flush(this, thread, dim_bounds, dim_kinds) this%r82d(lb1:ub1, lb2:ub2) = this%flushval case(site_pft_r8) this%r82d(lb1:ub1, lb2:ub2) = this%flushval - case(site_page_r8) + case(site_age_r8) this%r82d(lb1:ub1, lb2:ub2) = this%flushval case(patch_int) this%int1d(lb1:ub1) = nint(this%flushval) diff --git a/main/FatesIODimensionsMod.F90 b/main/FatesIODimensionsMod.F90 index 80973f2e..83b2475a 100644 --- a/main/FatesIODimensionsMod.F90 +++ b/main/FatesIODimensionsMod.F90 @@ -11,7 +11,7 @@ module FatesIODimensionsMod character(*), parameter :: levscpf = 'levscpf' character(*), parameter :: levscls = 'levscls' character(*), parameter :: levpft = 'levpft' - character(*), parameter :: levpage = 'levpage' + character(*), parameter :: levage = 'levage' ! patch = This is a structure that records where FATES patch boundaries ! on each thread point to in the host IO array, this structure @@ -33,7 +33,7 @@ module FatesIODimensionsMod ! levpft = This is a structure that records the boundaries for the ! number of pft dimension - ! levpage = This is a structure that records the boundaries for the + ! levage = This is a structure that records the boundaries for the ! number of patch-age-class dimension @@ -52,8 +52,8 @@ module FatesIODimensionsMod integer :: size_class_end integer :: pft_class_begin integer :: pft_class_end - integer :: page_class_begin - integer :: page_class_end + integer :: age_class_begin + integer :: age_class_end end type fates_bounds_type diff --git a/main/FatesIOVariableKindMod.F90 b/main/FatesIOVariableKindMod.F90 index 79305f0b..54c7707b 100644 --- a/main/FatesIOVariableKindMod.F90 +++ b/main/FatesIOVariableKindMod.F90 @@ -22,7 +22,7 @@ module FatesIOVariableKindMod character(*), parameter :: cohort_r8 = 'CO_R8' character(*), parameter :: cohort_int = 'CO_INT' character(*), parameter :: site_pft_r8 = 'SI_PFT_R8' - character(*), parameter :: site_page_r8 = 'SI_PAGE_R8' + character(*), parameter :: site_age_r8 = 'SI_AGE_R8' ! NOTE(RGK, 2016) %active is not used yet. Was intended as a check on the HLM->FATES From ae206fe01dc003758cecbb71bbad33a63ec61a6d Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 17 Jan 2017 11:49:54 -0800 Subject: [PATCH 288/437] Removal of ieee_ nan and inf checks. There was concern that many compilers have not adopted ieee_ checking functions and we would lose compiler compatibility. --- biogeophys/EDAccumulateFluxesMod.F90 | 35 ---------------------------- 1 file changed, 35 deletions(-) diff --git a/biogeophys/EDAccumulateFluxesMod.F90 b/biogeophys/EDAccumulateFluxesMod.F90 index 3310207f..bd2437c9 100644 --- a/biogeophys/EDAccumulateFluxesMod.F90 +++ b/biogeophys/EDAccumulateFluxesMod.F90 @@ -11,7 +11,6 @@ module EDAccumulateFluxesMod ! !USES: use abortutils, only : endrun use shr_log_mod , only : errMsg => shr_log_errMsg - use FatesConstantsMod, only : fates_huge, fates_tiny implicit none private ! @@ -79,40 +78,6 @@ subroutine AccumulateFluxes_ED(nsites, sites, bc_in, bc_out, dt_time) write(iulog,*) 'EDAccumFlux 67 ',ccohort%resp_tstep endif - ! Trap invalid values from photosynthesis and resp - ! ----------------------------------------------------------------------- - - if(ieee_is_nan(ccohort%gpp_tstep))then - write(iulog,*)'GPP NaN Trap Triggered',s,ifp,ccohort%gpp_tstep - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - if(ieee_is_nan(ccohort%resp_tstep))then - write(iulog,*)'RESP NaN Trap Triggered',s,ifp,ccohort%resp_tstep - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - if(ieee_is_nan(ccohort%npp_tstep))then - write(iulog,*)'NPP NaN Trap Triggered',s,ifp,ccohort%npp_tstep - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - if(.not.ieee_is_finite(ccohort%gpp_tstep))then - write(iulog,*)'GPP Infinite Trap Triggered',s,ifp,ccohort%gpp_tstep - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - if(.not.ieee_is_finite(ccohort%resp_tstep))then - write(iulog,*)'RESP Infinite Trap Triggered',s,ifp,ccohort%resp_tstep - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - if(.not.ieee_is_finite(ccohort%npp_tstep))then - write(iulog,*)'NPP Infinite Trap Triggered',s,ifp,ccohort%npp_tstep - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - ccohort%npp_acc = ccohort%npp_acc + ccohort%npp_tstep ccohort%gpp_acc = ccohort%gpp_acc + ccohort%gpp_tstep ccohort%resp_acc = ccohort%resp_acc + ccohort%resp_tstep From 87ea4e78095a7a353983eda444d2517bce3ee025 Mon Sep 17 00:00:00 2001 From: ckoven Date: Tue, 17 Jan 2017 14:55:09 -0800 Subject: [PATCH 289/437] removed the patch x size shape since it isn't used and could be buggy --- main/FatesHistoryInterfaceMod.F90 | 18 ++++-------------- main/FatesIOVariableKindMod.F90 | 1 - 2 files changed, 4 insertions(+), 15 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 1495baa6..69ef96ca 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -143,7 +143,7 @@ module FatesHistoryInterfaceMod ! The number of variable dim/kind types we have defined (static) integer, parameter :: fates_history_num_dimensions = 7 - integer, parameter :: fates_history_num_dim_kinds = 10 + integer, parameter :: fates_history_num_dim_kinds = 9 @@ -326,8 +326,7 @@ subroutine assemble_history_output_types(this) use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8 - use FatesIOVariableKindMod, only : patch_size_r8, site_size_r8 - use FatesIOVariableKindMod, only : site_pft_r8, site_age_r8 + use FatesIOVariableKindMod, only : site_size_r8, site_pft_r8, site_age_r8 implicit none @@ -351,9 +350,6 @@ subroutine assemble_history_output_types(this) call this%set_dim_indices(site_size_pft_r8, 1, this%column_index()) call this%set_dim_indices(site_size_pft_r8, 2, this%levscpf_index()) - call this%set_dim_indices(patch_size_r8, 1, this%patch_index()) - call this%set_dim_indices(patch_size_r8, 2, this%levscls_index()) - call this%set_dim_indices(site_size_r8, 1, this%column_index()) call this%set_dim_indices(site_size_r8, 2, this%levscls_index()) @@ -597,8 +593,7 @@ subroutine init_dim_kinds_maps(this) ! ---------------------------------------------------------------------------------- use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8 - use FatesIOVariableKindMod, only : patch_size_r8, site_size_r8 - use FatesIOVariableKindMod, only : site_pft_r8, site_age_r8 + use FatesIOVariableKindMod, only : site_size_r8, site_pft_r8, site_age_r8 implicit none @@ -632,10 +627,6 @@ subroutine init_dim_kinds_maps(this) index = index + 1 call this%dim_kinds(index)%Init(site_size_pft_r8, 2) - ! patch x size-class - index = index + 1 - call this%dim_kinds(index)%Init(patch_size_r8, 2) - ! site x size-class index = index + 1 call this%dim_kinds(index)%Init(site_size_r8, 2) @@ -1256,8 +1247,7 @@ subroutine define_history_vars(this, initialize_variables) use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8 - use FatesIOVariableKindMod, only : patch_size_r8, site_size_r8 - use FatesIOVariableKindMod, only : site_pft_r8, site_age_r8 + use FatesIOVariableKindMod, only : site_size_r8, site_pft_r8, site_age_r8 implicit none class(fates_history_interface_type), intent(inout) :: this diff --git a/main/FatesIOVariableKindMod.F90 b/main/FatesIOVariableKindMod.F90 index 54c7707b..2c8eb982 100644 --- a/main/FatesIOVariableKindMod.F90 +++ b/main/FatesIOVariableKindMod.F90 @@ -12,7 +12,6 @@ module FatesIOVariableKindMod character(*), parameter :: patch_r8 = 'PA_R8' character(*), parameter :: patch_ground_r8 = 'PA_GRND_R8' character(*), parameter :: patch_size_pft_r8 = 'PA_SCPF_R8' - character(*), parameter :: patch_size_r8 = 'PA_SCLS_R8' character(*), parameter :: site_r8 = 'SI_R8' character(*), parameter :: site_int = 'SI_INT' character(*), parameter :: site_ground_r8 = 'SI_GRND_R8' From 21bb9944ec01bd581212af9a43b5bffb2843cdc3 Mon Sep 17 00:00:00 2001 From: ckoven Date: Wed, 18 Jan 2017 14:54:00 -0800 Subject: [PATCH 290/437] fixed an error in pft biomass calculation and also a metadata issue on the patch age axis that made ferret display time weirdly --- main/FatesHistoryInterfaceMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 69ef96ca..e7bd7979 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -897,7 +897,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) ccohort%n hio_biomass_si_pft(io_si, ft) = hio_biomass_si_pft(io_si, ft) + & - n_density * ccohort%b * 1.e3_r8 + ccohort%n * ccohort%b * 1.e3_r8 / AREA ! Site by Size-Class x PFT (SCPF) ! ------------------------------------------------------------------------ From 146ddd1fbcb6fce46eb1605027ddc020a103544d Mon Sep 17 00:00:00 2001 From: ckoven Date: Wed, 18 Jan 2017 17:09:47 -0800 Subject: [PATCH 291/437] added a couple new diagnostic variables on age class dimension --- main/FatesHistoryInterfaceMod.F90 | 39 +++++++++++++++++++++++++++---- 1 file changed, 35 insertions(+), 4 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index e7bd7979..46e83c96 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -140,6 +140,8 @@ module FatesHistoryInterfaceMod ! indices to (site x patch-age) variables integer, private :: ih_area_si_age + integer, private :: ih_lai_si_age + integer, private :: ih_canopy_area_si_age ! The number of variable dim/kind types we have defined (static) integer, parameter :: fates_history_num_dimensions = 7 @@ -727,7 +729,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! Locals integer :: s ! The local site index integer :: io_si ! The site index of the IO array - integer :: ipa ! The local "I"ndex of "PA"tches + integer :: ipa, ipa2 ! The local "I"ndex of "PA"tches integer :: io_pa ! The patch index of the IO array integer :: io_pa1 ! The first patch index in the IO array for each site integer :: io_soipa @@ -746,6 +748,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) real(r8), parameter :: daysecs = 86400.0_r8 ! What modeler doesn't recognize 86400? real(r8), parameter :: yeardays = 365.0_r8 ! ALM/CLM do not use leap-years + real(r8), parameter :: tiny = 1.e-5_r8 ! some small number associate( hio_npatches_si => this%hvars(ih_npatches_si)%r81d, & hio_ncohorts_si => this%hvars(ih_ncohorts_si)%r81d, & @@ -800,7 +803,9 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_m5_si_scpf => this%hvars(ih_m5_si_scpf)%r82d, & hio_ba_si_scls => this%hvars(ih_ba_si_scls)%r82d, & hio_biomass_si_pft => this%hvars(ih_biomass_si_pft)%r82d, & - hio_area_si_age => this%hvars(ih_area_si_age)%r82d) + hio_area_si_age => this%hvars(ih_area_si_age)%r82d, & + hio_lai_si_age => this%hvars(ih_lai_si_age)%r82d, & + hio_canopy_area_si_age => this%hvars(ih_canopy_area_si_age)%r82d) ! --------------------------------------------------------------------------------- ! Flush arrays to values defined by %flushval (see registry entry in @@ -833,9 +838,15 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! Increment the number of patches per site hio_npatches_si(io_si) = hio_npatches_si(io_si) + 1._r8 - ! report the fractional area in each age class bin + ! Increment the fractional area in each age class bin hio_area_si_age(io_si,cpatch%age_class) = hio_area_si_age(io_si,cpatch%age_class) & + cpatch%area/AREA + + ! Increment the leaf and canopy areas in each age class bin + hio_lai_si_age(io_si,cpatch%age_class) = hio_lai_si_age(io_si,cpatch%age_class) & + + cpatch%lai * cpatch%area + hio_canopy_area_si_age(io_si,cpatch%age_class) = hio_canopy_area_si_age(io_si,cpatch%age_class) & + + cpatch%canopy_area/AREA ccohort => cpatch%shortest do while(associated(ccohort)) @@ -1026,6 +1037,15 @@ subroutine update_history_dyn(this,nc,nsites,sites) ipa = ipa + 1 cpatch => cpatch%younger end do !patch loop + + ! divide so-far-just-summed but to-be-averaged patch-age-class variables by patch-age-class area to get mean values + do ipa2 = 1, nlevage_ed + if (hio_area_si_age(io_si, ipa2) .gt. tiny) then + hio_lai_si_age(io_si, ipa2) = hio_lai_si_age(io_si, ipa2) / (hio_area_si_age(io_si, ipa2)*AREA) + else + hio_lai_si_age(io_si, ipa2) = 0._r8 + endif + end do enddo ! site loop @@ -1316,10 +1336,21 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_biomass_si_pft ) - call this%set_history_var(vname='patch_area_by_age', units='m2/m2', & + ! patch age class variables + call this%set_history_var(vname='PATCH_AREA_BY_AGE', units='m2/m2', & long='patch area by age bin', use_default='active', & avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_area_si_age ) + + call this%set_history_var(vname='LAI_BY_AGE', units='m2/m2', & + long='leaf area index by age bin', use_default='active', & + avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_lai_si_age ) + + call this%set_history_var(vname='CANOPY_AREA_BY_AGE', units='m2/m2', & + long='canopy area by age bin', use_default='active', & + avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_canopy_area_si_age ) ! Fire Variables From aedee0c02d9dd64e8967f060fadd2f2ef781077c Mon Sep 17 00:00:00 2001 From: ckoven Date: Thu, 19 Jan 2017 11:58:52 -0800 Subject: [PATCH 292/437] added npp and gpp by age class diagnostics --- biogeochem/EDPatchDynamicsMod.F90 | 2 - main/EDTypesMod.F90 | 2 - main/FatesHistoryInterfaceMod.F90 | 67 +++++++++++++++++++++++++++++-- 3 files changed, 64 insertions(+), 7 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 0cb9434b..efd17019 100755 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -937,8 +937,6 @@ subroutine zero_patch(cp_p) 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 ! DISTURBANCE currentPatch%disturbance_rates = 0._r8 diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index be94ffdd..d861559c 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -392,8 +392,6 @@ module EDTypesMod ! PHOTOSYNTHESIS real(r8) :: psn_z(cp_nclmax,numpft_ed,cp_nlevcan) ! 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:- diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 46e83c96..d17cf450 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -142,6 +142,10 @@ module FatesHistoryInterfaceMod integer, private :: ih_area_si_age integer, private :: ih_lai_si_age integer, private :: ih_canopy_area_si_age + integer, private :: ih_gpp_si_age + integer, private :: ih_npp_si_age + integer, private :: ih_ncl_si_age + integer, private :: ih_npatches_si_age ! The number of variable dim/kind types we have defined (static) integer, parameter :: fates_history_num_dimensions = 7 @@ -805,7 +809,10 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_biomass_si_pft => this%hvars(ih_biomass_si_pft)%r82d, & hio_area_si_age => this%hvars(ih_area_si_age)%r82d, & hio_lai_si_age => this%hvars(ih_lai_si_age)%r82d, & - hio_canopy_area_si_age => this%hvars(ih_canopy_area_si_age)%r82d) + hio_canopy_area_si_age => this%hvars(ih_canopy_area_si_age)%r82d, & + hio_ncl_si_age => this%hvars(ih_ncl_si_age)%r82d, & + hio_npatches_si_age => this%hvars(ih_npatches_si_age)%r82d) + ! --------------------------------------------------------------------------------- ! Flush arrays to values defined by %flushval (see registry entry in @@ -842,11 +849,14 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_area_si_age(io_si,cpatch%age_class) = hio_area_si_age(io_si,cpatch%age_class) & + cpatch%area/AREA - ! Increment the leaf and canopy areas in each age class bin + ! Increment some patch-age-resolved diagnostics hio_lai_si_age(io_si,cpatch%age_class) = hio_lai_si_age(io_si,cpatch%age_class) & + cpatch%lai * cpatch%area hio_canopy_area_si_age(io_si,cpatch%age_class) = hio_canopy_area_si_age(io_si,cpatch%age_class) & + cpatch%canopy_area/AREA + hio_ncl_si_age(io_si,cpatch%age_class) = hio_ncl_si_age(io_si,cpatch%age_class) & + + cpatch%ncl_p * cpatch%area + hio_npatches_si_age(io_si,cpatch%age_class) = hio_npatches_si_age(io_si,cpatch%age_class) + 1._r8 ccohort => cpatch%shortest do while(associated(ccohort)) @@ -1042,8 +1052,10 @@ subroutine update_history_dyn(this,nc,nsites,sites) do ipa2 = 1, nlevage_ed if (hio_area_si_age(io_si, ipa2) .gt. tiny) then hio_lai_si_age(io_si, ipa2) = hio_lai_si_age(io_si, ipa2) / (hio_area_si_age(io_si, ipa2)*AREA) + hio_ncl_si_age(io_si, ipa2) = hio_ncl_si_age(io_si, ipa2) / (hio_area_si_age(io_si, ipa2)*AREA) else hio_lai_si_age(io_si, ipa2) = 0._r8 + hio_ncl_si_age(io_si, ipa2) = 0._r8 endif end do @@ -1067,6 +1079,7 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) ed_cohort_type, & ed_patch_type, & AREA, & + nlevage_ed, & sclass_ed, & nlevsclass_ed ! Arguments @@ -1088,6 +1101,9 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) integer :: ft ! functional type index real(r8) :: n_density ! individual of cohort per m2. real(r8) :: n_perm2 ! individuals per m2 for the whole column + real(r8) :: patch_area_by_age(nlevage_ed) ! patch area in each bin for normalizing purposes + real(r8), parameter :: tiny = 1.e-5_r8 ! some small number + integer :: ipa2 ! patch incrementer type(fates_history_variable_type),pointer :: hvar type(ed_patch_type),pointer :: cpatch @@ -1108,7 +1124,10 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) hio_ar_agsapm_si_scpf => this%hvars(ih_ar_agsapm_si_scpf)%r82d, & hio_ar_darkm_si_scpf => this%hvars(ih_ar_darkm_si_scpf)%r82d, & hio_ar_crootm_si_scpf => this%hvars(ih_ar_crootm_si_scpf)%r82d, & - hio_ar_frootm_si_scpf => this%hvars(ih_ar_frootm_si_scpf)%r82d ) + hio_ar_frootm_si_scpf => this%hvars(ih_ar_frootm_si_scpf)%r82d, & + hio_gpp_si_age => this%hvars(ih_gpp_si_age)%r82d, & + hio_npp_si_age => this%hvars(ih_npp_si_age)%r82d & + ) ! Flush the relevant history variables @@ -1122,10 +1141,15 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) ipa = 0 cpatch => sites(s)%oldest_patch + + patch_area_by_age(:) = 0._r8 + do while(associated(cpatch)) io_pa = io_pa1 + ipa + patch_area_by_age(cpatch%age_class) = patch_area_by_age(cpatch%age_class) + cpatch%area + ccohort => cpatch%shortest do while(associated(ccohort)) @@ -1188,6 +1212,11 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) hio_ar_frootm_si_scpf(io_si,scpf) = hio_ar_frootm_si_scpf(io_si,scpf) + & ccohort%froot_mr * n_perm2 * daysecs * yeardays + ! accumulate fluxes per patch age bin + hio_gpp_si_age(io_si,cpatch%age_class) = hio_gpp_si_age(io_si,cpatch%age_class) & + + ccohort%gpp_tstep * ccohort%n * 1.e3_r8 / dt_tstep + hio_npp_si_age(io_si,cpatch%age_class) = hio_npp_si_age(io_si,cpatch%age_class) & + + ccohort%npp_tstep * ccohort%n * 1.e3_r8 / dt_tstep end associate endif @@ -1196,6 +1225,16 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) ipa = ipa + 1 cpatch => cpatch%younger end do !patch loop + + do ipa2 = 1, nlevage_ed + if (patch_area_by_age(ipa2) .gt. tiny) then + hio_gpp_si_age(io_si, ipa2) = hio_gpp_si_age(io_si, ipa2) / (patch_area_by_age(ipa2)) + hio_npp_si_age(io_si, ipa2) = hio_npp_si_age(io_si, ipa2) / (patch_area_by_age(ipa2)) + else + hio_gpp_si_age(io_si, ipa2) = 0._r8 + hio_npp_si_age(io_si, ipa2) = 0._r8 + endif + end do enddo ! site loop @@ -1352,6 +1391,16 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_canopy_area_si_age ) + call this%set_history_var(vname='NCL_BY_AGE', units='--', & + long='number of canopy levels by age bin', use_default='active', & + avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_ncl_si_age ) + + call this%set_history_var(vname='NPATCH_BY_AGE', units='--', & + long='number of patches by age bin', use_default='active', & + avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_npatches_si_age ) + ! Fire Variables call this%set_history_var(vname='FIRE_NESTEROV_INDEX', units='none', & @@ -1506,6 +1555,18 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & ivar=ivar, initialize=initialize_variables, index = ih_maint_resp_pa ) + ! fast fluxes by age bin + call this%set_history_var(vname='NPP_BY_AGE', units='gC/m^2/s', & + long='net primary productivity by age bin', use_default='active', & + avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_npp_si_age ) + + call this%set_history_var(vname='GPP_BY_AGE', units='gC/m^2/s', & + long='gross primary productivity by age bin', use_default='active', & + avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_gpp_si_age ) + + ! Carbon Flux (grid dimension x scpf) (THESE ARE DEFAULT INACTIVE!!! ! (BECAUSE THEY TAKE UP SPACE!!! From 9d70ed6769f5d8ba1d496b24c8ce154d1bdd21df Mon Sep 17 00:00:00 2001 From: ckoven Date: Thu, 19 Jan 2017 13:40:39 -0800 Subject: [PATCH 293/437] moved the old pft variables to the new pft dimension --- main/FatesHistoryInterfaceMod.F90 | 56 ++++++++++++------------------- 1 file changed, 22 insertions(+), 34 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index d17cf450..11ce1b4c 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -63,13 +63,6 @@ module FatesHistoryInterfaceMod integer, private :: ih_maint_resp_pa integer, private :: ih_growth_resp_pa - ! Indices to (patch x pft) variables (using nlevgrnd as surrogate) - !+++cdk+++ leaving these as-is for now to preserve b4b, but once established, need to move these to actual pft dimension - integer, private :: ih_biomass_pa_pft - integer, private :: ih_leafbiomass_pa_pft - integer, private :: ih_storebiomass_pa_pft - integer, private :: ih_nindivs_pa_pft - ! Indices to (site) variables integer, private :: ih_nep_si integer, private :: ih_nep_timeintegrated_si @@ -137,6 +130,10 @@ module FatesHistoryInterfaceMod ! indices to (site x pft) variables integer, private :: ih_biomass_si_pft + integer, private :: ih_leafbiomass_si_pft + integer, private :: ih_storebiomass_si_pft + integer, private :: ih_nindivs_si_pft + ! indices to (site x patch-age) variables integer, private :: ih_area_si_age @@ -760,10 +757,10 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_area_plant_pa => this%hvars(ih_area_plant_pa)%r81d, & hio_area_treespread_pa => this%hvars(ih_area_treespread_pa)%r81d, & hio_canopy_spread_pa => this%hvars(ih_canopy_spread_pa)%r81d, & - hio_biomass_pa_pft => this%hvars(ih_biomass_pa_pft)%r82d, & - hio_leafbiomass_pa_pft => this%hvars(ih_leafbiomass_pa_pft)%r82d, & - hio_storebiomass_pa_pft => this%hvars(ih_storebiomass_pa_pft)%r82d, & - hio_nindivs_pa_pft => this%hvars(ih_nindivs_pa_pft)%r82d, & + hio_biomass_si_pft => this%hvars(ih_biomass_si_pft)%r82d, & + hio_leafbiomass_si_pft => this%hvars(ih_leafbiomass_si_pft)%r82d, & + hio_storebiomass_si_pft => this%hvars(ih_storebiomass_si_pft)%r82d, & + hio_nindivs_si_pft => this%hvars(ih_nindivs_si_pft)%r82d, & hio_nesterov_fire_danger_pa => this%hvars(ih_nesterov_fire_danger_pa)%r81d, & hio_spitfire_ros_pa => this%hvars(ih_spitfire_ROS_pa)%r81d, & hio_tfc_ros_pa => this%hvars(ih_TFC_ROS_pa)%r81d, & @@ -806,7 +803,6 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_m4_si_scpf => this%hvars(ih_m4_si_scpf)%r82d, & hio_m5_si_scpf => this%hvars(ih_m5_si_scpf)%r82d, & hio_ba_si_scls => this%hvars(ih_ba_si_scls)%r82d, & - hio_biomass_si_pft => this%hvars(ih_biomass_si_pft)%r82d, & hio_area_si_age => this%hvars(ih_area_si_age)%r82d, & hio_lai_si_age => this%hvars(ih_lai_si_age)%r82d, & hio_canopy_area_si_age => this%hvars(ih_canopy_area_si_age)%r82d, & @@ -905,20 +901,17 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_balive_pa(io_pa) = hio_balive_pa(io_pa) + n_density * ccohort%balive * 1.e3_r8 ! Update PFT partitioned biomass components - hio_biomass_pa_pft(io_pa,ft) = hio_biomass_pa_pft(io_pa,ft) + & - n_density * ccohort%b * 1.e3_r8 - - hio_leafbiomass_pa_pft(io_pa,ft) = hio_leafbiomass_pa_pft(io_pa,ft) + & - n_density * ccohort%bl * 1.e3_r8 + hio_leafbiomass_si_pft(io_si,ft) = hio_leafbiomass_si_pft(io_si,ft) + & + (ccohort%n / AREA) * ccohort%bl * 1.e3_r8 - hio_storebiomass_pa_pft(io_pa,ft) = hio_storebiomass_pa_pft(io_pa,ft) + & - n_density * ccohort%bstore * 1.e3_r8 + hio_storebiomass_si_pft(io_si,ft) = hio_storebiomass_si_pft(io_si,ft) + & + (ccohort%n / AREA) * ccohort%bstore * 1.e3_r8 - hio_nindivs_pa_pft(io_pa,ft) = hio_nindivs_pa_pft(io_pa,ft) + & - ccohort%n + hio_nindivs_si_pft(io_si,ft) = hio_nindivs_si_pft(io_si,ft) + & + ccohort%n / AREA hio_biomass_si_pft(io_si, ft) = hio_biomass_si_pft(io_si, ft) + & - ccohort%n * ccohort%b * 1.e3_r8 / AREA + (ccohort%n / AREA) * ccohort%b * 1.e3_r8 ! Site by Size-Class x PFT (SCPF) ! ------------------------------------------------------------------------ @@ -1352,28 +1345,23 @@ subroutine define_history_vars(this, initialize_variables) call this%set_history_var(vname='PFTbiomass', units='gC/m2', & long='total PFT level biomass', use_default='active', & - avgflag='A', vtype=patch_ground_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_biomass_pa_pft ) + avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_biomass_si_pft ) call this%set_history_var(vname='PFTleafbiomass', units='gC/m2', & long='total PFT level leaf biomass', use_default='active', & - avgflag='A', vtype=patch_ground_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_leafbiomass_pa_pft ) + avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_leafbiomass_si_pft ) call this%set_history_var(vname='PFTstorebiomass', units='gC/m2', & long='total PFT level stored biomass', use_default='active', & - avgflag='A', vtype=patch_ground_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_storebiomass_pa_pft ) + avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_storebiomass_si_pft ) call this%set_history_var(vname='PFTnindivs', units='indiv / m2', & long='total PFT level number of individuals', use_default='active', & - avgflag='A', vtype=patch_ground_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_nindivs_pa_pft ) - - call this%set_history_var(vname='PFT_biomass', units='gC/m2', & - long='total PFT level biomass -- on actual PFT dimension', use_default='active',& avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_biomass_si_pft ) + ivar=ivar, initialize=initialize_variables, index = ih_nindivs_si_pft ) ! patch age class variables call this%set_history_var(vname='PATCH_AREA_BY_AGE', units='m2/m2', & From 6890a686c11dd587d72dc04793c4172e7b2af0e8 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 19 Jan 2017 15:52:35 -0800 Subject: [PATCH 294/437] A fix was added to properly account for the npp flux to roots and sapwood in cases where there were no leaves. This case was not being triggered in typical testing, as there were no deciduous trees entering this condition. Its still not entirely clear why we are encountering trees that have no leaves yet are carbon positive, but that is not completely within the scope of this fix. This fix was tested using a multi-year f45 simulation and a special PFT set that jaholm developed that includes some temperate species, total of 5 pfts. This configuration also tripped a false positive warning message that occured while processing output boundary conditions in btran. It was assuming that transpiration uptake weighting was summing to unity after receiving conductance weighting from different pfts. I think previously we were getting unity just by luck of all pfts having the same root extinction parameters. The warning message complained and re-normalized. I simply removed the complaint, as the re-normalization was required for most cases. I also removed a pesky LHP log message by binding it in a debug. --- biogeochem/EDCanopyStructureMod.F90 | 2 +- biogeochem/EDCohortDynamicsMod.F90 | 77 +++++++++++++++-------------- biogeophys/EDBtranMod.F90 | 9 ++-- 3 files changed, 46 insertions(+), 42 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index f5419ced..20ae7efe 100755 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1067,7 +1067,7 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) currentCohort%c_area/currentPatch%total_canopy_area) currentPatch%layer_height_profile(L,ft,iv) = currentPatch%layer_height_profile(L,ft,iv) + (remainder * fleaf * & currentCohort%c_area/currentPatch%total_canopy_area*(layer_top_hite+layer_bottom_hite)/2.0_r8) - write(fates_log(), *) 'LHP', currentPatch%layer_height_profile(L,ft,iv) + if ( DEBUG ) write(fates_log(), *) 'LHP', currentPatch%layer_height_profile(L,ft,iv) if(currentCohort%dbh <= 0._r8.or.currentCohort%n == 0._r8)then write(fates_log(), *) 'ED: dbh or n is zero in clmedlink', currentCohort%dbh,currentCohort%n endif diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 6588ceee..63f7ef84 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -184,6 +184,9 @@ subroutine allocate_live_biomass(cc_p,mode) ! 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. + real(r8) :: new_bl + real(r8) :: new_br + real(r8) :: new_bsw integer :: ft ! functional type integer :: leaves_off_switch @@ -218,68 +221,68 @@ subroutine allocate_live_biomass(cc_p,mode) ! Use different proportions if the leaves are on vs off if(leaves_off_switch==0)then - ! Tracking npp/gpp diagnostics only occur after growth derivatives is called - if(mode==1)then - ! it will not be able to put out as many leaves as it had previous timestep - currentcohort%npp_leaf = currentcohort%npp_leaf + & - max(0.0_r8,currentcohort%balive*leaf_frac - currentcohort%bl)/udata%deltat - end if + new_bl = currentcohort%balive*leaf_frac + + new_br = pftcon%froot_leaf(ft) * (currentcohort%balive + currentcohort%laimemory) * leaf_frac - currentcohort%bl = currentcohort%balive*leaf_frac + new_bsw = EDecophyscon%sapwood_ratio(ft) * currentcohort%hite *(currentcohort%balive + & + currentcohort%laimemory)*leaf_frac !diagnose the root and stem biomass from the functional balance hypothesis. This is used when the leaves are !fully on. - if(mode==1)then + if(mode==1)then + currentcohort%npp_leaf = currentcohort%npp_leaf + & + max(0.0_r8,new_bl - currentcohort%bl) / udata%deltat + currentcohort%npp_froot = currentcohort%npp_froot + & - max(0._r8,pftcon%froot_leaf(ft)*(currentcohort%balive+currentcohort%laimemory)*leaf_frac - currentcohort%br) / & - udata%deltat - - currentcohort%npp_bsw = max(0._r8,EDecophyscon%sapwood_ratio(ft) * currentcohort%hite *(currentcohort%balive + & - currentcohort%laimemory)*leaf_frac - currentcohort%bsw)/udata%deltat - + max(0._r8,new_br - currentcohort%br) / udata%deltat + + currentcohort%npp_bsw = max(0._r8,new_bsw - currentcohort%bsw)/udata%deltat + currentcohort%npp_bdead = currentCohort%dbdeaddt end if + + currentcohort%bl = new_bl + currentcohort%br = new_br + currentcohort%bsw = new_bsw - 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 - - else ! Leaves are on (leaves_off_switch==1) - - !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 + else ! Leaves are off (leaves_off_switch==1) - currentcohort%bl = 0.0_r8 + !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 + 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 + ratio_balive = currentcohort%balive / ideal_balive + + new_br = pftcon%froot_leaf(ft) * (ideal_balive + currentcohort%laimemory) * & + leaf_frac * ratio_balive + new_bsw = EDecophyscon%sapwood_ratio(ft) * currentcohort%hite * & + (ideal_balive + currentcohort%laimemory) * leaf_frac * ratio_balive ! Diagnostics if(mode==1)then currentcohort%npp_froot = currentcohort%npp_froot + & - max(0.0_r8,pftcon%froot_leaf(ft)*(ideal_balive + & - currentcohort%laimemory)*leaf_frac*ratio_balive-currentcohort%br)/udata%deltat + max(0.0_r8,new_br-currentcohort%br)/udata%deltat - currentcohort%npp_bsw = max(0.0_r8,EDecophyscon%sapwood_ratio(ft) * currentcohort%hite *(ideal_balive + & - currentcohort%laimemory)*leaf_frac*ratio_balive - currentcohort%bsw)/udata%deltat + currentcohort%npp_bsw = max(0.0_r8, new_bsw-currentcohort%bsw)/udata%deltat currentcohort%npp_bdead = currentCohort%dbdeaddt end if + currentcohort%bl = 0.0_r8 + currentcohort%br = new_bl + currentcohort%bsw = new_bsw + endif if (abs(currentcohort%balive -currentcohort%bl- currentcohort%br - currentcohort%bsw)>1e-12) then diff --git a/biogeophys/EDBtranMod.F90 b/biogeophys/EDBtranMod.F90 index 8ac4a51b..8283a4d5 100644 --- a/biogeophys/EDBtranMod.F90 +++ b/biogeophys/EDBtranMod.F90 @@ -192,7 +192,7 @@ subroutine btran_ed( nsites, sites, bc_in, bc_out) end if enddo enddo - + !weight patch level output BTRAN for the bc_out(s)%btran_pa(ifp) = 0.0_r8 do ft = 1,numpft_ed @@ -203,10 +203,11 @@ subroutine btran_ed( nsites, sites, bc_in, bc_out) bc_out(s)%btran_pa(ifp) = bc_out(s)%btran_pa(ifp) + cpatch%btran_ft(ft) * 1./numpft_ed end if enddo - - temprootr = sum(bc_out(s)%rootr_pagl(ifp,:)) + + ! While the in-pft root profiles summed to unity, averaging them weighted + ! by conductance, or not, will break sum to unity. Thus, re-normalize. + temprootr = sum(bc_out(s)%rootr_pagl(ifp,1:cp_numlevgrnd)) if(abs(1.0_r8-temprootr) > 1.0e-10_r8 .and. temprootr > 1.0e-10_r8)then - write(iulog,*) 'error with rootr in canopy fluxes',temprootr,sum(pftgs),sum(cpatch%rootr_ft(1:2,:),dim=2) do j = 1,cp_numlevgrnd bc_out(s)%rootr_pagl(ifp,j) = bc_out(s)%rootr_pagl(ifp,j)/temprootr enddo From 0b2c1630075134ef05ef4dd5a271d5cf1fdf6b44 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 19 Jan 2017 17:19:08 -0800 Subject: [PATCH 295/437] Added a FATES wrapper to the CIME shared endrun --- main/FatesGlobals.F90 | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) diff --git a/main/FatesGlobals.F90 b/main/FatesGlobals.F90 index 9ae06e20..0c3575e3 100644 --- a/main/FatesGlobals.F90 +++ b/main/FatesGlobals.F90 @@ -35,4 +35,32 @@ logical function fates_global_verbose() fates_global_verbose = fates_global_verbose_ end function fates_global_verbose + + subroutine fates_endrun(msg) + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Abort the model for abnormal termination + ! This subroutine was derived from CLM's + ! endrun_vanilla() in abortutils.F90 + ! + use shr_sys_mod , only: shr_sys_abort + ! + ! !ARGUMENTS: + implicit none + character(len=*), intent(in), optional :: msg ! string to be printed + !----------------------------------------------------------------------- + + if (present (msg)) then + write(fates_log(),*)'ENDRUN:', msg + else + write(fates_log(),*)'ENDRUN: called without a message string' + end if + + call shr_sys_abort() + + end subroutine fates_endrun + + + end module FatesGlobals From 8eafe07c7ec819e1eed5597ca1174b6c85313b26 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 19 Jan 2017 17:22:13 -0800 Subject: [PATCH 296/437] Typo fix in setting updated root biomass during growth. --- biogeochem/EDCohortDynamicsMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 63f7ef84..012926ab 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -280,7 +280,7 @@ subroutine allocate_live_biomass(cc_p,mode) end if currentcohort%bl = 0.0_r8 - currentcohort%br = new_bl + currentcohort%br = new_br currentcohort%bsw = new_bsw endif From 5088bc889dec11bea73b7c17af47ba4af91d9f25 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 19 Jan 2017 18:02:04 -0800 Subject: [PATCH 297/437] Converted global calls to abortutilsmods endrun to fates endrun. Also did some light cleaning of some other calls to the cime shares, mostly just for readability. --- biogeochem/EDCanopyStructureMod.F90 | 7 ++++--- biogeochem/EDCohortDynamicsMod.F90 | 5 +++-- biogeochem/EDPatchDynamicsMod.F90 | 12 +++++++----- biogeochem/EDPhysiologyMod.F90 | 3 ++- biogeochem/EDSharedParamsMod.F90 | 2 +- biogeophys/EDSurfaceAlbedoMod.F90 | 7 ++++--- biogeophys/FatesPlantRespPhotosynthMod.F90 | 8 +++++--- main/EDInitMod.F90 | 2 +- main/EDPftvarcon.F90 | 2 +- main/FatesRestartInterfaceMod.F90 | 6 +++--- 10 files changed, 31 insertions(+), 23 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 00a969a7..b4a42463 100755 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -5,7 +5,7 @@ module EDCanopyStructureMod ! 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 FatesConstantsMod , only : r8 => fates_r8 use FatesGlobals , only : fates_log use pftconMod , only : pftcon use EDGrowthFunctionsMod , only : c_area @@ -13,9 +13,10 @@ module EDCanopyStructureMod use EDtypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type, ncwd use EDtypesMod , only : cp_nclmax,cp_nlevcan use EDtypesMod , only : numpft_ed + use FatesGlobals , only : endrun => fates_endrun + + ! CIME Globals use shr_log_mod , only : errMsg => shr_log_errMsg - use abortutils , only : endrun - use FatesGlobals , only : fates_log implicit none private diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 199682bd..7e593386 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -4,12 +4,11 @@ module EDCohortDynamicsMod ! Cohort stuctures in ED. ! ! !USES: - use abortutils , only : endrun + use FatesGlobals , only : endrun => fates_endrun use FatesGlobals , only : fates_log use FatesGlobals , only : freq_day use FatesConstantsMod , only : r8 => fates_r8 use FatesConstantsMod , only : fates_unset_int - use shr_log_mod , only : errMsg => shr_log_errMsg use pftconMod , only : pftcon use EDEcophysContype , only : EDecophyscon use EDGrowthFunctionsMod , only : c_area, tree_lai @@ -18,6 +17,8 @@ module EDCohortDynamicsMod use EDtypesMod , only : ncwd, maxcohortsperpatch use EDtypesMod , only : sclass_ed,nlevsclass_ed,AREA use EDtypesMod , only : min_npm2, min_nppatch, min_n_safemath + ! CIME globals + use shr_log_mod , only : errMsg => shr_log_errMsg ! implicit none private diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 6d7c84eb..b78ae92f 100755 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -3,9 +3,7 @@ module EDPatchDynamicsMod ! ============================================================================ ! Controls formation, creation, fusing and termination of patch level processes. ! ============================================================================ - - use shr_kind_mod , only : r8 => shr_kind_r8; - use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + use clm_varctl , only : iulog use FatesGlobals , only : freq_day use pftconMod , only : pftcon @@ -13,6 +11,12 @@ module EDPatchDynamicsMod use EDtypesMod , only : ncwd, n_dbh_bins, ntol, numpft_ed, area, dbhmax, maxPatchesPerCol use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type use EDTypesMod , only : min_patch_area, cp_numlevgrnd, cp_numSWb + use FatesGlobals , only : endrun => fates_endrun + use FatesConstantsMod , only : r8 => fates_r8 + + ! CIME globals + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + ! implicit none private @@ -878,7 +882,6 @@ subroutine zero_patch(cp_p) ! (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 @@ -1475,7 +1478,6 @@ function countPatches( bounds, nsites, sites ) result ( totNumPatches ) ! ! !USES: use decompMod , only : bounds_type - use abortutils , only : endrun use EDTypesMod , only : ed_site_type ! ! !ARGUMENTS: diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index a4967670..d07dc7d5 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1281,7 +1281,8 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) use EDParamsMod, only : ED_val_ag_biomass use FatesInterfaceMod, only : bc_in_type, bc_out_type use clm_varctl, only : use_vertsoilc - use abortutils , only : endrun + use FatesGlobals, only : endrun => fates_endrun + ! INTERF-TODO: remove the control parameters: exponential_rooting_profile, ! pftspecific_rootingprofile, rootprof_exp, surfprof_exp, zisoi, dzsoi_decomp, zsoi diff --git a/biogeochem/EDSharedParamsMod.F90 b/biogeochem/EDSharedParamsMod.F90 index c4111c12..d6d7d7cb 100644 --- a/biogeochem/EDSharedParamsMod.F90 +++ b/biogeochem/EDSharedParamsMod.F90 @@ -28,7 +28,7 @@ module EDSharedParamsMod subroutine EDParamsReadShared(ncid) ! use ncdio_pio , only : file_desc_t,ncd_io - use abortutils , only : endrun + use FatesGlobals, only : endrun => fates_endrun use shr_log_mod , only : errMsg => shr_log_errMsg ! type(file_desc_t),intent(inout) :: ncid ! pio netCDF file id diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index d7669591..039f64e3 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -13,16 +13,17 @@ module EDSurfaceRadiationMod use EDtypesMod , only : ed_patch_type, ed_site_type use EDtypesMod , only : numpft_ed use EDtypesMod , only : maxPatchesPerCol - use shr_kind_mod , only : r8 => shr_kind_r8 - use shr_log_mod , only : errMsg => shr_log_errMsg + use FatesConstantsMod , only : r8 => fates_r8 use FatesInterfaceMod , only : bc_in_type, & bc_out_type use EDTypesMod , only : cp_numSWb, & ! Actual number of SW radiation bands cp_maxSWb, & ! maximum number of SW bands (for scratch) cp_nclmax ! control parameter, number of SW bands use EDCanopyStructureMod, only: calc_areaindex - + ! CIME globals + use shr_log_mod , only : errMsg => shr_log_errMsg + implicit none private diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index 73f995df..25fe730f 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -20,12 +20,14 @@ module FATESPlantRespPhotosynthMod ! !USES: - use abortutils, only : endrun + use FatesGlobals, only : endrun => fates_endrun use FatesGlobals, only : fates_log use FatesConstantsMod, only : r8 => fates_r8 - use shr_log_mod , only : errMsg => shr_log_errMsg use EDTypesMod, only : use_fates_plant_hydro - + + ! CIME Globals + use shr_log_mod , only : errMsg => shr_log_errMsg + implicit none private diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 76bc5ed9..f1fec24b 100755 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -5,7 +5,7 @@ module EDInitMod ! ============================================================================ use FatesConstantsMod , only : r8 => fates_r8 - use abortutils , only : endrun + use FatesGlobals , only : endrun => fates_endrun use EDTypesMod , only : cp_nclmax use FatesGlobals , only : fates_log use clm_varctl , only : use_ed_spit_fire diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index 475ee7b1..0961e71a 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -58,7 +58,7 @@ subroutine EDpftconrd( ncid ) ! ! !USES: use ncdio_pio , only : file_desc_t, ncd_io - use abortutils , only : endrun + use FatesGlobals, only : endrun => fates_endrun ! ! !ARGUMENTS: implicit none diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 18b77bc6..0ad8fb68 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -6,14 +6,14 @@ module FatesRestartInterfaceMod use FatesConstantsMod , only : fates_short_string_length use FatesConstantsMod , only : fates_long_string_length use FatesGlobals , only : fates_log - + use FatesGlobals , only : endrun => fates_endrun use FatesIODimensionsMod, only : fates_io_dimension_type use FatesIOVariableKindMod, only : fates_io_variable_kind_type use FatesRestartVariableMod, only : fates_restart_variable_type - ! TO BE REMOVED WHEN ERROR HANDLINE IS ADDED (rgk 11-2016) + ! CIME GLOBALS use shr_log_mod , only : errMsg => shr_log_errMsg - use abortutils , only : endrun + implicit none From a1b9d69420e4334bb6762d1a786e1d47af2d46a9 Mon Sep 17 00:00:00 2001 From: ckoven Date: Fri, 20 Jan 2017 18:14:11 -0800 Subject: [PATCH 298/437] fixed some issues that rgknox pointed out in PR --- biogeochem/EDPatchDynamicsMod.F90 | 2 +- main/FatesHistoryInterfaceMod.F90 | 10 +++++----- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index efd17019..7f5ffb94 100755 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -1170,7 +1170,7 @@ subroutine fuse_2_patches(dp, rp) !area weighted average of ages & litter rp%age = (dp%age * dp%area + rp%age * rp%area)/(dp%area + rp%area) - rp%age_class = max(1,count(rp%age-ageclass_ed.ge.0.0_r8)) + rp%age_class = count(rp%age-ageclass_ed.ge.0.0_r8) do p = 1,numpft_ed rp%seeds_in(p) = (rp%seeds_in(p)*rp%area + dp%seeds_in(p)*dp%area)/(rp%area + dp%area) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 11ce1b4c..3681f1d6 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -1343,22 +1343,22 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_canopy_spread_pa) - call this%set_history_var(vname='PFTbiomass', units='gC/m2', & + call this%set_history_var(vname='PFT_BIOMASS', units='gC/m2', & long='total PFT level biomass', use_default='active', & avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_biomass_si_pft ) - call this%set_history_var(vname='PFTleafbiomass', units='gC/m2', & + call this%set_history_var(vname='PFT_LEAF_BIOMASS', units='gC/m2', & long='total PFT level leaf biomass', use_default='active', & avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_leafbiomass_si_pft ) - call this%set_history_var(vname='PFTstorebiomass', units='gC/m2', & + call this%set_history_var(vname='PFT_STORE_BIOMASS', units='gC/m2', & long='total PFT level stored biomass', use_default='active', & avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_storebiomass_si_pft ) - call this%set_history_var(vname='PFTnindivs', units='indiv / m2', & + call this%set_history_var(vname='PFT_N_INDIVS', units='indiv / m2', & long='total PFT level number of individuals', use_default='active', & avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_nindivs_si_pft ) @@ -1380,7 +1380,7 @@ subroutine define_history_vars(this, initialize_variables) ivar=ivar, initialize=initialize_variables, index = ih_canopy_area_si_age ) call this%set_history_var(vname='NCL_BY_AGE', units='--', & - long='number of canopy levels by age bin', use_default='active', & + long='number of canopy levels by age bin', use_default='inactive', & avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_ncl_si_age ) From 706df0a03f05c9068263b7a1d5272b615d76efb9 Mon Sep 17 00:00:00 2001 From: ckoven Date: Fri, 20 Jan 2017 19:19:53 -0800 Subject: [PATCH 299/437] as it turns out, the testing scripts don't like the changed PFT variable names. reverting. --- main/FatesHistoryInterfaceMod.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 3681f1d6..568b9950 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -1343,22 +1343,22 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_canopy_spread_pa) - call this%set_history_var(vname='PFT_BIOMASS', units='gC/m2', & + call this%set_history_var(vname='PFTbiomass', units='gC/m2', & long='total PFT level biomass', use_default='active', & avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_biomass_si_pft ) - call this%set_history_var(vname='PFT_LEAF_BIOMASS', units='gC/m2', & + call this%set_history_var(vname='PFTleafbiomass', units='gC/m2', & long='total PFT level leaf biomass', use_default='active', & avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_leafbiomass_si_pft ) - call this%set_history_var(vname='PFT_STORE_BIOMASS', units='gC/m2', & + call this%set_history_var(vname='PFTstorebiomass', units='gC/m2', & long='total PFT level stored biomass', use_default='active', & avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_storebiomass_si_pft ) - call this%set_history_var(vname='PFT_N_INDIVS', units='indiv / m2', & + call this%set_history_var(vname='PFTnindivs', units='indiv / m2', & long='total PFT level number of individuals', use_default='active', & avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_nindivs_si_pft ) From 5900af9088e3774a1e9c7c7120a760137bf02db3 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 23 Jan 2017 11:34:38 -0800 Subject: [PATCH 300/437] Partial changes to fixing update sequence of cohort and patch dimension globals. --- main/EDTypesMod.F90 | 15 --------------- main/FatesGlobals.F90 | 38 ++++++++++++++++++++++++++++++++------ main/FatesInterfaceMod.F90 | 5 ++--- 3 files changed, 34 insertions(+), 24 deletions(-) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 1817de3e..75eb4631 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -16,21 +16,6 @@ module EDTypesMod real(r8) :: timestep_secs ! subdaily timestep in seconds (e.g. 1800 or 3600) 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 :: maxPatchesPerCol = 10 ! - integer, parameter :: maxCohortsPerPatch = 160 ! - integer, parameter :: cohorts_per_col = 1600 ! This is the max number of individual items one can store per - - ! each grid cell and effects the striding in the ED restart - ! data as some fields are arrays where each array is - ! associated with one cohort integer, parameter :: numWaterMem = 10 ! watermemory saved as site level var diff --git a/main/FatesGlobals.F90 b/main/FatesGlobals.F90 index 517d057b..1c2986fd 100644 --- a/main/FatesGlobals.F90 +++ b/main/FatesGlobals.F90 @@ -5,16 +5,34 @@ module FatesGlobals ! immediately obvious home. use FatesConstantsMod , only : r8 => fates_r8 + use EDTypes , only : cp_nclmax, cp_nlevcan, numpft_ed implicit none - - public :: FatesGlobalsInit public :: fates_log public :: fates_global_verbose public :: SetFatesTime + + ! for setting number of patches per gridcell and number of cohorts per patch + ! for I/O and converting to a vector + + integer, parameter :: maxPatchesPerSite = 10 ! maximum number of patches to live on a site + integer, parameter :: CohortsPerPatch = 160 ! maxCohortsPerPatch is the value that is ultimately + ! used to set array sizes. The arrays that it allocates + ! are sometimes used to hold non-cohort entities. As such + ! the size of those arrays must be the maximum of what we + ! expect from cohorts per patch, and those others. + + integer :: maxCohortsPerPatch ! See above for CohortsPerPatch + integer :: maxCohortsPerSite ! This is the max number of individual items one can store per + ! each grid cell and effects the striding in the ED restart + ! data as some fields are arrays where each array is + ! associated with one cohort + + + ! ------------------------------------------------------------------------------------- ! Timing Variables ! It is assumed that all of the sites on a given machine will be synchronous. @@ -33,22 +51,30 @@ module FatesGlobals ! this is a frequency integer, private :: fates_log_ - logical, private :: fates_global_verbose_ + logical, private, parameter :: fates_global_verbose_ = .false. contains - subroutine FatesGlobalsInit(log_unit, global_verbose) + subroutine FatesGlobalsInit(log_unit) implicit none integer, intent(in) :: log_unit - logical, intent(in) :: global_verbose + + + maxCohortsPerPatch = max(CohortsPerPatch, & + numpft_ed * cp_nclmax * cp_nlevcan) + + maxCohortsPerSite = maxPatchesPerCol * maxCohortsPerPatch + fates_log_ = log_unit fates_global_verbose_ = global_verbose end subroutine FatesGlobalsInit + ! ===================================================================================== + integer function fates_log() fates_log = fates_log_ end function fates_log @@ -112,7 +138,7 @@ subroutine SetFatesTime(current_year_in, current_month_in, & model_day = model_day_in day_of_year = day_of_year_in days_per_year = days_per_year_in - freq_day = freq_day_in + freq_day = freq_day_in end subroutine SetFatesTime diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 272bbfbc..6b996626 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -324,16 +324,15 @@ module FatesInterfaceMod contains ! ==================================================================================== - subroutine FatesInterfaceInit(log_unit, global_verbose) + subroutine FatesInterfaceInit(log_unit) use FatesGlobals, only : FatesGlobalsInit implicit none integer, intent(in) :: log_unit - logical, intent(in) :: global_verbose - call FatesGlobalsInit(log_unit, global_verbose) + call FatesGlobalsInit(log_unit) end subroutine FatesInterfaceInit From 5cb6a871044235336d2da2b47af3ef08d7bcef8d Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 23 Jan 2017 17:31:21 -0800 Subject: [PATCH 301/437] First pass of creating maxElements, having it live in FatesGlobals and having it a dependent variable that goes on to set HLM allocations. This pass also simplifies how HLM cohort<->grid,lu and column mappings are calculated. This is done by removing ed_cohort_vector. In this phase we have not removed that memory structure, but we are bypassing it. --- biogeochem/EDCanopyStructureMod.F90 | 10 +-- biogeochem/EDCohortDynamicsMod.F90 | 8 +- biogeochem/EDPatchDynamicsMod.F90 | 8 +- biogeophys/EDSurfaceAlbedoMod.F90 | 25 ++++--- biogeophys/FatesPlantRespPhotosynthMod.F90 | 6 +- main/EDInitMod.F90 | 5 +- main/EDTypesMod.F90 | 16 ++-- main/FatesGlobals.F90 | 63 +++++++++++----- main/FatesInterfaceMod.F90 | 87 +++++++++++----------- main/FatesRestartInterfaceMod.F90 | 38 +++++----- 10 files changed, 145 insertions(+), 121 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index b4a42463..315d8476 100755 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -11,8 +11,9 @@ module EDCanopyStructureMod use EDGrowthFunctionsMod , only : c_area use EDCohortDynamicsMod , only : copy_cohort, terminate_cohorts, fuse_cohorts use EDtypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type, ncwd - use EDtypesMod , only : cp_nclmax,cp_nlevcan - use EDtypesMod , only : numpft_ed + use FatesGlobals , only : cp_nclmax + use FatesGlobals , only : cp_nlevcan + use FatesGlobals , only : numpft_ed use FatesGlobals , only : endrun => fates_endrun ! CIME Globals @@ -80,7 +81,7 @@ subroutine canopy_structure( currentSite ) use EDParamsMod, only : ED_val_comp_excln, ED_val_ag_biomass use SFParamsMod, only : SF_val_cwd_frac - use EDtypesMod , only : ncwd, min_patch_area, cp_nlevcan + use EDtypesMod , only : ncwd, min_patch_area ! ! !ARGUMENTS type(ed_site_type) , intent(inout), target :: currentSite @@ -593,7 +594,6 @@ subroutine canopy_spread( currentSite ) ! Calculates the spatial spread of tree canopies based on canopy closure. ! ! !USES: - use EDTypesMod , only : cp_nlevcan use EDParamsMod , only : ED_val_maxspread, ED_val_minspread ! ! !ARGUMENTS @@ -773,7 +773,7 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) ! !USES: use EDGrowthFunctionsMod , only : tree_lai, tree_sai, c_area - use EDtypesMod , only : area, dinc_ed, hitemax, numpft_ed, n_hite_bins + use EDtypesMod , only : area, dinc_ed, hitemax, n_hite_bins use EDEcophysConType , only : EDecophyscon ! diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 7e593386..b4b15473 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -13,8 +13,10 @@ module EDCohortDynamicsMod 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, cp_nclmax - use EDtypesMod , only : ncwd, maxcohortsperpatch + use EDTypesMod , only : fusetol + use FatesGlobals , only : cp_nclmax + use EDtypesMod , only : ncwd + use FatesGlobals , only : maxCohortsPerPatch use EDtypesMod , only : sclass_ed,nlevsclass_ed,AREA use EDtypesMod , only : min_npm2, min_nppatch, min_n_safemath ! CIME globals @@ -599,7 +601,7 @@ subroutine fuse_cohorts(patchptr) ! Join similar cohorts to reduce total number ! ! !USES: - use EDTypesMod , only : cp_nlevcan + use FatesGlobals , only : cp_nlevcan ! ! !ARGUMENTS type (ed_patch_type), intent(inout), target :: patchptr diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index b78ae92f..35bf4c3d 100755 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -8,7 +8,9 @@ module EDPatchDynamicsMod use FatesGlobals , only : freq_day 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, maxPatchesPerCol + use EDtypesMod , only : ncwd, n_dbh_bins, ntol, area, dbhmax + use FatesGlobals , only : numpft_ed + use FatesGlobals , only : maxPatchesPerSite use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type use EDTypesMod , only : min_patch_area, cp_numlevgrnd, cp_numSWb use FatesGlobals , only : endrun => fates_endrun @@ -172,7 +174,7 @@ subroutine spawn_patches( currentSite ) ! 10) Area checked, and patchno recalculated. ! ! !USES: - use EDTypesMod , only : cp_nclmax + use FatesGlobals , only : cp_nclmax use EDParamsMod , only : ED_val_maxspread, ED_val_understorey_death use EDCohortDynamicsMod , only : zero_cohort, copy_cohort, terminate_cohorts ! @@ -1021,7 +1023,7 @@ subroutine fuse_patches( csite ) !--------------------------------------------------------------------- !maxpatch = 4 - maxpatch = maxPatchesPerCol + maxpatch = maxPatchesPerSite currentSite => csite diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index 039f64e3..d90fca88 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -11,14 +11,15 @@ module EDSurfaceRadiationMod #include "shr_assert.h" use EDtypesMod , only : ed_patch_type, ed_site_type - use EDtypesMod , only : numpft_ed - use EDtypesMod , only : maxPatchesPerCol + use FatesGlobals , only : numpft_ed + use FatesGlobals , only : maxPatchesPerSite use FatesConstantsMod , only : r8 => fates_r8 use FatesInterfaceMod , only : bc_in_type, & bc_out_type use EDTypesMod , only : cp_numSWb, & ! Actual number of SW radiation bands - cp_maxSWb, & ! maximum number of SW bands (for scratch) - cp_nclmax ! control parameter, number of SW bands + cp_maxSWb ! maximum number of SW bands (for scratch) + + use FatesGlobals , only : cp_nclmax use EDCanopyStructureMod, only: calc_areaindex ! CIME globals @@ -48,7 +49,9 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) ! !USES: use clm_varctl , only : iulog use pftconMod , only : pftcon - use EDtypesMod , only : ed_patch_type, numpft_ed, cp_nlevcan + use EDtypesMod , only : ed_patch_type + use FatesGlobals , only : numpft_ed + use FatesGlobals , only : cp_nlevcan use EDTypesMod , only : ed_site_type @@ -75,8 +78,8 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) real(r8) :: k_dir(numpft_ed) ! Direct beam extinction coefficient real(r8) :: tr_dir_z(cp_nclmax,numpft_ed,cp_nlevcan) ! Exponential transmittance of direct beam radiation through a single layer real(r8) :: tr_dif_z(cp_nclmax,numpft_ed,cp_nlevcan) ! Exponential transmittance of diffuse radiation through a single layer - real(r8) :: forc_dir(maxPatchesPerCol,cp_maxSWb) - real(r8) :: forc_dif(maxPatchesPerCol,cp_maxSWb) + real(r8) :: forc_dir(maxPatchesPerSite,cp_maxSWb) + real(r8) :: forc_dif(maxPatchesPerSite,cp_maxSWb) real(r8) :: weighted_dir_tr(cp_nclmax) real(r8) :: weighted_fsun(cp_nclmax) real(r8) :: weighted_dif_ratio(cp_nclmax,cp_maxSWb) @@ -94,8 +97,8 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) real(r8) :: abs_rad(cp_maxSWb) !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(maxPatchesPerCol,numpft_ed) ! Radiation transmitted to the soil surface. - real(r8) :: phi2b(maxPatchesPerCol,numpft_ed) + real(r8) :: phi1b(maxPatchesPerSite,numpft_ed) ! Radiation transmitted to the soil surface. + real(r8) :: phi2b(maxPatchesPerSite,numpft_ed) real(r8) :: laisum ! cumulative lai+sai for canopy layer (at middle of layer) real(r8) :: angle @@ -108,8 +111,8 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) integer :: fp,iv,s ! array indices integer :: ib ! waveband number real(r8) :: cosz ! 0.001 <= coszen <= 1.000 - real(r8) :: chil(maxPatchesPerCol) ! -0.4 <= xl <= 0.6 - real(r8) :: gdir(maxPatchesPerCol) ! leaf projection in solar direction (0 to 1) + real(r8) :: chil(maxPatchesPerSite) ! -0.4 <= xl <= 0.6 + real(r8) :: gdir(maxPatchesPerSite) ! leaf projection in solar direction (0 to 1) !----------------------------------------------------------------------- diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index 25fe730f..b8610213 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -68,10 +68,10 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) use EDTypesMod , only : ed_patch_type use EDTypesMod , only : ed_cohort_type use EDTypesMod , only : ed_site_type - use EDTypesMod , only : numpft_ed + use FatesGlobals , only : numpft_ed use EDTypesMod , only : cp_numlevsoil - use EDTypesMod , only : cp_nlevcan - use EDTypesMod , only : cp_nclmax + use FatesGlobals , only : cp_nlevcan + use FatesGlobals , only : cp_nclmax use EDEcophysContype , only : EDecophyscon use FatesInterfaceMod , only : bc_in_type use FatesInterfaceMod , only : bc_out_type diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index f1fec24b..aa5850ad 100755 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -6,7 +6,7 @@ module EDInitMod use FatesConstantsMod , only : r8 => fates_r8 use FatesGlobals , only : endrun => fates_endrun - use EDTypesMod , only : cp_nclmax + use FatesGlobals , only : cp_nclmax use FatesGlobals , only : fates_log use clm_varctl , only : use_ed_spit_fire use clm_time_manager , only : is_restart @@ -16,7 +16,8 @@ module EDInitMod use EDCohortDynamicsMod , only : create_cohort, fuse_cohorts, sort_cohorts use EDPatchDynamicsMod , only : create_patch use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type, area - use EDTypesMod , only : cohorts_per_col, ncwd, numpft_ed + use EDTypesMod , only : ncwd + use FatesGlobals , only : numpft_ed implicit none private diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 75eb4631..ec900b43 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -1,10 +1,9 @@ module EDTypesMod use shr_kind_mod , only : r8 => shr_kind_r8; - use decompMod , only : bounds_type - use clm_varpar , only : nlevgrnd, mxpft - use domainMod , only : domain_type - use shr_sys_mod , only : shr_sys_flush + use clm_varpar , only : mxpft + use FatesGlobals , only : cp_nclmax, cp_nlevcan, numpft_ed + implicit none save @@ -25,7 +24,7 @@ module EDTypesMod 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. + integer , parameter :: maxPft = 79 ! max number of PFTs potentially used by CLM @@ -96,11 +95,7 @@ module EDTypesMod ! Control Parameters (cp_) ! ------------------------------------------------------------------------------------- - ! These parameters are dictated by FATES internals - - integer, parameter :: cp_nclmax = 2 ! Maximum number of canopy layers - integer, parameter :: cp_nlevcan = 40 ! number of leaf layers in canopy layer integer, parameter :: cp_maxSWb = 2 ! maximum number of broad-bands in the ! shortwave spectrum cp_numSWb <= cp_maxSWb @@ -566,7 +561,7 @@ subroutine ed_hist_scpfmaps integer :: i integer :: isc integer :: ipft - + allocate( levsclass_ed(1:nlevsclass_ed )) allocate( pft_levscpf_ed(1:nlevsclass_ed*mxpft)) allocate(scls_levscpf_ed(1:nlevsclass_ed*mxpft)) @@ -628,7 +623,6 @@ subroutine set_root_fraction( this , depth_gl) ! Calculates the fractions of the root biomass in each layer for each pft. ! ! !USES: - use PatchType , only : clmpatch => patch use pftconMod , only : pftcon ! ! !ARGUMENTS diff --git a/main/FatesGlobals.F90 b/main/FatesGlobals.F90 index 1c2986fd..47bdf6cd 100644 --- a/main/FatesGlobals.F90 +++ b/main/FatesGlobals.F90 @@ -5,7 +5,7 @@ module FatesGlobals ! immediately obvious home. use FatesConstantsMod , only : r8 => fates_r8 - use EDTypes , only : cp_nclmax, cp_nlevcan, numpft_ed +! use EDTypesMod , only : cp_nclmax, cp_nlevcan, numpft_ed implicit none @@ -13,24 +13,41 @@ module FatesGlobals public :: fates_log public :: fates_global_verbose public :: SetFatesTime + public :: set_fates_global_elements ! for setting number of patches per gridcell and number of cohorts per patch ! for I/O and converting to a vector - integer, parameter :: maxPatchesPerSite = 10 ! maximum number of patches to live on a site - integer, parameter :: CohortsPerPatch = 160 ! maxCohortsPerPatch is the value that is ultimately - ! used to set array sizes. The arrays that it allocates - ! are sometimes used to hold non-cohort entities. As such - ! the size of those arrays must be the maximum of what we - ! expect from cohorts per patch, and those others. + integer, parameter :: maxPatchesPerSite = 10 ! maximum number of patches to live on a site + integer, parameter :: maxCohortsPerPatch = 160 ! maximum number of cohorts to live on a patch - integer :: maxCohortsPerPatch ! See above for CohortsPerPatch - integer :: maxCohortsPerSite ! This is the max number of individual items one can store per - ! each grid cell and effects the striding in the ED restart - ! data as some fields are arrays where each array is - ! associated with one cohort + ! Variables mostly used for dimensioning host land model (HLM) array spaces + + integer, protected :: maxElementsPerPatch ! maxElementsPerPatch is the value that is ultimately + ! used to set the size of the largest arrays necessary + ! in things like restart files (probably hosted by the + ! HLM). The size of these arrays are not a parameter + ! because it is simply the maximum of several different + ! dimensions. It is possible that this would be the + ! maximum number of cohorts per patch, but + ! but it could be other things. + + integer, protected :: maxElementsPerSite ! This is the max number of individual items one can store per + ! each grid cell and effects the striding in the ED restart + ! data as some fields are arrays where each array is + ! associated with one cohort + + integer, protected :: maxCohortsPerSite ! Maximum number of cohorts that can exist in a given + ! site. Its possible this is not used. + + + integer, parameter :: cp_nclmax = 2 ! Maximum number of canopy layers + + integer, parameter :: cp_nlevcan = 40 ! number of leaf layers in canopy layer + + integer , parameter :: numpft_ed = 2 ! number of PFTs used in ED. ! ------------------------------------------------------------------------------------- @@ -51,22 +68,30 @@ module FatesGlobals ! this is a frequency integer, private :: fates_log_ - logical, private, parameter :: fates_global_verbose_ = .false. + logical, private :: fates_global_verbose_ contains - subroutine FatesGlobalsInit(log_unit) + subroutine set_fates_global_elements() + implicit none - implicit none + maxElementsPerPatch = max(maxCohortsPerPatch, & + numpft_ed * cp_nclmax * cp_nlevcan) + + maxCohortsPerSite = maxPatchesPerSite * maxCohortsPerPatch + + maxElementsPerSite = maxPatchesPerSite * maxElementsPerPatch - integer, intent(in) :: log_unit + end subroutine set_fates_global_elements + ! ===================================================================================== - maxCohortsPerPatch = max(CohortsPerPatch, & - numpft_ed * cp_nclmax * cp_nlevcan) + subroutine FatesGlobalsInit(log_unit,global_verbose) - maxCohortsPerSite = maxPatchesPerCol * maxCohortsPerPatch + implicit none + integer, intent(in) :: log_unit + logical, intent(in) :: global_verbose fates_log_ = log_unit fates_global_verbose_ = global_verbose diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 6b996626..569af025 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -10,8 +10,8 @@ module FatesInterfaceMod ! ------------------------------------------------------------------------------------ use EDtypesMod , only : ed_site_type - use EDtypesMod , only : maxPatchesPerCol - use EDtypesMod , only : cp_nclmax + use FatesGlobals , only : maxPatchesPerSite + use FatesGlobals , only : cp_nclmax use EDtypesMod , only : cp_numSWb use EDtypesMod , only : cp_numlevgrnd use EDtypesMod , only : cp_maxSWb @@ -324,15 +324,16 @@ module FatesInterfaceMod contains ! ==================================================================================== - subroutine FatesInterfaceInit(log_unit) + subroutine FatesInterfaceInit(log_unit,global_verbose) use FatesGlobals, only : FatesGlobalsInit implicit none integer, intent(in) :: log_unit + logical, intent(in) :: global_verbose - call FatesGlobalsInit(log_unit) + call FatesGlobalsInit(log_unit,global_verbose) end subroutine FatesInterfaceInit @@ -372,15 +373,15 @@ subroutine allocate_bcin(bc_in) ! Allocate input boundaries ! Vegetation Dynamics - allocate(bc_in%t_veg24_pa(maxPatchesPerCol)) + allocate(bc_in%t_veg24_pa(maxPatchesPerSite)) - allocate(bc_in%wind24_pa(maxPatchesPerCol)) - allocate(bc_in%relhumid24_pa(maxPatchesPerCol)) - allocate(bc_in%precip24_pa(maxPatchesPerCol)) + allocate(bc_in%wind24_pa(maxPatchesPerSite)) + allocate(bc_in%relhumid24_pa(maxPatchesPerSite)) + allocate(bc_in%precip24_pa(maxPatchesPerSite)) ! Radiation - allocate(bc_in%solad_parb(maxPatchesPerCol,cp_numSWb)) - allocate(bc_in%solai_parb(maxPatchesPerCol,cp_numSWb)) + allocate(bc_in%solad_parb(maxPatchesPerSite,cp_numSWb)) + allocate(bc_in%solai_parb(maxPatchesPerSite,cp_numSWb)) ! Hydrology allocate(bc_in%smp_gl(cp_numlevgrnd)) @@ -390,20 +391,20 @@ subroutine allocate_bcin(bc_in) allocate(bc_in%h2o_liqvol_gl(cp_numlevgrnd)) ! Photosynthesis - allocate(bc_in%filter_photo_pa(maxPatchesPerCol)) - allocate(bc_in%dayl_factor_pa(maxPatchesPerCol)) - allocate(bc_in%esat_tv_pa(maxPatchesPerCol)) - allocate(bc_in%eair_pa(maxPatchesPerCol)) - allocate(bc_in%oair_pa(maxPatchesPerCol)) - allocate(bc_in%cair_pa(maxPatchesPerCol)) - allocate(bc_in%rb_pa(maxPatchesPerCol)) - allocate(bc_in%t_veg_pa(maxPatchesPerCol)) - allocate(bc_in%tgcm_pa(maxPatchesPerCol)) + allocate(bc_in%filter_photo_pa(maxPatchesPerSite)) + allocate(bc_in%dayl_factor_pa(maxPatchesPerSite)) + allocate(bc_in%esat_tv_pa(maxPatchesPerSite)) + allocate(bc_in%eair_pa(maxPatchesPerSite)) + allocate(bc_in%oair_pa(maxPatchesPerSite)) + allocate(bc_in%cair_pa(maxPatchesPerSite)) + allocate(bc_in%rb_pa(maxPatchesPerSite)) + allocate(bc_in%t_veg_pa(maxPatchesPerSite)) + allocate(bc_in%tgcm_pa(maxPatchesPerSite)) allocate(bc_in%t_soisno_gl(cp_numlevgrnd)) ! Canopy Radiation - allocate(bc_in%filter_vegzen_pa(maxPatchesPerCol)) - allocate(bc_in%coszen_pa(maxPatchesPerCol)) + allocate(bc_in%filter_vegzen_pa(maxPatchesPerSite)) + allocate(bc_in%coszen_pa(maxPatchesPerSite)) allocate(bc_in%albgr_dir_rb(cp_numSWb)) allocate(bc_in%albgr_dif_rb(cp_numSWb)) @@ -427,28 +428,28 @@ subroutine allocate_bcout(bc_out) ! Radiation - allocate(bc_out%fsun_pa(maxPatchesPerCol)) - allocate(bc_out%laisun_pa(maxPatchesPerCol)) - allocate(bc_out%laisha_pa(maxPatchesPerCol)) + allocate(bc_out%fsun_pa(maxPatchesPerSite)) + allocate(bc_out%laisun_pa(maxPatchesPerSite)) + allocate(bc_out%laisha_pa(maxPatchesPerSite)) ! Hydrology allocate(bc_out%active_suction_gl(cp_numlevgrnd)) - allocate(bc_out%rootr_pagl(maxPatchesPerCol,cp_numlevgrnd)) - allocate(bc_out%btran_pa(maxPatchesPerCol)) + allocate(bc_out%rootr_pagl(maxPatchesPerSite,cp_numlevgrnd)) + allocate(bc_out%btran_pa(maxPatchesPerSite)) ! Photosynthesis - allocate(bc_out%rssun_pa(maxPatchesPerCol)) - allocate(bc_out%rssha_pa(maxPatchesPerCol)) + allocate(bc_out%rssun_pa(maxPatchesPerSite)) + allocate(bc_out%rssha_pa(maxPatchesPerSite)) ! Canopy Radiation - allocate(bc_out%albd_parb(maxPatchesPerCol,cp_numSWb)) - allocate(bc_out%albi_parb(maxPatchesPerCol,cp_numSWb)) - allocate(bc_out%fabd_parb(maxPatchesPerCol,cp_numSWb)) - allocate(bc_out%fabi_parb(maxPatchesPerCol,cp_numSWb)) - allocate(bc_out%ftdd_parb(maxPatchesPerCol,cp_numSWb)) - allocate(bc_out%ftid_parb(maxPatchesPerCol,cp_numSWb)) - allocate(bc_out%ftii_parb(maxPatchesPerCol,cp_numSWb)) + allocate(bc_out%albd_parb(maxPatchesPerSite,cp_numSWb)) + allocate(bc_out%albi_parb(maxPatchesPerSite,cp_numSWb)) + allocate(bc_out%fabd_parb(maxPatchesPerSite,cp_numSWb)) + allocate(bc_out%fabi_parb(maxPatchesPerSite,cp_numSWb)) + allocate(bc_out%ftdd_parb(maxPatchesPerSite,cp_numSWb)) + allocate(bc_out%ftid_parb(maxPatchesPerSite,cp_numSWb)) + allocate(bc_out%ftii_parb(maxPatchesPerSite,cp_numSWb)) ! biogeochemistry allocate(bc_out%FATES_c_to_litr_lab_c_col(cp_numlevdecomp_full)) @@ -456,14 +457,14 @@ subroutine allocate_bcout(bc_out) allocate(bc_out%FATES_c_to_litr_lig_c_col(cp_numlevdecomp_full)) ! Canopy Structure - allocate(bc_out%elai_pa(maxPatchesPerCol)) - allocate(bc_out%esai_pa(maxPatchesPerCol)) - allocate(bc_out%tlai_pa(maxPatchesPerCol)) - allocate(bc_out%tsai_pa(maxPatchesPerCol)) - allocate(bc_out%htop_pa(maxPatchesPerCol)) - allocate(bc_out%hbot_pa(maxPatchesPerCol)) - allocate(bc_out%canopy_fraction_pa(maxPatchesPerCol)) - allocate(bc_out%frac_veg_nosno_alb_pa(maxPatchesPerCol)) + allocate(bc_out%elai_pa(maxPatchesPerSite)) + allocate(bc_out%esai_pa(maxPatchesPerSite)) + allocate(bc_out%tlai_pa(maxPatchesPerSite)) + allocate(bc_out%tsai_pa(maxPatchesPerSite)) + allocate(bc_out%htop_pa(maxPatchesPerSite)) + allocate(bc_out%hbot_pa(maxPatchesPerSite)) + allocate(bc_out%canopy_fraction_pa(maxPatchesPerSite)) + allocate(bc_out%frac_veg_nosno_alb_pa(maxPatchesPerSite)) return diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 0ad8fb68..41de351b 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -905,14 +905,13 @@ end subroutine set_restart_var subroutine set_restart_vectors(this,nc,nsites,sites) - use EDTypesMod, only : cp_nclmax - use EDTypesMod, only : cp_nlevcan - use EDTypesMod, only : maxCohortsPerPatch - use EDTypesMod, only : numpft_ed + use FatesGlobals, only : cp_nclmax + use FatesGlobals, only : cp_nlevcan + use FatesGlobals, only : maxElementsPerPatch + use FatesGlobals, only : numpft_ed use EDTypesMod, only : ed_site_type use EDTypesMod, only : ed_cohort_type use EDTypesMod, only : ed_patch_type - use EDTypesMod, only : cohorts_per_col use EDTypesMod, only : ncwd use EDTypesMod, only : numWaterMem @@ -1148,7 +1147,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) if ( DEBUG ) then write(fates_log(),*) 'offsetNumCohorts III ' & - ,io_idx_co,cohorts_per_col, cohortsperpatch + ,io_idx_co,cohortsperpatch endif ! ! deal with patch level fields of arrays here @@ -1196,7 +1195,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ! Set the first cohort index to the start of the next patch, increment ! by the maximum number of cohorts per patch - io_idx_co_1st = io_idx_co_1st + maxCohortsPerPatch + io_idx_co_1st = io_idx_co_1st + maxElementsPerPatch ! reset counters so that they are all advanced evenly. Currently ! the offset is 10, the max of numpft_ed, ncwd, cp_nclmax, @@ -1209,7 +1208,6 @@ subroutine set_restart_vectors(this,nc,nsites,sites) if ( DEBUG ) then write(fates_log(),*) 'CLTV io_idx_co_1st ', io_idx_co_1st - write(fates_log(),*) 'CLTV cohorts_per_col ', cohorts_per_col write(fates_log(),*) 'CLTV numCohort ', cohortsperpatch write(fates_log(),*) 'CLTV totalCohorts ', totalCohorts end if @@ -1275,10 +1273,10 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites ) use EDTypesMod, only : ed_cohort_type use EDTypesMod, only : ed_patch_type use EDTypesMod, only : ncwd - use EDTypesMod, only : cp_nlevcan - use EDTypesMod, only : cp_nclmax - use EDTypesMod, only : maxCohortsPerPatch - use EDTypesMod, only : numpft_ed + use FatesGlobals, only : cp_nlevcan + use FatesGlobals, only : cp_nclmax + use FatesGlobals, only : maxElementsPerPatch + use FatesGlobals, only : numpft_ed use EDTypesMod, only : area use EDPatchDynamicsMod, only : zero_patch use EDGrowthFunctionsMod, only : Dbh @@ -1453,7 +1451,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites ) endif - io_idx_co_1st = io_idx_co_1st + maxCohortsPerPatch + io_idx_co_1st = io_idx_co_1st + maxElementsPerPatch enddo ! ends loop over idx_pa @@ -1469,12 +1467,11 @@ subroutine get_restart_vectors(this, nc, nsites, sites) use EDTypesMod, only : ed_site_type use EDTypesMod, only : ed_cohort_type use EDTypesMod, only : ed_patch_type - use EDTypesMod, only : numpft_ed + use FatesGlobals, only : numpft_ed use EDTypesMod, only : ncwd - use EDTypesMod, only : cp_nlevcan - use EDTypesMod, only : cp_nclmax - use EDTypesMod, only : maxCohortsPerPatch - use EDTypesMod, only : cohorts_per_col + use FatesGlobals, only : cp_nlevcan + use FatesGlobals, only : cp_nclmax + use FatesGlobals, only : maxElementsPerPatch use EDTypesMod, only : numWaterMem ! !ARGUMENTS: @@ -1699,7 +1696,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) if ( DEBUG ) then write(fates_log(),*) 'CVTL III ' & - ,io_idx_co,cohorts_per_col, cohortsperpatch + ,io_idx_co,cohortsperpatch endif ! ! deal with patch level fields of arrays here @@ -1746,7 +1743,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ! Now increment the position of the first cohort to that of the next ! patch - io_idx_co_1st = io_idx_co_1st + maxCohortsPerPatch + io_idx_co_1st = io_idx_co_1st + maxElementsPerPatch ! and max the number of allowed cohorts per patch io_idx_pa_pft = io_idx_co_1st @@ -1757,7 +1754,6 @@ subroutine get_restart_vectors(this, nc, nsites, sites) if ( DEBUG ) then write(fates_log(),*) 'CVTL io_idx_co_1st ', io_idx_co_1st - write(fates_log(),*) 'CVTL cohorts_per_col ', cohorts_per_col write(fates_log(),*) 'CVTL cohortsperpatch ', cohortsperpatch write(fates_log(),*) 'CVTL totalCohorts ', totalCohorts end if From f79e3b7d3340ef212ea7f7f9387f20bddebbfde2 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 24 Jan 2017 14:04:12 -0800 Subject: [PATCH 302/437] Removed the ed_vec_cohort structure. --- main/EDVecCohortType.F90 | 42 ---------------------------------------- 1 file changed, 42 deletions(-) delete mode 100644 main/EDVecCohortType.F90 diff --git a/main/EDVecCohortType.F90 b/main/EDVecCohortType.F90 deleted file mode 100644 index feefd135..00000000 --- a/main/EDVecCohortType.F90 +++ /dev/null @@ -1,42 +0,0 @@ -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_column - integer , pointer :: column(:) !index into column 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%column(beg:end)) - - end subroutine Init - -end module EDVecCohortType From cb6b124292523a4bb065ad7a2256ad7001eedaef Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 25 Jan 2017 15:05:45 -0800 Subject: [PATCH 303/437] This commit completes the re-shuffling of global variables in fates in this phase. The difference is that scalars dictated by the hlm going into fates are now living in FatesInterface mod where their wrappers are. Likewise, the varialbes that are dictated by fates and are destined for the HLM are also in this module, as are the wrapper call functions. The wrapper call functions to set fates_maxElementsPerPatch and fates_maxElementsPerSite are called during Initialize1(), and fates_maxElementsPerSite is now used during decompInit instead of the ed_vec_cohort structure. --- biogeochem/EDCanopyStructureMod.F90 | 52 ++-- biogeochem/EDCohortDynamicsMod.F90 | 29 +- biogeochem/EDGrowthFunctionsMod.F90 | 16 +- biogeochem/EDPatchDynamicsMod.F90 | 112 +++++--- biogeochem/EDPhysiologyMod.F90 | 130 ++++----- biogeophys/EDAccumulateFluxesMod.F90 | 10 +- biogeophys/EDBtranMod.F90 | 22 +- biogeophys/EDSurfaceAlbedoMod.F90 | 186 +++++++------ biogeophys/FatesPlantRespPhotosynthMod.F90 | 30 +-- fire/SFMainMod.F90 | 76 +++--- fire/SFParamsMod.F90 | 2 +- main/EDInitMod.F90 | 11 +- main/EDMainMod.F90 | 83 +++--- main/EDTypesMod.F90 | 245 +++++------------ main/FatesConstantsMod.F90 | 4 + main/FatesGlobals.F90 | 94 +------ main/FatesHistoryInterfaceMod.F90 | 28 +- main/FatesInterfaceMod.F90 | 291 +++++++++++++++------ main/FatesRestartInterfaceMod.F90 | 52 ++-- 19 files changed, 729 insertions(+), 744 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 315d8476..65069708 100755 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -11,9 +11,9 @@ module EDCanopyStructureMod use EDGrowthFunctionsMod , only : c_area use EDCohortDynamicsMod , only : copy_cohort, terminate_cohorts, fuse_cohorts use EDtypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type, ncwd - use FatesGlobals , only : cp_nclmax - use FatesGlobals , only : cp_nlevcan - use FatesGlobals , only : numpft_ed + use EDTypesMod , only : nclmax + use EDTypesMod , only : nlevcan + use EDTypesMod , only : numpft_ed use FatesGlobals , only : endrun => fates_endrun ! CIME Globals @@ -96,10 +96,10 @@ subroutine canopy_structure( currentSite ) real(r8) :: cc_loss real(r8) :: lossarea real(r8) :: newarea - real(r8) :: arealayer(cp_nlevcan) ! Amount of plant area currently in each canopy layer - real(r8) :: sumdiff(cp_nlevcan) ! The total of the exclusion weights for all cohorts in layer z + real(r8) :: arealayer(nlevcan) ! Amount of plant area currently in each canopy layer + real(r8) :: sumdiff(nlevcan) ! 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(cp_nlevcan) + real(r8) :: sum_weights(nlevcan) real(r8) :: new_total_area_check real(r8) :: missing_area, promarea,cc_gain,sumgain integer :: promswitch,lower_cohort_switch @@ -140,7 +140,7 @@ subroutine canopy_structure( currentSite ) z = z + 1 endif - currentPatch%NCL_p = min(cp_nclmax,z) ! Set current canopy layer occupancy indicator. + currentPatch%NCL_p = min(nclmax,z) ! Set current canopy layer occupancy indicator. do i = 1,z ! Loop around the currently occupied canopy layers. @@ -201,7 +201,7 @@ subroutine canopy_structure( currentSite ) 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 > cp_nclmax)then + if(i+1 > nclmax)then !put the litter from the terminated cohorts into the fragmenting pools ! write(fates_log(),*) '3rd canopy layer' do c=1,ncwd @@ -246,8 +246,8 @@ subroutine canopy_structure( currentSite ) 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 cp_nclmax=2) - if(i+1 > cp_nclmax)then + !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 @@ -294,7 +294,7 @@ subroutine canopy_structure( currentSite ) enddo !arealayer loop if(arealayer(i)-currentPatch%area > 0.00001_r8)then - write(fates_log(),*) 'lossarea problem', lossarea,sumloss,z,currentPatch%patchno,currentPatch%clm_pno + write(fates_log(),*) 'lossarea problem', lossarea,sumloss,z,currentPatch%patchno endif enddo !z @@ -319,7 +319,7 @@ subroutine canopy_structure( currentSite ) excess_area = arealayer(j)-currentPatch%area endif enddo - currentPatch%ncl_p = min(z,cp_nclmax) + currentPatch%ncl_p = min(z,nclmax) enddo !is there still excess area in any layer? @@ -494,7 +494,7 @@ subroutine canopy_structure( currentSite ) if(currentPatch%area-arealayer(i) < 0.000001_r8)then !write(fates_log(),*) 'gainarea problem',sumgain,arealayer(i),currentPatch%area,z, & - !currentPatch%patchno,currentPatch%clm_pno,currentPatch%area - arealayer(i),i,missing_area,count_mi + !currentPatch%patchno,currentPatch%area - arealayer(i),i,missing_area,count_mi endif if(promswitch == 1)then ! write(fates_log(),*) 'z loop',arealayer(1:3),currentPatch%patchno,z @@ -521,7 +521,7 @@ subroutine canopy_structure( currentSite ) endif endif enddo - currentPatch%ncl_p = min(z,cp_nclmax) + currentPatch%ncl_p = min(z,nclmax) if(promswitch == 1)then ! write(fates_log(),*) 'missingarea loop',arealayer(1:3),currentPatch%patchno,missing_area,z endif @@ -532,7 +532,7 @@ subroutine canopy_structure( currentSite ) call terminate_cohorts(currentPatch) if(promswitch == 1)then - !write(fates_log(),*) 'going into cohort check',currentPatch%clm_pno + !write(fates_log(),*) 'going into cohort check' endif ! ----------- Check cohort area ------------------------------! do i = 1,z @@ -602,7 +602,7 @@ subroutine canopy_spread( currentSite ) ! !LOCAL VARIABLES: type (ed_cohort_type), pointer :: currentCohort type (ed_patch_type) , pointer :: currentPatch - real(r8) :: arealayer(cp_nlevcan) ! Amount of canopy in each layer. + real(r8) :: arealayer(nlevcan) ! Amount of canopy in each layer. real(r8) :: inc ! Arbitrary daily incremental change in canopy area integer :: z !---------------------------------------------------------------------- @@ -625,7 +625,7 @@ subroutine canopy_spread( currentSite ) enddo !If the canopy area is approaching closure, squash the tree canopies and make them taller and thinner - do z = 1,cp_nclmax + do z = 1,nclmax if(arealayer(z)/currentPatch%area > 0.9_r8)then currentPatch%spread(z) = currentPatch%spread(z) - inc @@ -660,6 +660,7 @@ subroutine canopy_summarization( nsites, sites, bc_in ) use FatesInterfaceMod , only : bc_in_type use EDPatchDynamicsMod , only : set_patchno + use EDPatchDYnamicsMod , only : set_root_fraction use EDCohortDynamicsMod , only : size_and_type_class_index use EDGrowthFunctionsMod , only : tree_lai, c_area use EDEcophysConType , only : EDecophyscon @@ -699,7 +700,7 @@ subroutine canopy_summarization( nsites, sites, bc_in ) do while(associated(currentPatch)) - call currentPatch%set_root_fraction(bc_in(s)%depth_gl) + call set_root_fraction(currentPatch,bc_in(s)%depth_gl) !zero cohort-summed variables. currentPatch%total_canopy_area = 0.0_r8 @@ -849,7 +850,7 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) max(currentPatch%ncan(currentCohort%canopy_layer,currentCohort%pft),currentCohort%NV) currentPatch%lai = currentPatch%lai +currentCohort%lai - do L = 1,cp_nclmax-1 + 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 @@ -1102,10 +1103,10 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) /currentPatch%tlai_profile(L,ft,iv) enddo - currentPatch%tlai_profile(L,ft,currentPatch%nrad(L,ft)+1: cp_nlevcan) = 0._r8 - currentPatch%tsai_profile(L,ft,currentPatch%nrad(L,ft)+1: cp_nlevcan) = 0._r8 - currentPatch%elai_profile(L,ft,currentPatch%nrad(L,ft)+1: cp_nlevcan) = 0._r8 - currentPatch%esai_profile(L,ft,currentPatch%nrad(L,ft)+1: cp_nlevcan) = 0._r8 + currentPatch%tlai_profile(L,ft,currentPatch%nrad(L,ft)+1: nlevcan) = 0._r8 + currentPatch%tsai_profile(L,ft,currentPatch%nrad(L,ft)+1: nlevcan) = 0._r8 + currentPatch%elai_profile(L,ft,currentPatch%nrad(L,ft)+1: nlevcan) = 0._r8 + currentPatch%esai_profile(L,ft,currentPatch%nrad(L,ft)+1: nlevcan) = 0._r8 enddo enddo @@ -1163,7 +1164,7 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) do L = 1,currentPatch%NCL_p do ft = 1,numpft_ed if(currentPatch%present(L,FT) > 1)then - write(fates_log(), *) 'ED: present issue',currentPatch%clm_pno,L,ft,currentPatch%present(L,FT) + write(fates_log(), *) 'ED: present issue',L,ft,currentPatch%present(L,FT) currentPatch%present(L,ft) = 1 endif enddo @@ -1190,7 +1191,6 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) use EDTypesMod , only : ed_patch_type, ed_cohort_type, & ed_site_type, AREA use FatesInterfaceMod , only : bc_out_type - use ColumnType , only : col ! THIS MUST BE REMOVED WITH CLM_PNO ! ! !ARGUMENTS @@ -1214,8 +1214,6 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) do while(associated(currentPatch)) ifp = ifp+1 - currentPatch%clm_pno = ifp + col%patchi(c) ! THIS IS SLOWLY BEING REMOVED - if ( currentPatch%total_canopy_area-currentPatch%area > 0.000001_r8 ) then write(fates_log(),*) 'ED: canopy area bigger than area',currentPatch%total_canopy_area ,currentPatch%area currentPatch%total_canopy_area = currentPatch%area diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index b4b15473..8a40de4d 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -6,7 +6,7 @@ module EDCohortDynamicsMod ! !USES: use FatesGlobals , only : endrun => fates_endrun use FatesGlobals , only : fates_log - use FatesGlobals , only : freq_day + use FatesInterfaceMod , only : hlm_freq_day use FatesConstantsMod , only : r8 => fates_r8 use FatesConstantsMod , only : fates_unset_int use pftconMod , only : pftcon @@ -14,11 +14,12 @@ module EDCohortDynamicsMod use EDGrowthFunctionsMod , only : c_area, tree_lai use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type use EDTypesMod , only : fusetol - use FatesGlobals , only : cp_nclmax - use EDtypesMod , only : ncwd - use FatesGlobals , only : maxCohortsPerPatch - use EDtypesMod , only : sclass_ed,nlevsclass_ed,AREA - use EDtypesMod , only : min_npm2, min_nppatch, min_n_safemath + use EDTypesMod , only : nclmax + use EDTypesMod , only : ncwd + use EDTypesMod , only : maxCohortsPerPatch + use EDTypesMod , only : sclass_ed,nlevsclass_ed,AREA + use EDTypesMod , only : min_npm2, min_nppatch + use EDTypesMod , only : min_n_safemath ! CIME globals use shr_log_mod , only : errMsg => shr_log_errMsg ! @@ -227,7 +228,7 @@ subroutine allocate_live_biomass(cc_p,mode) if(mode==1)then ! it will not be able to put out as many leaves as it had previous timestep currentcohort%npp_leaf = currentcohort%npp_leaf + & - max(0.0_r8,currentcohort%balive*leaf_frac - currentcohort%bl)/freq_day + max(0.0_r8,currentcohort%balive*leaf_frac - currentcohort%bl)/hlm_freq_day end if currentcohort%bl = currentcohort%balive*leaf_frac @@ -238,10 +239,10 @@ subroutine allocate_live_biomass(cc_p,mode) currentcohort%npp_froot = currentcohort%npp_froot + & max(0._r8,pftcon%froot_leaf(ft)*(currentcohort%balive+currentcohort%laimemory)*leaf_frac - currentcohort%br) / & - freq_day + hlm_freq_day currentcohort%npp_bsw = max(0._r8,EDecophyscon%sapwood_ratio(ft) * currentcohort%hite *(currentcohort%balive + & - currentcohort%laimemory)*leaf_frac - currentcohort%bsw)/freq_day + currentcohort%laimemory)*leaf_frac - currentcohort%bsw)/hlm_freq_day currentcohort%npp_bdead = currentCohort%dbdeaddt @@ -276,10 +277,10 @@ subroutine allocate_live_biomass(cc_p,mode) currentcohort%npp_froot = currentcohort%npp_froot + & max(0.0_r8,pftcon%froot_leaf(ft)*(ideal_balive + & - currentcohort%laimemory)*leaf_frac*ratio_balive-currentcohort%br)/freq_day + currentcohort%laimemory)*leaf_frac*ratio_balive-currentcohort%br)/hlm_freq_day currentcohort%npp_bsw = max(0.0_r8,EDecophyscon%sapwood_ratio(ft) * currentcohort%hite *(ideal_balive + & - currentcohort%laimemory)*leaf_frac*ratio_balive - currentcohort%bsw)/freq_day + currentcohort%laimemory)*leaf_frac*ratio_balive - currentcohort%bsw)/hlm_freq_day currentcohort%npp_bdead = currentCohort%dbdeaddt @@ -529,7 +530,7 @@ subroutine terminate_cohorts( patchptr ) endif ! In the third canopy layer - if (currentCohort%canopy_layer > cp_nclmax ) then + if (currentCohort%canopy_layer > nclmax ) then terminate = 1 if ( DEBUG ) then write(fates_log(),*) 'terminating cohorts 2', currentCohort%canopy_layer @@ -601,7 +602,7 @@ subroutine fuse_cohorts(patchptr) ! Join similar cohorts to reduce total number ! ! !USES: - use FatesGlobals , only : cp_nlevcan + use EDTypesMod , only : nlevcan ! ! !ARGUMENTS type (ed_patch_type), intent(inout), target :: patchptr @@ -753,7 +754,7 @@ subroutine fuse_cohorts(patchptr) currentCohort%npp_bseed = (currentCohort%n*currentCohort%npp_bseed + nextc%n*nextc%npp_bseed)/newn currentCohort%npp_store = (currentCohort%n*currentCohort%npp_store + nextc%n*nextc%npp_store)/newn - do i=1, cp_nlevcan + do i=1, nlevcan 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 diff --git a/biogeochem/EDGrowthFunctionsMod.F90 b/biogeochem/EDGrowthFunctionsMod.F90 index 12a46c79..cd330f1c 100755 --- a/biogeochem/EDGrowthFunctionsMod.F90 +++ b/biogeochem/EDGrowthFunctionsMod.F90 @@ -6,11 +6,11 @@ module EDGrowthFunctionsMod ! At present, there is only a single allocation trajectory. ! ============================================================================ - use shr_kind_mod , only : r8 => shr_kind_r8 + use FatesConstantsMod, only : r8 => fates_r8 use FatesGlobals , only : fates_log use pftconMod , only : pftcon use EDEcophysContype , only : EDecophyscon - use EDTypesMod , only : ed_cohort_type, cp_nlevcan, dinc_ed + use EDTypesMod , only : ed_cohort_type, nlevcan, dinc_ed implicit none private @@ -159,10 +159,10 @@ real(r8) function tree_lai( cohort_in ) 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 cp_nlevcan default is 40, which is very large, so exceeding this would clearly illustrate a + ! at the moments nlevcan default is 40, which is very large, so exceeding this would clearly illustrate a ! huge error - if(cohort_in%treelai > cp_nlevcan*dinc_ed)then - write(fates_log(),*) 'too much lai' , cohort_in%treelai , cohort_in%pft , cp_nlevcan * dinc_ed + if(cohort_in%treelai > nlevcan*dinc_ed)then + write(fates_log(),*) 'too much lai' , cohort_in%treelai , cohort_in%pft , nlevcan * dinc_ed endif return @@ -196,10 +196,10 @@ real(r8) function tree_sai( cohort_in ) 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 cp_nlevcan default is 40, which is very large, so exceeding this would clearly illustrate a + ! at the moments nlevcan default is 40, which is very large, so exceeding this would clearly illustrate a ! huge error - if(cohort_in%treesai > cp_nlevcan*dinc_ed)then - write(fates_log(),*) 'too much sai' , cohort_in%treesai , cohort_in%pft , cp_nlevcan * dinc_ed + if(cohort_in%treesai > nlevcan*dinc_ed)then + write(fates_log(),*) 'too much sai' , cohort_in%treesai , cohort_in%pft , nlevcan * dinc_ed endif return diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 35bf4c3d..34d22267 100755 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -4,15 +4,19 @@ module EDPatchDynamicsMod ! Controls formation, creation, fusing and termination of patch level processes. ! ============================================================================ - use clm_varctl , only : iulog - use FatesGlobals , only : freq_day + use FatesGlobals , only : fates_log + use FatesInterfaceMod , only : hlm_freq_day use pftconMod , only : pftcon use EDCohortDynamicsMod , only : fuse_cohorts, sort_cohorts, insert_cohort use EDtypesMod , only : ncwd, n_dbh_bins, ntol, area, dbhmax - use FatesGlobals , only : numpft_ed - use FatesGlobals , only : maxPatchesPerSite + use EDTypesMod , only : numpft_ed + use EDTypesMod , only : maxPatchesPerSite use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type - use EDTypesMod , only : min_patch_area, cp_numlevgrnd, cp_numSWb + use EDTypesMod , only : min_patch_area + use EDTypesMod , only : nclmax + use FatesInterfaceMod , only : hlm_numlevgrnd + use FatesInterfaceMod , only : hlm_numlevsoil + use FatesInterfaceMod , only : hlm_numSWb use FatesGlobals , only : endrun => fates_endrun use FatesConstantsMod , only : r8 => fates_r8 @@ -32,6 +36,7 @@ module EDPatchDynamicsMod public :: disturbance_rates public :: check_patch_area public :: set_patchno + public :: set_root_fraction private:: fuse_2_patches @@ -91,7 +96,7 @@ subroutine disturbance_rates( site_in) if(currentCohort%canopy_layer == 1)then currentPatch%disturbance_rates(1) = currentPatch%disturbance_rates(1) + & - min(1.0_r8,currentCohort%dmort)*freq_day*currentCohort%c_area/currentPatch%area + min(1.0_r8,currentCohort%dmort)*hlm_freq_day*currentCohort%c_area/currentPatch%area endif @@ -105,7 +110,7 @@ subroutine disturbance_rates( site_in) 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 + write(fates_log(),*) 'very high fire areas',currentPatch%disturbance_rates(2),currentPatch%frac_burnt endif !Only use larger of two natural disturbance modes WHY? @@ -174,7 +179,7 @@ subroutine spawn_patches( currentSite ) ! 10) Area checked, and patchno recalculated. ! ! !USES: - use FatesGlobals , only : cp_nclmax + use EDParamsMod , only : ED_val_maxspread, ED_val_understorey_death use EDCohortDynamicsMod , only : zero_cohort, copy_cohort, terminate_cohorts ! @@ -197,7 +202,7 @@ subroutine spawn_patches( currentSite ) 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) :: spread_local(cp_nclmax) ! initial value of canopy spread parameter.no units + real(r8) :: spread_local(nclmax) ! initial value of canopy spread parameter.no units !--------------------------------------------------------------------- storesmallcohort => null() ! storage of the smallest cohort for insertion routine @@ -225,7 +230,7 @@ subroutine spawn_patches( currentSite ) cwd_bg_local = 0.0_r8 leaf_litter_local = 0.0_r8 root_litter_local = 0.0_r8 - spread_local(1:cp_nclmax) = ED_val_maxspread + spread_local(1:nclmax) = ED_val_maxspread age = 0.0_r8 allocate(new_patch) @@ -277,7 +282,7 @@ subroutine spawn_patches( currentSite ) ! because this is the part of the original patch where no trees have actually fallen ! The diagnostic cmort,bmort and hmort rates have already been saved - currentCohort%n = currentCohort%n * (1.0_r8 - min(1.0_r8,currentCohort%dmort * freq_day)) + currentCohort%n = currentCohort%n * (1.0_r8 - min(1.0_r8,currentCohort%dmort * hlm_freq_day)) nc%n = 0.0_r8 ! kill all of the trees who caused the disturbance. nc%cmort = nan ! The mortality diagnostics are set to nan because the cohort should dissappear @@ -304,7 +309,7 @@ subroutine spawn_patches( currentSite ) ! so with the number density must come the effective mortality rates. nc%fmort = 0.0_r8 ! Should had also been zero in the donor - nc%imort = ED_val_understorey_death/freq_day ! This was zero in the donor + nc%imort = ED_val_understorey_death/hlm_freq_day ! This was zero in the donor nc%cmort = currentCohort%cmort nc%hmort = currentCohort%hmort nc%bmort = currentCohort%bmort @@ -342,7 +347,7 @@ subroutine spawn_patches( currentSite ) ! loss of individual from fire in new patch. nc%n = nc%n * (1.0_r8 - currentCohort%fire_mort) - nc%fmort = currentCohort%fire_mort/freq_day + nc%fmort = currentCohort%fire_mort/hlm_freq_day nc%imort = 0.0_r8 nc%cmort = currentCohort%cmort nc%hmort = currentCohort%hmort @@ -439,7 +444,7 @@ subroutine check_patch_area( currentSite ) areatot = areatot + currentPatch%area currentPatch => currentPatch%younger if (( areatot - area ) > 0._r8 ) then - write(iulog,*) 'trimming patch area - is too big' , areatot-area + write(fates_log(),*) 'trimming patch area - is too big' , areatot-area currentSite%oldest_patch%area = currentSite%oldest_patch%area - (areatot - area) endif enddo @@ -722,7 +727,7 @@ subroutine mortality_litter_fluxes(cp_target, new_patch_target, patch_site_aread !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 * freq_day) + canopy_dead = currentCohort%n * min(1.0_r8,currentCohort%dmort * hlm_freq_day) currentPatch%canopy_mortality_woody_litter = currentPatch%canopy_mortality_woody_litter + & canopy_dead*(currentCohort%bdead+currentCohort%bsw) @@ -814,16 +819,16 @@ subroutine create_patch(currentSite, new_patch, age, areap, spread_local,cwd_ag_ ! !LOCAL VARIABLES: !--------------------------------------------------------------------- - allocate(new_patch%tr_soil_dir(cp_numSWb)) - allocate(new_patch%tr_soil_dif(cp_numSWb)) - allocate(new_patch%tr_soil_dir_dif(cp_numSWb)) - allocate(new_patch%fab(cp_numSWb)) - allocate(new_patch%fabd(cp_numSWb)) - allocate(new_patch%fabi(cp_numSWb)) - allocate(new_patch%sabs_dir(cp_numSWb)) - allocate(new_patch%sabs_dif(cp_numSWb)) - allocate(new_patch%rootfr_ft(numpft_ed,cp_numlevgrnd)) - allocate(new_patch%rootr_ft(numpft_ed,cp_numlevgrnd)) + allocate(new_patch%tr_soil_dir(hlm_numSWb)) + allocate(new_patch%tr_soil_dif(hlm_numSWb)) + allocate(new_patch%tr_soil_dir_dif(hlm_numSWb)) + allocate(new_patch%fab(hlm_numSWb)) + allocate(new_patch%fabd(hlm_numSWb)) + allocate(new_patch%fabi(hlm_numSWb)) + allocate(new_patch%sabs_dir(hlm_numSWb)) + allocate(new_patch%sabs_dif(hlm_numSWb)) + allocate(new_patch%rootfr_ft(numpft_ed,hlm_numlevgrnd)) + allocate(new_patch%rootr_ft(numpft_ed,hlm_numlevgrnd)) call zero_patch(new_patch) !The nan value in here is not working?? @@ -901,7 +906,6 @@ subroutine zero_patch(cp_p) currentPatch%siteptr => null() currentPatch%patchno = 999 - currentPatch%clm_pno = 999 currentPatch%age = nan currentPatch%area = nan @@ -1063,7 +1067,7 @@ subroutine fuse_patches( csite ) do while(associated(tpp)) if(.not.associated(currentPatch))then - write(iulog,*) 'ED: issue with currentPatch' + write(fates_log(),*) 'ED: issue with currentPatch' endif if(associated(tpp).and.associated(currentPatch))then @@ -1105,7 +1109,7 @@ subroutine fuse_patches( csite ) call sort_cohorts(tpp) currentPatch => tmpptr else - ! write(iulog,*) 'patches not fused' + ! write(fates_log(),*) 'patches not fused' endif endif !are both patches associated? endif !are these different patches? @@ -1339,15 +1343,17 @@ subroutine terminate_patches(cs_pnt) ! Do not force the fusion of the youngest patch to its neighbour. ! This is only really meant for very old patches. if(associated(currentPatch%older) )then - write(iulog,*) 'fusing to older patch because this one is too small',currentPatch%area, currentPatch%lai, & + write(fates_log(),*) 'fusing to older patch because this one is too small',& + currentPatch%area, currentPatch%lai, & currentPatch%older%area,currentPatch%older%lai call fuse_2_patches(currentPatch%older, currentPatch) - write(iulog,*) 'after fusion to older patch',currentPatch%area + write(fates_log(),*) 'after fusion to older patch',currentPatch%area else - write(iulog,*) 'fusing to younger patch because oldest one is too small',currentPatch%area, currentPatch%lai + write(fates_log(),*) 'fusing to younger patch because oldest one is too small',& + currentPatch%area, currentPatch%lai tmpptr => currentPatch%younger call fuse_2_patches(currentPatch, currentPatch%younger) - write(iulog,*) 'after fusion to younger patch' + write(fates_log(),*) 'after fusion to younger patch' currentPatch => tmpptr endif endif @@ -1364,7 +1370,7 @@ subroutine terminate_patches(cs_pnt) areatot = areatot + currentPatch%area currentPatch => currentPatch%younger if((areatot-area) > 0.0000001_r8)then - write(iulog,*) 'ED: areatot too large. end terminate', areatot + write(fates_log(),*) 'ED: areatot too large. end terminate', areatot endif enddo @@ -1460,7 +1466,8 @@ subroutine patch_pft_size_profile(cp_pnt) 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) + & + currentPatch%pft_agb_profile(currentCohort%pft,j) = & + currentPatch%pft_agb_profile(currentCohort%pft,j) + & currentCohort%bdead*currentCohort%n/currentPatch%area endif @@ -1472,7 +1479,7 @@ subroutine patch_pft_size_profile(cp_pnt) end subroutine patch_pft_size_profile - ! ============================================================================ + ! ===================================================================================== function countPatches( bounds, nsites, sites ) result ( totNumPatches ) ! ! !DESCRIPTION: @@ -1505,4 +1512,39 @@ function countPatches( bounds, nsites, sites ) result ( totNumPatches ) end function countPatches + ! ==================================================================================== + + subroutine set_root_fraction( cpatch , depth_gl ) + ! + ! !DESCRIPTION: + ! Calculates the fractions of the root biomass in each layer for each pft. + ! + ! !USES: + use pftconMod , only : pftcon + ! + ! !ARGUMENTS + type(ed_patch_type),intent(inout), target :: cpatch + real(r8),intent(in) :: depth_gl(0:hlm_numlevgrnd) + ! + ! !LOCAL VARIABLES: + integer :: lev,p,c,ft + !---------------------------------------------------------------------- + + do ft = 1,numpft_ed + do lev = 1, hlm_numlevgrnd + cpatch%rootfr_ft(ft,lev) = 0._r8 + enddo + + do lev = 1, hlm_numlevsoil-1 + cpatch%rootfr_ft(ft,lev) = .5_r8*( & + exp(-pftcon%roota_par(ft) * depth_gl(lev-1)) & + + exp(-pftcon%rootb_par(ft) * depth_gl(lev-1)) & + - exp(-pftcon%roota_par(ft) * depth_gl(lev)) & + - exp(-pftcon%rootb_par(ft) * depth_gl(lev))) + end do + end do + + end subroutine set_root_fraction + + end module EDPatchDynamicsMod diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index d07dc7d5..91ca9fe8 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -7,18 +7,23 @@ module EDPhysiologyMod ! ============================================================================ use FatesGlobals, only : fates_log - use FatesGlobals, only : days_per_year - use FatesGlobals, only : model_day - use FatesGlobals, only : freq_day - use FatesGlobals, only : day_of_year + use FatesInterfaceMod, only : hlm_days_per_year + use FatesInterfaceMod, only : hlm_model_day + use FatesInterfaceMod, only : hlm_freq_day + use FatesInterfaceMod, only : hlm_day_of_year use FatesConstantsMod, only : r8 => fates_r8 - use pftconMod , only : pftcon - use EDEcophysContype , only : EDecophyscon + use pftconMod , only : pftcon + use EDEcophysContype , only : EDecophyscon use FatesInterfaceMod, only : bc_in_type use EDCohortDynamicsMod , only : allocate_live_biomass, zero_cohort use EDCohortDynamicsMod , only : create_cohort, fuse_cohorts, sort_cohorts - use EDTypesMod , only : dg_sf, dinc_ed, external_recruitment - use EDTypesMod , only : ncwd, cp_nlevcan, numpft_ed, senes + use EDTypesMod , only : numWaterMem + use EDTypesMod , only : dg_sf, dinc_ed + use EDTypesMod , only : external_recruitment + use EDTypesMod , only : ncwd + use EDTypesMod , only : nlevcan + use EDTypesMod , only : numpft_ed + use EDTypesMod , only : senes use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type implicit none @@ -172,13 +177,13 @@ subroutine trim_canopy( currentSite ) trimmed = 0 currentCohort%treelai = tree_lai(currentCohort) currentCohort%nv = ceiling((currentCohort%treelai+currentCohort%treesai)/dinc_ed) - if (currentCohort%nv > cp_nlevcan)then - write(fates_log(),*) 'nv > cp_nlevcan',currentCohort%nv,currentCohort%treelai,currentCohort%treesai, & + if (currentCohort%nv > nlevcan)then + write(fates_log(),*) 'nv > nlevcan',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,cp_nlevcan + do z = 1,nlevcan 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. @@ -292,7 +297,7 @@ subroutine phenology( currentSite, bc_in ) ncolddayslim = 5 cold_t = 7.5_r8 ! ed_ph_coldtemp - t = day_of_year + t = hlm_day_of_year temp_in_C = bc_in%t_veg24_si - tfrz !-----------------Cold Phenology--------------------! @@ -342,7 +347,7 @@ subroutine phenology( currentSite, bc_in ) endif - timesinceleafoff = model_day - currentSite%leafoffdate + timesinceleafoff = hlm_model_day - currentSite%leafoffdate !LEAF ON: COLD DECIDUOUS. Needs to !1) have exceeded the growing degree day threshold !2) The leaves should not be on already @@ -358,7 +363,7 @@ subroutine phenology( currentSite, bc_in ) endif !status endif !GDD - timesinceleafon = model_day - currentSite%leafondate + timesinceleafon = hlm_model_day - currentSite%leafondate !LEAF OFF: COLD THRESHOLD @@ -372,7 +377,7 @@ subroutine phenology( currentSite, bc_in ) if (timesinceleafon > mindayson)then if (currentSite%status == 2)then currentSite%status = 1 !alter status of site to 'leaves on' - currentSite%leafoffdate = model_day !record leaf off date + currentSite%leafoffdate = hlm_model_day !record leaf off date if ( DEBUG ) write(fates_log(),*) 'leaves off' endif endif @@ -382,7 +387,7 @@ subroutine phenology( currentSite, bc_in ) if(timesinceleafoff > 400)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 = model_day !record leaf off date + currentSite%leafoffdate = hlm_model_day !record leaf off date if ( DEBUG ) write(fates_log(),*) 'leaves off' endif endif @@ -416,8 +421,8 @@ subroutine phenology( currentSite, bc_in ) !Accumulate surface water memory of last 10 days. currentSite%water_memory(1) = bc_in%h2osoi_vol_si !waterstate_inst%h2osoi_vol_col(coli,1) - do i = 1,9 !shift memory along one - currentSite%water_memory(11-i) = currentSite%water_memory(10-i) + do i = 1,numWaterMem !shift memory along one + currentSite%water_memory(numWaterMem+1-i) = currentSite%water_memory(numWaterMem-i) enddo !In drought phenology, we often need to force the leaves to stay on or off as moisture fluctuates... @@ -446,7 +451,9 @@ subroutine phenology( currentSite, bc_in ) !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 + ! TODO: CHANGE THIS MATH, MOVE THE DENOMENATOR OUTSIDE OF THE SUM (rgk 01-2017) + if (sum(currentSite%water_memory(1:numWaterMem)/dble(numWaterMem)) & + >= 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' @@ -638,7 +645,7 @@ subroutine seeds_in( currentSite, cp_pnt ) currentPatch => currentSite%oldest_patch do while(associated(currentPatch)) - if (EXTERNAL_RECRUITMENT == 1) then !external seed rain - needed to prevent extinction + 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 @@ -767,9 +774,9 @@ subroutine Growth_Derivatives( currentSite, currentCohort, bc_in) ! convert from kgC/indiv/day into kgC/indiv/year ! TODO: CONVERT DAYS_PER_YEAR TO DBLE (HOLDING FOR B4B COMPARISONS, RGK-01-2017) - currentCohort%npp_acc_hold = currentCohort%npp_acc * days_per_year - currentCohort%gpp_acc_hold = currentCohort%gpp_acc * days_per_year - currentCohort%resp_acc_hold = currentCohort%resp_acc * days_per_year + currentCohort%npp_acc_hold = currentCohort%npp_acc * hlm_days_per_year + currentCohort%gpp_acc_hold = currentCohort%gpp_acc * hlm_days_per_year + currentCohort%resp_acc_hold = currentCohort%resp_acc * hlm_days_per_year currentSite%flux_in = currentSite%flux_in + currentCohort%npp_acc * currentCohort%n @@ -936,7 +943,7 @@ subroutine Growth_Derivatives( currentSite, currentCohort, bc_in) ! 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 * freq_day > currentCohort%balive*0.99)then + if (-1.0_r8*currentCohort%dbalivedt * hlm_freq_day > currentCohort%balive*0.99)then write(fates_log(),*) 'using non-neg leaf mass cap',currentCohort%balive , currentCohort%dbalivedt,currentCohort%dbstoredt, & currentCohort%carbon_balance currentCohort%dbstoredt = currentCohort%dbstoredt + currentCohort%dbalivedt @@ -992,7 +999,7 @@ subroutine recruitment( t, currentSite, currentPatch ) + 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)*freq_day & + temp_cohort%n = currentPatch%area * currentPatch%seed_germination(ft)*hlm_freq_day & / (temp_cohort%bdead+temp_cohort%balive+temp_cohort%bstore) if (t == 1)then @@ -1069,7 +1076,7 @@ subroutine CWD_Input( currentPatch) 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/freq_day + currentCohort%leaf_litter * currentCohort%n/currentPatch%area/hlm_freq_day !daily leaf loss needs to be scaled up to the annual scale here. @@ -1088,7 +1095,7 @@ subroutine CWD_Input( currentPatch) dead_n = -1.0_r8 * currentCohort%dndt / currentPatch%area currentPatch%leaf_litter_in(pft) = currentPatch%leaf_litter_in(pft) + & - (currentCohort%bl+currentCohort%leaf_litter/freq_day)* dead_n + (currentCohort%bl+currentCohort%leaf_litter/hlm_freq_day)* dead_n currentPatch%root_litter_in(pft) = currentPatch%root_litter_in(pft) + & (currentCohort%br+currentCohort%bstore) * dead_n @@ -1241,13 +1248,13 @@ subroutine cwd_out( currentSite, currentPatch, bc_in ) !add up carbon going into fragmenting pools currentSite%flux_out = currentSite%flux_out + sum(currentPatch%leaf_litter_out) * & - currentPatch%area *freq_day!kgC/site/day + currentPatch%area *hlm_freq_day!kgC/site/day currentSite%flux_out = currentSite%flux_out + sum(currentPatch%root_litter_out) * & - currentPatch%area *freq_day!kgC/site/day + currentPatch%area *hlm_freq_day!kgC/site/day currentSite%flux_out = currentSite%flux_out + sum(currentPatch%cwd_ag_out) * & - currentPatch%area *freq_day!kgC/site/day + currentPatch%area *hlm_freq_day!kgC/site/day currentSite%flux_out = currentSite%flux_out + sum(currentPatch%cwd_bg_out) * & - currentPatch%area *freq_day!kgC/site/day + currentPatch%area *hlm_freq_day!kgC/site/day end subroutine cwd_out @@ -1270,11 +1277,11 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) ! This means that the state update for the litter pools and for the CWD pools occurs at different timescales. - use EDTypesMod, only : AREA, numpft_ed, cp_numlevdecomp_full, cp_numlevdecomp + use EDTypesMod, only : AREA + use EDTypesMod, only : numpft_ed + use FatesInterfaceMod, only : hlm_numlevdecomp_full + use FatesInterfaceMod, only : hlm_numlevdecomp use SoilBiogeochemVerticalProfileMod, only: surfprof_exp - - !use EDCLMLinkMod, only: cwd_fcel_ed, cwd_flig - use pftconMod, only : pftcon use FatesConstantsMod, only : sec_per_day use clm_varcon, only : zisoi, dzsoi_decomp, zsoi @@ -1305,9 +1312,9 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) integer :: begp,endp integer :: begc,endc !bounds !------------------------------------------------------------------------ - real(r8) :: cinput_rootfr(1:numpft_ed, 1:cp_numlevdecomp_full) ! column by pft root fraction used for calculating inputs - real(r8) :: croot_prof_perpatch(1:cp_numlevdecomp_full) - real(r8) :: surface_prof(1:cp_numlevdecomp_full) + real(r8) :: cinput_rootfr(1:numpft_ed, 1:hlm_numlevdecomp_full) ! column by pft root fraction used for calculating inputs + real(r8) :: croot_prof_perpatch(1:hlm_numlevdecomp_full) + real(r8) :: surface_prof(1:hlm_numlevdecomp_full) integer :: ft real(r8) :: rootfr_tot(1:numpft_ed), biomass_bg_ft(1:numpft_ed) real(r8) :: surface_prof_tot, leaf_prof_sum, stem_prof_sum, froot_prof_sum, biomass_bg_tot @@ -1331,10 +1338,10 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) ! Doing so will be answer changing though so perhaps easiest to do this in steps. integer, parameter :: rooting_profile_varindex_water = 1 - real(r8) :: leaf_prof(1:nsites, 1:cp_numlevdecomp) - real(r8) :: froot_prof(1:nsites, 1:numpft_ed, 1:cp_numlevdecomp) - real(r8) :: croot_prof(1:nsites, 1:cp_numlevdecomp) - real(r8) :: stem_prof(1:nsites, 1:cp_numlevdecomp) + real(r8) :: leaf_prof(1:nsites, 1:hlm_numlevdecomp) + real(r8) :: froot_prof(1:nsites, 1:numpft_ed, 1:hlm_numlevdecomp) + real(r8) :: croot_prof(1:nsites, 1:hlm_numlevdecomp) + real(r8) :: stem_prof(1:nsites, 1:hlm_numlevdecomp) ! INTERF-TODO: THESE PARAMETERS WERE ORIGINALLY SET BY params_inst% ! THEY NEED THEIR OWN ENTRIES IN THE PARAMETER FILE (RGK) @@ -1364,7 +1371,7 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) ! define a single shallow surface profile for surface additions (leaves, stems, and N deposition) surface_prof(:) = 0._r8 - do j = 1, cp_numlevdecomp + do j = 1, hlm_numlevdecomp surface_prof(j) = exp(-surfprof_exp * zsoi(j)) / dzsoi_decomp(j) end do @@ -1381,14 +1388,14 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) if ( .not. pftspecific_rootingprofile ) then ! define rooting profile from exponential parameters do ft = 1, numpft_ed - do j = 1, cp_numlevdecomp + do j = 1, hlm_numlevdecomp cinput_rootfr(ft,j) = exp(-rootprof_exp * zsoi(j)) / dzsoi_decomp(j) end do end do else ! use beta distribution parameter from Jackson et al., 1996 do ft = 1, numpft_ed - do j = 1, cp_numlevdecomp + do j = 1, hlm_numlevdecomp cinput_rootfr(ft,j) = ( pftcon%rootprof_beta(ft, rooting_profile_varindex_water) ** (zisoi(j-1)*100._r8) - & pftcon%rootprof_beta(ft, rooting_profile_varindex_water) ** (zisoi(j)*100._r8) ) & / dzsoi_decomp(j) @@ -1397,7 +1404,7 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) endif else do ft = 1,numpft_ed - do j = 1, cp_numlevdecomp + do j = 1, hlm_numlevdecomp ! use standard CLM root fraction profiles; cinput_rootfr(ft,j) = ( .5_r8*( & exp(-pftcon%roota_par(ft) * zisoi(j-1)) & @@ -1418,11 +1425,11 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) end do surface_prof_tot = 0._r8 ! - do j = 1, min(max(bc_in(s)%max_rooting_depth_index_col, 1), cp_numlevdecomp) + do j = 1, min(max(bc_in(s)%max_rooting_depth_index_col, 1), hlm_numlevdecomp) surface_prof_tot = surface_prof_tot + surface_prof(j) * dzsoi_decomp(j) end do do ft = 1,numpft_ed - do j = 1, min(max(bc_in(s)%max_rooting_depth_index_col, 1), cp_numlevdecomp) + do j = 1, min(max(bc_in(s)%max_rooting_depth_index_col, 1), hlm_numlevdecomp) rootfr_tot(ft) = rootfr_tot(ft) + cinput_rootfr(ft,j) * dzsoi_decomp(j) end do end do @@ -1432,7 +1439,7 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) if ( (bc_in(s)%max_rooting_depth_index_col > 0) .and. (rootfr_tot(ft) > 0._r8) ) then ! where there is not permafrost extending to the surface, integrate the profiles over the active layer ! this is equivalent to integrating over all soil layers outside of permafrost regions - do j = 1, min(max(bc_in(s)%max_rooting_depth_index_col, 1), cp_numlevdecomp) + do j = 1, min(max(bc_in(s)%max_rooting_depth_index_col, 1), hlm_numlevdecomp) froot_prof(s,ft,j) = cinput_rootfr(ft,j) / rootfr_tot(ft) end do else @@ -1445,7 +1452,7 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) if ( (bc_in(s)%max_rooting_depth_index_col > 0) .and. (surface_prof_tot > 0._r8) ) then ! where there is not permafrost extending to the surface, integrate the profiles over the active layer ! this is equivalent to integrating over all soil layers outside of permafrost regions - do j = 1, min(max(bc_in(s)%max_rooting_depth_index_col, 1), cp_numlevdecomp) + do j = 1, min(max(bc_in(s)%max_rooting_depth_index_col, 1), hlm_numlevdecomp) ! set all surface processes to shallower profile leaf_prof(s,j) = surface_prof(j)/ surface_prof_tot stem_prof(s,j) = surface_prof(j)/ surface_prof_tot @@ -1454,7 +1461,7 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) ! if fully frozen, or no roots, put everything in the top layer leaf_prof(s,1) = 1._r8/dzsoi_decomp(1) stem_prof(s,1) = 1._r8/dzsoi_decomp(1) - do j = 2, cp_numlevdecomp + do j = 2, hlm_numlevdecomp leaf_prof(s,j) = 0._r8 stem_prof(s,j) = 0._r8 end do @@ -1475,7 +1482,7 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) ! check the leaf and stem profiles leaf_prof_sum = 0._r8 stem_prof_sum = 0._r8 - do j = 1, cp_numlevdecomp + do j = 1, hlm_numlevdecomp leaf_prof_sum = leaf_prof_sum + leaf_prof(s,j) * dzsoi_decomp(j) stem_prof_sum = stem_prof_sum + stem_prof(s,j) * dzsoi_decomp(j) end do @@ -1492,7 +1499,7 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) ! now check each fine root profile do ft = 1,numpft_ed froot_prof_sum = 0._r8 - do j = 1, cp_numlevdecomp + do j = 1, hlm_numlevdecomp froot_prof_sum = froot_prof_sum + froot_prof(s,ft,j) * dzsoi_decomp(j) end do if ( ( abs(froot_prof_sum - 1._r8) > delta ) ) then @@ -1504,7 +1511,7 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) ! zero the site-level C input variables do s = 1, nsites - do j = 1, cp_numlevdecomp + do j = 1, hlm_numlevdecomp bc_out(s)%FATES_c_to_litr_lab_c_col(j) = 0._r8 bc_out(s)%FATES_c_to_litr_cel_c_col(j) = 0._r8 bc_out(s)%FATES_c_to_litr_lig_c_col(j) = 0._r8 @@ -1540,14 +1547,14 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) biomass_bg_tot = biomass_bg_tot + biomass_bg_ft(ft) end do ! - do j = 1, cp_numlevdecomp + do j = 1, hlm_numlevdecomp ! zero this for each patch croot_prof_perpatch(j) = 0._r8 end do ! if ( biomass_bg_tot .gt. 0._r8) then do ft = 1,numpft_ed - do j = 1, cp_numlevdecomp + do j = 1, hlm_numlevdecomp croot_prof_perpatch(j) = croot_prof_perpatch(j) + froot_prof(s,ft,j) * biomass_bg_ft(ft) / biomass_bg_tot end do end do @@ -1557,7 +1564,7 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) ! ! add croot_prof as weighted average (weighted by patch area) of croot_prof_perpatch - do j = 1, cp_numlevdecomp + do j = 1, hlm_numlevdecomp croot_prof(s, j) = croot_prof(s, j) + croot_prof_perpatch(j) * currentPatch%area / AREA end do ! @@ -1574,7 +1581,7 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) ! ! ! CWD pools fragmenting into decomposing litter pools. do ci = 1, ncwd - do j = 1, cp_numlevdecomp + do j = 1, hlm_numlevdecomp bc_out(s)%FATES_c_to_litr_cel_c_col(j) = bc_out(s)%FATES_c_to_litr_cel_c_col(j) + & currentpatch%CWD_AG_out(ci) * cwd_fcel * currentpatch%area/AREA * stem_prof(s,j) bc_out(s)%FATES_c_to_litr_lig_c_col(j) = bc_out(s)%FATES_c_to_litr_lig_c_col(j) + & @@ -1589,7 +1596,7 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) ! leaf and fine root pools. do ft = 1,numpft_ed - do j = 1, cp_numlevdecomp + do j = 1, hlm_numlevdecomp bc_out(s)%FATES_c_to_litr_lab_c_col(j) = bc_out(s)%FATES_c_to_litr_lab_c_col(j) + & currentpatch%leaf_litter_out(ft) * pftcon%lf_flab(ft) * currentpatch%area/AREA * leaf_prof(s,j) bc_out(s)%FATES_c_to_litr_cel_c_col(j) = bc_out(s)%FATES_c_to_litr_cel_c_col(j) + & @@ -1621,19 +1628,18 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) end do ! do sites(s) do s = 1, nsites - do j = 1, cp_numlevdecomp + do j = 1, hlm_numlevdecomp ! time unit conversion bc_out(s)%FATES_c_to_litr_lab_c_col(j)=bc_out(s)%FATES_c_to_litr_lab_c_col(j) * mass_convert / time_convert bc_out(s)%FATES_c_to_litr_cel_c_col(j)=bc_out(s)%FATES_c_to_litr_cel_c_col(j) * mass_convert / time_convert bc_out(s)%FATES_c_to_litr_lig_c_col(j)=bc_out(s)%FATES_c_to_litr_lig_c_col(j) * mass_convert / time_convert - end do end do ! write(fates_log(),*)'cdk FATES_c_to_litr_lab_c: ', FATES_c_to_litr_lab_c ! write_col(fates_log(),*)'cdk FATES_c_to_litr_cel_c: ', FATES_c_to_litr_cel_c ! write_col(fates_log(),*)'cdk FATES_c_to_litr_lig_c: ', FATES_c_to_litr_lig_c - ! write_col(fates_log(),*)'cdk cp_numlevdecomp_full, bounds%begc, bounds%endc: ', cp_numlevdecomp_full, bounds%begc, bounds%endc + ! write_col(fates_log(),*)'cdk hlm_numlevdecomp_full, bounds%begc, bounds%endc: ', hlm_numlevdecomp_full, bounds%begc, bounds%endc ! write(fates_log(),*)'cdk leaf_prof: ', leaf_prof ! write(fates_log(),*)'cdk stem_prof: ', stem_prof ! write(fates_log(),*)'cdk froot_prof: ', froot_prof diff --git a/biogeophys/EDAccumulateFluxesMod.F90 b/biogeophys/EDAccumulateFluxesMod.F90 index 78563a3a..a63608ad 100644 --- a/biogeophys/EDAccumulateFluxesMod.F90 +++ b/biogeophys/EDAccumulateFluxesMod.F90 @@ -28,8 +28,8 @@ subroutine AccumulateFluxes_ED(nsites, sites, bc_in, bc_out, dt_time) ! see above ! ! !USES: - use shr_kind_mod , only : r8 => shr_kind_r8 - use clm_varctl , only : iulog + use FatesConstantsMod , only : r8 => fates_r8 + use FatesGlobals , only : fates_log use EDTypesMod , only : ed_patch_type, ed_cohort_type, & ed_site_type, AREA use FatesInterfaceMod , only : bc_in_type,bc_out_type @@ -67,10 +67,10 @@ subroutine AccumulateFluxes_ED(nsites, sites, bc_in, bc_out, dt_time) ! _tstep fluxes are KgC/indiv/timestep _acc are KgC/indiv/day if ( DEBUG ) then - write(iulog,*) 'EDAccumFlux 64 ',ccohort%npp_acc, & + write(fates_log(),*) 'EDAccumFlux 64 ',ccohort%npp_acc, & ccohort%npp_tstep - write(iulog,*) 'EDAccumFlux 66 ',ccohort%gpp_tstep - write(iulog,*) 'EDAccumFlux 67 ',ccohort%resp_tstep + write(fates_log(),*) 'EDAccumFlux 66 ',ccohort%gpp_tstep + write(fates_log(),*) 'EDAccumFlux 67 ',ccohort%resp_tstep endif ccohort%npp_acc = ccohort%npp_acc + ccohort%npp_tstep diff --git a/biogeophys/EDBtranMod.F90 b/biogeophys/EDBtranMod.F90 index 8ac4a51b..efcd2098 100644 --- a/biogeophys/EDBtranMod.F90 +++ b/biogeophys/EDBtranMod.F90 @@ -6,16 +6,16 @@ module EDBtranMod ! ------------------------------------------------------------------------------------ use pftconMod , only : pftcon - use clm_varcon , only : tfrz + use FatesConstantsMod , only : tfrz => t_water_freeze_k_1atm use EDTypesMod , only : ed_site_type, & ed_patch_type, & ed_cohort_type, & - numpft_ed, & - cp_numlevgrnd + numpft_ed + use FatesInterfaceMod , only : hlm_numlevgrnd use shr_kind_mod , only : r8 => shr_kind_r8 use FatesInterfaceMod , only : bc_in_type, & bc_out_type - use clm_varctl , only : iulog !INTERF-TODO: THIS SHOULD BE MOVED + use FatesGlobals , only : fates_log ! implicit none @@ -63,7 +63,7 @@ subroutine get_active_suction_layers(nsites, sites, bc_in, bc_out) do s = 1,nsites if (bc_in(s)%filter_btran) then - do j = 1,cp_numlevgrnd + do j = 1,hlm_numlevgrnd bc_out(s)%active_suction_gl(j) = check_layer_water( bc_in(s)%h2o_liqvol_gl(j),bc_in(s)%tempk_gl(j) ) end do else @@ -128,7 +128,7 @@ subroutine btran_ed( nsites, sites, bc_in, bc_out) do ft = 1,numpft_ed cpatch%btran_ft(ft) = 0.0_r8 - do j = 1,cp_numlevgrnd + do j = 1,hlm_numlevgrnd ! Calculations are only relevant where liquid water exists ! see clm_fates%wrap_btran for calculation with CLM/ALM @@ -155,7 +155,7 @@ subroutine btran_ed( nsites, sites, bc_in, bc_out) end do !j ! Normalize root resistances to get layer contribution to ET - do j = 1,cp_numlevgrnd + do j = 1,hlm_numlevgrnd if (cpatch%btran_ft(ft) > 0.0_r8) then cpatch%rootr_ft(ft,j) = cpatch%rootr_ft(ft,j)/cpatch%btran_ft(ft) else @@ -179,7 +179,7 @@ subroutine btran_ed( nsites, sites, bc_in, bc_out) ! pass the host a total transpiration for the patch. This needs rootr to be ! distributed over the soil layers. - do j = 1,cp_numlevgrnd + do j = 1,hlm_numlevgrnd bc_out(s)%rootr_pagl(ifp,j) = 0._r8 do ft = 1,numpft_ed if(sum(pftgs) > 0._r8)then !prevent problem with the first timestep - might fail @@ -206,8 +206,8 @@ subroutine btran_ed( nsites, sites, bc_in, bc_out) temprootr = sum(bc_out(s)%rootr_pagl(ifp,:)) if(abs(1.0_r8-temprootr) > 1.0e-10_r8 .and. temprootr > 1.0e-10_r8)then - write(iulog,*) 'error with rootr in canopy fluxes',temprootr,sum(pftgs),sum(cpatch%rootr_ft(1:2,:),dim=2) - do j = 1,cp_numlevgrnd + write(fates_log(),*) 'error with rootr in canopy fluxes',temprootr,sum(pftgs),sum(cpatch%rootr_ft(1:2,:),dim=2) + do j = 1,hlm_numlevgrnd bc_out(s)%rootr_pagl(ifp,j) = bc_out(s)%rootr_pagl(ifp,j)/temprootr enddo end if @@ -300,7 +300,7 @@ end subroutine btran_ed ! weighted_swp = weighted_swp/totestevap ! ! weight SWP for the total evaporation ! else -! write(iulog,*) 'empty soil', totestevap +! write(fates_log(),*) 'empty soil', totestevap ! ! error check ! weighted_swp = minlwp ! end if diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index d90fca88..130b093d 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -10,17 +10,19 @@ module EDSurfaceRadiationMod #include "shr_assert.h" - use EDtypesMod , only : ed_patch_type, ed_site_type - use FatesGlobals , only : numpft_ed - use FatesGlobals , only : maxPatchesPerSite + use EDTypesMod , only : ed_patch_type, ed_site_type + use EDTypesMod , only : numpft_ed + use EDTypesMod , only : maxPatchesPerSite use FatesConstantsMod , only : r8 => fates_r8 - use FatesInterfaceMod , only : bc_in_type, & - bc_out_type - use EDTypesMod , only : cp_numSWb, & ! Actual number of SW radiation bands - cp_maxSWb ! maximum number of SW bands (for scratch) - - use FatesGlobals , only : cp_nclmax + use FatesInterfaceMod , only : bc_in_type + use FatesInterfaceMod , only : bc_out_type + use FatesInterfaceMod , only : hlm_numSWb + use EDTypesMod , only : maxSWb + use EDTypesMod , only : nclmax + use EDTypesMod , only : numpft_ed + use EDTypesMod , only : nlevcan use EDCanopyStructureMod, only: calc_areaindex + use FatesGlobals , only : fates_log ! CIME globals use shr_log_mod , only : errMsg => shr_log_errMsg @@ -32,8 +34,9 @@ module EDSurfaceRadiationMod public :: ED_SunShadeFracs logical :: DEBUG = .false. ! for debugging this module + - real(r8), public :: albice(cp_maxSWb) = & ! albedo land ice by waveband (1=vis, 2=nir) + real(r8), public :: albice(maxSWb) = & ! albedo land ice by waveband (1=vis, 2=nir) (/ 0.80_r8, 0.55_r8 /) ! INTERF-TODO: THIS NEEDS SOME CONSISTENCY AND SHOULD BE SET IN THE INTERFACE @@ -47,11 +50,8 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) ! ! !USES: - use clm_varctl , only : iulog use pftconMod , only : pftcon use EDtypesMod , only : ed_patch_type - use FatesGlobals , only : numpft_ed - use FatesGlobals , only : cp_nlevcan use EDTypesMod , only : ed_site_type @@ -74,27 +74,27 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) 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(cp_nclmax,numpft_ed,cp_nlevcan) + real(r8) :: ftweight(nclmax,numpft_ed,nlevcan) real(r8) :: k_dir(numpft_ed) ! Direct beam extinction coefficient - real(r8) :: tr_dir_z(cp_nclmax,numpft_ed,cp_nlevcan) ! Exponential transmittance of direct beam radiation through a single layer - real(r8) :: tr_dif_z(cp_nclmax,numpft_ed,cp_nlevcan) ! Exponential transmittance of diffuse radiation through a single layer - real(r8) :: forc_dir(maxPatchesPerSite,cp_maxSWb) - real(r8) :: forc_dif(maxPatchesPerSite,cp_maxSWb) - real(r8) :: weighted_dir_tr(cp_nclmax) - real(r8) :: weighted_fsun(cp_nclmax) - real(r8) :: weighted_dif_ratio(cp_nclmax,cp_maxSWb) - real(r8) :: weighted_dif_down(cp_nclmax) - real(r8) :: weighted_dif_up(cp_nclmax) - real(r8) :: refl_dif(cp_nclmax,numpft_ed,cp_nlevcan,cp_maxSWb) ! Term for diffuse radiation reflected by laye - real(r8) :: tran_dif(cp_nclmax,numpft_ed,cp_nlevcan,cp_maxSWb) ! Term for diffuse radiation transmitted by layer - real(r8) :: dif_ratio(cp_nclmax,numpft_ed,cp_nlevcan,cp_maxSWb) ! Ratio of upward to forward diffuse fluxes - real(r8) :: Dif_dn(cp_nclmax,numpft_ed,cp_nlevcan) ! Forward diffuse flux onto canopy layer J (W/m**2 ground area) - real(r8) :: Dif_up(cp_nclmax,numpft_ed,cp_nlevcan) ! Upward diffuse flux above canopy layer J (W/m**2 ground area) - real(r8) :: lai_change(cp_nclmax,numpft_ed,cp_nlevcan) ! Forward diffuse flux onto canopy layer J (W/m**2 ground area) - real(r8) :: f_not_abs(numpft_ed,cp_maxSWb) ! Fraction reflected + transmitted. 1-absorbtion. - real(r8) :: Abs_dir_z(numpft_ed,cp_nlevcan) - real(r8) :: Abs_dif_z(numpft_ed,cp_nlevcan) - real(r8) :: abs_rad(cp_maxSWb) !radiation absorbed by soil + real(r8) :: tr_dir_z(nclmax,numpft_ed,nlevcan) ! Exponential transmittance of direct beam radiation through a single layer + real(r8) :: tr_dif_z(nclmax,numpft_ed,nlevcan) ! Exponential transmittance of diffuse radiation through a single layer + real(r8) :: forc_dir(maxPatchesPerSite,maxSWb) + real(r8) :: forc_dif(maxPatchesPerSite,maxSWb) + real(r8) :: weighted_dir_tr(nclmax) + real(r8) :: weighted_fsun(nclmax) + real(r8) :: weighted_dif_ratio(nclmax,maxSWb) + real(r8) :: weighted_dif_down(nclmax) + real(r8) :: weighted_dif_up(nclmax) + real(r8) :: refl_dif(nclmax,numpft_ed,nlevcan,maxSWb) ! Term for diffuse radiation reflected by laye + real(r8) :: tran_dif(nclmax,numpft_ed,nlevcan,maxSWb) ! Term for diffuse radiation transmitted by layer + real(r8) :: dif_ratio(nclmax,numpft_ed,nlevcan,maxSWb) ! Ratio of upward to forward diffuse fluxes + real(r8) :: Dif_dn(nclmax,numpft_ed,nlevcan) ! Forward diffuse flux onto canopy layer J (W/m**2 ground area) + real(r8) :: Dif_up(nclmax,numpft_ed,nlevcan) ! Upward diffuse flux above canopy layer J (W/m**2 ground area) + real(r8) :: lai_change(nclmax,numpft_ed,nlevcan) ! Forward diffuse flux onto canopy layer J (W/m**2 ground area) + real(r8) :: f_not_abs(numpft_ed,maxSWb) ! Fraction reflected + transmitted. 1-absorbtion. + real(r8) :: Abs_dir_z(numpft_ed,nlevcan) + real(r8) :: Abs_dif_z(numpft_ed,nlevcan) + real(r8) :: abs_rad(maxSWb) !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(maxPatchesPerSite,numpft_ed) ! Radiation transmitted to the soil surface. @@ -181,7 +181,7 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) ! no radiation is absorbed bc_out(s)%fabd_parb(ifp,:) = 0.0_r8 bc_out(s)%fabi_parb(ifp,:) = 0.0_r8 - do ib = 1,cp_numSWb + do ib = 1,hlm_numSWb bc_out(s)%albd_parb(ifp,ib) = bc_in(s)%albgr_dir_rb(ib) bc_out(s)%albd_parb(ifp,ib) = bc_in(s)%albgr_dif_rb(ib) bc_out(s)%ftdd_parb(ifp,ib)= 1.0_r8 @@ -191,7 +191,7 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) else ! Is this pft/canopy layer combination present in this patch? - do L = 1,cp_nclmax + do L = 1,nclmax do ft = 1,numpft_ed currentPatch%present(L,ft) = 0 do iv = 1, currentPatch%nrad(L,ft) @@ -204,7 +204,7 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) end do !L do radtype = 1,2 !do this once for one unit of diffuse, and once for one unit of direct radiation - do ib = 1,cp_numSWb + do ib = 1,hlm_numSWb 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. @@ -227,10 +227,10 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) end do !ft1 end do !L if (sum(ftweight(1,:,1))<0.999_r8)then - write(iulog,*) 'canopy not full',ftweight(1,:,1) + write(fates_log(),*) 'canopy not full',ftweight(1,:,1) endif if (sum(ftweight(1,:,1))>1.0001_r8)then - write(iulog,*) 'canopy too full',ftweight(1,:,1) + write(fates_log(),*) 'canopy too full',ftweight(1,:,1) endif !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! @@ -253,7 +253,7 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) 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:cp_numSWb) = 0._r8 + weighted_dif_ratio(L,1:hlm_numSWb) = 0._r8 !Each canopy layer (canopy, understorey) has multiple 'parallel' pft's do ft =1,numpft_ed if (currentPatch%present(L,ft) == 1)then !only do calculation if there are the appropriate leaves. @@ -296,7 +296,7 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) 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' , & + write(fates_log(),*) 'lower layer has more coverage. This is wrong' , & ftweight(L,ft,iv),ftweight(L,ft,iv+1),ftweight(L,ft,iv+1)-ftweight(L,ft,iv) endif @@ -393,7 +393,7 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) ! Iterative solution do scattering !==============================================================================! - do ib = 1,cp_numSWb !vis, nir + do ib = 1,hlm_numSWb !vis, nir !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! ! Leaf scattering coefficient and terms do diffuse radiation reflected ! and transmitted by a layer @@ -435,12 +435,12 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) 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!cp_numSWb + end do!hlm_numSWb endif ! currentPatch%present end do!ft end do!L - do ib = 1,cp_numSWb + do ib = 1,hlm_numSWb Dif_dn(:,:,:) = 0.00_r8 Dif_up(:,:,:) = 0.00_r8 do L = 1, currentPatch%NCL_p !work down from the top of the canopy. @@ -696,8 +696,8 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) do iv = 1, currentPatch%nrad(L,ft) if (radtype==1) then if ( DEBUG ) then - write(iulog,*) 'EDsurfAlb 730 ',Abs_dif_z(ft,iv),currentPatch%f_sun(L,ft,iv) - write(iulog,*) 'EDsurfAlb 731 ', currentPatch%fabd_sha_z(L,ft,iv), & + write(fates_log(),*) 'EDsurfAlb 730 ',Abs_dif_z(ft,iv),currentPatch%f_sun(L,ft,iv) + write(fates_log(),*) 'EDsurfAlb 731 ', currentPatch%fabd_sha_z(L,ft,iv), & currentPatch%fabd_sun_z(L,ft,iv) endif currentPatch%fabd_sha_z(L,ft,iv) = Abs_dif_z(ft,iv) * & @@ -712,7 +712,7 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) currentPatch%f_sun(L,ft,iv) endif if ( DEBUG ) then - write(iulog,*) 'EDsurfAlb 740 ', currentPatch%fabd_sha_z(L,ft,iv), & + write(fates_log(),*) 'EDsurfAlb 740 ', currentPatch%fabd_sha_z(L,ft,iv), & currentPatch%fabd_sun_z(L,ft,iv) endif end do @@ -790,22 +790,22 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) (1.0_r8-bc_in(s)%albgr_dir_rb(ib)) + & currentPatch%tr_soil_dir_dif(ib) * (1.0_r8-bc_in(s)%albgr_dif_rb(ib)))) if ( abs(error) > 0.0001)then - write(iulog,*)'dir ground absorption error',ifp,s,error,currentPatch%sabs_dir(ib), & + write(fates_log(),*)'dir ground absorption error',ifp,s,error,currentPatch%sabs_dir(ib), & currentPatch%tr_soil_dir(ib)* & (1.0_r8-bc_in(s)%albgr_dir_rb(ib)),currentPatch%NCL_p,ib,sum(ftweight(1,:,1)) - write(iulog,*) 'albedos',currentPatch%sabs_dir(ib) ,currentPatch%tr_soil_dir(ib), & + write(fates_log(),*) 'albedos',currentPatch%sabs_dir(ib) ,currentPatch%tr_soil_dir(ib), & (1.0_r8-bc_in(s)%albgr_dir_rb(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) + write(fates_log(),*) 'abs soil fluxes', Abs_dir_z(ft,iv),Abs_dif_z(ft,iv) end do end if else if ( abs(currentPatch%sabs_dif(ib)-(currentPatch%tr_soil_dif(ib) * & (1.0_r8-bc_in(s)%albgr_dif_rb(ib)))) > 0.0001)then - write(iulog,*)'dif ground absorption error',ifp,s,currentPatch%sabs_dif(ib) , & + write(fates_log(),*)'dif ground absorption error',ifp,s,currentPatch%sabs_dif(ib) , & (currentPatch%tr_soil_dif(ib)* & (1.0_r8-bc_in(s)%albgr_dif_rb(ib))),currentPatch%NCL_p,ib,sum(ftweight(1,:,1)) endif @@ -831,22 +831,22 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) 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) + ! write(fates_log(),*) '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) + ! write(fates_log(),*) ' 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 ! NO-OP - ! write(iulog,*) 'first layer of lai_change 2 3',lai_change(1,1,1:3) + ! write(fates_log(),*) '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 ! NO-OP - ! write(iulog,*) 'first layer of lai_change 3 4',lai_change(1,1,1:4) + ! write(fates_log(),*) '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 ! NO-OP - ! write(iulog,*) 'first layer of lai_change 4 5',lai_change(1,1,1:5) + ! write(fates_log(),*) 'first layer of lai_change 4 5',lai_change(1,1,1:5) endif if (radtype == 1)then @@ -862,15 +862,15 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) ! will deal with them for now. end if if (abs(error) > 0.15_r8)then - write(iulog,*) 'Large Dir Radn consvn error',error ,ifp,ib - write(iulog,*) 'diags', bc_out(s)%albd_parb(ifp,ib), bc_out(s)%ftdd_parb(ifp,ib), & + write(fates_log(),*) 'Large Dir Radn consvn error',error ,ifp,ib + write(fates_log(),*) 'diags', bc_out(s)%albd_parb(ifp,ib), bc_out(s)%ftdd_parb(ifp,ib), & bc_out(s)%ftid_parb(ifp,ib), bc_out(s)%fabd_parb(ifp,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,*) 'bc_in(s)%albgr_dir_rb(ib)',bc_in(s)%albgr_dir_rb(ib) + write(fates_log(),*) 'lai_change',lai_change(currentpatch%ncl_p,1:2,1:4) + write(fates_log(),*) 'elai',currentpatch%elai_profile(currentpatch%ncl_p,1:2,1:4) + write(fates_log(),*) 'esai',currentpatch%esai_profile(currentpatch%ncl_p,1:2,1:4) + write(fates_log(),*) 'ftweight',ftweight(1,1:2,1:4) + write(fates_log(),*) 'cp',currentPatch%area, currentPatch%patchno + write(fates_log(),*) 'bc_in(s)%albgr_dir_rb(ib)',bc_in(s)%albgr_dir_rb(ib) bc_out(s)%albd_parb(ifp,ib) = bc_out(s)%albd_parb(ifp,ib) + error end if @@ -881,19 +881,19 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) end if if (abs(error) > 0.15_r8)then - write(iulog,*) '>5% Dif Radn consvn error',error ,ifp,ib - write(iulog,*) 'diags', bc_out(s)%albi_parb(ifp,ib), bc_out(s)%ftii_parb(ifp,ib), & + write(fates_log(),*) '>5% Dif Radn consvn error',error ,ifp,ib + write(fates_log(),*) 'diags', bc_out(s)%albi_parb(ifp,ib), bc_out(s)%ftii_parb(ifp,ib), & bc_out(s)%fabi_parb(ifp,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,*) 'bc_in(s)%albgr_dif_rb(ib)',bc_in(s)%albgr_dif_rb(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) + write(fates_log(),*) 'lai_change',lai_change(currentpatch%ncl_p,1:2,1:4) + write(fates_log(),*) 'elai',currentpatch%elai_profile(currentpatch%ncl_p,1:2,1:4) + write(fates_log(),*) 'esai',currentpatch%esai_profile(currentpatch%ncl_p,1:2,1:4) + write(fates_log(),*) 'ftweight',ftweight(currentpatch%ncl_p,1:2,1:4) + write(fates_log(),*) 'cp',currentPatch%area, currentPatch%patchno + write(fates_log(),*) 'bc_in(s)%albgr_dif_rb(ib)',bc_in(s)%albgr_dif_rb(ib) + write(fates_log(),*) 'rhol',rhol(1:2,:) + write(fates_log(),*) 'ftw',sum(ftweight(1,:,1)),ftweight(1,1:2,1) + write(fates_log(),*) 'present',currentPatch%present(1,1:2) + write(fates_log(),*) 'CAP',currentPatch%canopy_area_profile(1,1:2,1) bc_out(s)%albi_parb(ifp,ib) = bc_out(s)%albi_parb(ifp,ib) + error end if @@ -907,12 +907,12 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) endif if (abs(error) > 0.00000001_r8)then - write(iulog,*) 'there is still error after correction',error ,ifp,ib + write(fates_log(),*) 'there is still error after correction',error ,ifp,ib end if end if - end do !cp_numSWb + end do !hlm_numSWb enddo ! rad-type endif ! is there vegetation? @@ -930,8 +930,6 @@ end subroutine ED_Norman_Radiation subroutine ED_SunShadeFracs(nsites, sites,bc_in,bc_out) - use clm_varctl , only : iulog - implicit none ! Arguments @@ -962,7 +960,7 @@ subroutine ED_SunShadeFracs(nsites, sites,bc_in,bc_out) ifp=ifp+1 - if( DEBUG ) write(iulog,*) 'edsurfRad_5600',ifp,s,cpatch%NCL_p,numpft_ed + if( DEBUG ) write(fates_log(),*) 'edsurfRad_5600',ifp,s,cpatch%NCL_p,numpft_ed ! zero out various datas cpatch%ed_parsun_z(:,:,:) = 0._r8 @@ -985,7 +983,7 @@ subroutine ED_SunShadeFracs(nsites, sites,bc_in,bc_out) do CL = 1, cpatch%NCL_p do FT = 1,numpft_ed - if( DEBUG ) write(iulog,*) 'edsurfRad_5601',CL,FT,cpatch%nrad(CL,ft) + if( DEBUG ) write(fates_log(),*) 'edsurfRad_5601',CL,FT,cpatch%nrad(CL,ft) do iv = 1, cpatch%nrad(CL,ft) !NORMAL CASE. @@ -995,8 +993,8 @@ subroutine ED_SunShadeFracs(nsites, sites,bc_in,bc_out) cpatch%ed_laisun_z(CL,ft,iv) = cpatch%elai_profile(CL,ft,iv) * & cpatch%f_sun(CL,ft,iv) - if ( DEBUG ) write(iulog,*) 'edsurfRad 570 ',cpatch%elai_profile(CL,ft,iv) - if ( DEBUG ) write(iulog,*) 'edsurfRad 571 ',cpatch%f_sun(CL,ft,iv) + if ( DEBUG ) write(fates_log(),*) 'edsurfRad 570 ',cpatch%elai_profile(CL,ft,iv) + if ( DEBUG ) write(fates_log(),*) 'edsurfRad 571 ',cpatch%f_sun(CL,ft,iv) cpatch%ed_laisha_z(CL,ft,iv) = cpatch%elai_profile(CL,ft,iv) * & (1._r8 - cpatch%f_sun(CL,ft,iv)) @@ -1017,7 +1015,7 @@ subroutine ED_SunShadeFracs(nsites, sites,bc_in,bc_out) endif if(bc_out(s)%fsun_pa(ifp) > 1._r8)then - write(iulog,*) 'too much leaf area in profile', bc_out(s)%fsun_pa(ifp), & + write(fates_log(),*) 'too much leaf area in profile', bc_out(s)%fsun_pa(ifp), & cpatch%lai,sunlai,shalai endif @@ -1030,34 +1028,34 @@ subroutine ED_SunShadeFracs(nsites, sites,bc_in,bc_out) ! If sun/shade big leaf code, nrad=1 and fluxes from SurfaceAlbedo ! are canopy integrated so that layer values equal big leaf values. - if ( DEBUG ) write(iulog,*) 'edsurfRad 645 ',cpatch%NCL_p,numpft_ed + if ( DEBUG ) write(fates_log(),*) 'edsurfRad 645 ',cpatch%NCL_p,numpft_ed do CL = 1, cpatch%NCL_p do FT = 1,numpft_ed - if ( DEBUG ) write(iulog,*) 'edsurfRad 649 ',cpatch%nrad(CL,ft) + if ( DEBUG ) write(fates_log(),*) 'edsurfRad 649 ',cpatch%nrad(CL,ft) do iv = 1, cpatch%nrad(CL,ft) if ( DEBUG ) then - write(iulog,*) 'edsurfRad 653 ', cpatch%ed_parsun_z(CL,ft,iv) - write(iulog,*) 'edsurfRad 654 ', bc_in(s)%solad_parb(ifp,ipar) - write(iulog,*) 'edsurfRad 655 ', bc_in(s)%solai_parb(ifp,ipar) - write(iulog,*) 'edsurfRad 656 ', cpatch%fabd_sun_z(CL,ft,iv) - write(iulog,*) 'edsurfRad 657 ', cpatch%fabi_sun_z(CL,ft,iv) + write(fates_log(),*) 'edsurfRad 653 ', cpatch%ed_parsun_z(CL,ft,iv) + write(fates_log(),*) 'edsurfRad 654 ', bc_in(s)%solad_parb(ifp,ipar) + write(fates_log(),*) 'edsurfRad 655 ', bc_in(s)%solai_parb(ifp,ipar) + write(fates_log(),*) 'edsurfRad 656 ', cpatch%fabd_sun_z(CL,ft,iv) + write(fates_log(),*) 'edsurfRad 657 ', cpatch%fabi_sun_z(CL,ft,iv) endif cpatch%ed_parsun_z(CL,ft,iv) = & bc_in(s)%solad_parb(ifp,ipar)*cpatch%fabd_sun_z(CL,ft,iv) + & bc_in(s)%solai_parb(ifp,ipar)*cpatch%fabi_sun_z(CL,ft,iv) - if ( DEBUG )write(iulog,*) 'edsurfRad 663 ', cpatch%ed_parsun_z(CL,ft,iv) + if ( DEBUG )write(fates_log(),*) 'edsurfRad 663 ', cpatch%ed_parsun_z(CL,ft,iv) cpatch%ed_parsha_z(CL,ft,iv) = & bc_in(s)%solad_parb(ifp,ipar)*cpatch%fabd_sha_z(CL,ft,iv) + & bc_in(s)%solai_parb(ifp,ipar)*cpatch%fabi_sha_z(CL,ft,iv) - if ( DEBUG ) write(iulog,*) 'edsurfRad 669 ', cpatch%ed_parsha_z(CL,ft,iv) + if ( DEBUG ) write(fates_log(),*) 'edsurfRad 669 ', cpatch%ed_parsha_z(CL,ft,iv) end do !iv end do !FT @@ -1096,7 +1094,7 @@ end subroutine ED_SunShadeFracs ! g = gridcell(p) ! errsol = (fsa(p) + fsr(p) - (forc_solad(g,1) + forc_solad(g,2) + forc_solai(g,1) + forc_solai(g,2))) ! if(abs(errsol) > 0.1_r8)then -! write(iulog,*) 'sol error in surf rad',p,g, errsol +! write(fates_log(),*) 'sol error in surf rad',p,g, errsol ! endif ! end do ! return diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index b8610213..6dd2592c 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -24,7 +24,10 @@ module FATESPlantRespPhotosynthMod use FatesGlobals, only : fates_log use FatesConstantsMod, only : r8 => fates_r8 use EDTypesMod, only : use_fates_plant_hydro - + use EDTypesMod, only : numpft_ed + use EDTypesMod, only : nlevcan + use EDTypesMod, only : nclmax + ! CIME Globals use shr_log_mod , only : errMsg => shr_log_errMsg @@ -68,10 +71,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) use EDTypesMod , only : ed_patch_type use EDTypesMod , only : ed_cohort_type use EDTypesMod , only : ed_site_type - use FatesGlobals , only : numpft_ed - use EDTypesMod , only : cp_numlevsoil - use FatesGlobals , only : cp_nlevcan - use FatesGlobals , only : cp_nclmax + use FatesInterfaceMod , only : hlm_numlevsoil use EDEcophysContype , only : EDecophyscon use FatesInterfaceMod , only : bc_in_type use FatesInterfaceMod , only : bc_out_type @@ -82,6 +82,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) use FatesConstantsMod, only : rgas => rgas_J_K_kmol use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm use FatesParameterDerivedMod, only : param_derived + use EDPatchDynamicsMod, only: set_root_fraction ! ARGUMENTS: @@ -115,17 +116,17 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! ----------------------------------------------------------------------------------- ! leaf maintenance (dark) respiration (umol CO2/m**2/s) Double check this - real(r8) :: lmr_z(cp_nlevcan,mxpft,cp_nclmax) + real(r8) :: lmr_z(nlevcan,mxpft,nclmax) ! stomatal resistance s/m - real(r8) :: rs_z(cp_nlevcan,mxpft,cp_nclmax) + real(r8) :: rs_z(nlevcan,mxpft,nclmax) ! net leaf photosynthesis averaged over sun and shade leaves. (umol CO2/m**2/s) - real(r8) :: anet_av_z(cp_nlevcan,mxpft,cp_nclmax) + real(r8) :: anet_av_z(nlevcan,mxpft,nclmax) ! Mask used to determine which leaf-layer biophysical rates have been ! used already - logical :: rate_mask_z(cp_nlevcan,mxpft,cp_nclmax) + logical :: rate_mask_z(nlevcan,mxpft,nclmax) real(r8) :: vcmax_z ! leaf layer maximum rate of carboxylation ! (umol co2/m**2/s) @@ -293,7 +294,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) end do !ft - call currentPatch%set_root_fraction(bc_in(s)%depth_gl) + call set_root_fraction(currentPatch,bc_in(s)%depth_gl) ! ------------------------------------------------------------------------ ! Part VI: Loop over all leaf layers. @@ -543,7 +544,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! Fine Root MR (kgC/plant/s) ! ------------------------------------------------------------------ currentCohort%froot_mr = 0._r8 - do j = 1,cp_numlevsoil + do j = 1,hlm_numlevsoil tcsoi = q10**((bc_in(s)%t_soisno_gl(j)-tfrz - 20.0_r8)/10.0_r8) currentCohort%froot_mr = currentCohort%froot_mr + & froot_n * base_mr_20 * tcsoi * currentPatch%rootfr_ft(ft,j) @@ -553,7 +554,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! ------------------------------------------------------------------ if (woody(ft) == 1) then currentCohort%livecroot_mr = 0._r8 - do j = 1,cp_numlevsoil + do j = 1,hlm_numlevsoil ! Soil temperature used to adjust base rate of MR tcsoi = q10**((bc_in(s)%t_soisno_gl(j)-tfrz - 20.0_r8)/10.0_r8) currentCohort%livecroot_mr = currentCohort%livecroot_mr + & @@ -1312,8 +1313,7 @@ subroutine UpdateCanopyNCanNRadPresent(currentPatch) ! profile). ! --------------------------------------------------------------------------------- - use EDTypesMod , only : cp_nclmax - use EDTypesMOd , only : numpft_ed + use EDTypesMod , only : ed_patch_type use EDTypesMod , only : ed_cohort_type @@ -1349,7 +1349,7 @@ subroutine UpdateCanopyNCanNRadPresent(currentPatch) currentPatch%nrad = currentPatch%ncan ! Now loop through and identify which layer and pft combo has scattering elements - do cl = 1,cp_nclmax + do cl = 1,nclmax do ft = 1,numpft_ed currentPatch%present(cl,ft) = 0 do iv = 1, currentPatch%nrad(cl,ft); diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index b6ff07c7..7c715dea 100755 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -7,8 +7,8 @@ module SFMainMod use FatesConstantsMod , only : r8 => fates_r8 -! use spmdMod , only : masterproc - use EDTypesMod , only : cp_masterproc ! 1= master process, 0=not master process + use FatesInterfaceMod , only : hlm_masterproc ! 1= master process, 0=not master process + use EDTypesMod , only : numWaterMem use FatesGlobals , only : fates_log use FatesInterfaceMod , only : bc_in_type @@ -184,15 +184,15 @@ subroutine charecteristics_of_fuel ( currentSite ) currentPatch%fuel_frac = 0.0_r8 if(write_sf == 1)then - if ( cp_masterproc == 1 ) write(fates_log(),*) ' leaf_litter1 ',currentPatch%leaf_litter - if ( cp_masterproc == 1 ) write(fates_log(),*) ' leaf_litter2 ',sum(currentPatch%CWD_AG) - if ( cp_masterproc == 1 ) write(fates_log(),*) ' leaf_litter3 ',currentPatch%livegrass - if ( cp_masterproc == 1 ) write(fates_log(),*) ' sum fuel', currentPatch%sum_fuel + if ( hlm_masterproc == 1 ) write(fates_log(),*) ' leaf_litter1 ',currentPatch%leaf_litter + if ( hlm_masterproc == 1 ) write(fates_log(),*) ' leaf_litter2 ',sum(currentPatch%CWD_AG) + if ( hlm_masterproc == 1 ) write(fates_log(),*) ' leaf_litter3 ',currentPatch%livegrass + if ( hlm_masterproc == 1 ) write(fates_log(),*) ' 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 ( cp_masterproc == 1 ) write(fates_log(),*) 'sum fuel', currentPatch%sum_fuel,currentPatch%area + if ( hlm_masterproc == 1 ) write(fates_log(),*) 'sum fuel', currentPatch%sum_fuel,currentPatch%area endif ! =============================================== ! Average moisture, bulk density, surface area-volume and moisture extinction of fuel @@ -204,9 +204,9 @@ subroutine charecteristics_of_fuel ( currentSite ) currentPatch%fuel_frac(dg_sf+1:tr_sf) = currentPatch%CWD_AG / currentPatch%sum_fuel if(write_sf == 1)then - if ( cp_masterproc == 1 ) write(fates_log(),*) 'ff1 ',currentPatch%fuel_frac - if ( cp_masterproc == 1 ) write(fates_log(),*) 'ff2 ',currentPatch%fuel_frac - if ( cp_masterproc == 1 ) write(fates_log(),*) 'ff2a ',lg_sf,currentPatch%livegrass,currentPatch%sum_fuel + if ( hlm_masterproc == 1 ) write(fates_log(),*) 'ff1 ',currentPatch%fuel_frac + if ( hlm_masterproc == 1 ) write(fates_log(),*) 'ff2 ',currentPatch%fuel_frac + if ( hlm_masterproc == 1 ) write(fates_log(),*) 'ff2a ',lg_sf,currentPatch%livegrass,currentPatch%sum_fuel endif currentPatch%fuel_frac(lg_sf) = currentPatch%livegrass / currentPatch%sum_fuel @@ -215,14 +215,14 @@ subroutine charecteristics_of_fuel ( currentSite ) !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 ( cp_masterproc == 1 ) write(fates_log(),*) 'ff3 ',currentPatch%fuel_frac - if ( cp_masterproc == 1 ) write(fates_log(),*) 'fm ',fuel_moisture - if ( cp_masterproc == 1 ) write(fates_log(),*) 'csa ',currentSite%acc_NI - if ( cp_masterproc == 1 ) write(fates_log(),*) 'sfv ',SF_val_alpha_FMC + if ( hlm_masterproc == 1 ) write(fates_log(),*) 'ff3 ',currentPatch%fuel_frac + if ( hlm_masterproc == 1 ) write(fates_log(),*) 'fm ',fuel_moisture + if ( hlm_masterproc == 1 ) write(fates_log(),*) 'csa ',currentSite%acc_NI + if ( hlm_masterproc == 1 ) write(fates_log(),*) '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 + timeav_swc = sum(currentSite%water_memory(1:numWaterMem)) / dble(numWaterMem) ! Equation B2 in Thonicke et al. 2010 fuel_moisture(lg_sf) = max(0.0_r8, 10.0_r8/9._r8 * timeav_swc - 1.0_r8/9.0_r8) @@ -232,7 +232,7 @@ subroutine charecteristics_of_fuel ( currentSite ) 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 ( cp_masterproc == 1 ) write(fates_log(),*) 'ff4 ',currentPatch%fuel_eff_moist + if ( hlm_masterproc == 1 ) write(fates_log(),*) '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) @@ -259,14 +259,14 @@ subroutine charecteristics_of_fuel ( currentSite ) if(write_SF == 1)then - if ( cp_masterproc == 1 ) write(fates_log(),*) 'no litter fuel at all',currentPatch%patchno, & + if ( hlm_masterproc == 1 ) write(fates_log(),*) '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 ( cp_masterproc == 1 ) write(fates_log(),*) 'problem with spitfire fuel averaging' + if ( hlm_masterproc == 1 ) write(fates_log(),*) 'problem with spitfire fuel averaging' ! FIX(SPM,032414) refactor...should not have 0 fuel unless everything is burnt ! off. @@ -282,7 +282,7 @@ subroutine charecteristics_of_fuel ( currentSite ) ! 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 ( cp_masterproc == 1 ) write(fates_log(),*) 'problem with spitfire fuel averaging' + if ( hlm_masterproc == 1 ) write(fates_log(),*) 'problem with spitfire fuel averaging' endif currentPatch => currentPatch%younger @@ -321,7 +321,7 @@ subroutine wind_effect ( currentSite, bc_in) wind = bc_in%wind24_pa(iofp) * sec_per_min ! Convert to m/min for SPITFIRE units. if(write_SF == 1)then - if ( cp_masterproc == 1 ) write(fates_log(),*) 'wind24', wind + if ( hlm_masterproc == 1 ) write(fates_log(),*) 'wind24', wind endif ! --- influence of wind speed, corrected for surface roughness---- ! --- averaged over the whole grid cell to prevent extreme divergence @@ -360,7 +360,7 @@ subroutine wind_effect ( currentSite, bc_in) grass_fraction = min(grass_fraction,1.0_r8-tree_fraction) bare_fraction = 1.0 - tree_fraction - grass_fraction if(write_sf == 1)then - if ( cp_masterproc == 1 ) write(fates_log(),*) 'grass, trees, bare',grass_fraction, tree_fraction, bare_fraction + if ( hlm_masterproc == 1 ) write(fates_log(),*) 'grass, trees, bare',grass_fraction, tree_fraction, bare_fraction endif currentPatch=>currentSite%oldest_patch; @@ -410,18 +410,18 @@ subroutine rate_of_spread ( currentSite ) currentPatch%sum_fuel = currentPatch%sum_fuel * (1.0_r8 - SF_val_miner_total) !net of minerals ! ----start spreading--- - if ( cp_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - currentPatch%fuel_bulkd ',currentPatch%fuel_bulkd - if ( cp_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - SF_val_part_dens ',SF_val_part_dens + if ( hlm_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - currentPatch%fuel_bulkd ',currentPatch%fuel_bulkd + if ( hlm_masterproc == 1 .and.DEBUG) write(fates_log(),*) '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 ( cp_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - beta ',beta - if ( cp_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - beta_op ',beta_op + if ( hlm_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - beta ',beta + if ( hlm_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - beta_op ',beta_op bet = beta/beta_op if(write_sf == 1)then - if ( cp_masterproc == 1 ) write(fates_log(),*) 'esf ',currentPatch%fuel_eff_moist + if ( hlm_masterproc == 1 ) write(fates_log(),*) 'esf ',currentPatch%fuel_eff_moist endif ! ---heat of pre-ignition--- ! Equation A4 in Thonicke et al. 2010 @@ -439,11 +439,11 @@ subroutine rate_of_spread ( currentSite ) ! Equation A5 in Thonicke et al. 2010 if (DEBUG) then - if ( cp_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - c ',c - if ( cp_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - currentPatch%effect_wspeed ',currentPatch%effect_wspeed - if ( cp_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - b ',b - if ( cp_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - bet ',bet - if ( cp_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - e ',e + if ( hlm_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - c ',c + if ( hlm_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - currentPatch%effect_wspeed ',currentPatch%effect_wspeed + if ( hlm_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - b ',b + if ( hlm_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - bet ',bet + if ( hlm_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - e ',e endif ! convert from m/min to ft/min for Rothermel ROS eqn @@ -605,7 +605,7 @@ subroutine fire_intensity ( currentSite ) 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( cp_masterproc == 1 ) write(fates_log(),*) 'fire_intensity',currentPatch%fi,W,currentPatch%ROS_front + if( hlm_masterproc == 1 ) write(fates_log(),*) '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 @@ -616,7 +616,7 @@ subroutine fire_intensity ( currentSite ) ! 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 ( cp_masterproc == 1 ) write(fates_log(),*) 'fire duration minutes',currentPatch%fd + if ( hlm_masterproc == 1 ) write(fates_log(),*) '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 @@ -703,19 +703,19 @@ subroutine area_burnt ( currentSite ) currentPatch%AB = size_of_fire * currentPatch%nf if (currentPatch%AB > gridarea*currentPatch%area/area) then !all of patch burnt. - if ( cp_masterproc == 1 ) write(fates_log(),*) 'burnt all of patch',currentPatch%patchno, & + if ( hlm_masterproc == 1 ) write(fates_log(),*) 'burnt all of patch',currentPatch%patchno, & currentPatch%area/area,currentPatch%ab,currentPatch%area/area*gridarea - if ( cp_masterproc == 1 ) write(fates_log(),*) 'ros',currentPatch%ROS_front,currentPatch%FD, & + if ( hlm_masterproc == 1 ) write(fates_log(),*) 'ros',currentPatch%ROS_front,currentPatch%FD, & currentPatch%NF,currentPatch%FI,size_of_fire - if ( cp_masterproc == 1 ) write(fates_log(),*) 'litter', & + if ( hlm_masterproc == 1 ) write(fates_log(),*) '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 ( cp_masterproc == 1 ) write(fates_log(),*) 'frac_burnt',currentPatch%frac_burnt + if ( hlm_masterproc == 1 ) write(fates_log(),*) 'frac_burnt',currentPatch%frac_burnt endif endif endif! fire @@ -772,7 +772,7 @@ subroutine crown_scorching ( currentSite ) currentCohort%bdead))*currentCohort%n)/tree_ag_biomass !equation 16 in Thonicke et al. 2010 if(write_SF == 1)then - if ( cp_masterproc == 1 ) write(fates_log(),*) 'currentPatch%SH',currentPatch%SH,f_ag_bmass + if ( hlm_masterproc == 1 ) write(fates_log(),*) '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) diff --git a/fire/SFParamsMod.F90 b/fire/SFParamsMod.F90 index 3caa526a..978ac5f9 100644 --- a/fire/SFParamsMod.F90 +++ b/fire/SFParamsMod.F90 @@ -2,7 +2,7 @@ module SFParamsMod ! ! module that deals with reading the SF parameter file ! - use shr_kind_mod , only: r8 => shr_kind_r8 + use FatesConstantsMod , only: r8 => fates_r8 use EDtypesMod , only: NLSC,NFSC,NCWD implicit none diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index aa5850ad..952e4863 100755 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -6,7 +6,7 @@ module EDInitMod use FatesConstantsMod , only : r8 => fates_r8 use FatesGlobals , only : endrun => fates_endrun - use FatesGlobals , only : cp_nclmax + use EDTypesMod , only : nclmax use FatesGlobals , only : fates_log use clm_varctl , only : use_ed_spit_fire use clm_time_manager , only : is_restart @@ -17,8 +17,9 @@ module EDInitMod use EDPatchDynamicsMod , only : create_patch use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type, area use EDTypesMod , only : ncwd - use FatesGlobals , only : numpft_ed - + use EDTypesMod , only : nuMWaterMem + use EDTypesMod , only : numpft_ed + implicit none private @@ -145,7 +146,7 @@ subroutine set_site_properties( nsites, sites) sites(s)%ED_GDD_site = GDD if ( .not. is_restart() ) then - sites(s)%water_memory(1:10) = watermem + sites(s)%water_memory(1:numWaterMem) = watermem end if sites(s)%status = stat @@ -179,7 +180,7 @@ subroutine init_patches( nsites, sites) integer :: s real(r8) :: cwd_ag_local(ncwd) real(r8) :: cwd_bg_local(ncwd) - real(r8) :: spread_local(cp_nclmax) + real(r8) :: spread_local(nclmax) real(r8) :: leaf_litter_local(numpft_ed) real(r8) :: root_litter_local(numpft_ed) real(r8) :: age !notional age of this patch diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 6882222f..749e06ff 100755 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -7,23 +7,34 @@ module EDMainMod use shr_kind_mod , only : r8 => shr_kind_r8 use FatesGlobals , only : fates_log - use FatesGlobals , only : freq_day - use FatesGlobals , only : day_of_year - use FatesGlobals , only : days_per_year - use FatesGlobals , only : current_year - use FatesGlobals , only : current_month - use FatesGlobals , only : current_day - use atm2lndType , only : atm2lnd_type - use SoilStateType , only : soilstate_type - use TemperatureType , only : temperature_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 FatesInterfaceMod , only : hlm_freq_day + use FatesInterfaceMod , only : hlm_day_of_year + use FatesInterfaceMod , only : hlm_days_per_year + use FatesInterfaceMod , only : hlm_current_year + use FatesInterfaceMod , only : hlm_current_month + use FatesInterfaceMod , only : hlm_current_day + use EDCohortDynamicsMod , only : allocate_live_biomass + use EDCohortDynamicsMod , only : terminate_cohorts + use EDCohortDynamicsMod , only : fuse_cohorts + use EDCohortDynamicsMod , only : sort_cohorts + use EDCohortDynamicsMod , only : count_cohorts + use EDPatchDynamicsMod , only : disturbance_rates + use EDPatchDynamicsMod , only : fuse_patches + use EDPatchDynamicsMod , only : spawn_patches + use EDPatchDynamicsMod , only : terminate_patches + use EDPhysiologyMod , only : canopy_derivs + use EDPhysiologyMod , only : non_canopy_derivs + use EDPhysiologyMod , only : phenology + use EDPhysiologyMod , only : recruitment + use EDPhysiologyMod , only : trim_canopy use SFMainMod , only : fire_model - use EDtypesMod , only : ncwd, numpft_ed - use EDtypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type + use EDtypesMod , only : ncwd + use EDTypesMod , only : numpft_ed + use EDtypesMod , only : ed_site_type + use EDtypesMod , only : ed_patch_type + use EDtypesMod , only : ed_cohort_type use FatesInterfaceMod , only : bc_in_type - use EDTypesMod , only : cp_masterproc + use FatesInterfaceMod , only : hlm_masterproc implicit none @@ -60,8 +71,8 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) type(ed_patch_type), pointer :: currentPatch !----------------------------------------------------------------------- - if ( cp_masterproc==1 ) write(fates_log(),'(A,I4,A,I2.2,A,I2.2)') 'FATES Dynamics: ',& - current_year,'-',current_month,'-',current_day + if ( hlm_masterproc==1 ) write(fates_log(),'(A,I4,A,I2.2,A,I2.2)') 'FATES Dynamics: ',& + hlm_current_year,'-',hlm_current_month,'-',hlm_current_day !************************************************************************** ! Fire, growth, biogeochemistry. @@ -170,7 +181,7 @@ subroutine ed_integrate_state_variables(currentSite, bc_in ) do while(associated(currentPatch)) - currentPatch%age = currentPatch%age + freq_day + currentPatch%age = currentPatch%age + hlm_freq_day ! FIX(SPM,032414) valgrind 'Conditional jump or move depends on uninitialised value' if( currentPatch%age < 0._r8 )then write(fates_log(),*) 'negative patch age?',currentPatch%age, & @@ -185,17 +196,17 @@ subroutine ed_integrate_state_variables(currentSite, bc_in ) do while(associated(currentCohort)) cohort_biomass_store = (currentCohort%balive+currentCohort%bdead+currentCohort%bstore) - currentCohort%dbh = max(small_no,currentCohort%dbh + currentCohort%ddbhdt * freq_day ) - currentCohort%balive = currentCohort%balive + currentCohort%dbalivedt * freq_day - currentCohort%bdead = max(small_no,currentCohort%bdead + currentCohort%dbdeaddt * freq_day ) + currentCohort%dbh = max(small_no,currentCohort%dbh + currentCohort%ddbhdt * hlm_freq_day ) + currentCohort%balive = currentCohort%balive + currentCohort%dbalivedt * hlm_freq_day + currentCohort%bdead = max(small_no,currentCohort%bdead + currentCohort%dbdeaddt * hlm_freq_day ) if ( DEBUG ) then write(fates_log(),*) 'EDMainMod dbstoredt I ',currentCohort%bstore, & - currentCohort%dbstoredt,freq_day + currentCohort%dbstoredt,hlm_freq_day end if - currentCohort%bstore = currentCohort%bstore + currentCohort%dbstoredt * freq_day + currentCohort%bstore = currentCohort%bstore + currentCohort%dbstoredt * hlm_freq_day if ( DEBUG ) then write(fates_log(),*) 'EDMainMod dbstoredt II ',currentCohort%bstore, & - currentCohort%dbstoredt,freq_day + currentCohort%dbstoredt,hlm_freq_day end if if( (currentCohort%balive+currentCohort%bdead+currentCohort%bstore)*currentCohort%n<0._r8)then @@ -203,10 +214,10 @@ subroutine ed_integrate_state_variables(currentSite, bc_in ) currentCohort%bdead,currentCohort%bstore endif - if(abs((currentCohort%balive+currentCohort%bdead+currentCohort%bstore+freq_day*(currentCohort%md+ & + if(abs((currentCohort%balive+currentCohort%bdead+currentCohort%bstore+hlm_freq_day*(currentCohort%md+ & currentCohort%seed_prod)-cohort_biomass_store)-currentCohort%npp_acc) > 1e-8_r8)then write(fates_log(),*) 'issue with c balance in integration', abs(currentCohort%balive+currentCohort%bdead+ & - currentCohort%bstore+freq_day* & + currentCohort%bstore+hlm_freq_day* & (currentCohort%md+currentCohort%seed_prod)-cohort_biomass_store-currentCohort%npp_acc) endif @@ -221,23 +232,19 @@ subroutine ed_integrate_state_variables(currentSite, bc_in ) enddo - if ( DEBUG ) then - write(6,*)'DEBUG18: calling non_canopy_derivs with pno= ',currentPatch%clm_pno - endif - call non_canopy_derivs( currentSite, currentPatch, bc_in) !update state variables simultaneously according to derivatives for this time period. ! first update the litter variables that are tracked at the patch level do c = 1,ncwd - currentPatch%cwd_ag(c) = currentPatch%cwd_ag(c) + currentPatch%dcwd_ag_dt(c)* freq_day - currentPatch%cwd_bg(c) = currentPatch%cwd_bg(c) + currentPatch%dcwd_bg_dt(c)* freq_day + currentPatch%cwd_ag(c) = currentPatch%cwd_ag(c) + currentPatch%dcwd_ag_dt(c)* hlm_freq_day + currentPatch%cwd_bg(c) = currentPatch%cwd_bg(c) + currentPatch%dcwd_bg_dt(c)* hlm_freq_day enddo do ft = 1,numpft_ed - currentPatch%leaf_litter(ft) = currentPatch%leaf_litter(ft) + currentPatch%dleaf_litter_dt(ft)* freq_day - currentPatch%root_litter(ft) = currentPatch%root_litter(ft) + currentPatch%droot_litter_dt(ft)* freq_day + currentPatch%leaf_litter(ft) = currentPatch%leaf_litter(ft) + currentPatch%dleaf_litter_dt(ft)* hlm_freq_day + currentPatch%root_litter(ft) = currentPatch%root_litter(ft) + currentPatch%droot_litter_dt(ft)* hlm_freq_day enddo do c = 1,ncwd @@ -261,7 +268,7 @@ subroutine ed_integrate_state_variables(currentSite, bc_in ) endif if(currentPatch%root_litter(ft) currentPatch%shortest do while(associated(currentCohort)) - currentCohort%n = max(small_no,currentCohort%n + currentCohort%dndt * freq_day ) + currentCohort%n = max(small_no,currentCohort%n + currentCohort%dndt * hlm_freq_day ) currentCohort => currentCohort%taller enddo @@ -282,7 +289,7 @@ subroutine ed_integrate_state_variables(currentSite, bc_in ) ! at the site level, update the seed bank mass do ft = 1,numpft_ed - currentSite%seed_bank(ft) = currentSite%seed_bank(ft) + currentSite%dseed_dt(ft)*freq_day + currentSite%seed_bank(ft) = currentSite%seed_bank(ft) + currentSite%dseed_dt(ft)*hlm_freq_day enddo ! Check for negative values. Write out warning to show carbon balance. @@ -355,7 +362,7 @@ subroutine ed_update_site( currentSite, bc_in ) ! FIX(RF,032414). This needs to be monthly, not annual ! If this is the second to last day of the year, then perform trimming - if( day_of_year == days_per_year-1) then + if( hlm_day_of_year == hlm_days_per_year-1) then write(fates_log(),*) 'calling trim canopy' call trim_canopy(currentSite) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index ec900b43..f0800522 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -1,32 +1,48 @@ module EDTypesMod - use shr_kind_mod , only : r8 => shr_kind_r8; + use FatesConstantsMod , only : r8 => fates_r8 use clm_varpar , only : mxpft - use FatesGlobals , only : cp_nclmax, cp_nlevcan, numpft_ed implicit none save - !SWITCHES THAT ARE READ IN - integer RESTART ! restart flag, 1= read initial system state 0 = bare ground + integer, parameter :: maxPatchesPerSite = 10 ! maximum number of patches to live on a site + integer, parameter :: maxCohortsPerPatch = 160 ! maximum number of cohorts to live on a patch + integer, parameter :: nclmax = 2 ! Maximum number of canopy layers + integer, parameter :: nlevcan = 40 ! number of leaf layers in canopy layer + integer, parameter :: maxpft = 10 ! maximum number of PFTs allowed + ! the parameter file may determine that fewer + ! are used, but this helps allocate scratch + ! space and output arrays. + + integer, parameter :: numpft_ed = 2 ! number of PFTs used in ED. + + ! TODO: we use this cp_maxSWb only because we have a static array (size=2) of + ! land-ice abledo for vis and nir. This should be a parameter, which would + ! get us on track to start using multi-spectral or hyper-spectral (RGK 02-2017) + integer, parameter :: maxSWb = 2 ! maximum number of broad-bands in the + ! shortwave spectrum cp_numSWb <= cp_maxSWb + ! this is just for scratch-array purposes + ! if cp_numSWb is larger than this value + ! simply bump this number up as needed + + ! Module switches (this will be read in one day) + ! This variable only exists now to serve as a place holder + !!!!!!!!!! THIS SHOULD NOT BE SET TO TRUE !!!!!!!!!!!!!!!!! + logical, parameter :: use_fates_plant_hydro = .false. + ! MODEL PARAMETERS - real(r8) :: timestep_secs ! subdaily timestep in seconds (e.g. 1800 or 3600) - real(r8), parameter :: AREA = 10000.0_r8 ! Notional area of simulated forest m2 - 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 :: 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 :: maxPft = 79 ! max number of PFTs potentially used by CLM - ! SPITFIRE integer , parameter :: NLSC = 6 ! number carbon compartments in above ground litter array @@ -54,9 +70,11 @@ module EDTypesMod real(r8), parameter :: min_npm2 = 1.0d-5 ! minimum cohort number density per m2 before termination real(r8), parameter :: min_patch_area = 0.001_r8 ! smallest allowable patch area before termination real(r8), parameter :: min_nppatch = 1.0d-8 ! minimum number of cohorts per patch (min_npm2*min_patch_area) - real(r8), parameter :: min_n_safemath = 1.0d-15 ! in some cases, we want to immediately remove super small - ! number densities of cohorts to prevent FPEs, this is usually - ! just relevant in the first day after recruitment + + ! in some cases, we want to immediately remove super small + ! number densities of cohorts to prevent FPEs, this is usually + ! just relevant in the first day after recruitment + real(r8), parameter :: min_n_safemath = 1.0E-15_r8 character*4 yearchar @@ -80,7 +98,8 @@ module EDTypesMod ! Number of ways to die ! (background,hydraulic,carbon,impact,fire) - character(len = 10), parameter,dimension(5) :: char_list = (/"background","hydraulic ","carbon ","impact ","fire "/) + character(len = 10), parameter,dimension(nlevmclass_ed) :: char_list = & + (/"background","hydraulic ","carbon ","impact ","fire "/) ! These three vectors are used for history output mapping @@ -90,56 +109,7 @@ module EDTypesMod ! the parameter array sclass_ed. integer , allocatable :: pft_levscpf_ed(:) integer , allocatable :: scls_levscpf_ed(:) - - - ! Control Parameters (cp_) - ! ------------------------------------------------------------------------------------- - - - - integer, parameter :: cp_maxSWb = 2 ! maximum number of broad-bands in the - ! shortwave spectrum cp_numSWb <= cp_maxSWb - ! this is just for scratch-array purposes - ! if cp_numSWb is larger than this value - ! simply bump this number up as needed - ! These parameters are dictated by the host model or driver - - integer :: cp_numSWb ! Number of broad-bands in the short-wave radiation - ! specturm to track - ! (typically 2 as a default, VIS/NIR, in ED variants <2016) - - integer :: cp_numlevgrnd ! Number of ground layers - integer :: cp_numlevsoil ! Number of soil layers - - ! Number of GROUND layers for the purposes of biogeochemistry; can be either 1 - ! or the total number of soil layers (includes bedrock) - integer :: cp_numlevdecomp_full - - ! Number of SOIL layers for the purposes of biogeochemistry; can be either 1 - ! or the total number of soil layers - integer :: cp_numlevdecomp - - ! This character string passed by the HLM is used during the processing of IO - ! data, so that FATES knows which IO variables it should prepare. For instance - ! ATS, ALM and CLM will only want variables specficially packaged for them. - ! This string will dictate which filter is enacted. - character(len=16) :: cp_hlm_name - - ! This value can be flushed to history diagnostics, such that the - ! HLM will interpret that the value should not be included in the average. - real(r8) :: cp_hio_ignore_val - - - ! Is this the master processor, typically useful for knowing if - ! the current machine should be printing out messages to the logs or terminals - ! 1 = TRUE (is master) 0 = FALSE (is not master) - integer :: cp_masterproc - - - ! Module switches (this will be read in one day) - ! This variable only exists now to serve as a place holder - !!!!!!!!!! THIS SHOULD NOT BE SET TO TRUE !!!!!!!!!!!!!!!!! - logical,parameter :: use_fates_plant_hydro = .false. + !************************************ !** COHORT type structure ** @@ -228,8 +198,8 @@ module EDTypesMod real(r8) :: npp_bseed ! NPP into seeds: KgC/indiv/day real(r8) :: npp_store ! NPP into storage: KgC/indiv/day - real(r8) :: ts_net_uptake(cp_nlevcan) ! Net uptake of leaf layers: kgC/m2/s - real(r8) :: year_net_uptake(cp_nlevcan) ! Net uptake of leaf layers: kgC/m2/year + real(r8) :: ts_net_uptake(nlevcan) ! Net uptake of leaf layers: kgC/m2/s + real(r8) :: year_net_uptake(nlevcan) ! Net uptake of leaf layers: kgC/m2/year ! RESPIRATION COMPONENTS real(r8) :: rdark ! Dark respiration: kgC/indiv/s @@ -300,9 +270,6 @@ module EDTypesMod !INDICES integer :: patchno ! unique number given to each new patch created for tracking - ! INTERF-TODO: THIS VARIABLE SHOULD BE REMOVED - 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 @@ -310,42 +277,42 @@ module EDTypesMod integer :: ncl_p ! Number of occupied canopy layers ! LEAF ORGANIZATION - real(r8) :: spread(cp_nclmax) ! dynamic ratio of dbh to canopy area: cm/m2 + 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(cp_nclmax) ! lai that is shading this canopy layer: m2/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(cp_nclmax,numpft_ed,cp_nlevcan) ! total leaf area in each canopy layer, pft, and leaf layer. m2/m2 - real(r8) :: elai_profile(cp_nclmax,numpft_ed,cp_nlevcan) ! exposed leaf area in each canopy layer, pft, and leaf layer. m2/m2 - real(r8) :: tsai_profile(cp_nclmax,numpft_ed,cp_nlevcan) ! total stem area in each canopy layer, pft, and leaf layer. m2/m2 - real(r8) :: esai_profile(cp_nclmax,numpft_ed,cp_nlevcan) ! exposed stem area in each canopy layer, pft, and leaf layer. m2/m2 - real(r8) :: layer_height_profile(cp_nclmax,numpft_ed,cp_nlevcan) - real(r8) :: canopy_area_profile(cp_nclmax,numpft_ed,cp_nlevcan) ! fraction of canopy in each canopy + real(r8) :: tlai_profile(nclmax,numpft_ed,nlevcan) ! total leaf area in each canopy layer, pft, and leaf layer. m2/m2 + real(r8) :: elai_profile(nclmax,numpft_ed,nlevcan) ! exposed leaf area in each canopy layer, pft, and leaf layer. m2/m2 + real(r8) :: tsai_profile(nclmax,numpft_ed,nlevcan) ! total stem area in each canopy layer, pft, and leaf layer. m2/m2 + real(r8) :: esai_profile(nclmax,numpft_ed,nlevcan) ! exposed stem area in each canopy layer, pft, and leaf layer. m2/m2 + real(r8) :: layer_height_profile(nclmax,numpft_ed,nlevcan) + real(r8) :: canopy_area_profile(nclmax,numpft_ed,nlevcan) ! fraction of canopy in each canopy ! layer, pft, and leaf layer:- - integer :: present(cp_nclmax,numpft_ed) ! is there any of this pft in this canopy layer? - integer :: nrad(cp_nclmax,numpft_ed) ! number of exposed leaf layers for each canopy layer and pft - integer :: ncan(cp_nclmax,numpft_ed) ! number of total leaf layers for each canopy layer and pft + 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(cp_nclmax,numpft_ed,cp_nlevcan) ! sun fraction of direct light absorbed by each canopy + real(r8) :: fabd_sun_z(nclmax,numpft_ed,nlevcan) ! sun fraction of direct light absorbed by each canopy ! layer, pft, and leaf layer:- - real(r8) :: fabd_sha_z(cp_nclmax,numpft_ed,cp_nlevcan) ! shade fraction of direct light absorbed by each canopy + real(r8) :: fabd_sha_z(nclmax,numpft_ed,nlevcan) ! shade fraction of direct light absorbed by each canopy ! layer, pft, and leaf layer:- - real(r8) :: fabi_sun_z(cp_nclmax,numpft_ed,cp_nlevcan) ! sun fraction of indirect light absorbed by each canopy + real(r8) :: fabi_sun_z(nclmax,numpft_ed,nlevcan) ! sun fraction of indirect light absorbed by each canopy ! layer, pft, and leaf layer:- - real(r8) :: fabi_sha_z(cp_nclmax,numpft_ed,cp_nlevcan) ! shade fraction of indirect light absorbed by each canopy + real(r8) :: fabi_sha_z(nclmax,numpft_ed,nlevcan) ! shade fraction of indirect light absorbed by each canopy ! layer, pft, and leaf layer:- - real(r8) :: ed_laisun_z(cp_nclmax,numpft_ed,cp_nlevcan) ! amount of LAI in the sun in each canopy layer, + real(r8) :: ed_laisun_z(nclmax,numpft_ed,nlevcan) ! amount of LAI in the sun in each canopy layer, ! pft, and leaf layer. m2/m2 - real(r8) :: ed_laisha_z(cp_nclmax,numpft_ed,cp_nlevcan) ! amount of LAI in the shade in each canopy layer, - real(r8) :: ed_parsun_z(cp_nclmax,numpft_ed,cp_nlevcan) ! PAR absorbed in the sun in each canopy layer, - real(r8) :: ed_parsha_z(cp_nclmax,numpft_ed,cp_nlevcan) ! PAR absorbed in the shade in each canopy layer, - real(r8) :: f_sun(cp_nclmax,numpft_ed,cp_nlevcan) ! fraction of leaves in the sun in each canopy layer, pft, + real(r8) :: ed_laisha_z(nclmax,numpft_ed,nlevcan) ! amount of LAI in the shade in each canopy layer, + real(r8) :: ed_parsun_z(nclmax,numpft_ed,nlevcan) ! PAR absorbed in the sun in each canopy layer, + real(r8) :: ed_parsha_z(nclmax,numpft_ed,nlevcan) ! PAR absorbed in the shade in each canopy layer, + real(r8) :: f_sun(nclmax,numpft_ed,nlevcan) ! fraction of leaves in the sun in each canopy layer, pft, ! and leaf layer. m2/m2 real(r8),allocatable :: tr_soil_dir(:) ! fraction of incoming direct radiation that (cm_numSWb) @@ -367,7 +334,7 @@ module EDTypesMod real(r8) :: seed_germination(numpft_ed) ! germination rate of seed pool in KgC/m2/year ! PHOTOSYNTHESIS - real(r8) :: psn_z(cp_nclmax,numpft_ed,cp_nlevcan) ! carbon assimilation in each canopy layer, pft, and leaf layer. umolC/m2/s + real(r8) :: psn_z(nclmax,numpft_ed,nlevcan) ! 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 @@ -417,13 +384,13 @@ module EDTypesMod 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 + ! (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). + ! (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). + ! 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) + ! (incl. live grasses. omits 1000hr fuels) real(r8) :: litter_moisture(ncwd+2) ! FIRE SPREAD @@ -445,8 +412,6 @@ module EDTypesMod contains - procedure, public :: set_root_fraction - end type ed_patch_type !************************************ @@ -516,7 +481,7 @@ module EDTypesMod 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) :: water_memory(numWaterMem) ! last 10 days of soil moisture memory... !SEED BANK real(r8) :: seed_bank(numpft_ed) ! seed pool in KgC/m2/year @@ -533,20 +498,6 @@ module EDTypesMod end type ed_site_type - !************************************ - !** Userdata type structure ** - !************************************ - -! type userdata -! integer :: cohort_number ! Counts up the number of cohorts which have been made. -! integer :: n_sub ! num of substeps in year -! 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 ! THIS WAS NOT THREADSAFE - !-------------------------------------------------------------------------------------! - public :: ed_hist_scpfmaps contains @@ -583,76 +534,6 @@ subroutine ed_hist_scpfmaps end subroutine ed_hist_scpfmaps - !-------------------------------------------------------------------------------------! - 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 , depth_gl) - ! - ! !DESCRIPTION: - ! Calculates the fractions of the root biomass in each layer for each pft. - ! - ! !USES: - use pftconMod , only : pftcon - ! - ! !ARGUMENTS - class(ed_patch_type) :: this - real(r8),intent(in) :: depth_gl(0:cp_numlevgrnd) - ! - ! !LOCAL VARIABLES: - integer :: lev,p,c,ft - !---------------------------------------------------------------------- - - do ft = 1,numpft_ed - do lev = 1, cp_numlevgrnd - this%rootfr_ft(ft,lev) = 0._r8 - enddo - - do lev = 1, cp_numlevsoil-1 - this%rootfr_ft(ft,lev) = .5_r8*( & - exp(-pftcon%roota_par(ft) * depth_gl(lev-1)) & - + exp(-pftcon%rootb_par(ft) * depth_gl(lev-1)) & - - exp(-pftcon%roota_par(ft) * depth_gl(lev)) & - - exp(-pftcon%rootb_par(ft) * depth_gl(lev))) - end do - end do - - end subroutine set_root_fraction - - - ! ===================================================================================== - - end module EDTypesMod diff --git a/main/FatesConstantsMod.F90 b/main/FatesConstantsMod.F90 index b7bf5edb..8bbf432f 100644 --- a/main/FatesConstantsMod.F90 +++ b/main/FatesConstantsMod.F90 @@ -64,4 +64,8 @@ module FatesConstantsMod real(fates_r8), parameter :: pi_const = 3.14159265359_fates_r8 + ! Numerical Constants + + + end module FatesConstantsMod diff --git a/main/FatesGlobals.F90 b/main/FatesGlobals.F90 index 47bdf6cd..3a1912b6 100644 --- a/main/FatesGlobals.F90 +++ b/main/FatesGlobals.F90 @@ -5,84 +5,24 @@ module FatesGlobals ! immediately obvious home. use FatesConstantsMod , only : r8 => fates_r8 -! use EDTypesMod , only : cp_nclmax, cp_nlevcan, numpft_ed implicit none public :: FatesGlobalsInit public :: fates_log public :: fates_global_verbose - public :: SetFatesTime - public :: set_fates_global_elements - ! for setting number of patches per gridcell and number of cohorts per patch - ! for I/O and converting to a vector + - integer, parameter :: maxPatchesPerSite = 10 ! maximum number of patches to live on a site - integer, parameter :: maxCohortsPerPatch = 160 ! maximum number of cohorts to live on a patch - ! Variables mostly used for dimensioning host land model (HLM) array spaces - - integer, protected :: maxElementsPerPatch ! maxElementsPerPatch is the value that is ultimately - ! used to set the size of the largest arrays necessary - ! in things like restart files (probably hosted by the - ! HLM). The size of these arrays are not a parameter - ! because it is simply the maximum of several different - ! dimensions. It is possible that this would be the - ! maximum number of cohorts per patch, but - ! but it could be other things. - - integer, protected :: maxElementsPerSite ! This is the max number of individual items one can store per - ! each grid cell and effects the striding in the ED restart - ! data as some fields are arrays where each array is - ! associated with one cohort - - integer, protected :: maxCohortsPerSite ! Maximum number of cohorts that can exist in a given - ! site. Its possible this is not used. - - - integer, parameter :: cp_nclmax = 2 ! Maximum number of canopy layers - - integer, parameter :: cp_nlevcan = 40 ! number of leaf layers in canopy layer - - integer , parameter :: numpft_ed = 2 ! number of PFTs used in ED. - - - ! ------------------------------------------------------------------------------------- - ! Timing Variables - ! It is assumed that all of the sites on a given machine will be synchronous. - ! It is also assumed that the HLM will control time. - ! ------------------------------------------------------------------------------------- - integer, protected :: current_year ! Current year - integer, protected :: current_month ! month of year - integer, protected :: current_day ! day of month - integer, protected :: current_tod ! time of day (seconds past 0Z) - integer, protected :: current_date ! time of day (seconds past 0Z) - integer, protected :: reference_date ! YYYYMMDD - real(r8), protected :: model_day ! elapsed days between current date and reference - integer, protected :: day_of_year ! The integer day of the year - integer, protected :: days_per_year ! The HLM controls time, some HLMs may include a leap - real(r8), protected :: freq_day ! fraction of year for daily time-step (1/days_per_year) - ! this is a frequency - integer, private :: fates_log_ logical, private :: fates_global_verbose_ contains - subroutine set_fates_global_elements() - implicit none - - maxElementsPerPatch = max(maxCohortsPerPatch, & - numpft_ed * cp_nclmax * cp_nlevcan) - - maxCohortsPerSite = maxPatchesPerSite * maxCohortsPerPatch - - maxElementsPerSite = maxPatchesPerSite * maxElementsPerPatch - end subroutine set_fates_global_elements ! ===================================================================================== @@ -135,36 +75,6 @@ end subroutine fates_endrun ! ===================================================================================== - subroutine SetFatesTime(current_year_in, current_month_in, & - current_day_in, current_tod_in, & - current_date_in, reference_date_in, & - model_day_in, day_of_year_in, & - days_per_year_in, freq_day_in) - - ! This subroutine should be called directly from the HLM - - integer, intent(in) :: current_year_in - integer, intent(in) :: current_month_in - integer, intent(in) :: current_day_in - integer, intent(in) :: current_tod_in - integer, intent(in) :: current_date_in - integer, intent(in) :: reference_date_in - real(r8), intent(in) :: model_day_in - integer, intent(in) :: day_of_year_in - integer, intent(in) :: days_per_year_in - real(r8), intent(in) :: freq_day_in - - current_year = current_year_in - current_month = current_month_in - current_day = current_day_in - current_tod = current_tod_in - current_date = current_date_in - reference_date = reference_date_in - model_day = model_day_in - day_of_year = day_of_year_in - days_per_year = days_per_year_in - freq_day = freq_day_in - - end subroutine SetFatesTime + end module FatesGlobals diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index b2b090b2..86844662 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -8,7 +8,7 @@ module FatesHistoryInterfaceMod use FatesIODimensionsMod, only : fates_io_dimension_type use FatesIOVariableKindMod, only : fates_io_variable_kind_type use FatesHistoryVariableType, only : fates_history_variable_type - use EDTypesMod , only : cp_hio_ignore_val + use FatesInterfaceMod, only : hlm_hio_ignore_val ! FIXME(bja, 2016-10) need to remove CLM dependancy use pftconMod , only : pftcon @@ -435,8 +435,8 @@ end subroutine flush_hvars subroutine set_history_var(this, vname, units, long, use_default, avgflag, vtype, & hlms, flushval, upfreq, ivar, initialize, index) - use FatesUtilsMod, only : check_hlm_list - use EDTypesMod, only : cp_hlm_name + use FatesUtilsMod, only : check_hlm_list + use FatesInterfaceMod, only : hlm_name implicit none @@ -466,7 +466,7 @@ subroutine set_history_var(this, vname, units, long, use_default, avgflag, vtype logical :: write_var - write_var = check_hlm_list(trim(hlms), trim(cp_hlm_name)) + write_var = check_hlm_list(trim(hlms), trim(hlm_name)) if( write_var ) then ivar = ivar+1 index = ivar @@ -1479,52 +1479,52 @@ subroutine define_history_vars(this, initialize_variables) call this%set_history_var(vname='NEP', units='gC/m^2/s', & long='net ecosystem production', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & upfreq=3, ivar=ivar, initialize=initialize_variables, index = ih_nep_si ) call this%set_history_var(vname='Fire_Closs', units='gC/m^2/s', & long='ED/SPitfire Carbon loss to atmosphere', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & upfreq=3, ivar=ivar, initialize=initialize_variables, index = ih_fire_c_to_atm_si ) call this%set_history_var(vname='NBP', units='gC/m^2/s', & long='net biosphere production', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & upfreq=3, ivar=ivar, initialize=initialize_variables, index = ih_nbp_si ) call this%set_history_var(vname='TOTECOSYSC', units='gC/m^2', & long='total ecosystem carbon', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & upfreq=3, ivar=ivar, initialize=initialize_variables, index = ih_totecosysc_si ) call this%set_history_var(vname='CBALANCE_ERROR_ED', units='gC/m^2/s', & long='total carbon balance error on ED side', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & upfreq=3, ivar=ivar, initialize=initialize_variables, index = ih_cbal_err_fates_si ) call this%set_history_var(vname='CBALANCE_ERROR_BGC', units='gC/m^2/s', & long='total carbon balance error on HLMs BGC side', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & upfreq=3, ivar=ivar, initialize=initialize_variables, index = ih_cbal_err_bgc_si ) call this%set_history_var(vname='CBALANCE_ERROR_TOTAL', units='gC/m^2/s', & long='total carbon balance error total', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & upfreq=3, ivar=ivar, initialize=initialize_variables, index = ih_cbal_err_tot_si ) call this%set_history_var(vname='BIOMASS_STOCK_COL', units='gC/m^2', & long='total ED biomass carbon at the column level', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & upfreq=3, ivar=ivar, initialize=initialize_variables, index = ih_biomass_stock_si ) call this%set_history_var(vname='ED_LITTER_STOCK_COL', units='gC/m^2', & long='total ED litter carbon at the column level', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & upfreq=3, ivar=ivar, initialize=initialize_variables, index = ih_litter_stock_si ) call this%set_history_var(vname='CWD_STOCK_COL', units='gC/m^2', & long='total CWD carbon at the column level', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & upfreq=3, ivar=ivar, initialize=initialize_variables, index = ih_cwd_stock_si ) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 569af025..cfa31b09 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -9,24 +9,118 @@ module FatesInterfaceMod ! which is allocated by thread ! ------------------------------------------------------------------------------------ - use EDtypesMod , only : ed_site_type - use FatesGlobals , only : maxPatchesPerSite - use FatesGlobals , only : cp_nclmax - use EDtypesMod , only : cp_numSWb - use EDtypesMod , only : cp_numlevgrnd - use EDtypesMod , only : cp_maxSWb - use EDtypesMod , only : cp_numlevdecomp - use EDtypesMod , only : cp_numlevdecomp_full - use EDtypesMod , only : cp_hlm_name - use EDtypesMod , only : cp_hio_ignore_val - use EDtypesMod , only : cp_numlevsoil - use EDtypesMod , only : cp_masterproc - use FatesConstantsMod , only : r8 => fates_r8 + use EDTypesMod , only : ed_site_type + use EDTypesMod , only : maxPatchesPerSite + use EDTypesMod , only : maxCohortsPerPatch + use EDTypesMod , only : maxSWb + use EDTypesMod , only : nclmax + use EDTypesMod , only : nlevcan + use EDTypesMod , only : numpft_ed + use FatesConstantsMod , only : r8 => fates_r8 + use FatesGlobals , only : fates_global_verbose + use FatesGlobals , only : fates_log + implicit none + public :: FatesInterfaceInit + public :: set_fates_ctrlparms + public :: SetFatesTime + public :: set_fates_global_elements + + ! ------------------------------------------------------------------------------------- + ! Parameters that are dictated by the Host Land Model + ! THESE ARE NOT DYNAMIC. SHOULD BE SET ONCE DURING INTIALIZATION. + ! ------------------------------------------------------------------------------------- + + + integer, protected :: hlm_numSWb ! Number of broad-bands in the short-wave radiation + ! specturm to track + ! (typically 2 as a default, VIS/NIR, in ED variants <2016) + + integer, protected :: hlm_numlevgrnd ! Number of ground layers + integer, protected :: hlm_numlevsoil ! Number of soil layers + + + integer, protected :: hlm_numlevdecomp_full ! Number of GROUND layers for the purposes + ! of biogeochemistry; can be either 1 + ! or the total number of soil layers + ! (includes bedrock) + + + integer, protected :: hlm_numlevdecomp ! Number of SOIL layers for the purposes of + ! biogeochemistry; can be either 1 or the total + ! number of soil layers + + + character(len=16), protected :: hlm_name ! This character string passed by the HLM + ! is used during the processing of IO data, + ! so that FATES knows which IO variables it + ! should prepare. For instance + ! ATS, ALM and CLM will only want variables + ! specficially packaged for them. + ! This string sets which filter is enacted. + + + real(r8), protected :: hlm_hio_ignore_val ! This value can be flushed to history + ! diagnostics, such that the + ! HLM will interpret that the value should not + ! be included in the average. + + integer, protected :: hlm_masterproc ! Is this the master processor, typically useful + ! for knowing if the current machine should be + ! printing out messages to the logs or terminals + ! 1 = TRUE (is master) 0 = FALSE (is not master) + + + ! ------------------------------------------------------------------------------------- + ! Parameters that are dictated by FATES and known to be required knowledge + ! needed by the HLMs + ! ------------------------------------------------------------------------------------- + + ! Variables mostly used for dimensioning host land model (HLM) array spaces + + integer, protected :: fates_maxElementsPerPatch ! maxElementsPerPatch is the value that is ultimately + ! used to set the size of the largest arrays necessary + ! in things like restart files (probably hosted by the + ! HLM). The size of these arrays are not a parameter + ! because it is simply the maximum of several different + ! dimensions. It is possible that this would be the + ! maximum number of cohorts per patch, but + ! but it could be other things. + + integer, protected :: fates_maxElementsPerSite ! This is the max number of individual items one can store per + ! each grid cell and effects the striding in the ED restart + ! data as some fields are arrays where each array is + ! associated with one cohort + + + + ! ------------------------------------------------------------------------------------ + ! DYNAMIC BOUNDARY CONDITIONS ! ------------------------------------------------------------------------------------ - ! Notes on types + + + ! ------------------------------------------------------------------------------------- + ! Scalar Timing Variables + ! It is assumed that all of the sites on a given machine will be synchronous. + ! It is also assumed that the HLM will control time. + ! ------------------------------------------------------------------------------------- + integer, protected :: hlm_current_year ! Current year + integer, protected :: hlm_current_month ! month of year + integer, protected :: hlm_current_day ! day of month + integer, protected :: hlm_current_tod ! time of day (seconds past 0Z) + integer, protected :: hlm_current_date ! time of day (seconds past 0Z) + integer, protected :: hlm_reference_date ! YYYYMMDD + real(r8), protected :: hlm_model_day ! elapsed days between current date and ref + integer, protected :: hlm_day_of_year ! The integer day of the year + integer, protected :: hlm_days_per_year ! The HLM controls time, some HLMs may + ! include a leap + real(r8), protected :: hlm_freq_day ! fraction of year for daily time-step + ! (1/days_per_year_, this is a frequency + + ! ------------------------------------------------------------------------------------- + ! Structured Boundary Conditions (SITE/PATCH SCALE) ! For floating point arrays, it is sometimes the convention to define the arrays as ! POINTER instead of ALLOCATABLE. This usually achieves the same result with subtle ! differences. POINTER arrays can point to scalar values, discontinuous array slices @@ -38,8 +132,9 @@ module FatesInterfaceMod ! _pa means patch dimensions ! _rb means radiation band ! ------------------------------------------------------------------------------------ - - + + + type, public :: bc_in_type @@ -317,8 +412,7 @@ module FatesInterfaceMod end type fates_interface_type - public :: FatesInterfaceInit - public :: set_fates_ctrlparms + contains @@ -380,15 +474,15 @@ subroutine allocate_bcin(bc_in) allocate(bc_in%precip24_pa(maxPatchesPerSite)) ! Radiation - allocate(bc_in%solad_parb(maxPatchesPerSite,cp_numSWb)) - allocate(bc_in%solai_parb(maxPatchesPerSite,cp_numSWb)) + allocate(bc_in%solad_parb(maxPatchesPerSite,hlm_numSWb)) + allocate(bc_in%solai_parb(maxPatchesPerSite,hlm_numSWb)) ! Hydrology - allocate(bc_in%smp_gl(cp_numlevgrnd)) - allocate(bc_in%eff_porosity_gl(cp_numlevgrnd)) - allocate(bc_in%watsat_gl(cp_numlevgrnd)) - allocate(bc_in%tempk_gl(cp_numlevgrnd)) - allocate(bc_in%h2o_liqvol_gl(cp_numlevgrnd)) + allocate(bc_in%smp_gl(hlm_numlevgrnd)) + allocate(bc_in%eff_porosity_gl(hlm_numlevgrnd)) + allocate(bc_in%watsat_gl(hlm_numlevgrnd)) + allocate(bc_in%tempk_gl(hlm_numlevgrnd)) + allocate(bc_in%h2o_liqvol_gl(hlm_numlevgrnd)) ! Photosynthesis allocate(bc_in%filter_photo_pa(maxPatchesPerSite)) @@ -400,19 +494,19 @@ subroutine allocate_bcin(bc_in) allocate(bc_in%rb_pa(maxPatchesPerSite)) allocate(bc_in%t_veg_pa(maxPatchesPerSite)) allocate(bc_in%tgcm_pa(maxPatchesPerSite)) - allocate(bc_in%t_soisno_gl(cp_numlevgrnd)) + allocate(bc_in%t_soisno_gl(hlm_numlevgrnd)) ! Canopy Radiation allocate(bc_in%filter_vegzen_pa(maxPatchesPerSite)) allocate(bc_in%coszen_pa(maxPatchesPerSite)) - allocate(bc_in%albgr_dir_rb(cp_numSWb)) - allocate(bc_in%albgr_dif_rb(cp_numSWb)) + allocate(bc_in%albgr_dir_rb(hlm_numSWb)) + allocate(bc_in%albgr_dif_rb(hlm_numSWb)) ! Carbon Balance Checking ! (snow-depth and snow fraction are site level and not vectors) ! Ground layer structure - allocate(bc_in%depth_gl(0:cp_numlevgrnd)) + allocate(bc_in%depth_gl(0:hlm_numlevgrnd)) return end subroutine allocate_bcin @@ -433,8 +527,8 @@ subroutine allocate_bcout(bc_out) allocate(bc_out%laisha_pa(maxPatchesPerSite)) ! Hydrology - allocate(bc_out%active_suction_gl(cp_numlevgrnd)) - allocate(bc_out%rootr_pagl(maxPatchesPerSite,cp_numlevgrnd)) + allocate(bc_out%active_suction_gl(hlm_numlevgrnd)) + allocate(bc_out%rootr_pagl(maxPatchesPerSite,hlm_numlevgrnd)) allocate(bc_out%btran_pa(maxPatchesPerSite)) ! Photosynthesis @@ -443,18 +537,18 @@ subroutine allocate_bcout(bc_out) allocate(bc_out%rssha_pa(maxPatchesPerSite)) ! Canopy Radiation - allocate(bc_out%albd_parb(maxPatchesPerSite,cp_numSWb)) - allocate(bc_out%albi_parb(maxPatchesPerSite,cp_numSWb)) - allocate(bc_out%fabd_parb(maxPatchesPerSite,cp_numSWb)) - allocate(bc_out%fabi_parb(maxPatchesPerSite,cp_numSWb)) - allocate(bc_out%ftdd_parb(maxPatchesPerSite,cp_numSWb)) - allocate(bc_out%ftid_parb(maxPatchesPerSite,cp_numSWb)) - allocate(bc_out%ftii_parb(maxPatchesPerSite,cp_numSWb)) + allocate(bc_out%albd_parb(maxPatchesPerSite,hlm_numSWb)) + allocate(bc_out%albi_parb(maxPatchesPerSite,hlm_numSWb)) + allocate(bc_out%fabd_parb(maxPatchesPerSite,hlm_numSWb)) + allocate(bc_out%fabi_parb(maxPatchesPerSite,hlm_numSWb)) + allocate(bc_out%ftdd_parb(maxPatchesPerSite,hlm_numSWb)) + allocate(bc_out%ftid_parb(maxPatchesPerSite,hlm_numSWb)) + allocate(bc_out%ftii_parb(maxPatchesPerSite,hlm_numSWb)) ! biogeochemistry - allocate(bc_out%FATES_c_to_litr_lab_c_col(cp_numlevdecomp_full)) - allocate(bc_out%FATES_c_to_litr_cel_c_col(cp_numlevdecomp_full)) - allocate(bc_out%FATES_c_to_litr_lig_c_col(cp_numlevdecomp_full)) + allocate(bc_out%FATES_c_to_litr_lab_c_col(hlm_numlevdecomp_full)) + allocate(bc_out%FATES_c_to_litr_cel_c_col(hlm_numlevdecomp_full)) + allocate(bc_out%FATES_c_to_litr_lig_c_col(hlm_numlevdecomp_full)) ! Canopy Structure allocate(bc_out%elai_pa(maxPatchesPerSite)) @@ -540,13 +634,59 @@ subroutine zero_bcs(this,s) return end subroutine zero_bcs - - ! ==================================================================================== - subroutine set_fates_ctrlparms(tag,ival,rval,cval) + + ! =================================================================================== + + subroutine set_fates_global_elements() + implicit none + + fates_maxElementsPerPatch = max(maxCohortsPerPatch, & + numpft_ed * nclmax * nlevcan) + + fates_maxElementsPerSite = maxPatchesPerSite * fates_maxElementsPerPatch + + end subroutine set_fates_global_elements + + ! =================================================================================== + + subroutine SetFatesTime(current_year_in, current_month_in, & + current_day_in, current_tod_in, & + current_date_in, reference_date_in, & + model_day_in, day_of_year_in, & + days_per_year_in, freq_day_in) + + ! This subroutine should be called directly from the HLM + + integer, intent(in) :: current_year_in + integer, intent(in) :: current_month_in + integer, intent(in) :: current_day_in + integer, intent(in) :: current_tod_in + integer, intent(in) :: current_date_in + integer, intent(in) :: reference_date_in + real(r8), intent(in) :: model_day_in + integer, intent(in) :: day_of_year_in + integer, intent(in) :: days_per_year_in + real(r8), intent(in) :: freq_day_in + + hlm_current_year = current_year_in + hlm_current_month = current_month_in + hlm_current_day = current_day_in + hlm_current_tod = current_tod_in + hlm_current_date = current_date_in + hlm_reference_date = reference_date_in + hlm_model_day = model_day_in + hlm_day_of_year = day_of_year_in + hlm_days_per_year = days_per_year_in + hlm_freq_day = freq_day_in + + end subroutine SetFatesTime + + ! ==================================================================================== + + subroutine set_fates_ctrlparms(tag,ival,rval,cval) ! --------------------------------------------------------------------------------- - ! INTERF-TODO: NEED ALLOWANCES FOR REAL AND CHARACTER ARGS.. ! Certain model control parameters and dimensions used by FATES are dictated by ! the the driver or the host mode. To see which parameters should be filled here ! please also look at the ctrl_parms_type in FATESTYpeMod, in the section listing @@ -568,8 +708,6 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) ! RGK-2016 ! --------------------------------------------------------------------------------- - use FatesGlobals, only : fates_log, fates_global_verbose - ! Arguments integer, optional, intent(in) :: ival real(r8), optional, intent(in) :: rval @@ -587,18 +725,18 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) if (fates_global_verbose()) then write(fates_log(), *) 'Flushing FATES control parameters prior to transfer from host' end if - cp_numSwb = unset_int - cp_numlevgrnd = unset_int - cp_numlevsoil = unset_int - cp_numlevdecomp_full = unset_int - cp_numlevdecomp = unset_int - cp_hlm_name = 'unset' - cp_hio_ignore_val = unset_double - cp_masterproc = unset_int + hlm_numSwb = unset_int + hlm_numlevgrnd = unset_int + hlm_numlevsoil = unset_int + hlm_numlevdecomp_full = unset_int + hlm_numlevdecomp = unset_int + hlm_name = 'unset' + hlm_hio_ignore_val = unset_double + hlm_masterproc = unset_int case('check_allset') - if(cp_numSWb .eq. unset_int) then + if(hlm_numSWb .eq. unset_int) then if (fates_global_verbose()) then write(fates_log(), *) 'FATES dimension/parameter unset: num_sw_rad_bbands' end if @@ -606,28 +744,28 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) ! end_run('MESSAGE') end if - if(cp_masterproc .eq. unset_int) then + if(hlm_masterproc .eq. unset_int) then if (fates_global_verbose()) then - write(fates_log(), *) 'FATES parameter unset: cp_masterproc' + write(fates_log(), *) 'FATES parameter unset: hlm_masterproc' end if ! INTERF-TODO: FATES NEEDS INTERNAL end_run ! end_run('MESSAGE') end if - if(cp_numSWb > cp_maxSWb) then + if(hlm_numSWb > maxSWb) then if (fates_global_verbose()) then write(fates_log(), *) 'FATES sets a maximum number of shortwave bands' - write(fates_log(), *) 'for some scratch-space, cp_maxSWb' + write(fates_log(), *) 'for some scratch-space, maxSWb' write(fates_log(), *) 'it defaults to 2, but can be increased as needed' write(fates_log(), *) 'your driver or host model is intending to drive' - write(fates_log(), *) 'FATES with:',cp_numSWb,' bands.' - write(fates_log(), *) 'please increase cp_maxSWb in EDTypes to match' + write(fates_log(), *) 'FATES with:',hlm_numSWb,' bands.' + write(fates_log(), *) 'please increase maxSWb in EDTypes to match' write(fates_log(), *) 'or exceed this value' end if ! end_run('MESSAGE') end if - if(cp_numlevgrnd .eq. unset_int) then + if(hlm_numlevgrnd .eq. unset_int) then if (fates_global_verbose()) then write(fates_log(), *) 'FATES dimension/parameter unset: numlevground' end if @@ -635,7 +773,7 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) ! end_run('MESSAGE') end if - if(cp_numlevsoil .eq. unset_int) then + if(hlm_numlevsoil .eq. unset_int) then if (fates_global_verbose()) then write(fates_log(), *) 'FATES dimension/parameter unset: numlevground' end if @@ -643,7 +781,7 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) ! end_run('MESSAGE') end if - if(cp_numlevdecomp_full .eq. unset_int) then + if(hlm_numlevdecomp_full .eq. unset_int) then if (fates_global_verbose()) then write(fates_log(), *) 'FATES dimension/parameter unset: numlevdecomp_full' end if @@ -651,7 +789,7 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) ! end_run('MESSAGE') end if - if(cp_numlevdecomp .eq. unset_int) then + if(hlm_numlevdecomp .eq. unset_int) then if (fates_global_verbose()) then write(fates_log(), *) 'FATES dimension/parameter unset: numlevdecomp' end if @@ -659,7 +797,7 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) ! end_run('MESSAGE') end if - if(trim(cp_hlm_name) .eq. 'unset') then + if(trim(hlm_name) .eq. 'unset') then if (fates_global_verbose()) then write(fates_log(),*) 'FATES dimension/parameter unset: hlm_name' end if @@ -667,7 +805,7 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) ! end_run('MESSAGE') end if - if( abs(cp_hio_ignore_val-unset_double)<1e-10 ) then + if( abs(hlm_hio_ignore_val-unset_double)<1e-10 ) then if (fates_global_verbose()) then write(fates_log(),*) 'FATES dimension/parameter unset: hio_ignore' end if @@ -686,37 +824,37 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) select case (trim(tag)) case('masterproc') - cp_masterproc = ival + hlm_masterproc = ival if (fates_global_verbose()) then write(fates_log(),*) 'Transfering masterproc = ',ival,' to FATES' end if case('num_sw_bbands') - cp_numSwb = ival + hlm_numSwb = ival if (fates_global_verbose()) then write(fates_log(),*) 'Transfering num_sw_bbands = ',ival,' to FATES' end if case('num_lev_ground') - cp_numlevgrnd = ival + hlm_numlevgrnd = ival if (fates_global_verbose()) then write(fates_log(),*) 'Transfering num_lev_ground = ',ival,' to FATES' end if case('num_lev_soil') - cp_numlevsoil = ival + hlm_numlevsoil = ival if (fates_global_verbose()) then write(fates_log(),*) 'Transfering num_lev_ground = ',ival,' to FATES' end if case('num_levdecomp_full') - cp_numlevdecomp_full = ival + hlm_numlevdecomp_full = ival if (fates_global_verbose()) then write(fates_log(),*) 'Transfering num_levdecomp_full = ',ival,' to FATES' end if case('num_levdecomp') - cp_numlevdecomp = ival + hlm_numlevdecomp = ival if (fates_global_verbose()) then write(fates_log(),*) 'Transfering num_levdecomp = ',ival,' to FATES' end if @@ -733,7 +871,7 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) if(present(rval))then select case (trim(tag)) case ('hio_ignore_val') - cp_hio_ignore_val = rval + hlm_hio_ignore_val = rval if (fates_global_verbose()) then write(fates_log(),*) 'Transfering hio_ignore_val = ',rval,' to FATES' end if @@ -749,7 +887,7 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) select case (trim(tag)) case('hlm_name') - cp_hlm_name = trim(cval) + hlm_name = trim(cval) if (fates_global_verbose()) then write(fates_log(),*) 'Transfering the HLM name = ',trim(cval) end if @@ -768,5 +906,4 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) end subroutine set_fates_ctrlparms - end module FatesInterfaceMod diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 41de351b..6f903da9 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -854,7 +854,7 @@ subroutine set_restart_var(this,vname,vtype,long_name,units,flushval, & hlms,initialize,ivar,index) use FatesUtilsMod, only : check_hlm_list - use EDTypesMod, only : cp_hlm_name + use FatesInterfaceMod, only : hlm_name ! arguments class(fates_restart_interface_type) :: this @@ -879,7 +879,7 @@ subroutine set_restart_var(this,vname,vtype,long_name,units,flushval, & logical :: use_var - use_var = check_hlm_list(trim(hlms), trim(cp_hlm_name)) + use_var = check_hlm_list(trim(hlms), trim(hlm_name)) if( use_var ) then @@ -905,10 +905,10 @@ end subroutine set_restart_var subroutine set_restart_vectors(this,nc,nsites,sites) - use FatesGlobals, only : cp_nclmax - use FatesGlobals, only : cp_nlevcan - use FatesGlobals, only : maxElementsPerPatch - use FatesGlobals, only : numpft_ed + use EDTypesMod, only : nclmax + use EDTypesMod, only : nlevcan + use FatesInterfaceMod, only : fates_maxElementsPerPatch + use EDTypesMod, only : numpft_ed use EDTypesMod, only : ed_site_type use EDTypesMod, only : ed_cohort_type use EDTypesMod, only : ed_patch_type @@ -1168,18 +1168,18 @@ subroutine set_restart_vectors(this,nc,nsites,sites) io_idx_pa_cwd = io_idx_pa_cwd + 1 end do - do i = 1,cp_nclmax ! cp_nclmax currently 2 + do i = 1,nclmax ! nclmax currently 2 rio_spread_pacl(io_idx_pa_cl) = cpatch%spread(i) io_idx_pa_cl = io_idx_pa_cl + 1 end do if ( DEBUG ) write(fates_log(),*) 'CLTV io_idx_pa_sunz 1 ',io_idx_pa_sunz - if ( DEBUG ) write(fates_log(),*) 'CLTV 1186 ',cp_nlevcan,numpft_ed,cp_nclmax + if ( DEBUG ) write(fates_log(),*) 'CLTV 1186 ',nlevcan,numpft_ed,nclmax - do k = 1,cp_nlevcan ! cp_nlevcan currently 40 + do k = 1,nlevcan ! nlevcan currently 40 do j = 1,numpft_ed ! numpft_ed currently 2 - do i = 1,cp_nclmax ! cp_nclmax currently 2 + do i = 1,nclmax ! nclmax currently 2 rio_fsun_paclftls(io_idx_pa_sunz) = cpatch%f_sun(i,j,k) rio_fabd_sun_z_paclftls(io_idx_pa_sunz) = cpatch%fabd_sun_z(i,j,k) rio_fabi_sun_z_paclftls(io_idx_pa_sunz) = cpatch%fabi_sun_z(i,j,k) @@ -1195,10 +1195,10 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ! Set the first cohort index to the start of the next patch, increment ! by the maximum number of cohorts per patch - io_idx_co_1st = io_idx_co_1st + maxElementsPerPatch + io_idx_co_1st = io_idx_co_1st + fates_maxElementsPerPatch ! reset counters so that they are all advanced evenly. Currently - ! the offset is 10, the max of numpft_ed, ncwd, cp_nclmax, + ! the offset is 10, the max of numpft_ed, ncwd, nclmax, ! io_idx_si_wmem and the number of allowed cohorts per patch io_idx_pa_pft = io_idx_co_1st io_idx_pa_cwd = io_idx_co_1st @@ -1273,10 +1273,10 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites ) use EDTypesMod, only : ed_cohort_type use EDTypesMod, only : ed_patch_type use EDTypesMod, only : ncwd - use FatesGlobals, only : cp_nlevcan - use FatesGlobals, only : cp_nclmax - use FatesGlobals, only : maxElementsPerPatch - use FatesGlobals, only : numpft_ed + use EDTypesMod, only : nlevcan + use EDTypesMod, only : nclmax + use FatesInterfaceMod, only : fates_maxElementsPerPatch + use EDTypesMod, only : numpft_ed use EDTypesMod, only : area use EDPatchDynamicsMod, only : zero_patch use EDGrowthFunctionsMod, only : Dbh @@ -1298,7 +1298,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites ) type(ed_cohort_type), allocatable :: temp_cohort real(r8) :: cwd_ag_local(ncwd) real(r8) :: cwd_bg_local(ncwd) - real(r8) :: spread_local(cp_nclmax) + real(r8) :: spread_local(nclmax) real(r8) :: leaf_litter_local(numpft_ed) real(r8) :: root_litter_local(numpft_ed) real(r8) :: patch_age @@ -1451,7 +1451,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites ) endif - io_idx_co_1st = io_idx_co_1st + maxElementsPerPatch + io_idx_co_1st = io_idx_co_1st + fates_maxElementsPerPatch enddo ! ends loop over idx_pa @@ -1467,11 +1467,11 @@ subroutine get_restart_vectors(this, nc, nsites, sites) use EDTypesMod, only : ed_site_type use EDTypesMod, only : ed_cohort_type use EDTypesMod, only : ed_patch_type - use FatesGlobals, only : numpft_ed + use EDTypesMod, only : numpft_ed use EDTypesMod, only : ncwd - use FatesGlobals, only : cp_nlevcan - use FatesGlobals, only : cp_nclmax - use FatesGlobals, only : maxElementsPerPatch + use EDTypesMod, only : nlevcan + use EDTypesMod, only : nclmax + use FatesInterfaceMod, only : fates_maxElementsPerPatch use EDTypesMod, only : numWaterMem ! !ARGUMENTS: @@ -1718,16 +1718,16 @@ subroutine get_restart_vectors(this, nc, nsites, sites) io_idx_pa_cwd = io_idx_pa_cwd + 1 enddo - do i = 1,cp_nclmax ! cp_nclmax currently 2 + do i = 1,nclmax ! nclmax currently 2 cpatch%spread(i) = rio_spread_pacl(io_idx_pa_cl) io_idx_pa_cl = io_idx_pa_cl + 1 enddo if ( DEBUG ) write(fates_log(),*) 'CVTL io_idx_pa_sunz 1 ',io_idx_pa_sunz - do k = 1,cp_nlevcan ! cp_nlevcan currently 40 + do k = 1,nlevcan ! nlevcan currently 40 do j = 1,numpft_ed ! numpft_ed currently 2 - do i = 1,cp_nclmax ! cp_nclmax currently 2 + do i = 1,nclmax ! nclmax currently 2 cpatch%f_sun(i,j,k) = rio_fsun_paclftls(io_idx_pa_sunz) cpatch%fabd_sun_z(i,j,k) = rio_fabd_sun_z_paclftls(io_idx_pa_sunz) cpatch%fabi_sun_z(i,j,k) = rio_fabi_sun_z_paclftls(io_idx_pa_sunz) @@ -1743,7 +1743,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ! Now increment the position of the first cohort to that of the next ! patch - io_idx_co_1st = io_idx_co_1st + maxElementsPerPatch + io_idx_co_1st = io_idx_co_1st + fates_maxElementsPerPatch ! and max the number of allowed cohorts per patch io_idx_pa_pft = io_idx_co_1st From 641e0e90622a1959c4d086e1645859011ce02405 Mon Sep 17 00:00:00 2001 From: ckoven Date: Thu, 26 Jan 2017 21:45:49 -0800 Subject: [PATCH 304/437] added seed homogenization mode to prevent compettive exclusion --- biogeochem/EDPhysiologyMod.F90 | 41 +++++++++++++++++++++++++++++++++- main/EDTypesMod.F90 | 3 +++ 2 files changed, 43 insertions(+), 1 deletion(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index fccd8c08..dbec515c 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -641,6 +641,7 @@ subroutine seeds_in( currentSite, cp_pnt ) ! ! !USES: use EDTypesMod, only : AREA + use EDTypesMod, only : homogenize_seed_pfts ! ! !ARGUMENTS type(ed_site_type), intent(inout), target :: currentSite @@ -650,12 +651,48 @@ subroutine seeds_in( currentSite, cp_pnt ) type(ed_patch_type), pointer :: currentPatch type(ed_cohort_type), pointer :: currentCohort integer :: p + logical :: pft_present(numpft_ed) + real(r8) :: npfts_present !---------------------------------------------------------------------- currentPatch => cp_pnt currentPatch%seeds_in(:) = 0.0_r8 - + + if ( homogenize_seed_pfts ) then + ! special mode to remove intergenerational filters on PFT existence: each PFT seeds all PFTs + ! first loop over all patches and cohorts to see what and how many PFTs are present on this site + pft_present(:) = .false. + npfts_present = 0._r8 + currentPatch => currentSite%oldest_patch + do while(associated(currentPatch)) + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + p = currentCohort%pft + if (.not. pft_present(p)) then + pft_present(p) = .true. + npfts_present = npfts_present + 1._r8 + endif + currentCohort => currentCohort%shorter + enddo !cohort loop + currentPatch => currentPatch%younger + enddo ! patch loop + + ! now calculate the homogenized seed flux into each PFT pool + currentPatch => cp_pnt + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + do p = 1, numpft_ed + if (pft_present(p)) then + currentPatch%seeds_in(p) = currentPatch%seeds_in(p) + currentCohort%seed_prod * currentCohort%n / & + (currentPatch%area * npfts_present) + endif + end do + currentCohort => currentCohort%shorter + enddo !cohort loop + else + + ! normal case: each PFT seeds its own type currentCohort => currentPatch%tallest do while (associated(currentCohort)) p = currentCohort%pft @@ -663,6 +700,8 @@ subroutine seeds_in( currentSite, cp_pnt ) currentCohort => currentCohort%shorter enddo !cohort loop + endif + currentPatch => currentSite%oldest_patch do while(associated(currentPatch)) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index d861559c..ff00f130 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -76,6 +76,9 @@ module EDTypesMod character*4 yearchar + ! special mode to cause PFTs to create seed mass of all currently-existing PFTs + logical, parameter :: homogenize_seed_pfts = .true. + !the lower limit of the size classes of ED cohorts !0-10,10-20... integer, parameter :: nlevsclass_ed = 13 ! Number of dbh size classes for size structure analysis From d94d0629803f9bf05534e6c859eec106dbefdc97 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 27 Jan 2017 12:31:32 -0800 Subject: [PATCH 305/437] Removed the necessity of allocating fates sites when fates is not running. Combined clm_fates%init and clm_fates%init_allocate. Created a trivial cohort dimensioning scheme for non-fates runs. --- main/FatesInterfaceMod.F90 | 25 +++++++++++++++++++++---- 1 file changed, 21 insertions(+), 4 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index cfa31b09..79279454 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -638,13 +638,30 @@ end subroutine zero_bcs ! =================================================================================== - subroutine set_fates_global_elements() + subroutine set_fates_global_elements(use_fates) implicit none - fates_maxElementsPerPatch = max(maxCohortsPerPatch, & - numpft_ed * nclmax * nlevcan) + logical,intent(in) :: use_fates ! Is fates turned on? - fates_maxElementsPerSite = maxPatchesPerSite * fates_maxElementsPerPatch + if (use_fates) then + + fates_maxElementsPerPatch = max(maxCohortsPerPatch, & + numpft_ed * nclmax * nlevcan) + + fates_maxElementsPerSite = maxPatchesPerSite * fates_maxElementsPerPatch + + else + ! If we are not using FATES, the cohort dimension is still + ! going to be initialized, lets set it to the smallest value + ! possible so that the dimensioning info takes up little space + + fates_maxElementsPerPatch = 1 + + fates_maxElementsPerSite = 1 + + + end if + end subroutine set_fates_global_elements From 6cc76bd17d218282f641239a261d4406b8b2b621 Mon Sep 17 00:00:00 2001 From: Ben Andre Date: Wed, 18 Jan 2017 12:55:46 -0700 Subject: [PATCH 306/437] Read fates parameters from their own file. The fates parameter file is now specified via a separate namelist fates_paramfile. This variable may or may not point to the same netcdf file as the host parameter file. All fates parameters are read from this file, including the pft level variables, which are now stored in EDpftvarcon instead of pftcon. Note that some parameters are shared between the host and fates. These are 'host' parameters, not fates parameters and are read from the host file. Work for NGT-ED Github issue #155 User interface changes?: Yes. Users who have custom parameter files will need to set namelist varible 'fates_paramfile' to point to their file instead. Host parameters are still read from the file specified by namelist variable 'paramfile'. If users have modified host parameters in addition to fates parameters, they will need to update both namelist variables. Code review: andre Test suite: clm_short Test baseline: clm4_5_12_r195 Test namelist changes: none Test answer changes: bit for bit Test summary: all tests pass Test suite: ed - yellowstone gnu, intel, pgi Test baseline: a651a4f Test namelist changes: yes, new namilest var fates_paramfile Test answer changes: bit for bit Test summary: all tests pass --- biogeochem/EDCanopyStructureMod.F90 | 16 ++-- biogeochem/EDCohortDynamicsMod.F90 | 30 +++---- biogeochem/EDGrowthFunctionsMod.F90 | 10 +-- biogeochem/EDPatchDynamicsMod.F90 | 10 +-- biogeochem/EDPhysiologyMod.F90 | 98 +++++++++++---------- biogeophys/EDBtranMod.F90 | 6 +- biogeophys/EDPhotosynthesisMod.F90 | 22 ++--- biogeophys/EDSurfaceAlbedoMod.F90 | 12 +-- fire/SFMainMod.F90 | 16 ++-- main/EDInitMod.F90 | 10 +-- main/EDPftvarcon.F90 | 129 +++++++++++++++++++++++++++- main/EDTypesMod.F90 | 10 +-- main/FatesHistoryInterfaceMod.F90 | 4 +- main/FatesRestartInterfaceMod.F90 | 4 +- 14 files changed, 254 insertions(+), 123 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index f5419ced..e91e4608 100755 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -7,7 +7,7 @@ module EDCanopyStructureMod use shr_kind_mod , only : r8 => shr_kind_r8; use FatesGlobals , only : fates_log - use pftconMod , only : pftcon + use EDPftvarcon , only : EDPftvarcon_inst use EDGrowthFunctionsMod , only : c_area use EDCohortDynamicsMod , only : copy_cohort, terminate_cohorts, fuse_cohorts use EDtypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type, ncwd @@ -617,7 +617,7 @@ subroutine canopy_spread( currentSite ) currentCohort => currentPatch%tallest do while (associated(currentCohort)) currentCohort%c_area = c_area(currentCohort) - if(pftcon%woody(currentCohort%pft) == 1)then + if(EDPftvarcon_inst%woody(currentCohort%pft) == 1)then arealayer(currentCohort%canopy_layer) = arealayer(currentCohort%canopy_layer) + currentCohort%c_area endif currentCohort => currentCohort%shorter @@ -663,7 +663,7 @@ subroutine canopy_summarization( nsites, sites, bc_in ) use EDGrowthFunctionsMod , only : tree_lai, c_area use EDEcophysConType , only : EDecophyscon use EDtypesMod , only : area - use pftconMod , only : pftcon + use EDPftvarcon , only : EDPftvarcon_inst ! !ARGUMENTS integer , intent(in) :: nsites @@ -727,7 +727,7 @@ subroutine canopy_summarization( nsites, sites, bc_in ) if(currentCohort%canopy_layer==1)then currentPatch%total_canopy_area = currentPatch%total_canopy_area + currentCohort%c_area - if(pftcon%woody(ft)==1)then + if(EDPftvarcon_inst%woody(ft)==1)then currentPatch%total_tree_area = currentPatch%total_tree_area + currentCohort%c_area endif endif @@ -989,11 +989,11 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) do iv = 1,currentCohort%NV-1 ! 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. + ! EDPftvarcon_inst%vertical_canopy_frac(ft))! fudge - this should be pft specific but i cant get it to compile. layer_top_hite = currentCohort%hite-((iv/currentCohort%NV) * currentCohort%hite * & EDecophyscon%crown(currentCohort%pft) ) layer_bottom_hite = currentCohort%hite-(((iv+1)/currentCohort%NV) * currentCohort%hite * & - EDecophyscon%crown(currentCohort%pft)) ! pftcon%vertical_canopy_frac(ft)) + EDecophyscon%crown(currentCohort%pft)) ! EDPftvarcon_inst%vertical_canopy_frac(ft)) fraction_exposed =1.0_r8 @@ -1022,10 +1022,10 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) !Bottom layer iv = currentCohort%NV - ! pftcon%vertical_canopy_frac(ft))! fudge - this should be pft specific but i cant get it to compile. + ! EDPftvarcon_inst%vertical_canopy_frac(ft))! fudge - this should be pft specific but i cant get it to compile. layer_top_hite = currentCohort%hite-((iv/currentCohort%NV) * currentCohort%hite * & EDecophyscon%crown(currentCohort%pft) ) - ! pftcon%vertical_canopy_frac(ft)) + ! EDPftvarcon_inst%vertical_canopy_frac(ft)) layer_bottom_hite = currentCohort%hite-(((iv+1)/currentCohort%NV) * currentCohort%hite * & EDecophyscon%crown(currentCohort%pft)) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 2ccea2ca..d468c03d 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -8,7 +8,7 @@ module EDCohortDynamicsMod use FatesGlobals , only : fates_log use FatesConstantsMod , only : r8 => fates_r8 use shr_log_mod , only : errMsg => shr_log_errMsg - use pftconMod , only : pftcon + use EDPftvarcon , only : EDPftvarcon_inst use EDEcophysContype , only : EDecophyscon use EDGrowthFunctionsMod , only : c_area, tree_lai use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type @@ -114,11 +114,11 @@ subroutine create_cohort(patchptr, pft, nn, hite, dbh, & call endrun(msg=errMsg(sourcefile, __LINE__)) endif - if (new_cohort%siteptr%status==2 .and. pftcon%season_decid(pft) == 1) then + if (new_cohort%siteptr%status==2 .and. EDPftvarcon_inst%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 + if (new_cohort%siteptr%dstatus==2 .and. EDPftvarcon_inst%stress_decid(pft) == 1) then new_cohort%laimemory = 0.0_r8 endif @@ -191,27 +191,27 @@ subroutine allocate_live_biomass(cc_p,mode) currentCohort => cc_p ft = currentcohort%pft - leaf_frac = 1.0_r8/(1.0_r8 + EDecophyscon%sapwood_ratio(ft) * currentcohort%hite + pftcon%froot_leaf(ft)) + leaf_frac = 1.0_r8/(1.0_r8 + EDecophyscon%sapwood_ratio(ft) * currentcohort%hite + EDPftvarcon_inst%froot_leaf(ft)) !currentcohort%bl = currentcohort%balive*leaf_frac !for deciduous trees, there are no leaves - if (pftcon%evergreen(ft) == 1) then + if (EDPftvarcon_inst%evergreen(ft) == 1) then currentcohort%laimemory = 0._r8 currentcohort%status_coh = 2 endif ! iagnore 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%br = EDPftvarcon_inst%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 + if (currentcohort%status_coh == 1.and.EDPftvarcon_inst%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 + if (currentcohort%status_coh == 1.and.EDPftvarcon_inst%season_decid(ft) == 1.and.currentcohort%siteptr%status==1) then !no leaves leaves_off_switch = 1 !cold decid endif @@ -232,8 +232,8 @@ subroutine allocate_live_biomass(cc_p,mode) if(mode==1)then currentcohort%npp_froot = currentcohort%npp_froot + & - max(0._r8,pftcon%froot_leaf(ft)*(currentcohort%balive+currentcohort%laimemory)*leaf_frac - currentcohort%br) / & - udata%deltat + max(0._r8, EDPftvarcon_inst%froot_leaf(ft)*(currentcohort%balive+currentcohort%laimemory)*leaf_frac - & + currentcohort%br) / udata%deltat currentcohort%npp_bsw = max(0._r8,EDecophyscon%sapwood_ratio(ft) * currentcohort%hite *(currentcohort%balive + & currentcohort%laimemory)*leaf_frac - currentcohort%bsw)/udata%deltat @@ -242,7 +242,7 @@ subroutine allocate_live_biomass(cc_p,mode) end if - currentcohort%br = pftcon%froot_leaf(ft) * (currentcohort%balive + currentcohort%laimemory) * leaf_frac + currentcohort%br = EDPftvarcon_inst%froot_leaf(ft) * (currentcohort%balive + currentcohort%laimemory) * leaf_frac currentcohort%bsw = EDecophyscon%sapwood_ratio(ft) * currentcohort%hite *(currentcohort%balive + & currentcohort%laimemory)*leaf_frac @@ -257,9 +257,9 @@ subroutine allocate_live_biomass(cc_p,mode) currentcohort%bl = 0.0_r8 - ideal_balive = currentcohort%laimemory * pftcon%froot_leaf(ft) + & + ideal_balive = currentcohort%laimemory * EDPftvarcon_inst%froot_leaf(ft) + & currentcohort%laimemory* EDecophyscon%sapwood_ratio(ft) * currentcohort%hite - currentcohort%br = pftcon%froot_leaf(ft) * (ideal_balive + currentcohort%laimemory) * leaf_frac + currentcohort%br = EDPftvarcon_inst%froot_leaf(ft) * (ideal_balive + currentcohort%laimemory) * leaf_frac currentcohort%bsw = EDecophyscon%sapwood_ratio(ft) * currentcohort%hite *(ideal_balive + & currentcohort%laimemory)*leaf_frac @@ -271,7 +271,7 @@ subroutine allocate_live_biomass(cc_p,mode) if(mode==1)then currentcohort%npp_froot = currentcohort%npp_froot + & - max(0.0_r8,pftcon%froot_leaf(ft)*(ideal_balive + & + max(0.0_r8,EDPftvarcon_inst%froot_leaf(ft)*(ideal_balive + & currentcohort%laimemory)*leaf_frac*ratio_balive-currentcohort%br)/udata%deltat currentcohort%npp_bsw = max(0.0_r8,EDecophyscon%sapwood_ratio(ft) * currentcohort%hite *(ideal_balive + & @@ -289,7 +289,7 @@ subroutine allocate_live_biomass(cc_p,mode) currentcohort%status_coh,currentcohort%balive write(fates_log(),*) 'actual vs predicted balive',ideal_balive,currentcohort%balive ,ratio_balive,leaf_frac write(fates_log(),*) 'leaf,root,stem',currentcohort%bl,currentcohort%br,currentcohort%bsw - write(fates_log(),*) 'pft',ft,pftcon%evergreen(ft),pftcon%season_decid(ft),leaves_off_switch + write(fates_log(),*) 'pft',ft,EDPftvarcon_inst%evergreen(ft),EDPftvarcon_inst%season_decid(ft),leaves_off_switch endif currentCohort%b = currentCohort%bdead + currentCohort%balive diff --git a/biogeochem/EDGrowthFunctionsMod.F90 b/biogeochem/EDGrowthFunctionsMod.F90 index a400f46a..a3fc06ce 100755 --- a/biogeochem/EDGrowthFunctionsMod.F90 +++ b/biogeochem/EDGrowthFunctionsMod.F90 @@ -8,7 +8,7 @@ module EDGrowthFunctionsMod use shr_kind_mod , only : r8 => shr_kind_r8 use clm_varctl , only : iulog - use pftconMod , only : pftcon + use EDPftvarcon , only : EDPftvarcon_inst use EDEcophysContype , only : EDecophyscon use EDTypesMod , only : ed_cohort_type, cp_nlevcan, dinc_ed @@ -114,7 +114,7 @@ real(r8) function Bleaf( cohort_in ) else bleaf = 0.0419_r8 * (EDecophyscon%max_dbh(cohort_in%pft)**1.56) * EDecophyscon%wood_density(cohort_in%pft)**0.55_r8 endif - slascaler = 0.03_r8/pftcon%slatop(cohort_in%pft) + slascaler = 0.03_r8/EDPftvarcon_inst%slatop(cohort_in%pft) bleaf = bleaf * slascaler !write(iulog,*) 'bleaf',bleaf, slascaler,cohort_in%pft @@ -145,7 +145,7 @@ real(r8) function tree_lai( cohort_in ) 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 + slat = 1000.0_r8 * EDPftvarcon_inst%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 @@ -225,7 +225,7 @@ real(r8) function c_area( cohort_in ) 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 3',EDPftvarcon_inst%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 @@ -233,7 +233,7 @@ real(r8) function c_area( cohort_in ) end if dbh = min(cohort_in%dbh,EDecophyscon%max_dbh(cohort_in%pft)) - if(pftcon%woody(cohort_in%pft) == 1)then + if(EDPftvarcon_inst%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 diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 5fae1a78..fe44705e 100755 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -7,7 +7,7 @@ module EDPatchDynamicsMod use shr_kind_mod , only : r8 => shr_kind_r8; use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) use clm_varctl , only : iulog - use pftconMod , only : pftcon + use EDPftvarcon , only : EDPftvarcon_inst use EDCohortDynamicsMod , only : fuse_cohorts, sort_cohorts, insert_cohort use EDtypesMod , only : ncwd, n_dbh_bins, ntol, numpft_ed, area, dbhmax, maxPatchesPerCol use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type, udata @@ -281,7 +281,7 @@ subroutine spawn_patches( currentSite ) nc%imort = nan else ! small trees - if(pftcon%woody(currentCohort%pft) == 1)then + if(EDPftvarcon_inst%woody(currentCohort%pft) == 1)then ! Number of trees in the understory of new patch, before we impose impact mortality and survivorship nc%n = currentCohort%n * patch_site_areadis/currentPatch%area @@ -566,7 +566,7 @@ subroutine fire_litter_fluxes(cp_target, new_patch_target, patch_site_areadis) currentCohort => currentPatch%shortest do while(associated(currentCohort)) p = currentCohort%pft - if(pftcon%woody(p) == 1)then !DEAD (FROM FIRE) TREES + if(EDPftvarcon_inst%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. @@ -649,7 +649,7 @@ subroutine fire_litter_fluxes(cp_target, new_patch_target, patch_site_areadis) do while(associated(currentCohort)) currentCohort%c_area = c_area(currentCohort) - if(pftcon%woody(currentCohort%pft) == 1)then + if(EDPftvarcon_inst%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) @@ -726,7 +726,7 @@ subroutine mortality_litter_fluxes(cp_target, new_patch_target, patch_site_aread canopy_dead*(currentCohort%br+currentCohort%bstore) else - if(pftcon%woody(currentCohort%pft) == 1)then + if(EDPftvarcon_inst%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 + & diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index fccd8c08..b2e51f09 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -12,7 +12,7 @@ module EDPhysiologyMod use TemperatureType , only : temperature_type use SoilStateType , only : soilstate_type use WaterstateType , only : waterstate_type - use pftconMod , only : pftcon + use EDPftvarcon , only : EDPftvarcon_inst use EDEcophysContype , only : EDecophyscon use EDCohortDynamicsMod , only : allocate_live_biomass, zero_cohort use EDCohortDynamicsMod , only : create_cohort, fuse_cohorts, sort_cohorts @@ -185,16 +185,19 @@ subroutine trim_canopy( currentSite ) 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) + if (EDPftvarcon_inst%season_decid(currentCohort%pft) == 1.or. & + EDPftvarcon_inst%stress_decid(currentCohort%pft) == 1)then + currentCohort%leaf_cost = 1._r8/(EDPftvarcon_inst%slatop(currentCohort%pft)*1000.0_r8) + currentCohort%leaf_cost = currentCohort%leaf_cost + & + 1.0_r8/(EDPftvarcon_inst%slatop(currentCohort%pft)*1000.0_r8) * & + EDPftvarcon_inst%froot_leaf(currentCohort%pft) / EDecophyscon%root_long(currentCohort%pft) currentCohort%leaf_cost = currentCohort%leaf_cost * (ED_val_grperc(currentCohort%pft) + 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 = 1.0_r8/(EDPftvarcon_inst%slatop(currentCohort%pft)* & + EDPftvarcon_inst%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/(EDPftvarcon_inst%slatop(currentCohort%pft)*1000.0_r8) * & + EDPftvarcon_inst%froot_leaf(currentCohort%pft) / EDecophyscon%root_long(currentCohort%pft) currentCohort%leaf_cost = currentCohort%leaf_cost * (ED_val_grperc(currentCohort%pft) + 1._r8) endif if (currentCohort%year_net_uptake(z) < currentCohort%leaf_cost)then @@ -207,7 +210,7 @@ subroutine trim_canopy( currentSite ) ! 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 + if (EDPftvarcon_inst%evergreen(currentCohort%pft) /= 1)then currentCohort%laimemory = currentCohort%laimemory*(1.0_r8 - inc) endif trimmed = 1 @@ -494,7 +497,7 @@ subroutine phenology( currentSite, temperature_inst, waterstate_inst) !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 + if (timesincedleafon > 365.0*EDPftvarcon_inst%leaf_long(7))then currentSite%dstatus = 1 !alter status of site to 'leaves on' currentSite%dleafoffdate = t !record leaf on date endif @@ -542,7 +545,7 @@ subroutine phenology_leafonoff(currentSite) do while(associated(currentCohort)) !COLD LEAF ON - if (pftcon%season_decid(currentCohort%pft) == 1)then + if (EDPftvarcon_inst%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. @@ -586,7 +589,7 @@ subroutine phenology_leafonoff(currentSite) endif !season_decid !DROUGHT LEAF ON - if (pftcon%stress_decid(currentCohort%pft) == 1)then + if (EDPftvarcon_inst%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. @@ -778,11 +781,11 @@ subroutine Growth_Derivatives( currentSite, currentCohort) call allocate_live_biomass(currentCohort,0) ! calculate target size of living biomass compartment for a given dbh. - target_balive = Bleaf(currentCohort) * (1.0_r8 + pftcon%froot_leaf(currentCohort%pft) + & + target_balive = Bleaf(currentCohort) * (1.0_r8 + EDPftvarcon_inst%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) + & + target_balive = Bleaf(currentCohort) * (EDPftvarcon_inst%froot_leaf(currentCohort%pft) + & EDecophyscon%sapwood_ratio(currentCohort%pft) * h) endif @@ -796,8 +799,8 @@ subroutine Growth_Derivatives( currentSite, currentCohort) 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) + if (EDPftvarcon_inst%evergreen(currentCohort%pft) == 1)then !grass and EBT + currentCohort%leaf_md = currentCohort%bl / EDPftvarcon_inst%leaf_long(currentCohort%pft) currentCohort%root_md = currentCohort%br / EDecophyscon%root_long(currentCohort%pft) currentCohort%md = currentCohort%root_md + currentCohort%leaf_md endif @@ -807,22 +810,22 @@ subroutine Growth_Derivatives( currentSite, currentCohort) !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 + if (EDPftvarcon_inst%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 + if (EDPftvarcon_inst%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) + if (EDPftvarcon_inst%stress_decid(currentCohort%pft) /= 1.and.EDPftvarcon_inst%season_decid(currentCohort%pft) /= 1.and. & + EDPftvarcon_inst%evergreen(currentCohort%pft) /= 1)then + write(iulog,*) 'problem with phenology definitions',currentCohort%pft,EDPftvarcon_inst%stress_decid(currentCohort%pft), & + EDPftvarcon_inst%season_decid(currentCohort%pft),EDPftvarcon_inst%evergreen(currentCohort%pft) endif ! FIX(RF,032414) -turned off for now as it makes balive go negative.... @@ -911,7 +914,7 @@ subroutine Growth_Derivatives( currentSite, currentCohort) ! 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 + dbrdbd = EDPftvarcon_inst%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) @@ -1011,9 +1014,9 @@ subroutine recruitment( t, currentSite, currentPatch ) 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) & + temp_cohort%balive = Bleaf(temp_cohort)*(1.0_r8 + EDPftvarcon_inst%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) & + temp_cohort%bstore = EDecophyscon%cushion(ft)*(temp_cohort%balive/ (1.0_r8 + EDPftvarcon_inst%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) @@ -1026,17 +1029,17 @@ subroutine recruitment( t, currentSite, currentPatch ) endif temp_cohort%laimemory = 0.0_r8 - if (pftcon%season_decid(temp_cohort%pft) == 1.and.currentSite%status == 1)then - temp_cohort%laimemory = (1.0_r8/(1.0_r8 + pftcon%froot_leaf(ft) + & + if (EDPftvarcon_inst%season_decid(temp_cohort%pft) == 1.and.currentSite%status == 1)then + temp_cohort%laimemory = (1.0_r8/(1.0_r8 + EDPftvarcon_inst%froot_leaf(ft) + & EDecophyscon%sapwood_ratio(ft)*temp_cohort%hite))*temp_cohort%balive endif - if (pftcon%stress_decid(temp_cohort%pft) == 1.and.currentSite%dstatus == 1)then - temp_cohort%laimemory = (1.0_r8/(1.0_r8 + pftcon%froot_leaf(ft) + & + if (EDPftvarcon_inst%stress_decid(temp_cohort%pft) == 1.and.currentSite%dstatus == 1)then + temp_cohort%laimemory = (1.0_r8/(1.0_r8 + EDPftvarcon_inst%froot_leaf(ft) + & EDecophyscon%sapwood_ratio(ft)*temp_cohort%hite))*temp_cohort%balive endif cohortstatus = currentSite%status - if (pftcon%stress_decid(ft) == 1)then !drought decidous, override status. + if (EDPftvarcon_inst%stress_decid(ft) == 1)then !drought decidous, override status. cohortstatus = currentSite%dstatus endif @@ -1294,7 +1297,7 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) !use EDCLMLinkMod, only: cwd_fcel_ed, cwd_flig - use pftconMod, only : pftcon + use EDPftvarcon, only : EDPftvarcon_inst use shr_const_mod, only: SHR_CONST_CDAY use clm_varcon, only : zisoi, dzsoi_decomp, zsoi use EDParamsMod, only : ED_val_ag_biomass @@ -1404,8 +1407,9 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) ! use beta distribution parameter from Jackson et al., 1996 do ft = 1, numpft_ed do j = 1, cp_numlevdecomp - cinput_rootfr(ft,j) = ( pftcon%rootprof_beta(ft, rooting_profile_varindex_water) ** (zisoi(j-1)*100._r8) - & - pftcon%rootprof_beta(ft, rooting_profile_varindex_water) ** (zisoi(j)*100._r8) ) & + cinput_rootfr(ft,j) = ( & + EDPftvarcon_inst%rootprof_beta(ft, rooting_profile_varindex_water) ** (zisoi(j-1)*100._r8) - & + EDPftvarcon_inst%rootprof_beta(ft, rooting_profile_varindex_water) ** (zisoi(j)*100._r8) ) & / dzsoi_decomp(j) end do end do @@ -1415,10 +1419,10 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) do j = 1, cp_numlevdecomp ! use standard CLM root fraction profiles; cinput_rootfr(ft,j) = ( .5_r8*( & - exp(-pftcon%roota_par(ft) * zisoi(j-1)) & - + exp(-pftcon%rootb_par(ft) * zisoi(j-1)) & - - exp(-pftcon%roota_par(ft) * zisoi(j)) & - - exp(-pftcon%rootb_par(ft) * zisoi(j)))) / dzsoi_decomp(j) + exp(-EDPftvarcon_inst%roota_par(ft) * zisoi(j-1)) & + + exp(-EDPftvarcon_inst%rootb_par(ft) * zisoi(j-1)) & + - exp(-EDPftvarcon_inst%roota_par(ft) * zisoi(j)) & + - exp(-EDPftvarcon_inst%rootb_par(ft) * zisoi(j)))) / dzsoi_decomp(j) end do end do endif @@ -1606,26 +1610,26 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) do ft = 1,numpft_ed do j = 1, cp_numlevdecomp bc_out(s)%FATES_c_to_litr_lab_c_col(j) = bc_out(s)%FATES_c_to_litr_lab_c_col(j) + & - currentpatch%leaf_litter_out(ft) * pftcon%lf_flab(ft) * currentpatch%area/AREA * leaf_prof(s,j) + currentpatch%leaf_litter_out(ft) * EDPftvarcon_inst%lf_flab(ft) * currentpatch%area/AREA * leaf_prof(s,j) bc_out(s)%FATES_c_to_litr_cel_c_col(j) = bc_out(s)%FATES_c_to_litr_cel_c_col(j) + & - currentpatch%leaf_litter_out(ft) * pftcon%lf_fcel(ft) * currentpatch%area/AREA * leaf_prof(s,j) + currentpatch%leaf_litter_out(ft) * EDPftvarcon_inst%lf_fcel(ft) * currentpatch%area/AREA * leaf_prof(s,j) bc_out(s)%FATES_c_to_litr_lig_c_col(j) = bc_out(s)%FATES_c_to_litr_lig_c_col(j) + & - currentpatch%leaf_litter_out(ft) * pftcon%lf_flig(ft) * currentpatch%area/AREA * leaf_prof(s,j) + currentpatch%leaf_litter_out(ft) * EDPftvarcon_inst%lf_flig(ft) * currentpatch%area/AREA * leaf_prof(s,j) ! bc_out(s)%FATES_c_to_litr_lab_c_col(j) = bc_out(s)%FATES_c_to_litr_lab_c_col(j) + & - currentpatch%root_litter_out(ft) * pftcon%fr_flab(ft) * currentpatch%area/AREA * froot_prof(s,ft,j) + currentpatch%root_litter_out(ft) * EDPftvarcon_inst%fr_flab(ft) * currentpatch%area/AREA * froot_prof(s,ft,j) bc_out(s)%FATES_c_to_litr_cel_c_col(j) = bc_out(s)%FATES_c_to_litr_cel_c_col(j) + & - currentpatch%root_litter_out(ft) * pftcon%fr_fcel(ft) * currentpatch%area/AREA * froot_prof(s,ft,j) + currentpatch%root_litter_out(ft) * EDPftvarcon_inst%fr_fcel(ft) * currentpatch%area/AREA * froot_prof(s,ft,j) bc_out(s)%FATES_c_to_litr_lig_c_col(j) = bc_out(s)%FATES_c_to_litr_lig_c_col(j) + & - currentpatch%root_litter_out(ft) * pftcon%fr_flig(ft) * currentpatch%area/AREA * froot_prof(s,ft,j) + currentpatch%root_litter_out(ft) * EDPftvarcon_inst%fr_flig(ft) * currentpatch%area/AREA * froot_prof(s,ft,j) ! !! and seed_decay too. for now, use the same lability fractions as for leaf litter bc_out(s)%FATES_c_to_litr_lab_c_col(j) = bc_out(s)%FATES_c_to_litr_lab_c_col(j) + & - currentpatch%seed_decay(ft) * pftcon%lf_flab(ft) * currentpatch%area/AREA * leaf_prof(s,j) + currentpatch%seed_decay(ft) * EDPftvarcon_inst%lf_flab(ft) * currentpatch%area/AREA * leaf_prof(s,j) bc_out(s)%FATES_c_to_litr_cel_c_col(j) = bc_out(s)%FATES_c_to_litr_cel_c_col(j) + & - currentpatch%seed_decay(ft) * pftcon%lf_fcel(ft) * currentpatch%area/AREA * leaf_prof(s,j) + currentpatch%seed_decay(ft) * EDPftvarcon_inst%lf_fcel(ft) * currentpatch%area/AREA * leaf_prof(s,j) bc_out(s)%FATES_c_to_litr_lig_c_col(j) = bc_out(s)%FATES_c_to_litr_lig_c_col(j) + & - currentpatch%seed_decay(ft) * pftcon%lf_flig(ft) * currentpatch%area/AREA * leaf_prof(s,j) + currentpatch%seed_decay(ft) * EDPftvarcon_inst%lf_flig(ft) * currentpatch%area/AREA * leaf_prof(s,j) ! enddo end do diff --git a/biogeophys/EDBtranMod.F90 b/biogeophys/EDBtranMod.F90 index 8ac4a51b..bc9d5413 100644 --- a/biogeophys/EDBtranMod.F90 +++ b/biogeophys/EDBtranMod.F90 @@ -5,7 +5,7 @@ module EDBtranMod ! ! ------------------------------------------------------------------------------------ - use pftconMod , only : pftcon + use EDPftvarcon , only : EDPftvarcon_inst use clm_varcon , only : tfrz use EDTypesMod , only : ed_site_type, & ed_patch_type, & @@ -111,8 +111,8 @@ subroutine btran_ed( nsites, sites, bc_in, bc_out) !------------------------------------------------------------------------------ associate( & - smpsc => pftcon%smpsc , & ! INTERF-TODO: THESE SHOULD BE FATES PARAMETERS - smpso => pftcon%smpso & ! INTERF-TODO: THESE SHOULD BE FATES PARAMETERS + smpsc => EDPftvarcon_inst%smpsc , & ! INTERF-TODO: THESE SHOULD BE FATES PARAMETERS + smpso => EDPftvarcon_inst%smpso & ! INTERF-TODO: THESE SHOULD BE FATES PARAMETERS ) do s = 1,nsites diff --git a/biogeophys/EDPhotosynthesisMod.F90 b/biogeophys/EDPhotosynthesisMod.F90 index 7e55aee9..c8970fdc 100644 --- a/biogeophys/EDPhotosynthesisMod.F90 +++ b/biogeophys/EDPhotosynthesisMod.F90 @@ -43,7 +43,7 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) use abortutils , only : endrun use clm_varpar , only : mxpft ! THIS WILL BE DEPRECATED WHEN PARAMETER ! READS ARE REFACTORED (RGK 10-13-2016) - use pftconMod , only : pftcon ! THIS WILL BE DEPRECATED WHEN PARAMETER + use EDPftvarcon , only : EDPftvarcon_inst ! THIS WILL BE DEPRECATED WHEN PARAMETER ! READS ARE REFACTORED (RGK 10-13-2016) use EDParamsMod , only : ED_val_grperc use EDParamsMod , only : ED_val_ag_biomass @@ -241,13 +241,13 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) 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) - frootcn => pftcon%frootcn , & ! froot C:N (gc/gN) + c3psn => EDPftvarcon_inst%c3psn , & ! photosynthetic pathway: 0. = c4, 1. = c3 + slatop => EDPftvarcon_inst%slatop , & ! specific leaf area at top of canopy, projected area basis [m^2/gC] + flnr => EDPftvarcon_inst%flnr , & ! fraction of leaf N in the Rubisco enzyme (gN Rubisco / gN leaf) + woody => EDPftvarcon_inst%woody , & ! Is vegetation woody or not? + fnitr => EDPftvarcon_inst%fnitr , & ! foliage nitrogen limitation factor (-) + leafcn => EDPftvarcon_inst%leafcn , & ! leaf C:N (gC/gN) + frootcn => EDPftvarcon_inst%frootcn , & ! froot C:N (gc/gN) bb_slope => EDecophyscon%BB_slope ) ! slope of BB relationship ! Peter Thornton: 3/13/09 @@ -533,7 +533,7 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) 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) * (1.0_r8-currentPatch%btran_ft(FT)) *EDPftvarcon_inst%resp_drought_response(FT)) lmr_z(CL,FT,iv) = lmr_z(CL,FT,iv) end do ! iv @@ -878,7 +878,7 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) currentCohort%rdark = currentCohort%rdark * umolC_to_kgC leaf_frac = 1.0_r8/(currentCohort%canopy_trim + EDecophyscon%sapwood_ratio(currentCohort%pft) * & - currentCohort%hite + pftcon%froot_leaf(currentCohort%pft)) + currentCohort%hite + EDPftvarcon_inst%froot_leaf(currentCohort%pft)) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -951,7 +951,7 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) currentCohort%gpp_tstep = currentCohort%gpp_tstep * umolC_to_kgC ! 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)) + ! no drought response * (1.0_r8 - currentPatch%btran_ft(currentCohort%pft)*EDPftvarcon_inst%resp_drought_response(FT)) currentCohort%resp_m = currentCohort%resp_m + currentCohort%rdark ! convert from kgC/indiv/s to kgC/indiv/timestep diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index d7669591..ce19f602 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -46,7 +46,7 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) ! ! !USES: use clm_varctl , only : iulog - use pftconMod , only : pftcon + use EDPftvarcon , only : EDPftvarcon_inst use EDtypesMod , only : ed_patch_type, numpft_ed, cp_nlevcan use EDTypesMod , only : ed_site_type @@ -113,11 +113,11 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) !----------------------------------------------------------------------- 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 + rhol => EDPftvarcon_inst%rhol , & ! Input: [real(r8) (:) ] leaf reflectance: 1=vis, 2=nir + rhos => EDPftvarcon_inst%rhos , & ! Input: [real(r8) (:) ] stem reflectance: 1=vis, 2=nir + taul => EDPftvarcon_inst%taul , & ! Input: [real(r8) (:) ] leaf transmittance: 1=vis, 2=nir + taus => EDPftvarcon_inst%taus , & ! Input: [real(r8) (:) ] stem transmittance: 1=vis, 2=nir + xl => EDPftvarcon_inst%xl) ! Input: [real(r8) (:) ] ecophys const - leaf/stem orientation index ! albd => surfalb_inst%albd_patch , & ! Output: [real(r8) (:,:) ] surface albedo (direct) (USED IN LND2ATM,BALANCE_CHECK) ! albi => surfalb_inst%albi_patch , & ! Output: [real(r8) (:,:) ] surface albedo (diffuse) (LND2ATM,BALANCE_CHECK) diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index be53100a..47c96c30 100755 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -10,7 +10,7 @@ module SFMainMod use clm_varctl , only : iulog use atm2lndType , only : atm2lnd_type use TemperatureType , only : temperature_type - use pftconMod , only : pftcon + use EDPftvarcon , only : EDPftvarcon_inst 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 @@ -158,7 +158,7 @@ subroutine charecteristics_of_fuel ( currentSite ) currentPatch%livegrass = 0.0_r8 currentCohort => currentPatch%tallest do while(associated(currentCohort)) - if(pftcon%woody(currentCohort%pft) == 0)then + if(EDPftvarcon_inst%woody(currentCohort%pft) == 0)then currentPatch%livegrass = currentPatch%livegrass + currentCohort%bl*currentCohort%n/currentPatch%area endif currentCohort => currentCohort%shorter @@ -329,7 +329,7 @@ subroutine wind_effect ( currentSite, atm2lnd_inst) do while(associated(currentCohort)) write(iulog,*) 'SF currentCohort%c_area ',currentCohort%c_area - if(pftcon%woody(currentCohort%pft) == 1)then + if(EDPftvarcon_inst%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 @@ -751,7 +751,7 @@ subroutine crown_scorching ( currentSite ) if (currentPatch%fire == 1) then currentCohort => currentPatch%tallest; do while(associated(currentCohort)) - if (pftcon%woody(currentCohort%pft) == 1) then !trees only + if (EDPftvarcon_inst%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 @@ -766,7 +766,7 @@ subroutine crown_scorching ( currentSite ) 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 + if (EDPftvarcon_inst%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 @@ -806,7 +806,7 @@ subroutine crown_damage ( currentSite ) do while(associated(currentCohort)) currentCohort%cfa = 0.0_r8 - if (pftcon%woody(currentCohort%pft) == 1) then !trees only + if (EDPftvarcon_inst%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 @@ -867,7 +867,7 @@ subroutine cambial_damage_kill ( currentSite ) if (currentPatch%fire == 1) then currentCohort => currentPatch%tallest; do while(associated(currentCohort)) - if (pftcon%woody(currentCohort%pft) == 1) then !trees only + if (EDPftvarcon_inst%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. @@ -919,7 +919,7 @@ subroutine post_fire_mortality ( currentSite ) do while(associated(currentCohort)) currentCohort%fire_mort = 0.0_r8 currentCohort%crownfire_mort = 0.0_r8 - if (pftcon%woody(currentCohort%pft) == 1) then + if (EDPftvarcon_inst%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. diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index e8830e41..fb1e7ea2 100755 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -14,7 +14,7 @@ module EDInitMod use CanopyStateType , only : canopystate_type use WaterStateType , only : waterstate_type use GridcellType , only : grc - use pftconMod , only : pftcon + use EDPftvarcon , only : EDPftvarcon_inst use EDEcophysConType , only : EDecophyscon use EDGrowthFunctionsMod , only : bdead, bleaf, dbh use EDCohortDynamicsMod , only : create_cohort, fuse_cohorts, sort_cohorts @@ -252,17 +252,17 @@ subroutine init_cohorts( patch_in ) 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) & + temp_cohort%balive = Bleaf(temp_cohort)*(1.0_r8 + EDPftvarcon_inst%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 + if( EDPftvarcon_inst%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 + if( EDPftvarcon_inst%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 @@ -274,7 +274,7 @@ subroutine init_cohorts( patch_in ) cstatus = patch_in%siteptr%status endif - if ( pftcon%stress_decid(pft) == 1 ) then + if ( EDPftvarcon_inst%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 diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index 475ee7b1..1ac59074 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -6,7 +6,7 @@ module EDPftvarcon ! read and initialize vegetation (PFT) constants. ! ! !USES: - use clm_varpar , only : mxpft + use clm_varpar , only : mxpft, numrad, ivis, inir, nvariants use shr_kind_mod, only : r8 => shr_kind_r8 ! @@ -39,10 +39,40 @@ module EDPftvarcon 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 real(r8) :: dbh2h_m (0:mxpft) ! allocation parameter m from dbh to height + real(r8) :: woody(0:mxpft) + real(r8) :: stress_decid(0:mxpft) + real(r8) :: season_decid(0:mxpft) + real(r8) :: evergreen(0:mxpft) + real(r8) :: froot_leaf(0:mxpft) + real(r8) :: slatop(0:mxpft) + real(r8) :: leaf_long(0:mxpft) + real(r8) :: rootprof_beta(0:mxpft,nvariants) + real(r8) :: roota_par(0:mxpft) + real(r8) :: rootb_par(0:mxpft) + real(r8) :: lf_flab(0:mxpft) + real(r8) :: lf_fcel(0:mxpft) + real(r8) :: lf_flig(0:mxpft) + real(r8) :: fr_flab(0:mxpft) + real(r8) :: fr_fcel(0:mxpft) + real(r8) :: fr_flig(0:mxpft) + real(r8) :: rhol(0:mxpft, numrad) + real(r8) :: rhos(0:mxpft, numrad) + real(r8) :: taul(0:mxpft, numrad) + real(r8) :: taus(0:mxpft, numrad) + real(r8) :: xl(0:mxpft) + real(r8) :: c3psn(0:mxpft) + real(r8) :: flnr(0:mxpft) + real(r8) :: fnitr(0:mxpft) + real(r8) :: leafcn(0:mxpft) + real(r8) :: frootcn(0:mxpft) + real(r8) :: smpso(0:mxpft) + real(r8) :: smpsc(0:mxpft) end type EDPftvarcon_type type(EDPftvarcon_type), public :: EDPftvarcon_inst + character(len=*), parameter, private :: sourcefile = & + __FILE__ ! ! !PUBLIC MEMBER FUNCTIONS: public :: EDpftconrd ! Read and initialize vegetation (PFT) constants @@ -59,6 +89,7 @@ subroutine EDpftconrd( ncid ) ! !USES: use ncdio_pio , only : file_desc_t, ncd_io use abortutils , only : endrun + use shr_log_mod , only : errMsg => shr_log_errMsg ! ! !ARGUMENTS: implicit none @@ -133,6 +164,102 @@ subroutine EDpftconrd( ncid ) 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') + call ncd_io('woody', EDPftvarcon_inst%woody, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('stress_decid', EDPftvarcon_inst%stress_decid, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('season_decid', EDPftvarcon_inst%season_decid, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('evergreen', EDPftvarcon_inst%evergreen, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('froot_leaf', EDPftvarcon_inst%froot_leaf, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('slatop', EDPftvarcon_inst%slatop, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('leaf_long', EDPftvarcon_inst%leaf_long, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('rootprof_beta', EDPftvarcon_inst%rootprof_beta, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('roota_par', EDPftvarcon_inst%roota_par, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('rootb_par', EDPftvarcon_inst%rootb_par, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('lf_flab', EDPftvarcon_inst%lf_flab, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('lf_fcel', EDPftvarcon_inst%lf_fcel, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('lf_flig', EDPftvarcon_inst%lf_flig, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('fr_flab', EDPftvarcon_inst%fr_flab, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('fr_fcel', EDPftvarcon_inst%fr_fcel, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('fr_flig', EDPftvarcon_inst%fr_flig, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('rholvis', EDPftvarcon_inst%rhol(:,ivis), 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('rholnir', EDPftvarcon_inst%rhol(:,inir), 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('rhosvis', EDPftvarcon_inst%rhos(:,ivis), 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('rhosnir', EDPftvarcon_inst% rhos(:,inir), 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('taulvis', EDPftvarcon_inst%taul(:,ivis), 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('taulnir', EDPftvarcon_inst%taul(:,inir), 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('tausvis', EDPftvarcon_inst%taus(:,ivis), 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('tausnir', EDPftvarcon_inst%taus(:,inir), 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('xl', EDPftvarcon_inst%xl, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('c3psn', EDPftvarcon_inst%c3psn, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('flnr', EDPftvarcon_inst%flnr, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('fnitr', EDPftvarcon_inst%fnitr, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('leafcn', EDPftvarcon_inst%leafcn, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('frootcn', EDPftvarcon_inst%frootcn, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('smpso', EDPftvarcon_inst%smpso, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('smpsc', EDPftvarcon_inst%smpsc, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + ! HOLDING ON SEW ENSITIVITY-ANALYSIS PARAMETERS UNTIL MACHINE CONFIGS SET RGK/CX ! call ncd_io('dbh2h_m',EDPftvarcon_inst%dbh2h_m, 'read', ncid, readvar=readv) ! if ( .not. readv) call endrun(trim(subname)// ' ERROR : error in reading in pft data') diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 3419386a..ce686880 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -634,7 +634,7 @@ subroutine set_root_fraction( this , depth_gl) ! ! !USES: use PatchType , only : clmpatch => patch - use pftconMod , only : pftcon + use EDPftvarcon , only : EDPftvarcon_inst ! ! !ARGUMENTS class(ed_patch_type) :: this @@ -651,10 +651,10 @@ subroutine set_root_fraction( this , depth_gl) do lev = 1, cp_numlevsoil-1 this%rootfr_ft(ft,lev) = .5_r8*( & - exp(-pftcon%roota_par(ft) * depth_gl(lev-1)) & - + exp(-pftcon%rootb_par(ft) * depth_gl(lev-1)) & - - exp(-pftcon%roota_par(ft) * depth_gl(lev)) & - - exp(-pftcon%rootb_par(ft) * depth_gl(lev))) + exp(-EDPftvarcon_inst%roota_par(ft) * depth_gl(lev-1)) & + + exp(-EDPftvarcon_inst%rootb_par(ft) * depth_gl(lev-1)) & + - exp(-EDPftvarcon_inst%roota_par(ft) * depth_gl(lev)) & + - exp(-EDPftvarcon_inst%rootb_par(ft) * depth_gl(lev))) end do end do diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index b2b090b2..662ead47 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -11,7 +11,7 @@ module FatesHistoryInterfaceMod use EDTypesMod , only : cp_hio_ignore_val ! FIXME(bja, 2016-10) need to remove CLM dependancy - use pftconMod , only : pftcon + use EDPftvarcon , only : EDPftvarcon_inst implicit none @@ -829,7 +829,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) end if ! Woody State Variables (basal area and number density and mortality) - if (pftcon%woody(ft) == 1) then + if (EDPftvarcon_inst%woody(ft) == 1) then hio_m1_si_scpf(io_si,scpf) = hio_m1_si_scpf(io_si,scpf) + ccohort%bmort*n_perm2*AREA hio_m2_si_scpf(io_si,scpf) = hio_m2_si_scpf(io_si,scpf) + ccohort%hmort*n_perm2*AREA diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 18b77bc6..f906ca1c 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -1286,7 +1286,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites ) use EDInitMod, only : zero_site use EDParamsMod, only : ED_val_maxspread use EDPatchDynamicsMod, only : create_patch - use pftconMod, only : pftcon + use EDPftvarcon, only : EDPftvarcon_inst ! !ARGUMENTS: class(fates_restart_interface_type) , intent(inout) :: this @@ -1396,7 +1396,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites ) cohortstatus = newp%siteptr%status - if(pftcon%stress_decid(ft) == 1)then !drought decidous, override status. + if(EDPftvarcon_inst%stress_decid(ft) == 1)then !drought decidous, override status. cohortstatus = newp%siteptr%dstatus endif From 8f8396971a129d4822e85f1b4d97be9b613c9d7a Mon Sep 17 00:00:00 2001 From: Ben Andre Date: Thu, 19 Jan 2017 13:36:00 -0700 Subject: [PATCH 307/437] First pass at FatesParametersInterface First implementation of FatesParametersInterface to allow fates to request a parameter set be read by the host. Implementation is used for scalar parameters. Initial implementation of 1d and 2d arrays is done, but not used (and not expected to work) until further refinement of array dimension bounds is implemented. User interface changes?: No Code review: andre Test suite: ed - yellowstone gnu, intel, pgi Test baseline: a651a4f Test namelist changes: yes, addition of fates_paramfile Test answer changes: bit for bit Test summary: all tests pass Test suite: clm_short - yellowstone gnu, intel, pgi Test baseline: clm4_5_1_r195 Test namelist changes: no Test answer changes: bit for bit Test summary: all tests pass --- main/EDParamsMod.F90 | 260 ++++++++++++++++++++++-------- main/FatesParametersInterface.F90 | 249 ++++++++++++++++++++++++++++ 2 files changed, 445 insertions(+), 64 deletions(-) create mode 100644 main/FatesParametersInterface.F90 diff --git a/main/EDParamsMod.F90 b/main/EDParamsMod.F90 index 16e2f2f5..44be691e 100644 --- a/main/EDParamsMod.F90 +++ b/main/EDParamsMod.F90 @@ -4,7 +4,8 @@ module EDParamsMod ! use shr_kind_mod , only: r8 => shr_kind_r8 use EDtypesMod , only: maxPft - + use FatesParametersInterface, only : param_string_length + implicit none save ! private - if we allow this module to be private, it does not allow the protected values below to be @@ -13,6 +14,7 @@ module EDParamsMod ! ! 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 @@ -26,20 +28,23 @@ module EDParamsMod 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" + character(len=param_string_length),parameter :: ED_name_grass_spread = "grass_spread" + character(len=param_string_length),parameter :: ED_name_comp_excln = "comp_excln" + character(len=param_string_length),parameter :: ED_name_stress_mort = "stress_mort" + character(len=param_string_length),parameter :: ED_name_dispersal = "dispersal" + character(len=param_string_length),parameter :: ED_name_grperc = "grperc" + character(len=param_string_length),parameter :: ED_name_maxspread = "maxspread" + character(len=param_string_length),parameter :: ED_name_minspread = "minspread" + character(len=param_string_length),parameter :: ED_name_init_litter = "init_litter" + character(len=param_string_length),parameter :: ED_name_nfires = "nfires" + character(len=param_string_length),parameter :: ED_name_understorey_death = "understorey_death" + character(len=param_string_length),parameter :: ED_name_profile_tol = "profile_tol" + character(len=param_string_length),parameter :: ED_name_ag_biomass= "ag_biomass" public :: EDParamsRead + public :: FatesParamsInit + public :: FatesRegisterParams + public :: FatesReceiveParams contains @@ -57,11 +62,34 @@ subroutine EDParamsRead(ncid) ! arguments type(file_desc_t),intent(inout) :: ncid ! pio netCDF file id + call FatesParamsInit() call EDParamsReadLocal(ncid) end subroutine EDParamsRead + !----------------------------------------------------------------------- + subroutine FatesParamsInit() + ! Initialize all parameters to nan to ensure that we get valid + ! values back from the host. + + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + + implicit none + ED_val_grass_spread = nan + ED_val_comp_excln = nan + ED_val_stress_mort = nan + ED_val_dispersal = nan + ED_val_grperc(:) = nan + ED_val_maxspread = nan + ED_val_minspread = nan + ED_val_init_litter = nan + ED_val_nfires = nan + ED_val_understorey_death = nan + ED_val_profile_tol = nan + ED_val_ag_biomass = nan + + end subroutine FatesParamsInit !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- @@ -84,67 +112,171 @@ subroutine EDParamsReadLocal(ncid) ! 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) + !X! call readNcdio(ncid = ncid, & + !X! varName=ED_name_grass_spread, & + !X! callingName=subname, & + !X! retVal=ED_val_grass_spread) - call readNcdio(ncid = ncid, & - varName=ED_name_stress_mort, & - callingName=subname, & - retVal=ED_val_stress_mort) + !X! call readNcdio(ncid = ncid, & + !X! varName=ED_name_comp_excln, & + !X! callingName=subname, & + !X! retVal=ED_val_comp_excln) - call readNcdio(ncid = ncid, & - varName=ED_name_dispersal, & - callingName=subname, & - retVal=ED_val_dispersal) + !X! call readNcdio(ncid = ncid, & + !X! varName=ED_name_stress_mort, & + !X! callingName=subname, & + !X! retVal=ED_val_stress_mort) + !X! + !X! call readNcdio(ncid = ncid, & + !X! varName=ED_name_dispersal, & + !X! callingName=subname, & + !X! 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) + !X! call readNcdio(ncid = ncid, & + !X! varName=ED_name_maxspread, & + !X! callingName=subname, & + !X! retVal=ED_val_maxspread) + !X! + !X! call readNcdio(ncid = ncid, & + !X! varName=ED_name_minspread, & + !X! callingName=subname, & + !X! retVal=ED_val_minspread) + !X! + !X! call readNcdio(ncid = ncid, & + !X! varName=ED_name_init_litter, & + !X! callingName=subname, & + !X! retVal=ED_val_init_litter) + !X! + !X! call readNcdio(ncid = ncid, & + !X! varName=ED_name_nfires, & + !X! callingName=subname, & + !X! retVal=ED_val_nfires) + !X! + !X! call readNcdio(ncid = ncid, & + !X! varName=ED_name_understorey_death, & + !X! callingName=subname, & + !X! retVal=ED_val_understorey_death) + !X! + !X! call readNcdio(ncid = ncid, & + !X! varName=ED_name_profile_tol, & + !X! callingName=subname, & + !X! retVal=ED_val_profile_tol) + !X! + !X! call readNcdio(ncid = ncid, & + !X! varName=ED_name_ag_biomass, & + !X! callingName=subname, & + !X! retVal=ED_val_ag_biomass) end subroutine EDParamsReadLocal + !----------------------------------------------------------------------- + subroutine FatesRegisterParams(fates_params) + ! Register the parameters we want the host to provide, and + ! indicate whether they are fates parameters or host parameters + ! that need to be synced with host values. + use FatesParametersInterface, only : fates_parameters_type, dimension_name_scalar, dimension_shape_scalar + + implicit none + + class(fates_parameters_type), intent(inout) :: fates_params + + character(len=param_string_length), parameter :: dim_names_scalar(1) = (/dimension_name_scalar/) + + call fates_params%RegisterParameter(name=ED_name_grass_spread, dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + + call fates_params%RegisterParameter(name=ED_name_comp_excln, dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + + call fates_params%RegisterParameter(name=ED_name_grass_spread, dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + + call fates_params%RegisterParameter(name=ED_name_comp_excln, dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + + call fates_params%RegisterParameter(name=ED_name_stress_mort, dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + + call fates_params%RegisterParameter(name=ED_name_dispersal, dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + + call fates_params%RegisterParameter(name=ED_name_maxspread, dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + + call fates_params%RegisterParameter(name=ED_name_minspread, dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + + call fates_params%RegisterParameter(name=ED_name_init_litter, dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + + call fates_params%RegisterParameter(name=ED_name_nfires, dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + + call fates_params%RegisterParameter(name=ED_name_understorey_death, dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + + call fates_params%RegisterParameter(name=ED_name_profile_tol, dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + + call fates_params%RegisterParameter(name=ED_name_ag_biomass, dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + + end subroutine FatesRegisterParams + + !----------------------------------------------------------------------- + subroutine FatesReceiveParams(fates_params) + + use FatesParametersInterface, only : fates_parameters_type, dimension_name_scalar + + implicit none + + class(fates_parameters_type), intent(inout) :: fates_params + + call fates_params%RetreiveParameter(name=ED_name_grass_spread, & + data=ED_val_grass_spread) + + call fates_params%RetreiveParameter(name=ED_name_comp_excln, & + data=ED_val_comp_excln) + + call fates_params%RetreiveParameter(name=ED_name_grass_spread, & + data=ED_val_grass_spread) + + call fates_params%RetreiveParameter(name=ED_name_comp_excln, & + data=ED_val_comp_excln) + + call fates_params%RetreiveParameter(name=ED_name_stress_mort, & + data=ED_val_stress_mort) + + call fates_params%RetreiveParameter(name=ED_name_dispersal, & + data=ED_val_dispersal) + + call fates_params%RetreiveParameter(name=ED_name_maxspread, & + data=ED_val_maxspread) + + call fates_params%RetreiveParameter(name=ED_name_minspread, & + data=ED_val_minspread) + + call fates_params%RetreiveParameter(name=ED_name_init_litter, & + data=ED_val_init_litter) + + call fates_params%RetreiveParameter(name=ED_name_nfires, & + data=ED_val_nfires) + + call fates_params%RetreiveParameter(name=ED_name_understorey_death, & + data=ED_val_understorey_death) + + call fates_params%RetreiveParameter(name=ED_name_profile_tol, & + data=ED_val_profile_tol) + + call fates_params%RetreiveParameter(name=ED_name_ag_biomass, & + data=ED_val_ag_biomass) + + end subroutine FatesReceiveParams + end module EDParamsMod diff --git a/main/FatesParametersInterface.F90 b/main/FatesParametersInterface.F90 new file mode 100644 index 00000000..1e21e64b --- /dev/null +++ b/main/FatesParametersInterface.F90 @@ -0,0 +1,249 @@ +module FatesParametersInterface + ! NOTE(bja, 2017-01) this is part of the interface between fates and + ! the host model. To avoid circular dependancies, it should not + ! depend on any host modules. + + use FatesConstantsMod, only : r8 => fates_r8 + + implicit none + + integer, parameter, public :: max_params = 250 + integer, parameter, public :: max_dimensions = 2 + integer, parameter, public :: param_string_length = 40 + integer, parameter, public :: dimension_shape_scalar = 0 + integer, parameter, public :: dimension_shape_1d = 1 + integer, parameter, public :: dimension_shape_2d = 2 + + ! FIXME(bja, 2017-01) these strings need to be changed to 'fates_' + ! to namespace dimonsions and prevent name collisions if someone + ! wants to write a single netcdf file containing host and fates + ! parameters. Can't be done easily until this framework is being + ! used to read variables. + character(len=*), parameter, public :: dimension_name_scalar = 'scalar' + character(len=*), parameter, public :: dimension_name_pft = 'pft' + character(len=*), parameter, public :: dimension_name_segment = 'segment' + + type, private :: parameter_type + character(len=param_string_length) :: name + logical :: host_parameter + integer :: dimension_shape + character(len=param_string_length) :: dimension_names(max_dimensions) + real(r8), allocatable :: data(:, :) + end type parameter_type + + type, public :: fates_parameters_type + integer, private :: num_parameters + type(parameter_type), private :: parameters(max_params) + + contains + procedure, public :: Init + procedure, public :: RegisterParameter + generic, public :: RetreiveParameter => RetreiveParameterScalar, RetreiveParameter1D, RetreiveParameter2D + generic, public :: SetData => SetDataScalar, SetData1D, SetData2D + procedure, public :: GetMetaData + procedure, public :: num_params + procedure, private :: RetreiveParameterScalar + procedure, private :: RetreiveParameter1D + procedure, private :: RetreiveParameter2D + procedure, private :: SetDataScalar + procedure, private :: SetData1D + procedure, private :: SetData2D + procedure, private :: FindIndex + + end type fates_parameters_type + +contains + + !----------------------------------------------------------------------- + subroutine Init(this) + + implicit none + + class(fates_parameters_type), intent(inout) :: this + + this%num_parameters = 0 + + end subroutine Init + + !----------------------------------------------------------------------- + subroutine RegisterParameter(this, name, dimension_shape, dimension_names, host_parameter) + + implicit none + + class(fates_parameters_type), intent(inout) :: this + character(len=param_string_length), intent(in) :: name + integer, intent(in) :: dimension_shape + character(len=param_string_length) :: dimension_names(1:) + logical, intent(in), optional :: host_parameter + + integer :: i, n, num_names + + this%num_parameters = this%num_parameters + 1 + i = this%num_parameters + ! FIXME(bja, 2017-01) assert(i <= max_params) + this%parameters(i)%name = name + this%parameters(i)%dimension_shape = dimension_shape + ! FIXME(bja, 2017-01) assert(size(dimension_names, 1) <= max_dimensions) + num_names = min(max_dimensions, size(dimension_names, 1)) + do n = 1, num_names + this%parameters(i)%dimension_names(n) = dimension_names(n) + end do + this%parameters(i)%host_parameter = .false. + if (present(host_parameter)) then + this%parameters(i)%host_parameter = .true. + end if + + end subroutine RegisterParameter + + !----------------------------------------------------------------------- + subroutine RetreiveParameterScalar(this, name, data) + + implicit none + + class(fates_parameters_type), intent(inout) :: this + character(len=param_string_length), intent(in) :: name + real(r8), intent(out) :: data + + integer :: i + + i = this%FindIndex(name) + ! assert(size(data) == size(this%parameters(i)%data)) + data = this%parameters(i)%data(1, 1) + + end subroutine RetreiveParameterScalar + + !----------------------------------------------------------------------- + subroutine RetreiveParameter1D(this, name, data) + + implicit none + + class(fates_parameters_type), intent(inout) :: this + character(len=param_string_length), intent(in) :: name + real(r8), intent(out) :: data(:) + + integer :: i + + i = this%FindIndex(name) + ! assert(size(data) == size(this%parameters(i)%data)) + data = this%parameters(i)%data(:, 1) + + end subroutine RetreiveParameter1D + + !----------------------------------------------------------------------- + subroutine RetreiveParameter2D(this, name, data) + + implicit none + + class(fates_parameters_type), intent(inout) :: this + character(len=param_string_length), intent(in) :: name + real(r8), intent(out) :: data(:, :) + + integer :: i + + i = this%FindIndex(name) + ! assert(size(data) == size(this%parameters(i)%data)) + data = this%parameters(i)%data + + end subroutine RetreiveParameter2D + + !----------------------------------------------------------------------- + function FindIndex(this, name) result(i) + + implicit none + + class(fates_parameters_type), intent(in) :: this + character(len=param_string_length), intent(in) :: name + + integer :: i + + do i = 1, this%num_parameters + if (trim(this%parameters(i)%name) == trim(name)) then + exit + end if + end do + if (i > this%num_parameters) then + ! error, parameter name not found. + end if + + end function FindIndex + + !----------------------------------------------------------------------- + integer function num_params(this) + + implicit none + + class(fates_parameters_type), intent(in) :: this + + num_params = this%num_parameters + + end function num_params + + !----------------------------------------------------------------------- + subroutine GetMetaData(this, index, name, dimension_shape) + + implicit none + + class(fates_parameters_type), intent(in) :: this + integer, intent(in) :: index + character(len=param_string_length), intent(out) :: name + integer, intent(out) :: dimension_shape + + name = this%parameters(index)%name + dimension_shape = this%parameters(index)%dimension_shape + + end subroutine GetMetaData + + !----------------------------------------------------------------------- + subroutine SetDataScalar(this, index, data) + + implicit none + + class(fates_parameters_type), intent(inout) :: this + integer, intent(in) :: index + real(r8), intent(in) :: data + + allocate(this%parameters(index)%data(1, 1)) + this%parameters(index)%data(1, 1) = data + + end subroutine SetDataScalar + + !----------------------------------------------------------------------- + subroutine SetData1D(this, index, data) + ! FIXME(bja, 2017-01) this is broken, needs data dimensions to work correctly! + + implicit none + + class(fates_parameters_type), intent(inout) :: this + integer, intent(in) :: index + real(r8), intent(in) :: data(:) + + allocate(this%parameters(index)%data(size(data), 1)) + this%parameters(index)%data(:, 1) = data + + end subroutine SetData1D + + !----------------------------------------------------------------------- + subroutine SetData2D(this, index, data) + ! FIXME(bja, 2017-01) this is broken, needs data dimensions to work correctly! + + implicit none + + class(fates_parameters_type), intent(inout) :: this + integer, intent(in) :: index + real(r8), intent(in) :: data(:, :) + + ! NOTE(bja, 2017-01) This should work for fortran 2003? Or 2008? + ! Either way, it works with intel and pgi being used in 2017-01, + ! but is broken in gfortran 5.2 and earlier. That would copy the + ! data as well.... + + !X! allocate(this%parameters(index)%data, source=data) + + allocate(this%parameters(index)%data(size(data, 1), size(data, 2))) + this%parameters(index)%data = data + + end subroutine SetData2D +end module FatesParametersInterface + + + From 9ed4d8c53fef1bb536c5f5b7ac07c6f1dc287aa2 Mon Sep 17 00:00:00 2001 From: Ben Andre Date: Fri, 20 Jan 2017 10:27:21 -0700 Subject: [PATCH 308/437] Move grperc parameter into EDPftvarcon EDParams is primarily scalar values, grperc was the only pft parameter. This moves grperc into EDPftvarcon with the other pft parameters. User interface changes?: No Code review: andre Test suite: ed - yellowstone gnu, intel, pgi Test baseline: a651a4f Test namelist changes: yes, addition of fates_paramfile Test answer changes: bit for bit Test summary: all tests pass --- biogeochem/EDPhysiologyMod.F90 | 5 ++--- biogeophys/EDPhotosynthesisMod.F90 | 4 ++-- main/EDParamsMod.F90 | 8 -------- main/EDPftvarcon.F90 | 4 ++++ 4 files changed, 8 insertions(+), 13 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index b2e51f09..8e99378d 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -146,7 +146,6 @@ subroutine trim_canopy( currentSite ) ! ! !USES: ! - use EDParamsMod, only : ED_val_grperc use EDGrowthFunctionsMod, only : tree_lai ! ! !ARGUMENTS @@ -191,14 +190,14 @@ subroutine trim_canopy( currentSite ) currentCohort%leaf_cost = currentCohort%leaf_cost + & 1.0_r8/(EDPftvarcon_inst%slatop(currentCohort%pft)*1000.0_r8) * & EDPftvarcon_inst%froot_leaf(currentCohort%pft) / EDecophyscon%root_long(currentCohort%pft) - currentCohort%leaf_cost = currentCohort%leaf_cost * (ED_val_grperc(currentCohort%pft) + 1._r8) + currentCohort%leaf_cost = currentCohort%leaf_cost * (EDPftvarcon_inst%grperc(currentCohort%pft) + 1._r8) else !evergreen costs currentCohort%leaf_cost = 1.0_r8/(EDPftvarcon_inst%slatop(currentCohort%pft)* & EDPftvarcon_inst%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/(EDPftvarcon_inst%slatop(currentCohort%pft)*1000.0_r8) * & EDPftvarcon_inst%froot_leaf(currentCohort%pft) / EDecophyscon%root_long(currentCohort%pft) - currentCohort%leaf_cost = currentCohort%leaf_cost * (ED_val_grperc(currentCohort%pft) + 1._r8) + currentCohort%leaf_cost = currentCohort%leaf_cost * (EDPftvarcon_inst%grperc(currentCohort%pft) + 1._r8) endif if (currentCohort%year_net_uptake(z) < currentCohort%leaf_cost)then if (currentCohort%canopy_trim > trim_limit)then diff --git a/biogeophys/EDPhotosynthesisMod.F90 b/biogeophys/EDPhotosynthesisMod.F90 index c8970fdc..8fd3a3d8 100644 --- a/biogeophys/EDPhotosynthesisMod.F90 +++ b/biogeophys/EDPhotosynthesisMod.F90 @@ -45,7 +45,6 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) ! READS ARE REFACTORED (RGK 10-13-2016) use EDPftvarcon , only : EDPftvarcon_inst ! THIS WILL BE DEPRECATED WHEN PARAMETER ! READS ARE REFACTORED (RGK 10-13-2016) - use EDParamsMod , only : ED_val_grperc use EDParamsMod , only : ED_val_ag_biomass use EDSharedParamsMod , only : EDParamsShareInst use EDTypesMod , only : numpft_ed @@ -962,7 +961,8 @@ subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) if ( DEBUG ) write(fates_log(),*) 'EDPhoto 912 ', currentCohort%resp_tstep if ( DEBUG ) write(fates_log(),*) 'EDPhoto 913 ', currentCohort%resp_m - currentCohort%resp_g = ED_val_grperc(ft) * (max(0._r8,currentCohort%gpp_tstep - currentCohort%resp_m)) + currentCohort%resp_g = EDPftvarcon_inst%grperc(ft) * & + (max(0._r8,currentCohort%gpp_tstep - currentCohort%resp_m)) currentCohort%resp_tstep = currentCohort%resp_m + currentCohort%resp_g ! kgC/indiv/ts currentCohort%npp_tstep = currentCohort%gpp_tstep - currentCohort%resp_tstep ! kgC/indiv/ts diff --git a/main/EDParamsMod.F90 b/main/EDParamsMod.F90 index 44be691e..a7f132be 100644 --- a/main/EDParamsMod.F90 +++ b/main/EDParamsMod.F90 @@ -19,7 +19,6 @@ module EDParamsMod 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(maxPft) real(r8),protected :: ED_val_maxspread real(r8),protected :: ED_val_minspread real(r8),protected :: ED_val_init_litter @@ -32,7 +31,6 @@ module EDParamsMod character(len=param_string_length),parameter :: ED_name_comp_excln = "comp_excln" character(len=param_string_length),parameter :: ED_name_stress_mort = "stress_mort" character(len=param_string_length),parameter :: ED_name_dispersal = "dispersal" - character(len=param_string_length),parameter :: ED_name_grperc = "grperc" character(len=param_string_length),parameter :: ED_name_maxspread = "maxspread" character(len=param_string_length),parameter :: ED_name_minspread = "minspread" character(len=param_string_length),parameter :: ED_name_init_litter = "init_litter" @@ -80,7 +78,6 @@ subroutine FatesParamsInit() ED_val_comp_excln = nan ED_val_stress_mort = nan ED_val_dispersal = nan - ED_val_grperc(:) = nan ED_val_maxspread = nan ED_val_minspread = nan ED_val_init_litter = nan @@ -132,11 +129,6 @@ subroutine EDParamsReadLocal(ncid) !X! callingName=subname, & !X! retVal=ED_val_dispersal) - call readNcdio(ncid = ncid, & - varName=ED_name_grperc, & - callingName=subname, & - retVal=ED_val_grperc) - !X! call readNcdio(ncid = ncid, & !X! varName=ED_name_maxspread, & !X! callingName=subname, & diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index 1ac59074..7a8a032e 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -67,6 +67,7 @@ module EDPftvarcon real(r8) :: frootcn(0:mxpft) real(r8) :: smpso(0:mxpft) real(r8) :: smpsc(0:mxpft) + real(r8) :: grperc(0:mxpft) ! NOTE(bja, 2017-01) moved from EDParamsMod, was allocated as (maxPft=79), not (0:mxpft=78)! end type EDPftvarcon_type type(EDPftvarcon_type), public :: EDPftvarcon_inst @@ -260,6 +261,9 @@ subroutine EDpftconrd( ncid ) call ncd_io('smpsc', EDPftvarcon_inst%smpsc, 'read', ncid, readvar=readv, posNOTonfile=.true.) if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + call ncd_io('grperc', EDPftvarcon_inst%grperc, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + ! HOLDING ON SEW ENSITIVITY-ANALYSIS PARAMETERS UNTIL MACHINE CONFIGS SET RGK/CX ! call ncd_io('dbh2h_m',EDPftvarcon_inst%dbh2h_m, 'read', ncid, readvar=readv) ! if ( .not. readv) call endrun(trim(subname)// ' ERROR : error in reading in pft data') From f493ad8bb690bb04c26fcd34ec90fd3ddfc28a6e Mon Sep 17 00:00:00 2001 From: Ben Andre Date: Fri, 20 Jan 2017 12:56:19 -0700 Subject: [PATCH 309/437] Start reading spit fire scalar parameters with new infrastructure. User interface changes?: no Test: ERS_D_Ld5.f10_f10.ICLM45ED.yellowstone_gnu.clm-edFire Test baseline: a651a4f Test namelist changes: fates_paramfile Test answer changes: bit for bit Test summary: pass --- fire/SFParamsMod.F90 | 264 +++++++++++++++++++++++++++++++------------ main/EDParamsMod.F90 | 100 +--------------- 2 files changed, 196 insertions(+), 168 deletions(-) diff --git a/fire/SFParamsMod.F90 b/fire/SFParamsMod.F90 index 3caa526a..38897382 100644 --- a/fire/SFParamsMod.F90 +++ b/fire/SFParamsMod.F90 @@ -4,6 +4,7 @@ module SFParamsMod ! use shr_kind_mod , only: r8 => shr_kind_r8 use EDtypesMod , only: NLSC,NFSC,NCWD + use FatesParametersInterface, only : param_string_length implicit none save @@ -35,31 +36,153 @@ module SFParamsMod 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" + character(len=param_string_length),parameter :: SF_name_fdi_a = "fdi_a" + character(len=param_string_length),parameter :: SF_name_fdi_b = "fdi_b" + character(len=param_string_length),parameter :: SF_name_fdi_alpha = "fdi_alpha" + character(len=param_string_length),parameter :: SF_name_miner_total = "miner_total" + character(len=param_string_length),parameter :: SF_name_fuel_energy = "fuel_energy" + character(len=param_string_length),parameter :: SF_name_part_dens = "part_dens" + character(len=param_string_length),parameter :: SF_name_miner_damp = "miner_damp" + character(len=param_string_length),parameter :: SF_name_max_durat = "max_durat" + character(len=param_string_length),parameter :: SF_name_durat_slope = "durat_slope" + character(len=param_string_length),parameter :: SF_name_alpha_SH = "alpha_SH" + character(len=param_string_length),parameter :: SF_name_alpha_FMC = "alpha_FMC" + character(len=param_string_length),parameter :: SF_name_CWD_frac = "CWD_frac" + character(len=param_string_length),parameter :: SF_name_max_decomp = "max_decomp" + character(len=param_string_length),parameter :: SF_name_SAV = "SAV" + character(len=param_string_length),parameter :: SF_name_FBD = "FBD" + character(len=param_string_length),parameter :: SF_name_min_moisture = "min_moisture" + character(len=param_string_length),parameter :: SF_name_mid_moisture = "mid_moisture" + character(len=param_string_length),parameter :: SF_name_low_moisture_C = "low_moisture_C" + character(len=param_string_length),parameter :: SF_name_low_moisture_S = "low_moisture_S" + character(len=param_string_length),parameter :: SF_name_mid_moisture_C = "mid_moisture_C" + character(len=param_string_length),parameter :: SF_name_mid_moisture_S = "mid_moisture_S" public :: SFParamsRead + public :: SpitFireParamsInit + public :: SpitFireRegisterParams + public :: SpitFireReceiveParams contains + !----------------------------------------------------------------------- + subroutine SpitFireParamsInit() + ! Initialize all parameters to nan to ensure that we get valid + ! values back from the host. + + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + + implicit none + + SF_val_fdi_a = nan + SF_val_fdi_b = nan + SF_val_fdi_alpha = nan + SF_val_miner_total = nan + SF_val_fuel_energy = nan + SF_val_part_dens = nan + SF_val_miner_damp = nan + SF_val_max_durat = nan + SF_val_durat_slope = nan + SF_val_alpha_SH = nan + SF_val_alpha_FMC(:) = nan + SF_val_CWD_frac(:) = nan + SF_val_max_decomp(:) = nan + SF_val_SAV(:) = nan + SF_val_FBD(:) = nan + SF_val_min_moisture(:) = nan + SF_val_mid_moisture(:) = nan + SF_val_low_moisture_C(:) = nan + SF_val_low_moisture_S(:) = nan + SF_val_mid_moisture_C(:) = nan + SF_val_mid_moisture_S(:) = nan + + end subroutine SpitFireParamsInit + !----------------------------------------------------------------------- + subroutine SpitFireRegisterParams(fates_params) + + use FatesParametersInterface, only : fates_parameters_type, dimension_name_scalar, dimension_shape_scalar + + implicit none + + class(fates_parameters_type), intent(inout) :: fates_params + + character(len=param_string_length), parameter :: dim_names_scalar(1) = (/dimension_name_scalar/) + + !call SpitFireParamsInit() + + + call fates_params%RegisterParameter(name=SF_name_fdi_a, dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + + call fates_params%RegisterParameter(name=SF_name_fdi_b, dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + + call fates_params%RegisterParameter(name=SF_name_fdi_alpha, dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + + call fates_params%RegisterParameter(name=SF_name_miner_total, dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + + call fates_params%RegisterParameter(name=SF_name_fuel_energy, dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + + call fates_params%RegisterParameter(name=SF_name_part_dens, dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + + call fates_params%RegisterParameter(name=SF_name_miner_damp, dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + + call fates_params%RegisterParameter(name=SF_name_max_durat, dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + + call fates_params%RegisterParameter(name=SF_name_durat_slope, dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + + call fates_params%RegisterParameter(name=SF_name_alpha_SH, dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + + end subroutine SpitFireRegisterParams + + !----------------------------------------------------------------------- + subroutine SpitFireReceiveParams(fates_params) + + use FatesParametersInterface, only : fates_parameters_type, dimension_name_scalar + + implicit none + + class(fates_parameters_type), intent(inout) :: fates_params + + + call fates_params%RetreiveParameter(name=SF_name_fdi_a, & + data=SF_val_fdi_a) + + call fates_params%RetreiveParameter(name=SF_name_fdi_b, & + data=SF_val_fdi_b) + + call fates_params%RetreiveParameter(name=SF_name_fdi_alpha, & + data=SF_val_fdi_alpha) + + call fates_params%RetreiveParameter(name=SF_name_miner_total, & + data=SF_val_miner_total) + + call fates_params%RetreiveParameter(name=SF_name_fuel_energy, & + data=SF_val_fuel_energy) + + call fates_params%RetreiveParameter(name=SF_name_part_dens, & + data=SF_val_part_dens) + + call fates_params%RetreiveParameter(name=SF_name_miner_damp, & + data=SF_val_miner_damp) + + call fates_params%RetreiveParameter(name=SF_name_max_durat, & + data=SF_val_max_durat) + + call fates_params%RetreiveParameter(name=SF_name_durat_slope, & + data=SF_val_durat_slope) + + call fates_params%RetreiveParameter(name=SF_name_alpha_SH, & + data=SF_val_alpha_SH) + + end subroutine SpitFireReceiveParams !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- @@ -74,6 +197,7 @@ subroutine SFParamsRead(ncid) ! arguments type(file_desc_t),intent(inout) :: ncid ! pio netCDF file id + call SpitFireParamsInit() call SFParamsReadLocal(ncid) end subroutine SFParamsRead @@ -101,55 +225,55 @@ subroutine SFParamsReadLocal(ncid) ! 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) + !X! call readNcdio(ncid = ncid, & + !X! varName=SF_name_fdi_a, & + !X! callingName=subname, & + !X! retVal=SF_val_fdi_a) + !X! + !X! call readNcdio(ncid = ncid, & + !X! varName=SF_name_fdi_b, & + !X! callingName=subname, & + !X! retVal=SF_val_fdi_b) + !X! + !X! call readNcdio(ncid = ncid, & + !X! varName=SF_name_fdi_alpha, & + !X! callingName=subname, & + !X! retVal=SF_val_fdi_alpha) + !X! + !X! call readNcdio(ncid = ncid, & + !X! varName=SF_name_miner_total, & + !X! callingName=subname, & + !X! retVal=SF_val_miner_total) + !X! + !X! call readNcdio(ncid = ncid, & + !X! varName=SF_name_fuel_energy, & + !X! callingName=subname, & + !X! retVal=SF_val_fuel_energy) + !X! + !X! call readNcdio(ncid = ncid, & + !X! varName=SF_name_part_dens, & + !X! callingName=subname, & + !X! retVal=SF_val_part_dens) + !X! + !X! call readNcdio(ncid = ncid, & + !X! varName=SF_name_miner_damp, & + !X! callingName=subname, & + !X! retVal=SF_val_miner_damp) + !X! + !X! call readNcdio(ncid = ncid, & + !X! varName=SF_name_max_durat, & + !X! callingName=subname, & + !X! retVal=SF_val_max_durat) + !X! + !X! call readNcdio(ncid = ncid, & + !X! varName=SF_name_durat_slope, & + !X! callingName=subname, & + !X! retVal=SF_val_durat_slope) + !X! + !X! call readNcdio(ncid = ncid, & + !X! varName=SF_name_alpha_SH, & + !X! callingName=subname, & + !X! retVal=SF_val_alpha_SH) call readNcdio(ncid = ncid, & varName=SF_name_alpha_FMC, & diff --git a/main/EDParamsMod.F90 b/main/EDParamsMod.F90 index a7f132be..344cf916 100644 --- a/main/EDParamsMod.F90 +++ b/main/EDParamsMod.F90 @@ -39,32 +39,12 @@ module EDParamsMod character(len=param_string_length),parameter :: ED_name_profile_tol = "profile_tol" character(len=param_string_length),parameter :: ED_name_ag_biomass= "ag_biomass" - public :: EDParamsRead public :: FatesParamsInit public :: FatesRegisterParams public :: FatesReceiveParams 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 FatesParamsInit() - call EDParamsReadLocal(ncid) - - end subroutine EDParamsRead - !----------------------------------------------------------------------- subroutine FatesParamsInit() ! Initialize all parameters to nan to ensure that we get valid @@ -87,84 +67,6 @@ subroutine FatesParamsInit() ED_val_ag_biomass = nan end subroutine FatesParamsInit - !----------------------------------------------------------------------- - ! - !----------------------------------------------------------------------- - 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 - ! - - !X! call readNcdio(ncid = ncid, & - !X! varName=ED_name_grass_spread, & - !X! callingName=subname, & - !X! retVal=ED_val_grass_spread) - - !X! call readNcdio(ncid = ncid, & - !X! varName=ED_name_comp_excln, & - !X! callingName=subname, & - !X! retVal=ED_val_comp_excln) - - !X! call readNcdio(ncid = ncid, & - !X! varName=ED_name_stress_mort, & - !X! callingName=subname, & - !X! retVal=ED_val_stress_mort) - !X! - !X! call readNcdio(ncid = ncid, & - !X! varName=ED_name_dispersal, & - !X! callingName=subname, & - !X! retVal=ED_val_dispersal) - - !X! call readNcdio(ncid = ncid, & - !X! varName=ED_name_maxspread, & - !X! callingName=subname, & - !X! retVal=ED_val_maxspread) - !X! - !X! call readNcdio(ncid = ncid, & - !X! varName=ED_name_minspread, & - !X! callingName=subname, & - !X! retVal=ED_val_minspread) - !X! - !X! call readNcdio(ncid = ncid, & - !X! varName=ED_name_init_litter, & - !X! callingName=subname, & - !X! retVal=ED_val_init_litter) - !X! - !X! call readNcdio(ncid = ncid, & - !X! varName=ED_name_nfires, & - !X! callingName=subname, & - !X! retVal=ED_val_nfires) - !X! - !X! call readNcdio(ncid = ncid, & - !X! varName=ED_name_understorey_death, & - !X! callingName=subname, & - !X! retVal=ED_val_understorey_death) - !X! - !X! call readNcdio(ncid = ncid, & - !X! varName=ED_name_profile_tol, & - !X! callingName=subname, & - !X! retVal=ED_val_profile_tol) - !X! - !X! call readNcdio(ncid = ncid, & - !X! varName=ED_name_ag_biomass, & - !X! callingName=subname, & - !X! retVal=ED_val_ag_biomass) - - end subroutine EDParamsReadLocal !----------------------------------------------------------------------- subroutine FatesRegisterParams(fates_params) @@ -180,6 +82,8 @@ subroutine FatesRegisterParams(fates_params) character(len=param_string_length), parameter :: dim_names_scalar(1) = (/dimension_name_scalar/) + call FatesParamsInit() + call fates_params%RegisterParameter(name=ED_name_grass_spread, dimension_shape=dimension_shape_scalar, & dimension_names=dim_names_scalar) From 79ffbdaea758a5cc0a5d0905aac8f1e56d2583eb Mon Sep 17 00:00:00 2001 From: Ben Andre Date: Thu, 26 Jan 2017 10:00:25 -0700 Subject: [PATCH 310/437] New infrastructure to read fates array parameters. Register and receive array parameters in fates with the host reading. Host allocates the data buffer based on the size of the largest used parameter dimension. Tested with spitfire array parameters. Some error checking of dimension sizes read from file vs memory size that fates is expecting. User interface changes?: no Test suite: ed - yellowstone gnu, intel, pgi Test baseline: a651a4f Test namelist changes: fates_paramfile Test answer changes: bit for bit Test summary: all tests pass Test suite: clm_short - yellowstone gnu, intel, pgi Test baseline: clm4_5_12_r195 Test namelist changes: none Test answer changes: bit for bit Test summary: all tests pass --- fire/SFParamsMod.F90 | 341 +++++++++++++++++------------- main/FatesParametersInterface.F90 | 162 +++++++++++++- 2 files changed, 345 insertions(+), 158 deletions(-) diff --git a/fire/SFParamsMod.F90 b/fire/SFParamsMod.F90 index 38897382..2f2de2eb 100644 --- a/fire/SFParamsMod.F90 +++ b/fire/SFParamsMod.F90 @@ -24,9 +24,12 @@ module SFParamsMod 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_alpha_FMC(NLSC) 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) @@ -58,10 +61,21 @@ module SFParamsMod character(len=param_string_length),parameter :: SF_name_mid_moisture_C = "mid_moisture_C" character(len=param_string_length),parameter :: SF_name_mid_moisture_S = "mid_moisture_S" - public :: SFParamsRead - public :: SpitFireParamsInit public :: SpitFireRegisterParams public :: SpitFireReceiveParams + + private :: SpitFireParamsInit + private :: SpitFireRegisterScalars + private :: SpitFireReceiveScalars + + private :: SpitFireRegisterNCWD + private :: SpitFireReceiveNCWD + + private :: SpitFireRegisterNLSC + private :: SpitFireReceiveNLSC + + private :: SpitFireRegisterNFSC + private :: SpitFireReceiveNFSC contains !----------------------------------------------------------------------- @@ -83,9 +97,12 @@ subroutine SpitFireParamsInit() SF_val_max_durat = nan SF_val_durat_slope = nan SF_val_alpha_SH = nan - SF_val_alpha_FMC(:) = nan + SF_val_CWD_frac(:) = nan + + SF_val_alpha_FMC(:) = nan SF_val_max_decomp(:) = nan + SF_val_SAV(:) = nan SF_val_FBD(:) = nan SF_val_min_moisture(:) = nan @@ -96,6 +113,7 @@ subroutine SpitFireParamsInit() SF_val_mid_moisture_S(:) = nan end subroutine SpitFireParamsInit + !----------------------------------------------------------------------- subroutine SpitFireRegisterParams(fates_params) @@ -105,10 +123,40 @@ subroutine SpitFireRegisterParams(fates_params) class(fates_parameters_type), intent(inout) :: fates_params - character(len=param_string_length), parameter :: dim_names_scalar(1) = (/dimension_name_scalar/) + call SpitFireParamsInit() + call SpitFireRegisterScalars(fates_params) + call SpitFireRegisterNCWD(fates_params) + call SpitFireRegisterNLSC(fates_params) + call SpitFireRegisterNFSC(fates_params) - !call SpitFireParamsInit() + end subroutine SpitFireRegisterParams + + !----------------------------------------------------------------------- + subroutine SpitFireReceiveParams(fates_params) + + use FatesParametersInterface, only : fates_parameters_type, dimension_name_scalar + + implicit none + + class(fates_parameters_type), intent(inout) :: fates_params + + call SpitFireReceiveScalars(fates_params) + call SpitFireReceiveNCWD(fates_params) + call SpitFireReceiveNLSC(fates_params) + call SpitFireReceiveNFSC(fates_params) + end subroutine SpitFireReceiveParams + + !----------------------------------------------------------------------- + subroutine SpitFireRegisterScalars(fates_params) + + use FatesParametersInterface, only : fates_parameters_type, dimension_name_scalar, dimension_shape_scalar + + implicit none + + class(fates_parameters_type), intent(inout) :: fates_params + + character(len=param_string_length), parameter :: dim_names_scalar(1) = (/dimension_name_scalar/) call fates_params%RegisterParameter(name=SF_name_fdi_a, dimension_shape=dimension_shape_scalar, & dimension_names=dim_names_scalar) @@ -140,17 +188,16 @@ subroutine SpitFireRegisterParams(fates_params) call fates_params%RegisterParameter(name=SF_name_alpha_SH, dimension_shape=dimension_shape_scalar, & dimension_names=dim_names_scalar) - end subroutine SpitFireRegisterParams + end subroutine SpitFireRegisterScalars !----------------------------------------------------------------------- - subroutine SpitFireReceiveParams(fates_params) + subroutine SpitFireReceiveScalars(fates_params) use FatesParametersInterface, only : fates_parameters_type, dimension_name_scalar implicit none class(fates_parameters_type), intent(inout) :: fates_params - call fates_params%RetreiveParameter(name=SF_name_fdi_a, & data=SF_val_fdi_a) @@ -182,155 +229,147 @@ subroutine SpitFireReceiveParams(fates_params) call fates_params%RetreiveParameter(name=SF_name_alpha_SH, & data=SF_val_alpha_SH) - end subroutine SpitFireReceiveParams - !----------------------------------------------------------------------- - ! + end subroutine SpitFireReceiveScalars + !----------------------------------------------------------------------- - subroutine SFParamsRead(ncid) - ! - ! calls to initialize parameter instance and do ncdio read - ! - use ncdio_pio , only : file_desc_t - - implicit none + subroutine SpitFireRegisterNCWD(fates_params) - ! arguments - type(file_desc_t),intent(inout) :: ncid ! pio netCDF file id + use FatesParametersInterface, only : fates_parameters_type, dimension_name_cwd, dimension_shape_1d - call SpitFireParamsInit() - call SFParamsReadLocal(ncid) + implicit none - end subroutine SFParamsRead - !----------------------------------------------------------------------- + class(fates_parameters_type), intent(inout) :: fates_params + + character(len=param_string_length), parameter :: dim_names_cwd(1) = (/dimension_name_cwd/) + + call fates_params%RegisterParameter(name=SF_name_CWD_frac, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names_cwd) + + end subroutine SpitFireRegisterNCWD + + !----------------------------------------------------------------------- + subroutine SpitFireReceiveNCWD(fates_params) + + use FatesParametersInterface, only : fates_parameters_type, dimension_name_scalar + + implicit none + + class(fates_parameters_type), intent(inout) :: fates_params + + call fates_params%RetreiveParameter(name=SF_name_CWD_frac, & + data=SF_val_CWD_frac) + + end subroutine SpitFireReceiveNCWD !----------------------------------------------------------------------- - ! + subroutine SpitFireRegisterNLSC(fates_params) + + use FatesParametersInterface, only : fates_parameters_type, dimension_name_lsc, dimension_shape_1d + + implicit none + + class(fates_parameters_type), intent(inout) :: fates_params + + character(len=param_string_length), parameter :: dim_names(1) = (/dimension_name_lsc/) + + call fates_params%RegisterParameter(name=SF_name_alpha_FMC, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=SF_name_max_decomp, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + end subroutine SpitFireRegisterNLSC + + !----------------------------------------------------------------------- + subroutine SpitFireReceiveNLSC(fates_params) + + use FatesParametersInterface, only : fates_parameters_type, dimension_name_scalar + + implicit none + + class(fates_parameters_type), intent(inout) :: fates_params + + call fates_params%RetreiveParameter(name=SF_name_alpha_FMC, & + data=SF_val_alpha_FMC) + + call fates_params%RetreiveParameter(name=SF_name_max_decomp, & + data=SF_val_max_decomp) + + end subroutine SpitFireReceiveNLSC + !----------------------------------------------------------------------- - 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 - ! - - !X! call readNcdio(ncid = ncid, & - !X! varName=SF_name_fdi_a, & - !X! callingName=subname, & - !X! retVal=SF_val_fdi_a) - !X! - !X! call readNcdio(ncid = ncid, & - !X! varName=SF_name_fdi_b, & - !X! callingName=subname, & - !X! retVal=SF_val_fdi_b) - !X! - !X! call readNcdio(ncid = ncid, & - !X! varName=SF_name_fdi_alpha, & - !X! callingName=subname, & - !X! retVal=SF_val_fdi_alpha) - !X! - !X! call readNcdio(ncid = ncid, & - !X! varName=SF_name_miner_total, & - !X! callingName=subname, & - !X! retVal=SF_val_miner_total) - !X! - !X! call readNcdio(ncid = ncid, & - !X! varName=SF_name_fuel_energy, & - !X! callingName=subname, & - !X! retVal=SF_val_fuel_energy) - !X! - !X! call readNcdio(ncid = ncid, & - !X! varName=SF_name_part_dens, & - !X! callingName=subname, & - !X! retVal=SF_val_part_dens) - !X! - !X! call readNcdio(ncid = ncid, & - !X! varName=SF_name_miner_damp, & - !X! callingName=subname, & - !X! retVal=SF_val_miner_damp) - !X! - !X! call readNcdio(ncid = ncid, & - !X! varName=SF_name_max_durat, & - !X! callingName=subname, & - !X! retVal=SF_val_max_durat) - !X! - !X! call readNcdio(ncid = ncid, & - !X! varName=SF_name_durat_slope, & - !X! callingName=subname, & - !X! retVal=SF_val_durat_slope) - !X! - !X! call readNcdio(ncid = ncid, & - !X! varName=SF_name_alpha_SH, & - !X! callingName=subname, & - !X! 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 + subroutine SpitFireRegisterNFSC(fates_params) + + use FatesParametersInterface, only : fates_parameters_type, dimension_name_fsc, dimension_shape_1d + + implicit none + + class(fates_parameters_type), intent(inout) :: fates_params + + character(len=param_string_length), parameter :: dim_names(1) = (/dimension_name_fsc/) + + call fates_params%RegisterParameter(name=SF_name_SAV, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=SF_name_FBD, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=SF_name_min_moisture, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=SF_name_mid_moisture, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=SF_name_low_moisture_C, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=SF_name_low_moisture_S, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=SF_name_mid_moisture_C, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=SF_name_mid_moisture_S, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + end subroutine SpitFireRegisterNFSC + + !----------------------------------------------------------------------- + subroutine SpitFireReceiveNFSC(fates_params) + + use FatesParametersInterface, only : fates_parameters_type + + implicit none + + class(fates_parameters_type), intent(inout) :: fates_params + + + call fates_params%RetreiveParameter(name=SF_name_SAV, & + data=SF_val_SAV) + + call fates_params%RetreiveParameter(name=SF_name_FBD, & + data=SF_val_FBD) + + call fates_params%RetreiveParameter(name=SF_name_min_moisture, & + data=SF_val_min_moisture) + + call fates_params%RetreiveParameter(name=SF_name_mid_moisture, & + data=SF_val_mid_moisture) + + call fates_params%RetreiveParameter(name=SF_name_low_moisture_C, & + data=SF_val_low_moisture_C) + + call fates_params%RetreiveParameter(name=SF_name_low_moisture_S, & + data=SF_val_low_moisture_S) + + call fates_params%RetreiveParameter(name=SF_name_mid_moisture_C, & + data=SF_val_mid_moisture_C) + + call fates_params%RetreiveParameter(name=SF_name_mid_moisture_S, & + data=SF_val_mid_moisture_S) + + end subroutine SpitFireReceiveNFSC !----------------------------------------------------------------------- + end module SFParamsMod diff --git a/main/FatesParametersInterface.F90 b/main/FatesParametersInterface.F90 index 1e21e64b..cb034cdf 100644 --- a/main/FatesParametersInterface.F90 +++ b/main/FatesParametersInterface.F90 @@ -4,11 +4,13 @@ module FatesParametersInterface ! depend on any host modules. use FatesConstantsMod, only : r8 => fates_r8 + use FatesGlobals, only : fates_log implicit none integer, parameter, public :: max_params = 250 integer, parameter, public :: max_dimensions = 2 + integer, parameter, public :: max_used_dimensions = 25 integer, parameter, public :: param_string_length = 40 integer, parameter, public :: dimension_shape_scalar = 0 integer, parameter, public :: dimension_shape_1d = 1 @@ -19,14 +21,19 @@ module FatesParametersInterface ! wants to write a single netcdf file containing host and fates ! parameters. Can't be done easily until this framework is being ! used to read variables. - character(len=*), parameter, public :: dimension_name_scalar = 'scalar' + ! FIXME(bja, 2017-01) change 'param' to 'scalar'! + character(len=*), parameter, public :: dimension_name_scalar = 'param' character(len=*), parameter, public :: dimension_name_pft = 'pft' character(len=*), parameter, public :: dimension_name_segment = 'segment' + character(len=*), parameter, public :: dimension_name_cwd = 'NCWD' + character(len=*), parameter, public :: dimension_name_lsc = 'litterclass' + character(len=*), parameter, public :: dimension_name_fsc = 'litterclass' type, private :: parameter_type character(len=param_string_length) :: name logical :: host_parameter integer :: dimension_shape + integer :: dimension_sizes(max_dimensions) character(len=param_string_length) :: dimension_names(max_dimensions) real(r8), allocatable :: data(:, :) end type parameter_type @@ -37,11 +44,16 @@ module FatesParametersInterface contains procedure, public :: Init + procedure, public :: Destroy procedure, public :: RegisterParameter generic, public :: RetreiveParameter => RetreiveParameterScalar, RetreiveParameter1D, RetreiveParameter2D generic, public :: SetData => SetDataScalar, SetData1D, SetData2D + procedure, public :: GetUsedDimensions + procedure, public :: SetDimensionSizes + procedure, public :: GetMaxDimensionSize procedure, public :: GetMetaData procedure, public :: num_params + procedure, private :: RetreiveParameterScalar procedure, private :: RetreiveParameter1D procedure, private :: RetreiveParameter2D @@ -65,6 +77,20 @@ subroutine Init(this) end subroutine Init + !----------------------------------------------------------------------- + subroutine Destroy(this) + + implicit none + + class(fates_parameters_type), intent(inout) :: this + + integer :: n + do n = 1, this%num_parameters + deallocate(this%parameters(n)%data) + end do + + end subroutine Destroy + !----------------------------------------------------------------------- subroutine RegisterParameter(this, name, dimension_shape, dimension_names, host_parameter) @@ -83,8 +109,10 @@ subroutine RegisterParameter(this, name, dimension_shape, dimension_names, host_ ! FIXME(bja, 2017-01) assert(i <= max_params) this%parameters(i)%name = name this%parameters(i)%dimension_shape = dimension_shape + this%parameters(i)%dimension_sizes(:) = 0 ! FIXME(bja, 2017-01) assert(size(dimension_names, 1) <= max_dimensions) num_names = min(max_dimensions, size(dimension_names, 1)) + this%parameters(i)%dimension_names(:) = '' do n = 1, num_names this%parameters(i)%dimension_names(n) = dimension_names(n) end do @@ -115,16 +143,28 @@ end subroutine RetreiveParameterScalar !----------------------------------------------------------------------- subroutine RetreiveParameter1D(this, name, data) + use abortutils, only : endrun + implicit none class(fates_parameters_type), intent(inout) :: this character(len=param_string_length), intent(in) :: name real(r8), intent(out) :: data(:) - integer :: i + integer :: i, d, size_dim_1 i = this%FindIndex(name) - ! assert(size(data) == size(this%parameters(i)%data)) + if (size(data) /= size(this%parameters(i)%data(:, 1))) then + write(fates_log(), *) 'ERROR : retreiveparameter1d : ', name, ' size inconsistent.' + write(fates_log(), *) 'ERROR : size expected size = ', size(data) + write(fates_log(), *) 'ERROR : data size received from file = ', size(this%parameters(i)%data(:, 1)) + write(fates_log(), *) 'ERROR : dimesions received from file' + write(fates_log(), *) 'ERROR : names size' + do d = 1, max_dimensions + write(fates_log(), *) this%parameters(i)%dimension_names(d), ', ', this%parameters(i)%dimension_sizes(d) + end do + call endrun(msg='size error retreiving 1d parameter.') + end if data = this%parameters(i)%data(:, 1) end subroutine RetreiveParameter1D @@ -179,7 +219,78 @@ integer function num_params(this) end function num_params !----------------------------------------------------------------------- - subroutine GetMetaData(this, index, name, dimension_shape) + subroutine GetUsedDimensions(this, num_used_dimensions, used_dimensions) + ! Construct a list of the unique dimension names used by the + ! parameters. + + implicit none + + class(fates_parameters_type), intent(inout) :: this + integer, intent(out) :: num_used_dimensions + character(len=param_string_length), intent(out) :: used_dimensions(max_used_dimensions) + + integer :: p, d, i + character(len=param_string_length) :: dim_name + + num_used_dimensions = 0 + do p = 1, this%num_parameters + do d = 1, max_dimensions + dim_name = this%parameters(p)%dimension_names(d) + if (len_trim(dim_name) /= 0) then + ! non-empty dimension name, check if it needs to be added to the list. + do i = 1, num_used_dimensions + if (used_dimensions(i) == dim_name) then + ! dimension is already in list. can stop searching + exit + end if + end do + + if (i > num_used_dimensions) then + ! dimension name was not in the list, add it. + num_used_dimensions = num_used_dimensions + 1 + used_dimensions(num_used_dimensions) = dim_name + end if + end if + end do + end do + + end subroutine GetUsedDimensions + + !----------------------------------------------------------------------- + subroutine SetDimensionSizes(this, num_used_dimensions, dimension_names, dimension_sizes) + ! Construct a list of the unique dimension names used by the + ! parameters. + + implicit none + + class(fates_parameters_type), intent(inout) :: this + integer, intent(in) :: num_used_dimensions + character(len=param_string_length), intent(in) :: dimension_names(max_used_dimensions) + integer, intent(in) :: dimension_sizes(max_used_dimensions) + + integer :: p, d, i + character(len=param_string_length) :: dim_name + + do p = 1, this%num_parameters + do d = 1, max_dimensions + dim_name = this%parameters(p)%dimension_names(d) + if (len_trim(dim_name) /= 0) then + ! non-empty dimension name, set the size + do i = 1, num_used_dimensions + if (trim(dimension_names(i)) == trim(dim_name)) then + !write(*, *) '--> ', trim(this%parameters(p)%name), ' setting ', trim(dim_name), ' d = ', d, 'size = ', dimension_sizes(i) + this%parameters(p)%dimension_sizes(d) = dimension_sizes(i) + exit + end if + end do + end if + end do + end do + + end subroutine SetDimensionSizes + + !----------------------------------------------------------------------- + subroutine GetMetaData(this, index, name, dimension_shape, dimension_sizes) implicit none @@ -187,12 +298,33 @@ subroutine GetMetaData(this, index, name, dimension_shape) integer, intent(in) :: index character(len=param_string_length), intent(out) :: name integer, intent(out) :: dimension_shape + integer, intent(out) :: dimension_sizes(max_dimensions) name = this%parameters(index)%name dimension_shape = this%parameters(index)%dimension_shape + dimension_sizes = this%parameters(index)%dimension_sizes end subroutine GetMetaData + !----------------------------------------------------------------------- + function GetMaxDimensionSize(this) result(max_dim_size) + + implicit none + + class(fates_parameters_type), intent(in) :: this + + integer :: p, d, max_dim_size + + max_dim_size = 0 + + do p = 1, this%num_params() + do d = 1, max_dimensions + max_dim_size = max(max_dim_size, this%parameters(p)%dimension_sizes(d)) + end do + end do + + end function GetMaxDimensionSize + !----------------------------------------------------------------------- subroutine SetDataScalar(this, index, data) @@ -209,16 +341,32 @@ end subroutine SetDataScalar !----------------------------------------------------------------------- subroutine SetData1D(this, index, data) - ! FIXME(bja, 2017-01) this is broken, needs data dimensions to work correctly! + use abortutils, only : endrun + implicit none class(fates_parameters_type), intent(inout) :: this integer, intent(in) :: index real(r8), intent(in) :: data(:) - allocate(this%parameters(index)%data(size(data), 1)) - this%parameters(index)%data(:, 1) = data + integer :: size_dim_1, d + + size_dim_1 = this%parameters(index)%dimension_sizes(1) + if (size(data) /= size_dim_1) then + write(fates_log(), *) 'ERROR : setdata1d : ', this%parameters(index)%name, ' size inconsistent.' + write(fates_log(), *) 'ERROR : expected size = ', size(data) + write(fates_log(), *) 'ERROR : data size received from file = ', size_dim_1 + write(fates_log(), *) 'ERROR : dimesions received from file' + write(fates_log(), *) 'ERROR : names size' + do d = 1, max_dimensions + write(fates_log(), *) this%parameters(index)%dimension_names(d), ', ', this%parameters(index)%dimension_sizes(d) + end do + call endrun(msg='size error setting 1d parameter.') + end if + + allocate(this%parameters(index)%data(size_dim_1, 1)) + this%parameters(index)%data(:, 1) = data(:) end subroutine SetData1D From 3f4249df1f251618ffb40497c25de5dec11c4b31 Mon Sep 17 00:00:00 2001 From: Ben Andre Date: Fri, 27 Jan 2017 14:46:22 -0700 Subject: [PATCH 311/437] Add hooks to read host parameters used by fates from the host file. Add logical flags to read infrastructure to distinguish between host files and fates files. Host and fates parameters are read from the correct file to avoid read errors with invalid dimension ids. Read EDSharedParams with new infrastructure. User interface changes?: no Test: SMS_D_Ld5.f10_f10.ICLM45ED.yellowstone_intel.clm-edTest Test baseline: a651a4f Test namelist changes: addition of fates_paramfile Test answer changes: bit for bit Test summary: pass --- biogeochem/EDSharedParamsMod.F90 | 137 +++++++++++++++++++++++------- main/FatesParametersInterface.F90 | 91 +++++++++++--------- 2 files changed, 156 insertions(+), 72 deletions(-) diff --git a/biogeochem/EDSharedParamsMod.F90 b/biogeochem/EDSharedParamsMod.F90 index c4111c12..a6aaa26d 100644 --- a/biogeochem/EDSharedParamsMod.F90 +++ b/biogeochem/EDSharedParamsMod.F90 @@ -13,10 +13,16 @@ module EDSharedParamsMod type, public :: EDParamsShareType real(r8) :: Q10 ! temperature dependence real(r8) :: froz_q10 ! separate q10 for frozen soil respiration rates + contains + procedure, public :: RegisterParams + procedure, public :: ReceiveParams + procedure, private :: Init + procedure, private :: RegisterParamsScalar + procedure, private :: ReceiveParamsScalar end type EDParamsShareType - type(EDParamsShareType), protected :: EDParamsShareInst - + type(EDParamsShareType), public :: EDParamsShareInst + character(len=*), parameter, private :: sourcefile = & __FILE__ @@ -24,34 +30,103 @@ module EDSharedParamsMod contains + subroutine Init(this) + ! Initialize all parameters to nan to ensure that we get valid + ! values back from the host. + + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + + implicit none + + class(EDParamsShareType), intent(inout) :: this + + this%Q10 = nan + this%froz_q10 = nan + + end subroutine Init + !----------------------------------------------------------------------- - 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(sourcefile, __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(sourcefile, __LINE__)) - EDParamsShareInst%froz_q10=tempr - - end subroutine EDParamsReadShared - + subroutine RegisterParams(this, fates_params) + ! Register the parameters we want the host to provide, and + ! indicate whether they are fates parameters or host parameters + ! that need to be synced with host values. + + use FatesParametersInterface, only : fates_parameters_type, param_string_length + use FatesParametersInterface, only : dimension_name_scalar, dimension_shape_scalar + + implicit none + + class(EDParamsShareType), intent(inout) :: this + class(fates_parameters_type), intent(inout) :: fates_params + + call this%Init() + call this%RegisterParamsScalar(fates_params) + + end subroutine RegisterParams + + !----------------------------------------------------------------------- + subroutine ReceiveParams(this, fates_params) + + use FatesParametersInterface, only : fates_parameters_type, param_string_length + + implicit none + + class(EDParamsShareType), intent(inout) :: this + class(fates_parameters_type), intent(inout) :: fates_params + + call this%ReceiveParamsScalar(fates_params) + + end subroutine ReceiveParams + + !----------------------------------------------------------------------- + subroutine RegisterParamsScalar(this, fates_params) + ! Register the parameters we want the host to provide, and + ! indicate whether they are fates parameters or host parameters + ! that need to be synced with host values. + + use FatesParametersInterface, only : fates_parameters_type, param_string_length + use FatesParametersInterface, only : dimension_name_allpfts, dimension_shape_scalar + + implicit none + + class(EDParamsShareType), intent(inout) :: this + class(fates_parameters_type), intent(inout) :: fates_params + + character(len=param_string_length), parameter :: dim_names(1) = (/dimension_name_allpfts/) + character(len=param_string_length) :: name + + call this%Init() + + name = 'q10_mr' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names, sync_with_host=.true.) + + name = 'froz_q10' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names, sync_with_host=.true.) + + end subroutine RegisterParamsScalar + + !----------------------------------------------------------------------- + subroutine ReceiveParamsScalar(this, fates_params) + + use FatesParametersInterface, only : fates_parameters_type, param_string_length + + implicit none + + class(EDParamsShareType), intent(inout) :: this + class(fates_parameters_type), intent(inout) :: fates_params + + character(len=param_string_length) :: name + + name = 'q10_mr' + call fates_params%RetreiveParameter(name=name, & + data=this%Q10) + + name = 'froz_q10' + call fates_params%RetreiveParameter(name=name, & + data=this%froz_q10) + + end subroutine ReceiveParamsScalar + end module EDSharedParamsMod diff --git a/main/FatesParametersInterface.F90 b/main/FatesParametersInterface.F90 index cb034cdf..6ebadce2 100644 --- a/main/FatesParametersInterface.F90 +++ b/main/FatesParametersInterface.F90 @@ -28,10 +28,11 @@ module FatesParametersInterface character(len=*), parameter, public :: dimension_name_cwd = 'NCWD' character(len=*), parameter, public :: dimension_name_lsc = 'litterclass' character(len=*), parameter, public :: dimension_name_fsc = 'litterclass' + character(len=*), parameter, public :: dimension_name_allpfts = 'allpfts' type, private :: parameter_type character(len=param_string_length) :: name - logical :: host_parameter + logical :: sync_with_host integer :: dimension_shape integer :: dimension_sizes(max_dimensions) character(len=param_string_length) :: dimension_names(max_dimensions) @@ -92,7 +93,7 @@ subroutine Destroy(this) end subroutine Destroy !----------------------------------------------------------------------- - subroutine RegisterParameter(this, name, dimension_shape, dimension_names, host_parameter) + subroutine RegisterParameter(this, name, dimension_shape, dimension_names, sync_with_host) implicit none @@ -100,7 +101,7 @@ subroutine RegisterParameter(this, name, dimension_shape, dimension_names, host_ character(len=param_string_length), intent(in) :: name integer, intent(in) :: dimension_shape character(len=param_string_length) :: dimension_names(1:) - logical, intent(in), optional :: host_parameter + logical, intent(in), optional :: sync_with_host integer :: i, n, num_names @@ -116,9 +117,9 @@ subroutine RegisterParameter(this, name, dimension_shape, dimension_names, host_ do n = 1, num_names this%parameters(i)%dimension_names(n) = dimension_names(n) end do - this%parameters(i)%host_parameter = .false. - if (present(host_parameter)) then - this%parameters(i)%host_parameter = .true. + this%parameters(i)%sync_with_host = .false. + if (present(sync_with_host)) then + this%parameters(i)%sync_with_host = sync_with_host end if end subroutine RegisterParameter @@ -219,13 +220,14 @@ integer function num_params(this) end function num_params !----------------------------------------------------------------------- - subroutine GetUsedDimensions(this, num_used_dimensions, used_dimensions) + subroutine GetUsedDimensions(this, is_host_file, num_used_dimensions, used_dimensions) ! Construct a list of the unique dimension names used by the ! parameters. implicit none class(fates_parameters_type), intent(inout) :: this + logical, intent(in) :: is_host_file integer, intent(out) :: num_used_dimensions character(len=param_string_length), intent(out) :: used_dimensions(max_used_dimensions) @@ -234,36 +236,39 @@ subroutine GetUsedDimensions(this, num_used_dimensions, used_dimensions) num_used_dimensions = 0 do p = 1, this%num_parameters - do d = 1, max_dimensions - dim_name = this%parameters(p)%dimension_names(d) - if (len_trim(dim_name) /= 0) then - ! non-empty dimension name, check if it needs to be added to the list. - do i = 1, num_used_dimensions - if (used_dimensions(i) == dim_name) then - ! dimension is already in list. can stop searching - exit + if (is_host_file .eqv. this%parameters(p)%sync_with_host) then + do d = 1, max_dimensions + dim_name = this%parameters(p)%dimension_names(d) + if (len_trim(dim_name) /= 0) then + ! non-empty dimension name, check if it needs to be added to the list. + do i = 1, num_used_dimensions + if (used_dimensions(i) == dim_name) then + ! dimension is already in list. can stop searching + exit + end if + end do + + if (i > num_used_dimensions) then + ! dimension name was not in the list, add it. + num_used_dimensions = num_used_dimensions + 1 + used_dimensions(num_used_dimensions) = dim_name end if - end do - - if (i > num_used_dimensions) then - ! dimension name was not in the list, add it. - num_used_dimensions = num_used_dimensions + 1 - used_dimensions(num_used_dimensions) = dim_name - end if - end if - end do - end do + end if ! if dim_name + end do ! do d + end if ! if host_param + end do ! do p end subroutine GetUsedDimensions !----------------------------------------------------------------------- - subroutine SetDimensionSizes(this, num_used_dimensions, dimension_names, dimension_sizes) + subroutine SetDimensionSizes(this, is_host_file, num_used_dimensions, dimension_names, dimension_sizes) ! Construct a list of the unique dimension names used by the ! parameters. implicit none class(fates_parameters_type), intent(inout) :: this + logical, intent(in) :: is_host_file integer, intent(in) :: num_used_dimensions character(len=param_string_length), intent(in) :: dimension_names(max_used_dimensions) integer, intent(in) :: dimension_sizes(max_used_dimensions) @@ -272,25 +277,27 @@ subroutine SetDimensionSizes(this, num_used_dimensions, dimension_names, dimensi character(len=param_string_length) :: dim_name do p = 1, this%num_parameters - do d = 1, max_dimensions - dim_name = this%parameters(p)%dimension_names(d) - if (len_trim(dim_name) /= 0) then - ! non-empty dimension name, set the size - do i = 1, num_used_dimensions - if (trim(dimension_names(i)) == trim(dim_name)) then - !write(*, *) '--> ', trim(this%parameters(p)%name), ' setting ', trim(dim_name), ' d = ', d, 'size = ', dimension_sizes(i) - this%parameters(p)%dimension_sizes(d) = dimension_sizes(i) - exit - end if - end do - end if - end do - end do + if (is_host_file .eqv. this%parameters(p)%sync_with_host) then + do d = 1, max_dimensions + dim_name = this%parameters(p)%dimension_names(d) + if (len_trim(dim_name) /= 0) then + ! non-empty dimension name, set the size + do i = 1, num_used_dimensions + if (trim(dimension_names(i)) == trim(dim_name)) then + !write(*, *) '--> ', trim(this%parameters(p)%name), ' setting ', trim(dim_name), ' d = ', d, 'size = ', dimension_sizes(i) + this%parameters(p)%dimension_sizes(d) = dimension_sizes(i) + exit + end if + end do + end if ! if dim_name + end do ! do dim + end if ! if host_param + end do ! do param end subroutine SetDimensionSizes !----------------------------------------------------------------------- - subroutine GetMetaData(this, index, name, dimension_shape, dimension_sizes) + subroutine GetMetaData(this, index, name, dimension_shape, dimension_sizes, is_host_param) implicit none @@ -299,10 +306,12 @@ subroutine GetMetaData(this, index, name, dimension_shape, dimension_sizes) character(len=param_string_length), intent(out) :: name integer, intent(out) :: dimension_shape integer, intent(out) :: dimension_sizes(max_dimensions) + logical, intent(out) :: is_host_param name = this%parameters(index)%name dimension_shape = this%parameters(index)%dimension_shape dimension_sizes = this%parameters(index)%dimension_sizes + is_host_param = this%parameters(index)%sync_with_host end subroutine GetMetaData From 256550a500e282d1790426377b55c3156fda3370 Mon Sep 17 00:00:00 2001 From: Ben Andre Date: Sat, 28 Jan 2017 14:58:20 -0700 Subject: [PATCH 312/437] Convert ed pftvarcon to use new parameter interface. Test suite: ed - yellowstone gnu, intel, pgi Test baseline: a651a4f Test namelist changes: fates_paramfile Test answer changes: bit for bit Test summary: all tests pass Test suite: clm_short - yellowstone gnu, intel, pgi Test baseline: clm4_5_12_r195 Test namelist changes: none Test answer changes: bit for bit Test summary: all tests pass --- main/EDPftvarcon.F90 | 921 +++++++++++++++++++++++++----- main/FatesParametersInterface.F90 | 23 +- 2 files changed, 813 insertions(+), 131 deletions(-) diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index 7a8a032e..c9f42e7b 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -9,6 +9,7 @@ module EDPftvarcon use clm_varpar , only : mxpft, numrad, ivis, inir, nvariants use shr_kind_mod, only : r8 => shr_kind_r8 + use FatesGlobals, only : fates_log ! ! !PUBLIC TYPES: implicit none @@ -68,6 +69,16 @@ module EDPftvarcon real(r8) :: smpso(0:mxpft) real(r8) :: smpsc(0:mxpft) real(r8) :: grperc(0:mxpft) ! NOTE(bja, 2017-01) moved from EDParamsMod, was allocated as (maxPft=79), not (0:mxpft=78)! + contains + procedure, public :: Init => EDpftconInit + procedure, public :: Register + procedure, public :: Receive + procedure, private :: Register_PFT + procedure, private :: Receive_PFT + procedure, private :: Register_PFT_nvariants + procedure, private :: Receive_PFT_nvariants + procedure, private :: Register_PFT_numrad + procedure, private :: Receive_PFT_numrad end type EDPftvarcon_type type(EDPftvarcon_type), public :: EDPftvarcon_inst @@ -77,196 +88,850 @@ module EDPftvarcon ! ! !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 - use shr_log_mod , only : errMsg => shr_log_errMsg - ! - ! !ARGUMENTS: + subroutine EDpftconInit(this) + + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + implicit none - ! - type(file_desc_t), intent(inout) :: ncid ! pio netCDF file id - ! !LOCAL VARIABLES: + class(EDPftvarcon_type), intent(inout) :: this + + this%max_dbh(:) = nan + this%freezetol(:) = nan + this%wood_density(:) = nan + this%alpha_stem(:) = nan + this%hgt_min(:) = nan + this%cushion(:) = nan + this%leaf_stor_priority(:) = nan + this%leafwatermax(:) = nan + this%rootresist(:) = nan + this%soilbeta(:) = nan + this%crown(:) = nan + this%bark_scaler(:) = nan + this%crown_kill(:) = nan + this%initd(:) = nan + this%sd_mort(:) = nan + this%seed_rain(:) = nan + this%BB_slope(:) = nan + this%root_long(:) = nan + this%clone_alloc(:) = nan + this%seed_alloc(:) = nan + this%sapwood_ratio(:) = nan + this%dbh2h_m(:) = nan + this%woody(:) = nan + this%stress_decid(:) = nan + this%season_decid(:) = nan + this%evergreen(:) = nan + this%froot_leaf(:) = nan + this%slatop(:) = nan + this%leaf_long(:) = nan + this%roota_par(:) = nan + this%rootb_par(:) = nan + this%lf_flab(:) = nan + this%lf_fcel(:) = nan + this%lf_flig(:) = nan + this%fr_flab(:) = nan + this%fr_fcel(:) = nan + this%fr_flig(:) = nan + this%xl(:) = nan + this%c3psn(:) = nan + this%flnr(:) = nan + this%fnitr(:) = nan + this%leafcn(:) = nan + this%frootcn(:) = nan + this%smpso(:) = nan + this%smpsc(:) = nan + this%grperc(:) = nan + + this%rootprof_beta(:, :) = nan + this%rhol(:, :) = nan + this%rhos(:, :) = nan + this%taul(:, :) = nan + this%taus(:, :) = nan + + end subroutine EDpftconInit - logical :: readv ! read variable in or not - character(len=32) :: subname = 'EDpftconrd' ! subroutine name + !----------------------------------------------------------------------- + subroutine Register(this, fates_params) + + use FatesParametersInterface, only : fates_parameters_type + + implicit none + + class(EDPftvarcon_type), intent(inout) :: this + class(fates_parameters_type), intent(inout) :: fates_params + + call this%Register_PFT(fates_params) + call this%Register_PFT_numrad(fates_params) + call this%Register_PFT_nvariants(fates_params) + + end subroutine Register + + !----------------------------------------------------------------------- + subroutine Receive(this, fates_params) + + use FatesParametersInterface, only : fates_parameters_type + + implicit none + + class(EDPftvarcon_type), intent(inout) :: this + class(fates_parameters_type), intent(inout) :: fates_params + + call this%Receive_PFT(fates_params) + call this%Receive_PFT_numrad(fates_params) + call this%Receive_PFT_nvariants(fates_params) + + end subroutine Receive + + !----------------------------------------------------------------------- + subroutine Register_PFT(this, fates_params) + + use FatesParametersInterface, only : fates_parameters_type, param_string_length + use FatesParametersInterface, only : dimension_name_pft, dimension_shape_1d + + implicit none + + class(EDPftvarcon_type), intent(inout) :: this + class(fates_parameters_type), intent(inout) :: fates_params + + character(len=param_string_length), parameter :: dim_names(1) = (/dimension_name_pft/) + + character(len=param_string_length) :: name + + !X! name = '' + !X! call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + !X! dimension_names=dim_names) - 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' ) + name = 'max_dbh' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) - 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' ) + name = 'freezetol' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) - 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' ) + name = 'wood_density' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) - 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' ) + name = 'alpha_stem' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) - 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' ) + name = 'hgt_min' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) - 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' ) + name = 'cushion' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) - 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' ) + name = 'leaf_stor_priority' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) - 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' ) + name = 'leafwatermax' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) - 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' ) + name = 'rootresist' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) - 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') + name = 'soilbeta' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + name = 'crown' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + name = 'bark_scaler' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + name = 'crown_kill' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + name = 'initd' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + name = 'sd_mort' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + name = 'seed_rain' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + name = 'BB_slope' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + name = 'root_long' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + name = 'clone_alloc' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + name = 'seed_alloc' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + name = 'sapwood_ratio' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + name = 'woody' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + name = 'stress_decid' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + name = 'season_decid' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + name = 'evergreen' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + name = 'froot_leaf' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + name = 'slatop' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + name = 'leaf_long' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + name = 'roota_par' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + name = 'rootb_par' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + name = 'lf_flab' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + name = 'lf_fcel' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + name = 'lf_flig' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + name = 'fr_flab' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + name = 'fr_fcel' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + name = 'fr_flig' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + name = 'xl' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + name = 'c3psn' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + name = 'flnr' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + name = 'fnitr' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + name = 'leafcn' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + name = 'frootcn' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + name = 'smpso' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + name = 'smpsc' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + name = 'grperc' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + + end subroutine Register_PFT + + !----------------------------------------------------------------------- + subroutine Receive_PFT(this, fates_params) + + use FatesParametersInterface, only : fates_parameters_type, param_string_length + + implicit none - 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') + class(EDPftvarcon_type), intent(inout) :: this + class(fates_parameters_type), intent(inout) :: fates_params - 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') + character(len=param_string_length) :: name - 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') + !X! name = '' + !X! call fates_params%RetreiveParameter(name=name, & + !X! data=this%) - 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') + name = 'max_dbh' + call fates_params%RetreiveParameter(name=name, & + data=this%max_dbh) - 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') + name = 'freezetol' + call fates_params%RetreiveParameter(name=name, & + data=this%freezetol) - 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') + name = 'wood_density' + call fates_params%RetreiveParameter(name=name, & + data=this%wood_density) - 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') + name = 'alpha_stem' + call fates_params%RetreiveParameter(name=name, & + data=this%alpha_stem) - 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') + name = 'hgt_min' + call fates_params%RetreiveParameter(name=name, & + data=this%hgt_min) - 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') + name = 'cushion' + call fates_params%RetreiveParameter(name=name, & + data=this%cushion) - 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') + name = 'leaf_stor_priority' + call fates_params%RetreiveParameter(name=name, & + data=this%leaf_stor_priority) - 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') - - call ncd_io('woody', EDPftvarcon_inst%woody, 'read', ncid, readvar=readv, posNOTonfile=.true.) - if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + name = 'leafwatermax' + call fates_params%RetreiveParameter(name=name, & + data=this%leafwatermax) - call ncd_io('stress_decid', EDPftvarcon_inst%stress_decid, 'read', ncid, readvar=readv, posNOTonfile=.true.) - if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + name = 'rootresist' + call fates_params%RetreiveParameter(name=name, & + data=this%rootresist) - call ncd_io('season_decid', EDPftvarcon_inst%season_decid, 'read', ncid, readvar=readv, posNOTonfile=.true.) - if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + name = 'soilbeta' + call fates_params%RetreiveParameter(name=name, & + data=this%soilbeta) - call ncd_io('evergreen', EDPftvarcon_inst%evergreen, 'read', ncid, readvar=readv, posNOTonfile=.true.) - if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + name = 'crown' + call fates_params%RetreiveParameter(name=name, & + data=this%crown) - call ncd_io('froot_leaf', EDPftvarcon_inst%froot_leaf, 'read', ncid, readvar=readv, posNOTonfile=.true.) - if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + name = 'bark_scaler' + call fates_params%RetreiveParameter(name=name, & + data=this%bark_scaler) - call ncd_io('slatop', EDPftvarcon_inst%slatop, 'read', ncid, readvar=readv, posNOTonfile=.true.) - if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + name = 'crown_kill' + call fates_params%RetreiveParameter(name=name, & + data=this%crown_kill) - call ncd_io('leaf_long', EDPftvarcon_inst%leaf_long, 'read', ncid, readvar=readv, posNOTonfile=.true.) - if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + name = 'initd' + call fates_params%RetreiveParameter(name=name, & + data=this%initd) - call ncd_io('rootprof_beta', EDPftvarcon_inst%rootprof_beta, 'read', ncid, readvar=readv, posNOTonfile=.true.) - if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + name = 'sd_mort' + call fates_params%RetreiveParameter(name=name, & + data=this%sd_mort) - call ncd_io('roota_par', EDPftvarcon_inst%roota_par, 'read', ncid, readvar=readv, posNOTonfile=.true.) - if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + name = 'seed_rain' + call fates_params%RetreiveParameter(name=name, & + data=this%seed_rain) - call ncd_io('rootb_par', EDPftvarcon_inst%rootb_par, 'read', ncid, readvar=readv, posNOTonfile=.true.) - if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + name = 'BB_slope' + call fates_params%RetreiveParameter(name=name, & + data=this%BB_slope) - call ncd_io('lf_flab', EDPftvarcon_inst%lf_flab, 'read', ncid, readvar=readv, posNOTonfile=.true.) - if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + name = 'root_long' + call fates_params%RetreiveParameter(name=name, & + data=this%root_long) - call ncd_io('lf_fcel', EDPftvarcon_inst%lf_fcel, 'read', ncid, readvar=readv, posNOTonfile=.true.) - if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + name = 'clone_alloc' + call fates_params%RetreiveParameter(name=name, & + data=this%clone_alloc) - call ncd_io('lf_flig', EDPftvarcon_inst%lf_flig, 'read', ncid, readvar=readv, posNOTonfile=.true.) - if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + name = 'seed_alloc' + call fates_params%RetreiveParameter(name=name, & + data=this%seed_alloc) - call ncd_io('fr_flab', EDPftvarcon_inst%fr_flab, 'read', ncid, readvar=readv, posNOTonfile=.true.) - if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + name = 'sapwood_ratio' + call fates_params%RetreiveParameter(name=name, & + data=this%sapwood_ratio) - call ncd_io('fr_fcel', EDPftvarcon_inst%fr_fcel, 'read', ncid, readvar=readv, posNOTonfile=.true.) - if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + name = 'woody' + call fates_params%RetreiveParameter(name=name, & + data=this%woody) - call ncd_io('fr_flig', EDPftvarcon_inst%fr_flig, 'read', ncid, readvar=readv, posNOTonfile=.true.) - if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + name = 'stress_decid' + call fates_params%RetreiveParameter(name=name, & + data=this%stress_decid) - call ncd_io('rholvis', EDPftvarcon_inst%rhol(:,ivis), 'read', ncid, readvar=readv, posNOTonfile=.true.) - if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + name = 'season_decid' + call fates_params%RetreiveParameter(name=name, & + data=this%season_decid) - call ncd_io('rholnir', EDPftvarcon_inst%rhol(:,inir), 'read', ncid, readvar=readv, posNOTonfile=.true.) - if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + name = 'evergreen' + call fates_params%RetreiveParameter(name=name, & + data=this%evergreen) - call ncd_io('rhosvis', EDPftvarcon_inst%rhos(:,ivis), 'read', ncid, readvar=readv, posNOTonfile=.true.) - if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + name = 'froot_leaf' + call fates_params%RetreiveParameter(name=name, & + data=this%froot_leaf) - call ncd_io('rhosnir', EDPftvarcon_inst% rhos(:,inir), 'read', ncid, readvar=readv, posNOTonfile=.true.) - if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + name = 'slatop' + call fates_params%RetreiveParameter(name=name, & + data=this%slatop) - call ncd_io('taulvis', EDPftvarcon_inst%taul(:,ivis), 'read', ncid, readvar=readv, posNOTonfile=.true.) - if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + name = 'leaf_long' + call fates_params%RetreiveParameter(name=name, & + data=this%leaf_long) - call ncd_io('taulnir', EDPftvarcon_inst%taul(:,inir), 'read', ncid, readvar=readv, posNOTonfile=.true.) - if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + name = 'roota_par' + call fates_params%RetreiveParameter(name=name, & + data=this%roota_par) - call ncd_io('tausvis', EDPftvarcon_inst%taus(:,ivis), 'read', ncid, readvar=readv, posNOTonfile=.true.) - if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + name = 'rootb_par' + call fates_params%RetreiveParameter(name=name, & + data=this%rootb_par) - call ncd_io('tausnir', EDPftvarcon_inst%taus(:,inir), 'read', ncid, readvar=readv, posNOTonfile=.true.) - if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + name = 'lf_flab' + call fates_params%RetreiveParameter(name=name, & + data=this%lf_flab) - call ncd_io('xl', EDPftvarcon_inst%xl, 'read', ncid, readvar=readv, posNOTonfile=.true.) - if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + name = 'lf_fcel' + call fates_params%RetreiveParameter(name=name, & + data=this%lf_fcel) - call ncd_io('c3psn', EDPftvarcon_inst%c3psn, 'read', ncid, readvar=readv, posNOTonfile=.true.) - if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + name = 'lf_flig' + call fates_params%RetreiveParameter(name=name, & + data=this%lf_flig) - call ncd_io('flnr', EDPftvarcon_inst%flnr, 'read', ncid, readvar=readv, posNOTonfile=.true.) - if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + name = 'fr_flab' + call fates_params%RetreiveParameter(name=name, & + data=this%fr_flab) - call ncd_io('fnitr', EDPftvarcon_inst%fnitr, 'read', ncid, readvar=readv, posNOTonfile=.true.) - if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + name = 'fr_fcel' + call fates_params%RetreiveParameter(name=name, & + data=this%fr_fcel) - call ncd_io('leafcn', EDPftvarcon_inst%leafcn, 'read', ncid, readvar=readv, posNOTonfile=.true.) - if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + name = 'fr_flig' + call fates_params%RetreiveParameter(name=name, & + data=this%fr_flig) - call ncd_io('frootcn', EDPftvarcon_inst%frootcn, 'read', ncid, readvar=readv, posNOTonfile=.true.) - if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + name = 'xl' + call fates_params%RetreiveParameter(name=name, & + data=this%xl) - call ncd_io('smpso', EDPftvarcon_inst%smpso, 'read', ncid, readvar=readv, posNOTonfile=.true.) - if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + name = 'c3psn' + call fates_params%RetreiveParameter(name=name, & + data=this%c3psn) - call ncd_io('smpsc', EDPftvarcon_inst%smpsc, 'read', ncid, readvar=readv, posNOTonfile=.true.) - if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + name = 'flnr' + call fates_params%RetreiveParameter(name=name, & + data=this%flnr) - call ncd_io('grperc', EDPftvarcon_inst%grperc, 'read', ncid, readvar=readv, posNOTonfile=.true.) - if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + name = 'fnitr' + call fates_params%RetreiveParameter(name=name, & + data=this%fnitr) + + name = 'leafcn' + call fates_params%RetreiveParameter(name=name, & + data=this%leafcn) + + name = 'frootcn' + call fates_params%RetreiveParameter(name=name, & + data=this%frootcn) + + name = 'smpso' + call fates_params%RetreiveParameter(name=name, & + data=this%smpso) + + name = 'smpsc' + call fates_params%RetreiveParameter(name=name, & + data=this%smpsc) + + name = 'grperc' + call fates_params%RetreiveParameter(name=name, & + data=this%grperc) + + end subroutine Receive_PFT + + !----------------------------------------------------------------------- + subroutine Register_PFT_numrad(this, fates_params) + + use FatesParametersInterface, only : fates_parameters_type, param_string_length + use FatesParametersInterface, only : dimension_name_pft, dimension_shape_1d + + implicit none + + class(EDPftvarcon_type), intent(inout) :: this + class(fates_parameters_type), intent(inout) :: fates_params + + character(len=param_string_length), parameter :: dim_names(1) = (/dimension_name_pft/) + + character(len=param_string_length) :: name + + !X! name = '' + !X! call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + !X! dimension_names=dim_names) + + name = 'rholvis' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + name = 'rholnir' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + name = 'rhosvis' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + name = 'rhosnir' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + name = 'taulvis' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + name = 'taulnir' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + name = 'tausvis' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + name = 'tausnir' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + + end subroutine Register_PFT_numrad + + !----------------------------------------------------------------------- + subroutine Receive_PFT_numrad(this, fates_params) + + use FatesParametersInterface, only : fates_parameters_type + use FatesParametersInterface, only : param_string_length + + implicit none + + class(EDPftvarcon_type), intent(inout) :: this + class(fates_parameters_type), intent(inout) :: fates_params + + character(len=param_string_length) :: name + + !X! name = '' + !X! call fates_params%RetreiveParameter(name=name, & + !X! data=this%) + + name = 'rholvis' + call fates_params%RetreiveParameter(name=name, & + data=this%rhol(:,ivis)) + + name = 'rholnir' + call fates_params%RetreiveParameter(name=name, & + data=this%rhol(:,inir)) + + name = 'rhosvis' + call fates_params%RetreiveParameter(name=name, & + data=this%rhos(:,ivis)) + + name = 'rhosnir' + call fates_params%RetreiveParameter(name=name, & + data=this%rhos(:,inir)) + + name = 'taulvis' + call fates_params%RetreiveParameter(name=name, & + data=this%taul(:,ivis)) + + name = 'taulnir' + call fates_params%RetreiveParameter(name=name, & + data=this%taul(:,inir)) + + name = 'tausvis' + call fates_params%RetreiveParameter(name=name, & + data=this%taus(:,ivis)) + + name = 'tausnir' + call fates_params%RetreiveParameter(name=name, & + data=this%taus(:,inir)) + + end subroutine Receive_PFT_numrad + + !----------------------------------------------------------------------- + subroutine Register_PFT_nvariants(this, fates_params) + + use FatesParametersInterface, only : fates_parameters_type, param_string_length + use FatesParametersInterface, only : max_dimensions, dimension_name_variants, dimension_name_pft, dimension_shape_2d + + implicit none + + class(EDPftvarcon_type), intent(inout) :: this + class(fates_parameters_type), intent(inout) :: fates_params + + character(len=param_string_length) :: dim_names(2) + character(len=param_string_length) :: name + + ! NOTE(bja, 2017-01) initialization doesn't seem to work correctly + ! if dim_names has a paramater qualifier. + dim_names(1) = dimension_name_pft + dim_names(2) = dimension_name_variants + + !X! name = '' + !X! call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & + !X! dimension_names=dim_names) + + name = 'rootprof_beta' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & + dimension_names=dim_names) + + end subroutine Register_PFT_nvariants + + !----------------------------------------------------------------------- + subroutine Receive_PFT_nvariants(this, fates_params) + + use FatesParametersInterface, only : fates_parameters_type + use FatesParametersInterface, only : param_string_length + + implicit none + + class(EDPftvarcon_type), intent(inout) :: this + class(fates_parameters_type), intent(inout) :: fates_params + + character(len=param_string_length) :: name + + !X! name = '' + !X! call fates_params%RetreiveParameter(name=name, & + !X! data=this%) + + name = 'rootprof_beta' + call fates_params%RetreiveParameter(name=name, & + data=this%rootprof_beta) + + end subroutine Receive_PFT_nvariants + + !----------------------------------------------------------------------- + subroutine EDpftconrd( ncid ) + ! + ! !DESCRIPTION: + ! Read and initialize vegetation (PFT) constants + ! + ! !USES: + use ncdio_pio , only : file_desc_t, ncd_io + use abortutils , only : endrun + use shr_log_mod , only : errMsg => shr_log_errMsg + ! + ! !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 -! HOLDING ON SEW ENSITIVITY-ANALYSIS PARAMETERS UNTIL MACHINE CONFIGS SET RGK/CX -! call ncd_io('dbh2h_m',EDPftvarcon_inst%dbh2h_m, 'read', ncid, readvar=readv) -! if ( .not. readv) call endrun(trim(subname)// ' ERROR : error in reading in pft data') + !X! call ncd_io('max_dbh',EDPftvarcon_inst%max_dbh, 'read', ncid, readvar=readv) + !X! if ( .not. readv ) call endrun( trim(subname)//' ERROR: error in reading in pft data' ) + + !X! call ncd_io('freezetol',EDPftvarcon_inst%freezetol, 'read', ncid, readvar=readv) + !X! if ( .not. readv ) call endrun( trim(subname)//' ERROR: error in reading in pft data' ) + !X! + !X! call ncd_io('wood_density',EDPftvarcon_inst%wood_density, 'read', ncid, readvar=readv) + !X! if ( .not. readv ) call endrun( trim(subname)//' ERROR: error in reading in pft data' ) + !X! + !X! call ncd_io('alpha_stem',EDPftvarcon_inst%alpha_stem, 'read', ncid, readvar=readv) + !X! if ( .not. readv ) call endrun( trim(subname)//' ERROR: error in reading in pft data' ) + !X! + !X! call ncd_io('hgt_min',EDPftvarcon_inst%hgt_min, 'read', ncid, readvar=readv) + !X! if ( .not. readv ) call endrun( trim(subname)//' ERROR: error in reading in pft data' ) + !X! + !X! call ncd_io('cushion',EDPftvarcon_inst%cushion, 'read', ncid, readvar=readv) + !X! if ( .not. readv ) call endrun( trim(subname)//' ERROR: error in reading in pft data' ) + !X! + !X! call ncd_io('leaf_stor_priority',EDPftvarcon_inst%leaf_stor_priority, 'read', ncid, readvar=readv) + !X! if ( .not. readv ) call endrun( trim(subname)//' ERROR: error in reading in pft data' ) + !X! + !X! call ncd_io('leafwatermax',EDPftvarcon_inst%leafwatermax, 'read', ncid, readvar=readv) + !X! if ( .not. readv ) call endrun( trim(subname)//' ERROR: error in reading in pft data' ) + !X! + !X! call ncd_io('rootresist',EDPftvarcon_inst%rootresist,'read', ncid, readvar=readv) + !X! if ( .not. readv ) call endrun( trim(subname)//' ERROR: error in reading in pft data' ) + !X! + !X! call ncd_io('soilbeta',EDPftvarcon_inst%soilbeta,'read', ncid, readvar=readv) + !X! if ( .not. readv) call endrun(trim(subname)// ' ERROR : error in reading in pft data') + !X! + !X! call ncd_io('crown',EDPftvarcon_inst%crown,'read', ncid, readvar=readv) + !X! if ( .not. readv) call endrun(trim(subname)// ' ERROR : error in reading in pft data') + !X! + !X! call ncd_io('bark_scaler',EDPftvarcon_inst%bark_scaler,'read', ncid, readvar=readv) + !X! if ( .not. readv) call endrun(trim(subname)// ' ERROR : error in reading in pft data') + !X! + !X! call ncd_io('crown_kill',EDPftvarcon_inst%crown_kill,'read', ncid, readvar=readv) + !X! if ( .not. readv) call endrun(trim(subname)// ' ERROR : error in reading in pft data') + !X! + !X! call ncd_io('initd',EDPftvarcon_inst%initd,'read', ncid, readvar=readv) + !X! if ( .not. readv) call endrun(trim(subname)// ' ERROR : error in reading in pft data') + !X! + !X! call ncd_io('sd_mort',EDPftvarcon_inst%sd_mort,'read', ncid, readvar=readv) + !X! if ( .not. readv) call endrun(trim(subname)// ' ERROR : error in reading in pft data') + !X! + !X! call ncd_io('seed_rain',EDPftvarcon_inst%seed_rain,'read', ncid, readvar=readv) + !X! if ( .not. readv) call endrun(trim(subname)// ' ERROR : error in reading in pft data') + !X! + !X! call ncd_io('BB_slope',EDPftvarcon_inst%BB_slope,'read', ncid, readvar=readv) + !X! if ( .not. readv) call endrun(trim(subname)// ' ERROR : error in reading in pft data') + !X! + !X! call ncd_io('root_long',EDPftvarcon_inst%root_long, 'read', ncid, readvar=readv) + !X! if ( .not. readv) call endrun(trim(subname)// ' ERROR : error in reading in pft data') + !X! + !X! call ncd_io('seed_alloc',EDPftvarcon_inst%seed_alloc, 'read', ncid, readvar=readv) + !X! if ( .not. readv) call endrun(trim(subname)// ' ERROR : error in reading in pft data') + !X! + !X! call ncd_io('clone_alloc',EDPftvarcon_inst%clone_alloc, 'read', ncid, readvar=readv) + !X! if ( .not. readv) call endrun(trim(subname)// ' ERROR : error in reading in pft data') + !X! + !X! call ncd_io('sapwood_ratio',EDPftvarcon_inst%sapwood_ratio, 'read', ncid, readvar=readv) + !X! if ( .not. readv) call endrun(trim(subname)// ' ERROR : error in reading in pft data') + !X! + !X! call ncd_io('woody', EDPftvarcon_inst%woody, 'read', ncid, readvar=readv, posNOTonfile=.true.) + !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + !X! + !X! call ncd_io('stress_decid', EDPftvarcon_inst%stress_decid, 'read', ncid, readvar=readv, posNOTonfile=.true.) + !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + !X! + !X! call ncd_io('season_decid', EDPftvarcon_inst%season_decid, 'read', ncid, readvar=readv, posNOTonfile=.true.) + !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + !X! + !X! call ncd_io('evergreen', EDPftvarcon_inst%evergreen, 'read', ncid, readvar=readv, posNOTonfile=.true.) + !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + !X! + !X! call ncd_io('froot_leaf', EDPftvarcon_inst%froot_leaf, 'read', ncid, readvar=readv, posNOTonfile=.true.) + !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + !X! + !X! call ncd_io('slatop', EDPftvarcon_inst%slatop, 'read', ncid, readvar=readv, posNOTonfile=.true.) + !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + !X! + !X! call ncd_io('leaf_long', EDPftvarcon_inst%leaf_long, 'read', ncid, readvar=readv, posNOTonfile=.true.) + !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + !X! call ncd_io('rootprof_beta', EDPftvarcon_inst%rootprof_beta, 'read', ncid, readvar=readv, posNOTonfile=.true.) + !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + !X! call ncd_io('roota_par', EDPftvarcon_inst%roota_par, 'read', ncid, readvar=readv, posNOTonfile=.true.) + !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + !X! + !X! call ncd_io('rootb_par', EDPftvarcon_inst%rootb_par, 'read', ncid, readvar=readv, posNOTonfile=.true.) + !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + !X! + !X! call ncd_io('lf_flab', EDPftvarcon_inst%lf_flab, 'read', ncid, readvar=readv, posNOTonfile=.true.) + !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + !X! + !X! call ncd_io('lf_fcel', EDPftvarcon_inst%lf_fcel, 'read', ncid, readvar=readv, posNOTonfile=.true.) + !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + !X! + !X! call ncd_io('lf_flig', EDPftvarcon_inst%lf_flig, 'read', ncid, readvar=readv, posNOTonfile=.true.) + !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + !X! + !X! call ncd_io('fr_flab', EDPftvarcon_inst%fr_flab, 'read', ncid, readvar=readv, posNOTonfile=.true.) + !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + !X! + !X! call ncd_io('fr_fcel', EDPftvarcon_inst%fr_fcel, 'read', ncid, readvar=readv, posNOTonfile=.true.) + !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + !X! + !X! call ncd_io('fr_flig', EDPftvarcon_inst%fr_flig, 'read', ncid, readvar=readv, posNOTonfile=.true.) + !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + !X! call ncd_io('rholvis', EDPftvarcon_inst%rhol(:,ivis), 'read', ncid, readvar=readv, posNOTonfile=.true.) + !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + !X! + !X! call ncd_io('rholnir', EDPftvarcon_inst%rhol(:,inir), 'read', ncid, readvar=readv, posNOTonfile=.true.) + !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + !X! + !X! call ncd_io('rhosvis', EDPftvarcon_inst%rhos(:,ivis), 'read', ncid, readvar=readv, posNOTonfile=.true.) + !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + !X! + !X! call ncd_io('rhosnir', EDPftvarcon_inst% rhos(:,inir), 'read', ncid, readvar=readv, posNOTonfile=.true.) + !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + !X! + !X! call ncd_io('taulvis', EDPftvarcon_inst%taul(:,ivis), 'read', ncid, readvar=readv, posNOTonfile=.true.) + !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + !X! + !X! call ncd_io('taulnir', EDPftvarcon_inst%taul(:,inir), 'read', ncid, readvar=readv, posNOTonfile=.true.) + !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + !X! + !X! call ncd_io('tausvis', EDPftvarcon_inst%taus(:,ivis), 'read', ncid, readvar=readv, posNOTonfile=.true.) + !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + !X! + !X! call ncd_io('tausnir', EDPftvarcon_inst%taus(:,inir), 'read', ncid, readvar=readv, posNOTonfile=.true.) + !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + !X! call ncd_io('xl', EDPftvarcon_inst%xl, 'read', ncid, readvar=readv, posNOTonfile=.true.) + !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + !X! + !X! call ncd_io('c3psn', EDPftvarcon_inst%c3psn, 'read', ncid, readvar=readv, posNOTonfile=.true.) + !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + !X! + !X! call ncd_io('flnr', EDPftvarcon_inst%flnr, 'read', ncid, readvar=readv, posNOTonfile=.true.) + !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + !X! + !X! call ncd_io('fnitr', EDPftvarcon_inst%fnitr, 'read', ncid, readvar=readv, posNOTonfile=.true.) + !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + !X! + !X! call ncd_io('leafcn', EDPftvarcon_inst%leafcn, 'read', ncid, readvar=readv, posNOTonfile=.true.) + !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + !X! + !X! call ncd_io('frootcn', EDPftvarcon_inst%frootcn, 'read', ncid, readvar=readv, posNOTonfile=.true.) + !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + !X! + !X! call ncd_io('smpso', EDPftvarcon_inst%smpso, 'read', ncid, readvar=readv, posNOTonfile=.true.) + !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + !X! + !X! call ncd_io('smpsc', EDPftvarcon_inst%smpsc, 'read', ncid, readvar=readv, posNOTonfile=.true.) + !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + !X! + !X! call ncd_io('grperc', EDPftvarcon_inst%grperc, 'read', ncid, readvar=readv, posNOTonfile=.true.) + !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + ! HOLDING ON SEW ENSITIVITY-ANALYSIS PARAMETERS UNTIL MACHINE CONFIGS SET RGK/CX + ! call ncd_io('dbh2h_m',EDPftvarcon_inst%dbh2h_m, 'read', ncid, readvar=readv) + ! if ( .not. readv) call endrun(trim(subname)// ' ERROR : error in reading in pft data') end subroutine EDpftconrd diff --git a/main/FatesParametersInterface.F90 b/main/FatesParametersInterface.F90 index 6ebadce2..60bae8eb 100644 --- a/main/FatesParametersInterface.F90 +++ b/main/FatesParametersInterface.F90 @@ -29,6 +29,7 @@ module FatesParametersInterface character(len=*), parameter, public :: dimension_name_lsc = 'litterclass' character(len=*), parameter, public :: dimension_name_fsc = 'litterclass' character(len=*), parameter, public :: dimension_name_allpfts = 'allpfts' + character(len=*), parameter, public :: dimension_name_variants = 'variants' type, private :: parameter_type character(len=param_string_length) :: name @@ -157,7 +158,7 @@ subroutine RetreiveParameter1D(this, name, data) i = this%FindIndex(name) if (size(data) /= size(this%parameters(i)%data(:, 1))) then write(fates_log(), *) 'ERROR : retreiveparameter1d : ', name, ' size inconsistent.' - write(fates_log(), *) 'ERROR : size expected size = ', size(data) + write(fates_log(), *) 'ERROR : expected size = ', size(data) write(fates_log(), *) 'ERROR : data size received from file = ', size(this%parameters(i)%data(:, 1)) write(fates_log(), *) 'ERROR : dimesions received from file' write(fates_log(), *) 'ERROR : names size' @@ -173,16 +174,32 @@ end subroutine RetreiveParameter1D !----------------------------------------------------------------------- subroutine RetreiveParameter2D(this, name, data) + use abortutils, only : endrun + implicit none class(fates_parameters_type), intent(inout) :: this character(len=param_string_length), intent(in) :: name real(r8), intent(out) :: data(:, :) - integer :: i + integer :: i, d i = this%FindIndex(name) - ! assert(size(data) == size(this%parameters(i)%data)) + if (size(data, 1) /= size(this%parameters(i)%data, 1) .and. & + size(data, 2) /= size(this%parameters(i)%data, 2)) then + write(fates_log(), *) 'ERROR : retreiveparameter2d : ', name, ' size inconsistent.' + write(fates_log(), *) 'ERROR : expected shape = ', shape(data) + write(fates_log(), *) 'ERROR : dim 1 expected size = ', size(data, 1) + write(fates_log(), *) 'ERROR : dim 2 expected size = ', size(data, 2) + write(fates_log(), *) 'ERROR : dim 1 data size received from file = ', size(this%parameters(i)%data, 1) + write(fates_log(), *) 'ERROR : dim 2 data size received from file = ', size(this%parameters(i)%data, 2) + write(fates_log(), *) 'ERROR : dimesions received from file' + write(fates_log(), *) 'ERROR : names size' + do d = 1, max_dimensions + write(fates_log(), *) this%parameters(i)%dimension_names(d), ', ', this%parameters(i)%dimension_sizes(d) + end do + call endrun(msg='size error retreiving 2d parameter.') + end if data = this%parameters(i)%data end subroutine RetreiveParameter2D From cd39de95c9c4e3ab2bb8253fb3e6a8e6e25b5905 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 6 Feb 2017 12:41:57 -0800 Subject: [PATCH 313/437] Changed endrun() to require a message. --- main/FatesGlobals.F90 | 9 +-------- 1 file changed, 1 insertion(+), 8 deletions(-) diff --git a/main/FatesGlobals.F90 b/main/FatesGlobals.F90 index 3a1912b6..dda07ec6 100644 --- a/main/FatesGlobals.F90 +++ b/main/FatesGlobals.F90 @@ -12,11 +12,6 @@ module FatesGlobals public :: fates_log public :: fates_global_verbose - - - - - integer, private :: fates_log_ logical, private :: fates_global_verbose_ @@ -60,13 +55,11 @@ subroutine fates_endrun(msg) ! ! !ARGUMENTS: implicit none - character(len=*), intent(in), optional :: msg ! string to be printed + character(len=*), intent(in) :: msg ! string to be printed !----------------------------------------------------------------------- if (present (msg)) then write(fates_log(),*)'ENDRUN:', msg - else - write(fates_log(),*)'ENDRUN: called without a message string' end if call shr_sys_abort() From c0d352e61aeefd4123a1d64b5c383c15550c23e8 Mon Sep 17 00:00:00 2001 From: ckoven Date: Mon, 6 Feb 2017 13:58:08 -0800 Subject: [PATCH 314/437] added new diagnostics on canopy/understory plants, carbon storage, and carbon mortality --- main/FatesHistoryInterfaceMod.F90 | 83 ++++++++++++++++++++++++++++--- 1 file changed, 75 insertions(+), 8 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 568b9950..f474ffd7 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -100,14 +100,15 @@ module FatesHistoryInterfaceMod integer, private :: ih_npp_agsw_si_scpf integer, private :: ih_npp_agdw_si_scpf integer, private :: ih_npp_stor_si_scpf - integer, private :: ih_litt_leaf_si_scpf - integer, private :: ih_litt_fnrt_si_scpf - integer, private :: ih_litt_sawd_si_scpf - integer, private :: ih_litt_ddwd_si_scpf - integer, private :: ih_r_leaf_si_scpf - integer, private :: ih_r_stem_si_scpf - integer, private :: ih_r_root_si_scpf - integer, private :: ih_r_stor_si_scpf + + integer, private :: ih_bstor_canopy_si_scpf + integer, private :: ih_bstor_understory_si_scpf + integer, private :: ih_bleaf_canopy_si_scpf + integer, private :: ih_bleaf_understory_si_scpf + integer, private :: ih_m3_canopy_si_scpf + integer, private :: ih_m3_understory_si_scpf + integer, private :: ih_nplant_canopy_si_scpf + integer, private :: ih_nplant_understory_si_scpf integer, private :: ih_ddbh_si_scpf integer, private :: ih_ba_si_scpf @@ -794,6 +795,14 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_npp_agsw_si_scpf => this%hvars(ih_npp_agsw_si_scpf)%r82d, & hio_npp_agdw_si_scpf => this%hvars(ih_npp_agdw_si_scpf)%r82d, & hio_npp_stor_si_scpf => this%hvars(ih_npp_stor_si_scpf)%r82d, & + hio_bstor_canopy_si_scpf => this%hvars(ih_bstor_canopy_si_scpf)%r82d, & + hio_bstor_understory_si_scpf => this%hvars(ih_bstor_understory_si_scpf)%r82d, & + hio_bleaf_canopy_si_scpf => this%hvars(ih_bleaf_canopy_si_scpf)%r82d, & + hio_bleaf_understory_si_scpf => this%hvars(ih_bleaf_understory_si_scpf)%r82d, & + hio_m3_canopy_si_scpf => this%hvars(ih_m3_canopy_si_scpf)%r82d, & + hio_m3_understory_si_scpf => this%hvars(ih_m3_understory_si_scpf)%r82d, & + hio_nplant_canopy_si_scpf => this%hvars(ih_nplant_canopy_si_scpf)%r82d, & + hio_nplant_understory_si_scpf => this%hvars(ih_nplant_understory_si_scpf)%r82d, & hio_ddbh_si_scpf => this%hvars(ih_ddbh_si_scpf)%r82d, & hio_ba_si_scpf => this%hvars(ih_ba_si_scpf)%r82d, & hio_nplant_si_scpf => this%hvars(ih_nplant_si_scpf)%r82d, & @@ -989,6 +998,23 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_ddbh_si_scpf(io_si,scpf) = -999.9 end if end if + + ! update SCPF- and canopy/subcanopy- partitioned quantities + if (ccohort%canopy_layer .eq. 1) then + hio_bstor_canopy_si_scpf(io_si,scpf) = hio_bstor_canopy_si_scpf(io_si,scpf) + & + ccohort%bstore * n_perm2 * AREA + hio_bleaf_canopy_si_scpf(io_si,scpf) = hio_bleaf_canopy_si_scpf(io_si,scpf) + & + ccohort%bl * n_perm2 * AREA + hio_m3_canopy_si_scpf(io_si,scpf) = hio_m3_canopy_si_scpf(io_si,scpf) + ccohort%cmort*n_perm2*AREA + hio_nplant_canopy_si_scpf(io_si,scpf) = hio_nplant_canopy_si_scpf(io_si,scpf) + AREA*n_perm2 + else + hio_bstor_understory_si_scpf(io_si,scpf) = hio_bstor_understory_si_scpf(io_si,scpf) + & + ccohort%bstore * n_perm2 + hio_bleaf_understory_si_scpf(io_si,scpf) = hio_bleaf_understory_si_scpf(io_si,scpf) + & + ccohort%bl * n_perm2 + hio_m3_understory_si_scpf(io_si,scpf) = hio_m3_understory_si_scpf(io_si,scpf) + ccohort%cmort*n_perm2*AREA + hio_nplant_understory_si_scpf(io_si,scpf) = hio_nplant_understory_si_scpf(io_si,scpf) + AREA*n_perm2 + endif end associate end if @@ -1651,6 +1677,47 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m5_si_scpf ) + call this%set_history_var(vname='M3_CANOPY_SCPF', units = 'N/ha/yr', & + long='carbon starvation mortality of canopy plants count by patch and pft/size', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m3_canopy_si_scpf ) + + call this%set_history_var(vname='BSTOR_CANOPY_SCPF', units = 'kgC/ha', & + long='biomass carbon in storage pools of canopy plants count by patch and pft/size', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_bstor_canopy_si_scpf ) + + call this%set_history_var(vname='BLEAF_CANOPY_SCPF', units = 'kgC/ha', & + long='biomass carbon in leaf of canopy plants count by patch and pft/size', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_bleaf_canopy_si_scpf ) + + call this%set_history_var(vname='NPLANT_CANOPY_SCPF', units = 'N/ha', & + long='stem number of canopy plants density by patch and pft/size', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_canopy_si_scpf ) + + call this%set_history_var(vname='M3_UNDERSTORY_SCPF', units = 'N/ha/yr', & + long='carbon starvation mortality of understory plants count by patch and pft/size', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m3_understory_si_scpf ) + + call this%set_history_var(vname='BSTOR_UNDERSTORY_SCPF', units = 'kgC/ha', & + long='biomass carbon in storage pools of understory plants count by patch and pft/size', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_bstor_understory_si_scpf ) + + call this%set_history_var(vname='BLEAF_UNDERSTORY_SCPF', units = 'kgC/ha', & + long='biomass carbon in leaf of understory plants count by patch and pft/size', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_bleaf_understory_si_scpf ) + + call this%set_history_var(vname='NPLANT_UNDERSTORY_SCPF', units = 'N/ha', & + long='stem number of understory plants density by patch and pft/size', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_understory_si_scpf ) + + ! Size structured diagnostics that require rapid updates (upfreq=2) call this%set_history_var(vname='AR_SCPF',units = 'kgC/m2/yr', & From 043099be6c1bd2cd436b3c0b4d437b035ae9ee73 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 6 Feb 2017 14:17:50 -0800 Subject: [PATCH 315/437] Some calls to fates_endrun() were not passing messages. --- biogeochem/EDPhysiologyMod.F90 | 4 ++-- main/FatesGlobals.F90 | 5 +---- 2 files changed, 3 insertions(+), 6 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 90cac685..2eb77c48 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1505,7 +1505,7 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) write(fates_log(), *) 'stem_prof: ', stem_prof(s,:) write(fates_log(), *) 'max_rooting_depth_index_col: ', bc_in(s)%max_rooting_depth_index_col write(fates_log(), *) 'dzsoi_decomp: ', dzsoi_decomp - call endrun() + call endrun(msg=errMsg(sourcefile, __LINE__)) endif ! now check each fine root profile do ft = 1,numpft_ed @@ -1515,7 +1515,7 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) end do if ( ( abs(froot_prof_sum - 1._r8) > delta ) ) then write(fates_log(), *) 'profile sums: ', froot_prof_sum - call endrun() + call endrun(msg=errMsg(sourcefile, __LINE__)) endif end do end do diff --git a/main/FatesGlobals.F90 b/main/FatesGlobals.F90 index dda07ec6..3d4d561c 100644 --- a/main/FatesGlobals.F90 +++ b/main/FatesGlobals.F90 @@ -58,10 +58,7 @@ subroutine fates_endrun(msg) character(len=*), intent(in) :: msg ! string to be printed !----------------------------------------------------------------------- - if (present (msg)) then - write(fates_log(),*)'ENDRUN:', msg - end if - + write(fates_log(),*)'ENDRUN:', msg call shr_sys_abort() end subroutine fates_endrun From 610128d9030e1e48337b9deaf41ca5ea1b91e366 Mon Sep 17 00:00:00 2001 From: ckoven Date: Tue, 7 Feb 2017 13:33:32 -0800 Subject: [PATCH 316/437] added more canopy/understory diagnostics on ddbh, gpp, and ar --- main/FatesHistoryInterfaceMod.F90 | 107 ++++++++++++++++++++++++++++-- 1 file changed, 100 insertions(+), 7 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index f474ffd7..84e36859 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -62,6 +62,10 @@ module FatesHistoryInterfaceMod integer, private :: ih_aresp_pa integer, private :: ih_maint_resp_pa integer, private :: ih_growth_resp_pa + integer, private :: ih_ar_canopy_pa + integer, private :: ih_gpp_canopy_pa + integer, private :: ih_ar_understory_pa + integer, private :: ih_gpp_understory_pa ! Indices to (site) variables integer, private :: ih_nep_si @@ -109,6 +113,12 @@ module FatesHistoryInterfaceMod integer, private :: ih_m3_understory_si_scpf integer, private :: ih_nplant_canopy_si_scpf integer, private :: ih_nplant_understory_si_scpf + integer, private :: ih_ddbh_canopy_si_scpf + integer, private :: ih_ddbh_understory_si_scpf + integer, private :: ih_gpp_canopy_si_scpf + integer, private :: ih_gpp_understory_si_scpf + integer, private :: ih_ar_canopy_si_scpf + integer, private :: ih_ar_understory_si_scpf integer, private :: ih_ddbh_si_scpf integer, private :: ih_ba_si_scpf @@ -803,6 +813,12 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_m3_understory_si_scpf => this%hvars(ih_m3_understory_si_scpf)%r82d, & hio_nplant_canopy_si_scpf => this%hvars(ih_nplant_canopy_si_scpf)%r82d, & hio_nplant_understory_si_scpf => this%hvars(ih_nplant_understory_si_scpf)%r82d, & + hio_ddbh_canopy_si_scpf => this%hvars(ih_ddbh_canopy_si_scpf)%r82d, & + hio_ddbh_understory_si_scpf => this%hvars(ih_ddbh_understory_si_scpf)%r82d, & + hio_gpp_canopy_si_scpf => this%hvars(ih_gpp_canopy_si_scpf)%r82d, & + hio_gpp_understory_si_scpf => this%hvars(ih_gpp_understory_si_scpf)%r82d, & + hio_ar_canopy_si_scpf => this%hvars(ih_ar_canopy_si_scpf)%r82d, & + hio_ar_understory_si_scpf => this%hvars(ih_ar_understory_si_scpf)%r82d, & hio_ddbh_si_scpf => this%hvars(ih_ddbh_si_scpf)%r82d, & hio_ba_si_scpf => this%hvars(ih_ba_si_scpf)%r82d, & hio_nplant_si_scpf => this%hvars(ih_nplant_si_scpf)%r82d, & @@ -990,13 +1006,9 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! number density [/ha] hio_nplant_si_scpf(io_si,scpf) = hio_nplant_si_scpf(io_si,scpf) + AREA*n_perm2 - ! Growth Incrments must have NaN check and woody check - if(ccohort%ddbhdt == ccohort%ddbhdt) then - hio_ddbh_si_scpf(io_si,scpf) = hio_ddbh_si_scpf(io_si,scpf) + & - ccohort%ddbhdt*n_perm2*AREA - else - hio_ddbh_si_scpf(io_si,scpf) = -999.9 - end if + ! growth increment + hio_ddbh_si_scpf(io_si,scpf) = hio_ddbh_si_scpf(io_si,scpf) + & + ccohort%ddbhdt*n_perm2*AREA end if ! update SCPF- and canopy/subcanopy- partitioned quantities @@ -1007,6 +1019,13 @@ subroutine update_history_dyn(this,nc,nsites,sites) ccohort%bl * n_perm2 * AREA hio_m3_canopy_si_scpf(io_si,scpf) = hio_m3_canopy_si_scpf(io_si,scpf) + ccohort%cmort*n_perm2*AREA hio_nplant_canopy_si_scpf(io_si,scpf) = hio_nplant_canopy_si_scpf(io_si,scpf) + AREA*n_perm2 + hio_gpp_canopy_si_scpf(io_si,scpf) = hio_gpp_canopy_si_scpf(io_si,scpf) + & + n_perm2*ccohort%gpp_acc_hold + hio_ar_canopy_si_scpf(io_si,scpf) = hio_ar_canopy_si_scpf(io_si,scpf) + & + n_perm2*ccohort%resp_acc_hold + ! growth increment + hio_ddbh_canopy_si_scpf(io_si,scpf) = hio_ddbh_canopy_si_scpf(io_si,scpf) + & + ccohort%ddbhdt*n_perm2*AREA else hio_bstor_understory_si_scpf(io_si,scpf) = hio_bstor_understory_si_scpf(io_si,scpf) + & ccohort%bstore * n_perm2 @@ -1014,6 +1033,13 @@ subroutine update_history_dyn(this,nc,nsites,sites) ccohort%bl * n_perm2 hio_m3_understory_si_scpf(io_si,scpf) = hio_m3_understory_si_scpf(io_si,scpf) + ccohort%cmort*n_perm2*AREA hio_nplant_understory_si_scpf(io_si,scpf) = hio_nplant_understory_si_scpf(io_si,scpf) + AREA*n_perm2 + hio_gpp_understory_si_scpf(io_si,scpf) = hio_gpp_understory_si_scpf(io_si,scpf) + & + n_perm2*ccohort%gpp_acc_hold + hio_ar_understory_si_scpf(io_si,scpf) = hio_ar_understory_si_scpf(io_si,scpf) + & + n_perm2*ccohort%resp_acc_hold + ! growth increment + hio_ddbh_understory_si_scpf(io_si,scpf) = hio_ddbh_understory_si_scpf(io_si,scpf) + & + ccohort%ddbhdt*n_perm2*AREA endif end associate @@ -1144,6 +1170,10 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) hio_ar_darkm_si_scpf => this%hvars(ih_ar_darkm_si_scpf)%r82d, & hio_ar_crootm_si_scpf => this%hvars(ih_ar_crootm_si_scpf)%r82d, & hio_ar_frootm_si_scpf => this%hvars(ih_ar_frootm_si_scpf)%r82d, & + hio_gpp_canopy_pa => this%hvars(ih_gpp_canopy_pa)%r81d, & + hio_ar_canopy_pa => this%hvars(ih_ar_canopy_pa)%r81d, & + hio_gpp_understory_pa => this%hvars(ih_gpp_understory_pa)%r81d, & + hio_ar_understory_pa => this%hvars(ih_ar_understory_pa)%r81d, & hio_gpp_si_age => this%hvars(ih_gpp_si_age)%r82d, & hio_npp_si_age => this%hvars(ih_npp_si_age)%r82d & ) @@ -1236,6 +1266,19 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) + ccohort%gpp_tstep * ccohort%n * 1.e3_r8 / dt_tstep hio_npp_si_age(io_si,cpatch%age_class) = hio_npp_si_age(io_si,cpatch%age_class) & + ccohort%npp_tstep * ccohort%n * 1.e3_r8 / dt_tstep + + ! accumulate fluxes on canopy- and understory- separated fluxes + if (ccohort%canopy_layer .eq. 1) then + hio_gpp_canopy_pa(io_pa) = hio_gpp_canopy_pa(io_pa) + & + ccohort%gpp_tstep * 1.e3_r8 * n_density / dt_tstep + hio_ar_canopy_pa(io_pa) = hio_ar_canopy_pa(io_pa) + & + ccohort%resp_tstep * 1.e3_r8 * n_density / dt_tstep + else + hio_gpp_understory_pa(io_pa) = hio_gpp_understory_pa(io_pa) + & + ccohort%gpp_tstep * 1.e3_r8 * n_density / dt_tstep + hio_ar_understory_pa(io_pa) = hio_ar_understory_pa(io_pa) + & + ccohort%resp_tstep * 1.e3_r8 * n_density / dt_tstep + endif end associate endif @@ -1580,6 +1623,26 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & ivar=ivar, initialize=initialize_variables, index = ih_gpp_si_age ) + ! fast fluxes separated canopy/understory + call this%set_history_var(vname='GPP_CANOPY', units='gC/m^2/s', & + long='gross primary production of canopy plants', use_default='active', & + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_gpp_canopy_pa ) + + call this%set_history_var(vname='AR_CANOPY', units='gC/m^2/s', & + long='autotrophic respiration of canopy plants', use_default='active', & + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_ar_canopy_pa ) + + call this%set_history_var(vname='GPP_UNDERSTORY', units='gC/m^2/s', & + long='gross primary production of understory plants', use_default='active', & + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_gpp_understory_pa ) + + call this%set_history_var(vname='AR_UNDERSTORY', units='gC/m^2/s', & + long='autotrophic respiration of understory plants', use_default='active', & + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_ar_understory_pa ) ! Carbon Flux (grid dimension x scpf) (THESE ARE DEFAULT INACTIVE!!! @@ -1591,6 +1654,26 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_gpp_si_scpf ) + call this%set_history_var(vname='GPP_CANOPY_SCPF', units='kgC/m2/yr', & + long='gross primary production of canopy plants', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_gpp_canopy_si_scpf ) + + call this%set_history_var(vname='AR_CANOPY_SCPF', units='kgC/m2/yr', & + long='autotrophic respiration of canopy plants', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ar_canopy_si_scpf ) + + call this%set_history_var(vname='GPP_UNDERSTORY_SCPF', units='kgC/m2/yr', & + long='gross primary production of understory plants', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_gpp_understory_si_scpf ) + + call this%set_history_var(vname='AR_UNDERSTORY_SCPF', units='kgC/m2/yr', & + long='autotrophic respiration of understory plants', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ar_understory_si_scpf ) + call this%set_history_var(vname='NPP_SCPF', units='kgC/m2/yr', & long='total net primary production', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & @@ -1642,6 +1725,16 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ddbh_si_scpf ) + call this%set_history_var(vname='DDBH_CANOPY_SCPF', units = 'cm/yr/ha', & + long='diameter growth increment and pft/size',use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ddbh_canopy_si_scpf ) + + call this%set_history_var(vname='DDBH_UNDERSTORY_SCPF', units = 'cm/yr/ha', & + long='diameter growth increment and pft/size',use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ddbh_understory_si_scpf ) + call this%set_history_var(vname='BA_SCPF', units = 'm2/ha', & long='basal area by patch and pft/size', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & From e5cd3a0e04e8ccc0c1604f30a4b06104297edf57 Mon Sep 17 00:00:00 2001 From: ckoven Date: Tue, 7 Feb 2017 14:34:55 -0800 Subject: [PATCH 317/437] fixed a unit error --- main/FatesHistoryInterfaceMod.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 84e36859..9464e693 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -1028,9 +1028,9 @@ subroutine update_history_dyn(this,nc,nsites,sites) ccohort%ddbhdt*n_perm2*AREA else hio_bstor_understory_si_scpf(io_si,scpf) = hio_bstor_understory_si_scpf(io_si,scpf) + & - ccohort%bstore * n_perm2 + ccohort%bstore * n_perm2 * AREA hio_bleaf_understory_si_scpf(io_si,scpf) = hio_bleaf_understory_si_scpf(io_si,scpf) + & - ccohort%bl * n_perm2 + ccohort%bl * n_perm2 * AREA hio_m3_understory_si_scpf(io_si,scpf) = hio_m3_understory_si_scpf(io_si,scpf) + ccohort%cmort*n_perm2*AREA hio_nplant_understory_si_scpf(io_si,scpf) = hio_nplant_understory_si_scpf(io_si,scpf) + AREA*n_perm2 hio_gpp_understory_si_scpf(io_si,scpf) = hio_gpp_understory_si_scpf(io_si,scpf) + & From 33bb9deea25417228b13da772c115b341c2a34ab Mon Sep 17 00:00:00 2001 From: Ben Andre Date: Wed, 8 Feb 2017 14:54:28 -0700 Subject: [PATCH 318/437] Update some fates scalar parameter representations. The fates input file has two ways of indicating scalars, true scalars and 1-D arays with length 1. Inorder to check dimensions and compare code expectations vs what is on the file, we need to more clearly distinguish between these two ways or represeting scalars. Test suite: SMS_D_Ld5.f10_f10.ICLM45ED.yellowstone_intel.clm-edTest Test baseline: a651a4f Test namelist changes: addition of fates_paramfile Test answer changes: bit for bit Test summary: pass --- biogeochem/EDSharedParamsMod.F90 | 7 ++-- main/EDParamsMod.F90 | 56 +++++++++++++++---------------- main/FatesParametersInterface.F90 | 3 +- 3 files changed, 33 insertions(+), 33 deletions(-) diff --git a/biogeochem/EDSharedParamsMod.F90 b/biogeochem/EDSharedParamsMod.F90 index a6aaa26d..c3610b05 100644 --- a/biogeochem/EDSharedParamsMod.F90 +++ b/biogeochem/EDSharedParamsMod.F90 @@ -52,7 +52,6 @@ subroutine RegisterParams(this, fates_params) ! that need to be synced with host values. use FatesParametersInterface, only : fates_parameters_type, param_string_length - use FatesParametersInterface, only : dimension_name_scalar, dimension_shape_scalar implicit none @@ -85,7 +84,7 @@ subroutine RegisterParamsScalar(this, fates_params) ! that need to be synced with host values. use FatesParametersInterface, only : fates_parameters_type, param_string_length - use FatesParametersInterface, only : dimension_name_allpfts, dimension_shape_scalar + use FatesParametersInterface, only : dimension_name_allpfts, dimension_shape_1d implicit none @@ -98,11 +97,11 @@ subroutine RegisterParamsScalar(this, fates_params) call this%Init() name = 'q10_mr' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_scalar, & + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, sync_with_host=.true.) name = 'froz_q10' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_scalar, & + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, sync_with_host=.true.) end subroutine RegisterParamsScalar diff --git a/main/EDParamsMod.F90 b/main/EDParamsMod.F90 index 344cf916..dc67ebd8 100644 --- a/main/EDParamsMod.F90 +++ b/main/EDParamsMod.F90 @@ -74,54 +74,54 @@ subroutine FatesRegisterParams(fates_params) ! indicate whether they are fates parameters or host parameters ! that need to be synced with host values. - use FatesParametersInterface, only : fates_parameters_type, dimension_name_scalar, dimension_shape_scalar + use FatesParametersInterface, only : fates_parameters_type, dimension_name_scalar1d, dimension_shape_1d implicit none class(fates_parameters_type), intent(inout) :: fates_params - character(len=param_string_length), parameter :: dim_names_scalar(1) = (/dimension_name_scalar/) + character(len=param_string_length), parameter :: dim_names(1) = (/dimension_name_scalar1d/) call FatesParamsInit() - call fates_params%RegisterParameter(name=ED_name_grass_spread, dimension_shape=dimension_shape_scalar, & - dimension_names=dim_names_scalar) + call fates_params%RegisterParameter(name=ED_name_grass_spread, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) - call fates_params%RegisterParameter(name=ED_name_comp_excln, dimension_shape=dimension_shape_scalar, & - dimension_names=dim_names_scalar) + call fates_params%RegisterParameter(name=ED_name_comp_excln, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) - call fates_params%RegisterParameter(name=ED_name_grass_spread, dimension_shape=dimension_shape_scalar, & - dimension_names=dim_names_scalar) + call fates_params%RegisterParameter(name=ED_name_grass_spread, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) - call fates_params%RegisterParameter(name=ED_name_comp_excln, dimension_shape=dimension_shape_scalar, & - dimension_names=dim_names_scalar) + call fates_params%RegisterParameter(name=ED_name_comp_excln, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) - call fates_params%RegisterParameter(name=ED_name_stress_mort, dimension_shape=dimension_shape_scalar, & - dimension_names=dim_names_scalar) + call fates_params%RegisterParameter(name=ED_name_stress_mort, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) - call fates_params%RegisterParameter(name=ED_name_dispersal, dimension_shape=dimension_shape_scalar, & - dimension_names=dim_names_scalar) + call fates_params%RegisterParameter(name=ED_name_dispersal, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) - call fates_params%RegisterParameter(name=ED_name_maxspread, dimension_shape=dimension_shape_scalar, & - dimension_names=dim_names_scalar) + call fates_params%RegisterParameter(name=ED_name_maxspread, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) - call fates_params%RegisterParameter(name=ED_name_minspread, dimension_shape=dimension_shape_scalar, & - dimension_names=dim_names_scalar) + call fates_params%RegisterParameter(name=ED_name_minspread, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) - call fates_params%RegisterParameter(name=ED_name_init_litter, dimension_shape=dimension_shape_scalar, & - dimension_names=dim_names_scalar) + call fates_params%RegisterParameter(name=ED_name_init_litter, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) - call fates_params%RegisterParameter(name=ED_name_nfires, dimension_shape=dimension_shape_scalar, & - dimension_names=dim_names_scalar) + call fates_params%RegisterParameter(name=ED_name_nfires, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) - call fates_params%RegisterParameter(name=ED_name_understorey_death, dimension_shape=dimension_shape_scalar, & - dimension_names=dim_names_scalar) + call fates_params%RegisterParameter(name=ED_name_understorey_death, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) - call fates_params%RegisterParameter(name=ED_name_profile_tol, dimension_shape=dimension_shape_scalar, & - dimension_names=dim_names_scalar) + call fates_params%RegisterParameter(name=ED_name_profile_tol, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) - call fates_params%RegisterParameter(name=ED_name_ag_biomass, dimension_shape=dimension_shape_scalar, & - dimension_names=dim_names_scalar) + call fates_params%RegisterParameter(name=ED_name_ag_biomass, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) end subroutine FatesRegisterParams diff --git a/main/FatesParametersInterface.F90 b/main/FatesParametersInterface.F90 index 60bae8eb..cfebf64f 100644 --- a/main/FatesParametersInterface.F90 +++ b/main/FatesParametersInterface.F90 @@ -22,7 +22,8 @@ module FatesParametersInterface ! parameters. Can't be done easily until this framework is being ! used to read variables. ! FIXME(bja, 2017-01) change 'param' to 'scalar'! - character(len=*), parameter, public :: dimension_name_scalar = 'param' + character(len=*), parameter, public :: dimension_name_scalar = '' + character(len=*), parameter, public :: dimension_name_scalar1d = 'param' character(len=*), parameter, public :: dimension_name_pft = 'pft' character(len=*), parameter, public :: dimension_name_segment = 'segment' character(len=*), parameter, public :: dimension_name_cwd = 'NCWD' From 3f683df40b0f45c9e23be849bc54aaa0502ffbe1 Mon Sep 17 00:00:00 2001 From: ckoven Date: Wed, 8 Feb 2017 15:20:55 -0800 Subject: [PATCH 319/437] added new mortality term to report terminated cohorts and also redefined the newish canopy_area_by_patch_age variable --- biogeochem/EDCohortDynamicsMod.F90 | 4 ++++ main/EDInitMod.F90 | 3 +++ main/EDTypesMod.F90 | 3 +++ main/FatesHistoryInterfaceMod.F90 | 20 ++++++++++++++++++-- 4 files changed, 28 insertions(+), 2 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 2237553c..79da24d3 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -559,6 +559,10 @@ subroutine terminate_cohorts( patchptr ) endif if (terminate == 1) then + ! preserve a record of the to-be-terminated cohort for mortality accounting + currentPatch%siteptr%terminated_nindivs(currentCohort%size_by_pft_class) = & + currentPatch%siteptr%terminated_nindivs(currentCohort%size_by_pft_class) + currentCohort%n + if (.not. associated(currentCohort%taller)) then currentPatch%tallest => currentCohort%shorter else diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 76bc5ed9..53576224 100755 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -79,6 +79,9 @@ subroutine zero_site( site_in ) site_in%fates_to_bgc_this_ts = 0.0_r8 site_in%fates_to_bgc_last_ts = 0.0_r8 + ! termination info + site_in%terminated_nindivs(:) = 0._r8 + end subroutine zero_site ! ============================================================================ diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index a92283eb..19b2cf63 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -558,6 +558,9 @@ module EDTypesMod real(r8) :: cwd_ag_burned(ncwd) real(r8) :: leaf_litter_burned(numpft_ed) + ! TERMINATION + real(r8) :: terminated_nindivs(1:nlevsclass_ed*mxpft) ! number of individuals that were in cohorts which were terminated this timestep on scpf array + end type ed_site_type !************************************ diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 9464e693..8735697b 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -127,6 +127,7 @@ module FatesHistoryInterfaceMod integer, private :: ih_m3_si_scpf integer, private :: ih_m4_si_scpf integer, private :: ih_m5_si_scpf + integer, private :: ih_m6_si_scpf integer, private :: ih_ar_si_scpf integer, private :: ih_ar_grow_si_scpf @@ -729,6 +730,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) nlevsclass_ed, & levage_ed, & nlevage_ed, & + mxpft, & levpft_ed use EDParamsMod , only : ED_val_ag_biomass @@ -748,6 +750,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) integer :: lb1,ub1,lb2,ub2 ! IO array bounds for the calling thread integer :: ivar ! index of IO variable object vector integer :: ft ! functional type index + integer :: i_scpf ! iterator for scpf dim real(r8) :: n_density ! individual of cohort per m2. real(r8) :: n_perm2 ! individuals per m2 for the whole column @@ -827,6 +830,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_m3_si_scpf => this%hvars(ih_m3_si_scpf)%r82d, & hio_m4_si_scpf => this%hvars(ih_m4_si_scpf)%r82d, & hio_m5_si_scpf => this%hvars(ih_m5_si_scpf)%r82d, & + hio_m6_si_scpf => this%hvars(ih_m6_si_scpf)%r82d, & hio_ba_si_scls => this%hvars(ih_ba_si_scls)%r82d, & hio_area_si_age => this%hvars(ih_area_si_age)%r82d, & hio_lai_si_age => this%hvars(ih_lai_si_age)%r82d, & @@ -873,8 +877,6 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! Increment some patch-age-resolved diagnostics hio_lai_si_age(io_si,cpatch%age_class) = hio_lai_si_age(io_si,cpatch%age_class) & + cpatch%lai * cpatch%area - hio_canopy_area_si_age(io_si,cpatch%age_class) = hio_canopy_area_si_age(io_si,cpatch%age_class) & - + cpatch%canopy_area/AREA hio_ncl_si_age(io_si,cpatch%age_class) = hio_ncl_si_age(io_si,cpatch%age_class) & + cpatch%ncl_p * cpatch%area hio_npatches_si_age(io_si,cpatch%age_class) = hio_npatches_si_age(io_si,cpatch%age_class) + 1._r8 @@ -918,6 +920,9 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_area_treespread_pa(io_pa) = 0.0_r8 end if + hio_canopy_area_si_age(io_si,cpatch%age_class) = hio_canopy_area_si_age(io_si,cpatch%age_class) & + + ccohort%c_area/AREA + ! Update biomass components hio_bleaf_pa(io_pa) = hio_bleaf_pa(io_pa) + n_density * ccohort%bl * 1.e3_r8 hio_bstore_pa(io_pa) = hio_bstore_pa(io_pa) + n_density * ccohort%bstore * 1.e3_r8 @@ -1103,6 +1108,12 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_ncl_si_age(io_si, ipa2) = 0._r8 endif end do + + ! pass the cohort termination mortality as a flux to the history, and then reset the termination mortality buffer + do i_scpf = 1, nlevsclass_ed * mxpft + hio_m6_si_scpf(io_si,i_scpf) = sites(s)%terminated_nindivs(i_scpf) * yeardays + end do + sites(s)%terminated_nindivs(:) = 0._r8 enddo ! site loop @@ -1770,6 +1781,11 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m5_si_scpf ) + call this%set_history_var(vname='M6_SCPF', units = 'N/ha/yr', & + long='termination mortality count by patch and pft/size',use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m6_si_scpf ) + call this%set_history_var(vname='M3_CANOPY_SCPF', units = 'N/ha/yr', & long='carbon starvation mortality of canopy plants count by patch and pft/size', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & From c5f9e016990378e00a0c96a4d14521f86428d10d Mon Sep 17 00:00:00 2001 From: Ben Andre Date: Wed, 8 Feb 2017 15:06:16 -0700 Subject: [PATCH 320/437] Check fates parameter dimensions when reading from file. Automatically check the number of dimensions and their names when reading fates parameters from the file. Compare the data on file against what is expected by the code. Test suite: ed - yellowstone gnu, intel, pgi Test baseline: a651a4f Test namelist changes: add fates_paramfile Test answer changes: bit for bit Test summary: all tests pass --- main/FatesParametersInterface.F90 | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/main/FatesParametersInterface.F90 b/main/FatesParametersInterface.F90 index cfebf64f..5da9bd7e 100644 --- a/main/FatesParametersInterface.F90 +++ b/main/FatesParametersInterface.F90 @@ -315,7 +315,7 @@ subroutine SetDimensionSizes(this, is_host_file, num_used_dimensions, dimension_ end subroutine SetDimensionSizes !----------------------------------------------------------------------- - subroutine GetMetaData(this, index, name, dimension_shape, dimension_sizes, is_host_param) + subroutine GetMetaData(this, index, name, dimension_shape, dimension_sizes, dimension_names, is_host_param) implicit none @@ -324,11 +324,13 @@ subroutine GetMetaData(this, index, name, dimension_shape, dimension_sizes, is_h character(len=param_string_length), intent(out) :: name integer, intent(out) :: dimension_shape integer, intent(out) :: dimension_sizes(max_dimensions) + character(len=param_string_length), intent(out) :: dimension_names(max_dimensions) logical, intent(out) :: is_host_param name = this%parameters(index)%name dimension_shape = this%parameters(index)%dimension_shape dimension_sizes = this%parameters(index)%dimension_sizes + dimension_names = this%parameters(index)%dimension_names is_host_param = this%parameters(index)%sync_with_host end subroutine GetMetaData From df550ccecade2be62faf91469d64457327874451 Mon Sep 17 00:00:00 2001 From: ckoven Date: Thu, 9 Feb 2017 13:20:29 -0800 Subject: [PATCH 321/437] added a recruitment rate variable to history so that we can ensure conservation of individuals --- biogeochem/EDPhysiologyMod.F90 | 3 +++ main/EDInitMod.F90 | 3 ++- main/EDTypesMod.F90 | 5 +++-- main/FatesHistoryInterfaceMod.F90 | 15 ++++++++++++++- 4 files changed, 22 insertions(+), 4 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index c127a0b5..273625b4 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1072,6 +1072,9 @@ subroutine recruitment( t, currentSite, currentPatch ) 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) + + ! keep track of how many individuals were recruited for passing to history + currentPatch%siteptr%recruitment_rate(ft) = currentPatch%siteptr%recruitment_rate(ft) + temp_cohort%n endif enddo !pft loop diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 53576224..082942fc 100755 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -79,8 +79,9 @@ subroutine zero_site( site_in ) site_in%fates_to_bgc_this_ts = 0.0_r8 site_in%fates_to_bgc_last_ts = 0.0_r8 - ! termination info + ! termination and recruitment info site_in%terminated_nindivs(:) = 0._r8 + site_in%recruitment_rate(:) = 0._r8 end subroutine zero_site diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 19b2cf63..400ae2bb 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -67,7 +67,7 @@ module EDTypesMod integer , parameter :: N_DBH_BINS = 5 ! no. of dbh bins used when comparing patches - real(r8), parameter :: min_npm2 = 1.0d-5 ! minimum cohort number density per m2 before termination + real(r8), parameter :: min_npm2 = 1.0d-5 ! minimum cohort number density per m2 before termintion real(r8), parameter :: min_patch_area = 0.001_r8 ! smallest allowable patch area before termination real(r8), parameter :: min_nppatch = 1.0d-8 ! minimum number of cohorts per patch (min_npm2*min_patch_area) real(r8), parameter :: min_n_safemath = 1.0d-15 ! in some cases, we want to immediately remove super small @@ -558,8 +558,9 @@ module EDTypesMod real(r8) :: cwd_ag_burned(ncwd) real(r8) :: leaf_litter_burned(numpft_ed) - ! TERMINATION + ! TERMINATION AND RECRUITMENT real(r8) :: terminated_nindivs(1:nlevsclass_ed*mxpft) ! number of individuals that were in cohorts which were terminated this timestep on scpf array + real(r8) :: recruitment_rate(1:mxpft) ! number of individuals that were recruited into new cohorts end type ed_site_type diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 8735697b..144178c5 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -145,6 +145,7 @@ module FatesHistoryInterfaceMod integer, private :: ih_leafbiomass_si_pft integer, private :: ih_storebiomass_si_pft integer, private :: ih_nindivs_si_pft + integer, private :: ih_recruitment_si_pft ! indices to (site x patch-age) variables @@ -750,7 +751,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) integer :: lb1,ub1,lb2,ub2 ! IO array bounds for the calling thread integer :: ivar ! index of IO variable object vector integer :: ft ! functional type index - integer :: i_scpf ! iterator for scpf dim + integer :: i_scpf,i_pft ! iterators for scpf and pft dims real(r8) :: n_density ! individual of cohort per m2. real(r8) :: n_perm2 ! individuals per m2 for the whole column @@ -775,6 +776,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_leafbiomass_si_pft => this%hvars(ih_leafbiomass_si_pft)%r82d, & hio_storebiomass_si_pft => this%hvars(ih_storebiomass_si_pft)%r82d, & hio_nindivs_si_pft => this%hvars(ih_nindivs_si_pft)%r82d, & + hio_recruitment_si_pft => this%hvars(ih_recruitment_si_pft)%r82d, & hio_nesterov_fire_danger_pa => this%hvars(ih_nesterov_fire_danger_pa)%r81d, & hio_spitfire_ros_pa => this%hvars(ih_spitfire_ROS_pa)%r81d, & hio_tfc_ros_pa => this%hvars(ih_TFC_ROS_pa)%r81d, & @@ -1114,6 +1116,12 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_m6_si_scpf(io_si,i_scpf) = sites(s)%terminated_nindivs(i_scpf) * yeardays end do sites(s)%terminated_nindivs(:) = 0._r8 + + ! pass the recruitment rate as a flux to the history, and then reset the recruitment buffer + do i_pft = 1, mxpft + hio_recruitment_si_pft(io_si,i_pft) = sites(s)%recruitment_rate(i_pft) * yeardays + end do + sites(s)%recruitment_rate(:) = 0._r8 enddo ! site loop @@ -1443,6 +1451,11 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_nindivs_si_pft ) + call this%set_history_var(vname='RECRUITMENT', units='indiv/ha/yr', & + long='Rate of recruitment by PFT', use_default='active', & + avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_recruitment_si_pft ) + ! patch age class variables call this%set_history_var(vname='PATCH_AREA_BY_AGE', units='m2/m2', & long='patch area by age bin', use_default='active', & From b2509eeb9c55276a4b856ed78a0a6f1c5aace781 Mon Sep 17 00:00:00 2001 From: ckoven Date: Thu, 9 Feb 2017 15:06:25 -0800 Subject: [PATCH 322/437] cleanup, new default-on scls summary vars, and aggregation of canopy/understory scpf mortality rates --- biogeochem/EDCohortDynamicsMod.F90 | 10 ++- main/EDInitMod.F90 | 2 +- main/EDTypesMod.F90 | 6 +- main/FatesHistoryInterfaceMod.F90 | 127 +++++++++++++++++++++++------ 4 files changed, 112 insertions(+), 33 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 79da24d3..edbfdd34 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -498,6 +498,7 @@ subroutine terminate_cohorts( patchptr ) type (ed_cohort_type) , pointer :: nextc integer :: terminate ! do we terminate (1) or not (0) integer :: c ! counter for litter size class. + integer :: levcan ! canopy level !---------------------------------------------------------------------- currentPatch => patchptr @@ -560,8 +561,13 @@ subroutine terminate_cohorts( patchptr ) if (terminate == 1) then ! preserve a record of the to-be-terminated cohort for mortality accounting - currentPatch%siteptr%terminated_nindivs(currentCohort%size_by_pft_class) = & - currentPatch%siteptr%terminated_nindivs(currentCohort%size_by_pft_class) + currentCohort%n + if (currentCohort%canopy_layer .eq. 1) then + levcan = 1 + else + levcan = 2 + endif + currentPatch%siteptr%terminated_nindivs(currentCohort%size_class,currentCohort%pft,levcan) = & + currentPatch%siteptr%terminated_nindivs(currentCohort%size_class,currentCohort%pft,levcan) + currentCohort%n if (.not. associated(currentCohort%taller)) then currentPatch%tallest => currentCohort%shorter diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 082942fc..a9b9a987 100755 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -80,7 +80,7 @@ subroutine zero_site( site_in ) site_in%fates_to_bgc_last_ts = 0.0_r8 ! termination and recruitment info - site_in%terminated_nindivs(:) = 0._r8 + site_in%terminated_nindivs(:,:,:) = 0._r8 site_in%recruitment_rate(:) = 0._r8 end subroutine zero_site diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 400ae2bb..48eeb96c 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -67,7 +67,7 @@ module EDTypesMod integer , parameter :: N_DBH_BINS = 5 ! no. of dbh bins used when comparing patches - real(r8), parameter :: min_npm2 = 1.0d-5 ! minimum cohort number density per m2 before termintion + real(r8), parameter :: min_npm2 = 1.0d-5 ! minimum cohort number density per m2 before termination real(r8), parameter :: min_patch_area = 0.001_r8 ! smallest allowable patch area before termination real(r8), parameter :: min_nppatch = 1.0d-8 ! minimum number of cohorts per patch (min_npm2*min_patch_area) real(r8), parameter :: min_n_safemath = 1.0d-15 ! in some cases, we want to immediately remove super small @@ -558,8 +558,8 @@ module EDTypesMod real(r8) :: cwd_ag_burned(ncwd) real(r8) :: leaf_litter_burned(numpft_ed) - ! TERMINATION AND RECRUITMENT - real(r8) :: terminated_nindivs(1:nlevsclass_ed*mxpft) ! number of individuals that were in cohorts which were terminated this timestep on scpf array + ! TERMINATION AND RECRUITMENT~ + real(r8) :: terminated_nindivs(1:nlevsclass_ed,1:mxpft,2) ! number of individuals that were in cohorts which were terminated this timestep, on size x pft x canopy array. real(r8) :: recruitment_rate(1:mxpft) ! number of individuals that were recruited into new cohorts end type ed_site_type diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 144178c5..8c8702e7 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -109,8 +109,8 @@ module FatesHistoryInterfaceMod integer, private :: ih_bstor_understory_si_scpf integer, private :: ih_bleaf_canopy_si_scpf integer, private :: ih_bleaf_understory_si_scpf - integer, private :: ih_m3_canopy_si_scpf - integer, private :: ih_m3_understory_si_scpf + integer, private :: ih_mortality_canopy_si_scpf + integer, private :: ih_mortality_understory_si_scpf integer, private :: ih_nplant_canopy_si_scpf integer, private :: ih_nplant_understory_si_scpf integer, private :: ih_ddbh_canopy_si_scpf @@ -139,6 +139,10 @@ module FatesHistoryInterfaceMod ! indices to (site x scls) variables integer, private :: ih_ba_si_scls + integer, private :: ih_nplant_canopy_si_scls + integer, private :: ih_nplant_understory_si_scls + integer, private :: ih_mortality_canopy_si_scls + integer, private :: ih_mortality_understory_si_scls ! indices to (site x pft) variables integer, private :: ih_biomass_si_pft @@ -146,6 +150,7 @@ module FatesHistoryInterfaceMod integer, private :: ih_storebiomass_si_pft integer, private :: ih_nindivs_si_pft integer, private :: ih_recruitment_si_pft + integer, private :: ih_mortality_si_pft ! indices to (site x patch-age) variables @@ -751,7 +756,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) integer :: lb1,ub1,lb2,ub2 ! IO array bounds for the calling thread integer :: ivar ! index of IO variable object vector integer :: ft ! functional type index - integer :: i_scpf,i_pft ! iterators for scpf and pft dims + integer :: i_scpf,i_pft,i_scls ! iterators for scpf, pft, and scls dims real(r8) :: n_density ! individual of cohort per m2. real(r8) :: n_perm2 ! individuals per m2 for the whole column @@ -777,6 +782,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_storebiomass_si_pft => this%hvars(ih_storebiomass_si_pft)%r82d, & hio_nindivs_si_pft => this%hvars(ih_nindivs_si_pft)%r82d, & hio_recruitment_si_pft => this%hvars(ih_recruitment_si_pft)%r82d, & + hio_mortality_si_pft => this%hvars(ih_mortality_si_pft)%r82d, & hio_nesterov_fire_danger_pa => this%hvars(ih_nesterov_fire_danger_pa)%r81d, & hio_spitfire_ros_pa => this%hvars(ih_spitfire_ROS_pa)%r81d, & hio_tfc_ros_pa => this%hvars(ih_TFC_ROS_pa)%r81d, & @@ -814,8 +820,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_bstor_understory_si_scpf => this%hvars(ih_bstor_understory_si_scpf)%r82d, & hio_bleaf_canopy_si_scpf => this%hvars(ih_bleaf_canopy_si_scpf)%r82d, & hio_bleaf_understory_si_scpf => this%hvars(ih_bleaf_understory_si_scpf)%r82d, & - hio_m3_canopy_si_scpf => this%hvars(ih_m3_canopy_si_scpf)%r82d, & - hio_m3_understory_si_scpf => this%hvars(ih_m3_understory_si_scpf)%r82d, & + hio_mortality_canopy_si_scpf => this%hvars(ih_mortality_canopy_si_scpf)%r82d, & + hio_mortality_understory_si_scpf => this%hvars(ih_mortality_understory_si_scpf)%r82d, & hio_nplant_canopy_si_scpf => this%hvars(ih_nplant_canopy_si_scpf)%r82d, & hio_nplant_understory_si_scpf => this%hvars(ih_nplant_understory_si_scpf)%r82d, & hio_ddbh_canopy_si_scpf => this%hvars(ih_ddbh_canopy_si_scpf)%r82d, & @@ -834,6 +840,10 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_m5_si_scpf => this%hvars(ih_m5_si_scpf)%r82d, & hio_m6_si_scpf => this%hvars(ih_m6_si_scpf)%r82d, & hio_ba_si_scls => this%hvars(ih_ba_si_scls)%r82d, & + hio_nplant_canopy_si_scls => this%hvars(ih_nplant_canopy_si_scls)%r82d, & + hio_nplant_understory_si_scls => this%hvars(ih_nplant_understory_si_scls)%r82d, & + hio_mortality_canopy_si_scls => this%hvars(ih_mortality_canopy_si_scls)%r82d, & + hio_mortality_understory_si_scls => this%hvars(ih_mortality_understory_si_scls)%r82d, & hio_area_si_age => this%hvars(ih_area_si_age)%r82d, & hio_lai_si_age => this%hvars(ih_lai_si_age)%r82d, & hio_canopy_area_si_age => this%hvars(ih_canopy_area_si_age)%r82d, & @@ -1018,14 +1028,16 @@ subroutine update_history_dyn(this,nc,nsites,sites) ccohort%ddbhdt*n_perm2*AREA end if - ! update SCPF- and canopy/subcanopy- partitioned quantities + ! update SCPF/SCLS- and canopy/subcanopy- partitioned quantities if (ccohort%canopy_layer .eq. 1) then hio_bstor_canopy_si_scpf(io_si,scpf) = hio_bstor_canopy_si_scpf(io_si,scpf) + & ccohort%bstore * n_perm2 * AREA hio_bleaf_canopy_si_scpf(io_si,scpf) = hio_bleaf_canopy_si_scpf(io_si,scpf) + & ccohort%bl * n_perm2 * AREA - hio_m3_canopy_si_scpf(io_si,scpf) = hio_m3_canopy_si_scpf(io_si,scpf) + ccohort%cmort*n_perm2*AREA + hio_mortality_canopy_si_scpf(io_si,scpf) = hio_mortality_canopy_si_scpf(io_si,scpf)+ & + (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%imort + ccohort%fmort) * n_perm2*AREA hio_nplant_canopy_si_scpf(io_si,scpf) = hio_nplant_canopy_si_scpf(io_si,scpf) + AREA*n_perm2 + hio_nplant_canopy_si_scls(io_si,scls) = hio_nplant_canopy_si_scls(io_si,scls) + AREA*n_perm2 hio_gpp_canopy_si_scpf(io_si,scpf) = hio_gpp_canopy_si_scpf(io_si,scpf) + & n_perm2*ccohort%gpp_acc_hold hio_ar_canopy_si_scpf(io_si,scpf) = hio_ar_canopy_si_scpf(io_si,scpf) + & @@ -1033,13 +1045,18 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! growth increment hio_ddbh_canopy_si_scpf(io_si,scpf) = hio_ddbh_canopy_si_scpf(io_si,scpf) + & ccohort%ddbhdt*n_perm2*AREA + ! sum of all mortality + hio_mortality_canopy_si_scls(io_si,scls) = hio_mortality_canopy_si_scls(io_si,scls) + & + (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%imort + ccohort%fmort) * n_perm2*AREA else hio_bstor_understory_si_scpf(io_si,scpf) = hio_bstor_understory_si_scpf(io_si,scpf) + & ccohort%bstore * n_perm2 * AREA hio_bleaf_understory_si_scpf(io_si,scpf) = hio_bleaf_understory_si_scpf(io_si,scpf) + & ccohort%bl * n_perm2 * AREA - hio_m3_understory_si_scpf(io_si,scpf) = hio_m3_understory_si_scpf(io_si,scpf) + ccohort%cmort*n_perm2*AREA + hio_mortality_understory_si_scpf(io_si,scpf) = hio_mortality_understory_si_scpf(io_si,scpf)+ & + (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%imort + ccohort%fmort) * n_perm2*AREA hio_nplant_understory_si_scpf(io_si,scpf) = hio_nplant_understory_si_scpf(io_si,scpf) + AREA*n_perm2 + hio_nplant_understory_si_scls(io_si,scls) = hio_nplant_understory_si_scls(io_si,scls) + AREA*n_perm2 hio_gpp_understory_si_scpf(io_si,scpf) = hio_gpp_understory_si_scpf(io_si,scpf) + & n_perm2*ccohort%gpp_acc_hold hio_ar_understory_si_scpf(io_si,scpf) = hio_ar_understory_si_scpf(io_si,scpf) + & @@ -1047,6 +1064,9 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! growth increment hio_ddbh_understory_si_scpf(io_si,scpf) = hio_ddbh_understory_si_scpf(io_si,scpf) + & ccohort%ddbhdt*n_perm2*AREA + ! sum of all mortality + hio_mortality_understory_si_scls(io_si,scls) = hio_mortality_understory_si_scls(io_si,scls) + & + (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%imort + ccohort%fmort) * n_perm2*AREA endif end associate @@ -1112,16 +1132,43 @@ subroutine update_history_dyn(this,nc,nsites,sites) end do ! pass the cohort termination mortality as a flux to the history, and then reset the termination mortality buffer - do i_scpf = 1, nlevsclass_ed * mxpft - hio_m6_si_scpf(io_si,i_scpf) = sites(s)%terminated_nindivs(i_scpf) * yeardays + ! note there are various ways of reporting the total mortality, so pass to these as well + do i_pft = 1, mxpft + do i_scls = 1,nlevsclass_ed + hio_m6_si_scpf(io_si,(i_pft-1)*nlevsclass_ed + i_scls) = (sites(s)%terminated_nindivs(i_pft,i_scls,1) + & + sites(s)%terminated_nindivs(i_scls,i_pft,2)) * yeardays + hio_mortality_canopy_si_scls(io_si,i_pft) = hio_mortality_canopy_si_scls(io_si,i_pft) + & + sites(s)%terminated_nindivs(i_scls,i_pft,1) * yeardays + hio_mortality_understory_si_scls(io_si,i_pft) = hio_mortality_understory_si_scls(io_si,i_pft) + & + sites(s)%terminated_nindivs(i_scls,i_pft,2) * yeardays + hio_mortality_canopy_si_scpf(io_si,(i_pft-1)*nlevsclass_ed + i_scls) = & + hio_mortality_canopy_si_scpf(io_si,(i_pft-1)*nlevsclass_ed + i_scls) + & + sites(s)%terminated_nindivs(i_scls,i_pft,1) * yeardays + hio_mortality_understory_si_scpf(io_si,(i_pft-1)*nlevsclass_ed + i_scls) = & + hio_mortality_understory_si_scpf(io_si,(i_pft-1)*nlevsclass_ed + i_scls) + & + sites(s)%terminated_nindivs(i_scls,i_pft,2) * yeardays + end do end do - sites(s)%terminated_nindivs(:) = 0._r8 + sites(s)%terminated_nindivs(:,:,:) = 0._r8 ! pass the recruitment rate as a flux to the history, and then reset the recruitment buffer do i_pft = 1, mxpft hio_recruitment_si_pft(io_si,i_pft) = sites(s)%recruitment_rate(i_pft) * yeardays end do sites(s)%recruitment_rate(:) = 0._r8 + + ! summarize all of the mortality fluxes by PFT + do i_pft = 1, mxpft + do i_scls = 1,nlevsclass_ed + hio_mortality_si_pft(io_si,i_pft) = hio_mortality_si_pft(io_si,i_pft) + & + hio_m1_si_scpf(io_si,(i_pft-1)*nlevsclass_ed + i_scls) + & + hio_m2_si_scpf(io_si,(i_pft-1)*nlevsclass_ed + i_scls) + & + hio_m3_si_scpf(io_si,(i_pft-1)*nlevsclass_ed + i_scls) + & + hio_m4_si_scpf(io_si,(i_pft-1)*nlevsclass_ed + i_scls) + & + hio_m5_si_scpf(io_si,(i_pft-1)*nlevsclass_ed + i_scls) + & + hio_m6_si_scpf(io_si,(i_pft-1)*nlevsclass_ed + i_scls) + end do + end do enddo ! site loop @@ -1456,6 +1503,11 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_recruitment_si_pft ) + call this%set_history_var(vname='MORTALITY', units='indiv/ha/yr', & + long='Rate of total mortality by PFT', use_default='active', & + avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_mortality_si_pft ) + ! patch age class variables call this%set_history_var(vname='PATCH_AREA_BY_AGE', units='m2/m2', & long='patch area by age bin', use_default='active', & @@ -1770,47 +1822,47 @@ subroutine define_history_vars(this, initialize_variables) upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_si_scpf ) call this%set_history_var(vname='M1_SCPF', units = 'N/ha/yr', & - long='background mortality count by patch and pft/size', use_default='inactive', & + long='background mortality by patch and pft/size', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m1_si_scpf ) call this%set_history_var(vname='M2_SCPF', units = 'N/ha/yr', & - long='hydraulic mortality count by patch and pft/size',use_default='inactive', & + long='hydraulic mortality by patch and pft/size',use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m2_si_scpf ) call this%set_history_var(vname='M3_SCPF', units = 'N/ha/yr', & - long='carbon starvation mortality count by patch and pft/size', use_default='inactive', & + long='carbon starvation mortality by patch and pft/size', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m3_si_scpf ) call this%set_history_var(vname='M4_SCPF', units = 'N/ha/yr', & - long='impact mortality count by patch and pft/size',use_default='inactive', & + long='impact mortality by patch and pft/size',use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m4_si_scpf ) call this%set_history_var(vname='M5_SCPF', units = 'N/ha/yr', & - long='fire mortality count by patch and pft/size',use_default='inactive', & + long='fire mortality by patch and pft/size',use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m5_si_scpf ) call this%set_history_var(vname='M6_SCPF', units = 'N/ha/yr', & - long='termination mortality count by patch and pft/size',use_default='inactive', & + long='termination mortality by patch and pft/size',use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m6_si_scpf ) - call this%set_history_var(vname='M3_CANOPY_SCPF', units = 'N/ha/yr', & - long='carbon starvation mortality of canopy plants count by patch and pft/size', use_default='inactive', & + call this%set_history_var(vname='MORTALITY_CANOPY_SCPF', units = 'N/ha/yr', & + long='total mortality of canopy plants by patch and pft/size', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m3_canopy_si_scpf ) + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_mortality_canopy_si_scpf ) call this%set_history_var(vname='BSTOR_CANOPY_SCPF', units = 'kgC/ha', & - long='biomass carbon in storage pools of canopy plants count by patch and pft/size', use_default='inactive', & + long='biomass carbon in storage pools of canopy plants by patch and pft/size', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_bstor_canopy_si_scpf ) call this%set_history_var(vname='BLEAF_CANOPY_SCPF', units = 'kgC/ha', & - long='biomass carbon in leaf of canopy plants count by patch and pft/size', use_default='inactive', & + long='biomass carbon in leaf of canopy plants by patch and pft/size', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_bleaf_canopy_si_scpf ) @@ -1819,18 +1871,18 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_canopy_si_scpf ) - call this%set_history_var(vname='M3_UNDERSTORY_SCPF', units = 'N/ha/yr', & - long='carbon starvation mortality of understory plants count by patch and pft/size', use_default='inactive', & + call this%set_history_var(vname='MORTALITY_UNDERSTORY_SCPF', units = 'N/ha/yr', & + long='total mortality of understory plants by patch and pft/size', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m3_understory_si_scpf ) + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_mortality_understory_si_scpf ) call this%set_history_var(vname='BSTOR_UNDERSTORY_SCPF', units = 'kgC/ha', & - long='biomass carbon in storage pools of understory plants count by patch and pft/size', use_default='inactive', & + long='biomass carbon in storage pools of understory plants by patch and pft/size', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_bstor_understory_si_scpf ) call this%set_history_var(vname='BLEAF_UNDERSTORY_SCPF', units = 'kgC/ha', & - long='biomass carbon in leaf of understory plants count by patch and pft/size', use_default='inactive', & + long='biomass carbon in leaf of understory plants by patch and pft/size', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_bleaf_understory_si_scpf ) @@ -1883,6 +1935,27 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ba_si_scls ) + call this%set_history_var(vname='NPLANT_CANOPY_SCLS', units = 'indiv/ha', & + long='number of canopy plants by size class', use_default='active', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_canopy_si_scls ) + + call this%set_history_var(vname='MORTALITY_CANOPY_SCLS', units = 'indiv/ha/yr', & + long='total mortality of canopy trees by size class', use_default='active', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_mortality_canopy_si_scls ) + + call this%set_history_var(vname='NPLANT_UNDERSTORY_SCLS', units = 'indiv/ha', & + long='number of understory plants by size class', use_default='active', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_understory_si_scls ) + + call this%set_history_var(vname='MORTALITY_UNDERSTORY_SCLS', units = 'indiv/ha/yr', & + long='total mortality of understory trees by size class', use_default='active', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_mortality_understory_si_scls ) + + ! CARBON BALANCE VARIABLES THAT DEPEND ON HLM BGC INPUTS call this%set_history_var(vname='NEP', units='gC/m^2/s', & From 7730bc137fcf37645462850443ca84c380d41625 Mon Sep 17 00:00:00 2001 From: ckoven Date: Thu, 9 Feb 2017 16:04:02 -0800 Subject: [PATCH 323/437] turned off seed homogenization --- main/EDTypesMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 48eeb96c..79386f3e 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -77,7 +77,7 @@ module EDTypesMod character*4 yearchar ! special mode to cause PFTs to create seed mass of all currently-existing PFTs - logical, parameter :: homogenize_seed_pfts = .true. + logical, parameter :: homogenize_seed_pfts = .false. !the lower limit of the size classes of ED cohorts !0-10,10-20... From 5a34ab826769dd4db7c56c5f8da925ec046293ac Mon Sep 17 00:00:00 2001 From: ckoven Date: Thu, 9 Feb 2017 19:41:32 -0800 Subject: [PATCH 324/437] indexing bugfix --- main/FatesHistoryInterfaceMod.F90 | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 8c8702e7..b2634f13 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -1135,17 +1135,16 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! note there are various ways of reporting the total mortality, so pass to these as well do i_pft = 1, mxpft do i_scls = 1,nlevsclass_ed - hio_m6_si_scpf(io_si,(i_pft-1)*nlevsclass_ed + i_scls) = (sites(s)%terminated_nindivs(i_pft,i_scls,1) + & + i_scpf = (i_pft-1)*nlevsclass_ed + i_scls + hio_m6_si_scpf(io_si,i_scpf) = (sites(s)%terminated_nindivs(i_pft,i_scls,1) + & sites(s)%terminated_nindivs(i_scls,i_pft,2)) * yeardays - hio_mortality_canopy_si_scls(io_si,i_pft) = hio_mortality_canopy_si_scls(io_si,i_pft) + & + hio_mortality_canopy_si_scls(io_si,i_scls) = hio_mortality_canopy_si_scls(io_si,i_scls) + & sites(s)%terminated_nindivs(i_scls,i_pft,1) * yeardays - hio_mortality_understory_si_scls(io_si,i_pft) = hio_mortality_understory_si_scls(io_si,i_pft) + & + hio_mortality_understory_si_scls(io_si,i_scls) = hio_mortality_understory_si_scls(io_si,i_scls) + & sites(s)%terminated_nindivs(i_scls,i_pft,2) * yeardays - hio_mortality_canopy_si_scpf(io_si,(i_pft-1)*nlevsclass_ed + i_scls) = & - hio_mortality_canopy_si_scpf(io_si,(i_pft-1)*nlevsclass_ed + i_scls) + & + hio_mortality_canopy_si_scpf(io_si,i_scpf) = hio_mortality_canopy_si_scpf(io_si,i_scpf) + & sites(s)%terminated_nindivs(i_scls,i_pft,1) * yeardays - hio_mortality_understory_si_scpf(io_si,(i_pft-1)*nlevsclass_ed + i_scls) = & - hio_mortality_understory_si_scpf(io_si,(i_pft-1)*nlevsclass_ed + i_scls) + & + hio_mortality_understory_si_scpf(io_si,i_scpf) = hio_mortality_understory_si_scpf(io_si,i_scpf) + & sites(s)%terminated_nindivs(i_scls,i_pft,2) * yeardays end do end do @@ -1160,13 +1159,14 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! summarize all of the mortality fluxes by PFT do i_pft = 1, mxpft do i_scls = 1,nlevsclass_ed + i_scpf = (i_pft-1)*nlevsclass_ed + i_scls hio_mortality_si_pft(io_si,i_pft) = hio_mortality_si_pft(io_si,i_pft) + & - hio_m1_si_scpf(io_si,(i_pft-1)*nlevsclass_ed + i_scls) + & - hio_m2_si_scpf(io_si,(i_pft-1)*nlevsclass_ed + i_scls) + & - hio_m3_si_scpf(io_si,(i_pft-1)*nlevsclass_ed + i_scls) + & - hio_m4_si_scpf(io_si,(i_pft-1)*nlevsclass_ed + i_scls) + & - hio_m5_si_scpf(io_si,(i_pft-1)*nlevsclass_ed + i_scls) + & - hio_m6_si_scpf(io_si,(i_pft-1)*nlevsclass_ed + i_scls) + hio_m1_si_scpf(io_si,i_scpf) + & + hio_m2_si_scpf(io_si,i_scpf) + & + hio_m3_si_scpf(io_si,i_scpf) + & + hio_m4_si_scpf(io_si,i_scpf) + & + hio_m5_si_scpf(io_si,i_scpf) + & + hio_m6_si_scpf(io_si,i_scpf) end do end do From 9f3d6a68b4bc42e7cae5049b5ae5aaa21f1f949f Mon Sep 17 00:00:00 2001 From: Ben Andre Date: Thu, 9 Feb 2017 16:13:19 -0700 Subject: [PATCH 325/437] Dynamic allocation of fates pft parameters. Dynamically allocate pft parameters based on the input data size from the parameter file instead of a hard coded dimension size.. Test suite: ed - yellowstone gnu, intel, pgi - hobart nag Test baseline: a651a4f Test namelist changes: add fates_paramfile Test answer changes: bit for bit Test summary: all tests pass. Test suite: clm_short - yellowstone gnu, intel, pgi Test baseline: clm4_5_12_r195 Test namelist changes: none Test answer changes: bit for bit Test summary: all tests pass. --- main/EDPftvarcon.F90 | 431 +++++++++++++++--------------- main/FatesParametersInterface.F90 | 70 ++++- 2 files changed, 286 insertions(+), 215 deletions(-) diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index c9f42e7b..b5eb1ff9 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -16,59 +16,62 @@ module EDPftvarcon save private + integer, parameter, public :: lower_bound_pft = 0 + integer, parameter, public :: lower_bound_general = 1 + !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 - real(r8) :: dbh2h_m (0:mxpft) ! allocation parameter m from dbh to height - real(r8) :: woody(0:mxpft) - real(r8) :: stress_decid(0:mxpft) - real(r8) :: season_decid(0:mxpft) - real(r8) :: evergreen(0:mxpft) - real(r8) :: froot_leaf(0:mxpft) - real(r8) :: slatop(0:mxpft) - real(r8) :: leaf_long(0:mxpft) - real(r8) :: rootprof_beta(0:mxpft,nvariants) - real(r8) :: roota_par(0:mxpft) - real(r8) :: rootb_par(0:mxpft) - real(r8) :: lf_flab(0:mxpft) - real(r8) :: lf_fcel(0:mxpft) - real(r8) :: lf_flig(0:mxpft) - real(r8) :: fr_flab(0:mxpft) - real(r8) :: fr_fcel(0:mxpft) - real(r8) :: fr_flig(0:mxpft) - real(r8) :: rhol(0:mxpft, numrad) - real(r8) :: rhos(0:mxpft, numrad) - real(r8) :: taul(0:mxpft, numrad) - real(r8) :: taus(0:mxpft, numrad) - real(r8) :: xl(0:mxpft) - real(r8) :: c3psn(0:mxpft) - real(r8) :: flnr(0:mxpft) - real(r8) :: fnitr(0:mxpft) - real(r8) :: leafcn(0:mxpft) - real(r8) :: frootcn(0:mxpft) - real(r8) :: smpso(0:mxpft) - real(r8) :: smpsc(0:mxpft) - real(r8) :: grperc(0:mxpft) ! NOTE(bja, 2017-01) moved from EDParamsMod, was allocated as (maxPft=79), not (0:mxpft=78)! + real(r8), allocatable :: max_dbh (:) ! maximum dbh at which height growth ceases... + real(r8), allocatable :: freezetol (:) ! minimum temperature tolerance... + real(r8), allocatable :: wood_density (:) ! wood density g cm^-3 ... + real(r8), allocatable :: alpha_stem (:) ! live stem turnover rate. y-1 + real(r8), allocatable :: hgt_min (:) ! sapling height m + real(r8), allocatable :: cushion (:) ! labile carbon storage target as multiple of leaf pool. + real(r8), allocatable :: leaf_stor_priority (:) ! leaf turnover vs labile carbon use prioritisation. (1 = lose leaves, 0 = use store). + real(r8), allocatable :: leafwatermax (:) ! degree to which respiration is limited by btran if btran = 0 + real(r8), allocatable :: rootresist (:) + real(r8), allocatable :: soilbeta (:) + real(r8), allocatable :: crown (:) + real(r8), allocatable :: bark_scaler (:) + real(r8), allocatable :: crown_kill (:) + real(r8), allocatable :: initd (:) + real(r8), allocatable :: sd_mort (:) + real(r8), allocatable :: seed_rain (:) + real(r8), allocatable :: BB_slope (:) + real(r8), allocatable :: root_long (:) ! root longevity (yrs) + real(r8), allocatable :: clone_alloc (:) ! fraction of carbon balance allocated to clonal reproduction. + real(r8), allocatable :: seed_alloc (:) ! fraction of carbon balance allocated to seeds. + real(r8), allocatable :: sapwood_ratio (:) ! amount of sapwood per unit leaf carbon and m of height. gC/gC/m + real(r8), allocatable :: dbh2h_m (:) ! allocation parameter m from dbh to height + real(r8), allocatable :: woody(:) + real(r8), allocatable :: stress_decid(:) + real(r8), allocatable :: season_decid(:) + real(r8), allocatable :: evergreen(:) + real(r8), allocatable :: froot_leaf(:) + real(r8), allocatable :: slatop(:) + real(r8), allocatable :: leaf_long(:) + real(r8), allocatable :: roota_par(:) + real(r8), allocatable :: rootb_par(:) + real(r8), allocatable :: lf_flab(:) + real(r8), allocatable :: lf_fcel(:) + real(r8), allocatable :: lf_flig(:) + real(r8), allocatable :: fr_flab(:) + real(r8), allocatable :: fr_fcel(:) + real(r8), allocatable :: fr_flig(:) + real(r8), allocatable :: xl(:) + real(r8), allocatable :: c3psn(:) + real(r8), allocatable :: flnr(:) + real(r8), allocatable :: fnitr(:) + real(r8), allocatable :: leafcn(:) + real(r8), allocatable :: frootcn(:) + real(r8), allocatable :: smpso(:) + real(r8), allocatable :: smpsc(:) + real(r8), allocatable :: grperc(:) ! NOTE(bja, 2017-01) moved from EDParamsMod, was allocated as (maxPft=79), not (0:mxpft=78)! + real(r8), allocatable :: rhol(:, :) + real(r8), allocatable :: rhos(:, :) + real(r8), allocatable :: taul(:, :) + real(r8), allocatable :: taus(:, :) + real(r8), allocatable :: rootprof_beta(:, :) contains procedure, public :: Init => EDpftconInit procedure, public :: Register @@ -102,59 +105,6 @@ subroutine EDpftconInit(this) class(EDPftvarcon_type), intent(inout) :: this - this%max_dbh(:) = nan - this%freezetol(:) = nan - this%wood_density(:) = nan - this%alpha_stem(:) = nan - this%hgt_min(:) = nan - this%cushion(:) = nan - this%leaf_stor_priority(:) = nan - this%leafwatermax(:) = nan - this%rootresist(:) = nan - this%soilbeta(:) = nan - this%crown(:) = nan - this%bark_scaler(:) = nan - this%crown_kill(:) = nan - this%initd(:) = nan - this%sd_mort(:) = nan - this%seed_rain(:) = nan - this%BB_slope(:) = nan - this%root_long(:) = nan - this%clone_alloc(:) = nan - this%seed_alloc(:) = nan - this%sapwood_ratio(:) = nan - this%dbh2h_m(:) = nan - this%woody(:) = nan - this%stress_decid(:) = nan - this%season_decid(:) = nan - this%evergreen(:) = nan - this%froot_leaf(:) = nan - this%slatop(:) = nan - this%leaf_long(:) = nan - this%roota_par(:) = nan - this%rootb_par(:) = nan - this%lf_flab(:) = nan - this%lf_fcel(:) = nan - this%lf_flig(:) = nan - this%fr_flab(:) = nan - this%fr_fcel(:) = nan - this%fr_flig(:) = nan - this%xl(:) = nan - this%c3psn(:) = nan - this%flnr(:) = nan - this%fnitr(:) = nan - this%leafcn(:) = nan - this%frootcn(:) = nan - this%smpso(:) = nan - this%smpsc(:) = nan - this%grperc(:) = nan - - this%rootprof_beta(:, :) = nan - this%rhol(:, :) = nan - this%rhos(:, :) = nan - this%taul(:, :) = nan - this%taus(:, :) = nan - end subroutine EDpftconInit !----------------------------------------------------------------------- @@ -202,191 +152,193 @@ subroutine Register_PFT(this, fates_params) character(len=param_string_length), parameter :: dim_names(1) = (/dimension_name_pft/) + integer, parameter :: dim_lower_bound(1) = (/ lower_bound_pft /) + character(len=param_string_length) :: name !X! name = '' !X! call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - !X! dimension_names=dim_names) + !X! dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'max_dbh' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names) + dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'freezetol' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names) + dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'wood_density' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names) + dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'alpha_stem' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names) + dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'hgt_min' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names) + dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'cushion' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names) + dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'leaf_stor_priority' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names) + dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'leafwatermax' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names) + dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'rootresist' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names) + dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'soilbeta' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names) + dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'crown' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names) + dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'bark_scaler' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names) + dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'crown_kill' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names) + dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'initd' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names) + dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'sd_mort' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names) + dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'seed_rain' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names) + dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'BB_slope' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names) + dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'root_long' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names) + dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'clone_alloc' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names) + dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'seed_alloc' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names) + dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'sapwood_ratio' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names) + dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'woody' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names) + dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'stress_decid' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names) + dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'season_decid' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names) + dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'evergreen' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names) + dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'froot_leaf' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names) + dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'slatop' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names) + dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'leaf_long' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names) + dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'roota_par' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names) + dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'rootb_par' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names) + dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'lf_flab' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names) + dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'lf_fcel' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names) + dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'lf_flig' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names) + dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'fr_flab' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names) + dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'fr_fcel' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names) + dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'fr_flig' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names) + dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'xl' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names) + dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'c3psn' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names) + dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'flnr' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names) + dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'fnitr' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names) + dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'leafcn' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names) + dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'frootcn' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names) + dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'smpso' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names) + dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'smpsc' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names) + dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'grperc' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names) + dimension_names=dim_names, lower_bounds=dim_lower_bound) end subroutine Register_PFT @@ -408,190 +360,193 @@ subroutine Receive_PFT(this, fates_params) !X! data=this%) name = 'max_dbh' - call fates_params%RetreiveParameter(name=name, & + call fates_params%RetreiveParameterAllocate(name=name, & data=this%max_dbh) name = 'freezetol' - call fates_params%RetreiveParameter(name=name, & + call fates_params%RetreiveParameterAllocate(name=name, & data=this%freezetol) name = 'wood_density' - call fates_params%RetreiveParameter(name=name, & + call fates_params%RetreiveParameterAllocate(name=name, & data=this%wood_density) name = 'alpha_stem' - call fates_params%RetreiveParameter(name=name, & + call fates_params%RetreiveParameterAllocate(name=name, & data=this%alpha_stem) name = 'hgt_min' - call fates_params%RetreiveParameter(name=name, & + call fates_params%RetreiveParameterAllocate(name=name, & data=this%hgt_min) name = 'cushion' - call fates_params%RetreiveParameter(name=name, & + call fates_params%RetreiveParameterAllocate(name=name, & data=this%cushion) name = 'leaf_stor_priority' - call fates_params%RetreiveParameter(name=name, & + call fates_params%RetreiveParameterAllocate(name=name, & data=this%leaf_stor_priority) name = 'leafwatermax' - call fates_params%RetreiveParameter(name=name, & + call fates_params%RetreiveParameterAllocate(name=name, & data=this%leafwatermax) name = 'rootresist' - call fates_params%RetreiveParameter(name=name, & + call fates_params%RetreiveParameterAllocate(name=name, & data=this%rootresist) name = 'soilbeta' - call fates_params%RetreiveParameter(name=name, & + call fates_params%RetreiveParameterAllocate(name=name, & data=this%soilbeta) name = 'crown' - call fates_params%RetreiveParameter(name=name, & + call fates_params%RetreiveParameterAllocate(name=name, & data=this%crown) name = 'bark_scaler' - call fates_params%RetreiveParameter(name=name, & + call fates_params%RetreiveParameterAllocate(name=name, & data=this%bark_scaler) name = 'crown_kill' - call fates_params%RetreiveParameter(name=name, & + call fates_params%RetreiveParameterAllocate(name=name, & data=this%crown_kill) name = 'initd' - call fates_params%RetreiveParameter(name=name, & + call fates_params%RetreiveParameterAllocate(name=name, & data=this%initd) name = 'sd_mort' - call fates_params%RetreiveParameter(name=name, & + call fates_params%RetreiveParameterAllocate(name=name, & data=this%sd_mort) name = 'seed_rain' - call fates_params%RetreiveParameter(name=name, & + call fates_params%RetreiveParameterAllocate(name=name, & data=this%seed_rain) name = 'BB_slope' - call fates_params%RetreiveParameter(name=name, & + call fates_params%RetreiveParameterAllocate(name=name, & data=this%BB_slope) name = 'root_long' - call fates_params%RetreiveParameter(name=name, & + call fates_params%RetreiveParameterAllocate(name=name, & data=this%root_long) name = 'clone_alloc' - call fates_params%RetreiveParameter(name=name, & + call fates_params%RetreiveParameterAllocate(name=name, & data=this%clone_alloc) name = 'seed_alloc' - call fates_params%RetreiveParameter(name=name, & + call fates_params%RetreiveParameterAllocate(name=name, & data=this%seed_alloc) name = 'sapwood_ratio' - call fates_params%RetreiveParameter(name=name, & + call fates_params%RetreiveParameterAllocate(name=name, & data=this%sapwood_ratio) name = 'woody' - call fates_params%RetreiveParameter(name=name, & + call fates_params%RetreiveParameterAllocate(name=name, & data=this%woody) name = 'stress_decid' - call fates_params%RetreiveParameter(name=name, & + call fates_params%RetreiveParameterAllocate(name=name, & data=this%stress_decid) name = 'season_decid' - call fates_params%RetreiveParameter(name=name, & + call fates_params%RetreiveParameterAllocate(name=name, & data=this%season_decid) name = 'evergreen' - call fates_params%RetreiveParameter(name=name, & + call fates_params%RetreiveParameterAllocate(name=name, & data=this%evergreen) name = 'froot_leaf' - call fates_params%RetreiveParameter(name=name, & + call fates_params%RetreiveParameterAllocate(name=name, & data=this%froot_leaf) name = 'slatop' - call fates_params%RetreiveParameter(name=name, & + call fates_params%RetreiveParameterAllocate(name=name, & data=this%slatop) name = 'leaf_long' - call fates_params%RetreiveParameter(name=name, & + call fates_params%RetreiveParameterAllocate(name=name, & data=this%leaf_long) name = 'roota_par' - call fates_params%RetreiveParameter(name=name, & + call fates_params%RetreiveParameterAllocate(name=name, & data=this%roota_par) name = 'rootb_par' - call fates_params%RetreiveParameter(name=name, & + call fates_params%RetreiveParameterAllocate(name=name, & data=this%rootb_par) name = 'lf_flab' - call fates_params%RetreiveParameter(name=name, & + call fates_params%RetreiveParameterAllocate(name=name, & data=this%lf_flab) name = 'lf_fcel' - call fates_params%RetreiveParameter(name=name, & + call fates_params%RetreiveParameterAllocate(name=name, & data=this%lf_fcel) name = 'lf_flig' - call fates_params%RetreiveParameter(name=name, & + call fates_params%RetreiveParameterAllocate(name=name, & data=this%lf_flig) name = 'fr_flab' - call fates_params%RetreiveParameter(name=name, & + call fates_params%RetreiveParameterAllocate(name=name, & data=this%fr_flab) name = 'fr_fcel' - call fates_params%RetreiveParameter(name=name, & + call fates_params%RetreiveParameterAllocate(name=name, & data=this%fr_fcel) name = 'fr_flig' - call fates_params%RetreiveParameter(name=name, & + call fates_params%RetreiveParameterAllocate(name=name, & data=this%fr_flig) name = 'xl' - call fates_params%RetreiveParameter(name=name, & + call fates_params%RetreiveParameterAllocate(name=name, & data=this%xl) name = 'c3psn' - call fates_params%RetreiveParameter(name=name, & + call fates_params%RetreiveParameterAllocate(name=name, & data=this%c3psn) name = 'flnr' - call fates_params%RetreiveParameter(name=name, & + call fates_params%RetreiveParameterAllocate(name=name, & data=this%flnr) name = 'fnitr' - call fates_params%RetreiveParameter(name=name, & + call fates_params%RetreiveParameterAllocate(name=name, & data=this%fnitr) name = 'leafcn' - call fates_params%RetreiveParameter(name=name, & + call fates_params%RetreiveParameterAllocate(name=name, & data=this%leafcn) name = 'frootcn' - call fates_params%RetreiveParameter(name=name, & + call fates_params%RetreiveParameterAllocate(name=name, & data=this%frootcn) name = 'smpso' - call fates_params%RetreiveParameter(name=name, & + call fates_params%RetreiveParameterAllocate(name=name, & data=this%smpso) name = 'smpsc' - call fates_params%RetreiveParameter(name=name, & + call fates_params%RetreiveParameterAllocate(name=name, & data=this%smpsc) name = 'grperc' - call fates_params%RetreiveParameter(name=name, & + call fates_params%RetreiveParameterAllocate(name=name, & data=this%grperc) end subroutine Receive_PFT !----------------------------------------------------------------------- subroutine Register_PFT_numrad(this, fates_params) - + ! NOTE(bja, 2017-02) these are 2-d parameters, but they are + ! currently stored in the parameter file as separate 1-d + ! arrays. We have to register the parameters as 1-d arrays as they + ! are on the parameter file. We store them as 2-d in the receive step. use FatesParametersInterface, only : fates_parameters_type, param_string_length use FatesParametersInterface, only : dimension_name_pft, dimension_shape_1d @@ -601,7 +556,7 @@ subroutine Register_PFT_numrad(this, fates_params) class(fates_parameters_type), intent(inout) :: fates_params character(len=param_string_length), parameter :: dim_names(1) = (/dimension_name_pft/) - + integer, parameter :: dim_lower_bound(1) = (/ lower_bound_pft /) character(len=param_string_length) :: name !X! name = '' @@ -645,9 +600,15 @@ end subroutine Register_PFT_numrad !----------------------------------------------------------------------- subroutine Receive_PFT_numrad(this, fates_params) - + ! NOTE(bja, 2017-02) these are 2-d parameters, but they are + ! currently stored in the parameter file as separate 1-d arrays. + ! We can't allocate slices of arrays separately, so we have to + ! manually allocate the memory here, retreive into a dummy array, + ! and copy. All parameters in this subroutine are sized the same, + ! so we can reused the dummy array. If someone wants to cleanup + ! the input file, all this complexity can be removed. use FatesParametersInterface, only : fates_parameters_type - use FatesParametersInterface, only : param_string_length + use FatesParametersInterface, only : param_string_length, max_dimensions implicit none @@ -660,37 +621,86 @@ subroutine Receive_PFT_numrad(this, fates_params) !X! call fates_params%RetreiveParameter(name=name, & !X! data=this%) + integer :: index + integer :: dimension_shape + integer :: dimension_sizes(max_dimensions) + character(len=param_string_length) :: dimension_names(max_dimensions) + logical :: is_host_param + + integer :: lower_bound_1, upper_bound_1, lower_bound_2, upper_bound_2 + real(r8), allocatable :: dummy_data(:) + + ! Fetch metadata from a representative variable. All variables + ! called by this subroutine must be dimensioned the same way! + name = 'rholvis' + index = fates_params%FindIndex(name) + call fates_params%GetMetaData(index, name, dimension_shape, dimension_sizes, dimension_names, is_host_param) + lower_bound_1 = lower_bound_pft + upper_bound_1 = lower_bound_pft + dimension_sizes(1) - 1 + lower_bound_2 = lower_bound_general + upper_bound_2 = numrad + + allocate(dummy_data(lower_bound_1:upper_bound_1)) + + ! + ! received rhol data + ! + allocate(this%rhol(lower_bound_1:upper_bound_1, lower_bound_2:upper_bound_2)) + name = 'rholvis' call fates_params%RetreiveParameter(name=name, & - data=this%rhol(:,ivis)) + data=dummy_data) + this%rhol(lower_bound_1:upper_bound_1, ivis) = dummy_data name = 'rholnir' call fates_params%RetreiveParameter(name=name, & - data=this%rhol(:,inir)) + data=dummy_data) + this%rhol(lower_bound_1:upper_bound_1, inir) = dummy_data + ! + ! received rhos data + ! + allocate(this%rhos(lower_bound_1:upper_bound_1, lower_bound_2:upper_bound_2)) + name = 'rhosvis' call fates_params%RetreiveParameter(name=name, & - data=this%rhos(:,ivis)) + data=dummy_data) + this%rhos(lower_bound_1:upper_bound_1, ivis) = dummy_data name = 'rhosnir' call fates_params%RetreiveParameter(name=name, & - data=this%rhos(:,inir)) + data=dummy_data) + this%rhos(lower_bound_1:upper_bound_1, inir) = dummy_data + ! + ! received taul data + ! + allocate(this%taul(lower_bound_1:upper_bound_1, lower_bound_2:upper_bound_2)) + name = 'taulvis' call fates_params%RetreiveParameter(name=name, & - data=this%taul(:,ivis)) + data=dummy_data) + this%taul(lower_bound_1:upper_bound_1, ivis) = dummy_data name = 'taulnir' call fates_params%RetreiveParameter(name=name, & - data=this%taul(:,inir)) + data=dummy_data) + this%taul(lower_bound_1:upper_bound_1, inir) = dummy_data + ! + ! received taus data + ! + allocate(this%taus(lower_bound_1:upper_bound_1, lower_bound_2:upper_bound_2)) + name = 'tausvis' call fates_params%RetreiveParameter(name=name, & - data=this%taus(:,ivis)) + data=dummy_data) + this%taus(lower_bound_1:upper_bound_1, ivis) = dummy_data name = 'tausnir' call fates_params%RetreiveParameter(name=name, & - data=this%taus(:,inir)) + data=dummy_data) + this%taus(lower_bound_1:upper_bound_1, inir) = dummy_data end subroutine Receive_PFT_numrad @@ -705,11 +715,12 @@ subroutine Register_PFT_nvariants(this, fates_params) class(EDPftvarcon_type), intent(inout) :: this class(fates_parameters_type), intent(inout) :: fates_params + integer, parameter :: dim_lower_bound(2) = (/ lower_bound_pft, lower_bound_general /) character(len=param_string_length) :: dim_names(2) character(len=param_string_length) :: name ! NOTE(bja, 2017-01) initialization doesn't seem to work correctly - ! if dim_names has a paramater qualifier. + ! if dim_names has a parameter qualifier. dim_names(1) = dimension_name_pft dim_names(2) = dimension_name_variants @@ -719,7 +730,7 @@ subroutine Register_PFT_nvariants(this, fates_params) name = 'rootprof_beta' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & - dimension_names=dim_names) + dimension_names=dim_names, lower_bounds=dim_lower_bound) end subroutine Register_PFT_nvariants @@ -741,7 +752,7 @@ subroutine Receive_PFT_nvariants(this, fates_params) !X! data=this%) name = 'rootprof_beta' - call fates_params%RetreiveParameter(name=name, & + call fates_params%RetreiveParameterAllocate(name=name, & data=this%rootprof_beta) end subroutine Receive_PFT_nvariants diff --git a/main/FatesParametersInterface.F90 b/main/FatesParametersInterface.F90 index 5da9bd7e..9daef59a 100644 --- a/main/FatesParametersInterface.F90 +++ b/main/FatesParametersInterface.F90 @@ -12,6 +12,8 @@ module FatesParametersInterface integer, parameter, public :: max_dimensions = 2 integer, parameter, public :: max_used_dimensions = 25 integer, parameter, public :: param_string_length = 40 + ! NOTE(bja, 2017-02) these are the values returned from netcdf after + ! inquiring about the number of dimensions integer, parameter, public :: dimension_shape_scalar = 0 integer, parameter, public :: dimension_shape_1d = 1 integer, parameter, public :: dimension_shape_2d = 2 @@ -38,6 +40,7 @@ module FatesParametersInterface integer :: dimension_shape integer :: dimension_sizes(max_dimensions) character(len=param_string_length) :: dimension_names(max_dimensions) + integer :: dimension_lower_bound(max_dimensions) real(r8), allocatable :: data(:, :) end type parameter_type @@ -50,20 +53,23 @@ module FatesParametersInterface procedure, public :: Destroy procedure, public :: RegisterParameter generic, public :: RetreiveParameter => RetreiveParameterScalar, RetreiveParameter1D, RetreiveParameter2D + generic, public :: RetreiveParameterAllocate => RetreiveParameter1DAllocate, RetreiveParameter2DAllocate generic, public :: SetData => SetDataScalar, SetData1D, SetData2D procedure, public :: GetUsedDimensions procedure, public :: SetDimensionSizes procedure, public :: GetMaxDimensionSize procedure, public :: GetMetaData procedure, public :: num_params + procedure, public :: FindIndex procedure, private :: RetreiveParameterScalar procedure, private :: RetreiveParameter1D procedure, private :: RetreiveParameter2D + procedure, private :: RetreiveParameter1DAllocate + procedure, private :: RetreiveParameter2DAllocate procedure, private :: SetDataScalar procedure, private :: SetData1D procedure, private :: SetData2D - procedure, private :: FindIndex end type fates_parameters_type @@ -95,8 +101,9 @@ subroutine Destroy(this) end subroutine Destroy !----------------------------------------------------------------------- - subroutine RegisterParameter(this, name, dimension_shape, dimension_names, sync_with_host) - + subroutine RegisterParameter(this, name, dimension_shape, dimension_names, & + sync_with_host, lower_bounds) + implicit none class(fates_parameters_type), intent(inout) :: this @@ -104,8 +111,9 @@ subroutine RegisterParameter(this, name, dimension_shape, dimension_names, sync_ integer, intent(in) :: dimension_shape character(len=param_string_length) :: dimension_names(1:) logical, intent(in), optional :: sync_with_host + integer, intent(in), optional :: lower_bounds(1:) - integer :: i, n, num_names + integer :: i, n, num_names, num_bounds this%num_parameters = this%num_parameters + 1 i = this%num_parameters @@ -123,7 +131,15 @@ subroutine RegisterParameter(this, name, dimension_shape, dimension_names, sync_ if (present(sync_with_host)) then this%parameters(i)%sync_with_host = sync_with_host end if - + ! allocate as a standard 1-based array unless otherwise specified + ! by the caller. + this%parameters(i)%dimension_lower_bound = (/ 1, 1 /) + if (present(lower_bounds)) then + num_bounds = min(max_dimensions, size(lower_bounds, 1)) + do n = 1, num_bounds + this%parameters(i)%dimension_lower_bound(n) = lower_bounds(n) + end do + endif end subroutine RegisterParameter !----------------------------------------------------------------------- @@ -205,6 +221,50 @@ subroutine RetreiveParameter2D(this, name, data) end subroutine RetreiveParameter2D + !----------------------------------------------------------------------- + subroutine RetreiveParameter1DAllocate(this, name, data) + + use abortutils, only : endrun + + implicit none + + class(fates_parameters_type), intent(inout) :: this + character(len=param_string_length), intent(in) :: name + real(r8), intent(out), allocatable :: data(:) + + integer :: i, lower_bound, upper_bound + + i = this%FindIndex(name) + lower_bound = this%parameters(i)%dimension_lower_bound(1) + upper_bound = lower_bound + this%parameters(i)%dimension_sizes(1) - 1 + allocate(data(lower_bound:upper_bound)) + data(lower_bound:upper_bound) = this%parameters(i)%data(:, 1) + + end subroutine RetreiveParameter1DAllocate + + !----------------------------------------------------------------------- + subroutine RetreiveParameter2DAllocate(this, name, data) + + use abortutils, only : endrun + + implicit none + + class(fates_parameters_type), intent(inout) :: this + character(len=param_string_length), intent(in) :: name + real(r8), intent(out), allocatable :: data(:, :) + + integer :: i, lb_1, ub_1, lb_2, ub_2 + + i = this%FindIndex(name) + lb_1 = this%parameters(i)%dimension_lower_bound(1) + ub_1 = lb_1 + this%parameters(i)%dimension_sizes(1) - 1 + lb_2 = this%parameters(i)%dimension_lower_bound(2) + ub_2 = lb_2 + this%parameters(i)%dimension_sizes(2) - 1 + allocate(data(lb_1:ub_1, lb_2:ub_2)) + data(lb_1:ub_1, lb_2:ub_2) = this%parameters(i)%data + + end subroutine RetreiveParameter2DAllocate + !----------------------------------------------------------------------- function FindIndex(this, name) result(i) From a8e75f999cbf7b58c48a6624e40f9002dc64a126 Mon Sep 17 00:00:00 2001 From: Ben Andre Date: Fri, 10 Feb 2017 13:12:07 -0700 Subject: [PATCH 326/437] Apply fates_ namespace to fates parameters. Fates parameters and dimensions have are now namespaced with 'fates_' in the input parameter file. This allows fates and clm to share an input file without name collisions. Update to new default parameter file with proper namespace. User interface changes?: yes, all fates input via the netcdf input parameter file must be namespaced with 'fates_' for both parameter and dimension names. Test suite: ed - yellowstone gnu, intel, pgi - hobart nag Test baseline: a651a4f Test namelist changes: yes, add fates_paramfile Test answer changes: bit for bit Test summary: all tests pass Test suite: clm_short - yellowstone gnu, intel, pgi Test baseline: clm4_5_12_r195 Test namelist changes: none Test answer changes: bit for bit Test summary: all tests pass --- biogeochem/EDSharedParamsMod.F90 | 4 +- fire/SFParamsMod.F90 | 42 +++--- main/EDParamsMod.F90 | 22 +-- main/EDPftvarcon.F90 | 218 +++++++++++++++--------------- main/FatesParametersInterface.F90 | 26 ++-- 5 files changed, 155 insertions(+), 157 deletions(-) diff --git a/biogeochem/EDSharedParamsMod.F90 b/biogeochem/EDSharedParamsMod.F90 index c3610b05..fb0f6c6c 100644 --- a/biogeochem/EDSharedParamsMod.F90 +++ b/biogeochem/EDSharedParamsMod.F90 @@ -84,14 +84,14 @@ subroutine RegisterParamsScalar(this, fates_params) ! that need to be synced with host values. use FatesParametersInterface, only : fates_parameters_type, param_string_length - use FatesParametersInterface, only : dimension_name_allpfts, dimension_shape_1d + use FatesParametersInterface, only : dimension_name_host_allpfts, dimension_shape_1d implicit none class(EDParamsShareType), intent(inout) :: this class(fates_parameters_type), intent(inout) :: fates_params - character(len=param_string_length), parameter :: dim_names(1) = (/dimension_name_allpfts/) + character(len=param_string_length), parameter :: dim_names(1) = (/dimension_name_host_allpfts/) character(len=param_string_length) :: name call this%Init() diff --git a/fire/SFParamsMod.F90 b/fire/SFParamsMod.F90 index 2f2de2eb..0677a9f7 100644 --- a/fire/SFParamsMod.F90 +++ b/fire/SFParamsMod.F90 @@ -39,27 +39,27 @@ module SFParamsMod real(r8),protected :: SF_val_mid_moisture_C(NFSC) real(r8),protected :: SF_val_mid_moisture_S(NFSC) - character(len=param_string_length),parameter :: SF_name_fdi_a = "fdi_a" - character(len=param_string_length),parameter :: SF_name_fdi_b = "fdi_b" - character(len=param_string_length),parameter :: SF_name_fdi_alpha = "fdi_alpha" - character(len=param_string_length),parameter :: SF_name_miner_total = "miner_total" - character(len=param_string_length),parameter :: SF_name_fuel_energy = "fuel_energy" - character(len=param_string_length),parameter :: SF_name_part_dens = "part_dens" - character(len=param_string_length),parameter :: SF_name_miner_damp = "miner_damp" - character(len=param_string_length),parameter :: SF_name_max_durat = "max_durat" - character(len=param_string_length),parameter :: SF_name_durat_slope = "durat_slope" - character(len=param_string_length),parameter :: SF_name_alpha_SH = "alpha_SH" - character(len=param_string_length),parameter :: SF_name_alpha_FMC = "alpha_FMC" - character(len=param_string_length),parameter :: SF_name_CWD_frac = "CWD_frac" - character(len=param_string_length),parameter :: SF_name_max_decomp = "max_decomp" - character(len=param_string_length),parameter :: SF_name_SAV = "SAV" - character(len=param_string_length),parameter :: SF_name_FBD = "FBD" - character(len=param_string_length),parameter :: SF_name_min_moisture = "min_moisture" - character(len=param_string_length),parameter :: SF_name_mid_moisture = "mid_moisture" - character(len=param_string_length),parameter :: SF_name_low_moisture_C = "low_moisture_C" - character(len=param_string_length),parameter :: SF_name_low_moisture_S = "low_moisture_S" - character(len=param_string_length),parameter :: SF_name_mid_moisture_C = "mid_moisture_C" - character(len=param_string_length),parameter :: SF_name_mid_moisture_S = "mid_moisture_S" + character(len=param_string_length),parameter :: SF_name_fdi_a = "fates_fdi_a" + character(len=param_string_length),parameter :: SF_name_fdi_b = "fates_fdi_b" + character(len=param_string_length),parameter :: SF_name_fdi_alpha = "fates_fdi_alpha" + character(len=param_string_length),parameter :: SF_name_miner_total = "fates_miner_total" + character(len=param_string_length),parameter :: SF_name_fuel_energy = "fates_fuel_energy" + character(len=param_string_length),parameter :: SF_name_part_dens = "fates_part_dens" + character(len=param_string_length),parameter :: SF_name_miner_damp = "fates_miner_damp" + character(len=param_string_length),parameter :: SF_name_max_durat = "fates_max_durat" + character(len=param_string_length),parameter :: SF_name_durat_slope = "fates_durat_slope" + character(len=param_string_length),parameter :: SF_name_alpha_SH = "fates_alpha_SH" + character(len=param_string_length),parameter :: SF_name_alpha_FMC = "fates_alpha_FMC" + character(len=param_string_length),parameter :: SF_name_CWD_frac = "fates_CWD_frac" + character(len=param_string_length),parameter :: SF_name_max_decomp = "fates_max_decomp" + character(len=param_string_length),parameter :: SF_name_SAV = "fates_SAV" + character(len=param_string_length),parameter :: SF_name_FBD = "fates_FBD" + character(len=param_string_length),parameter :: SF_name_min_moisture = "fates_min_moisture" + character(len=param_string_length),parameter :: SF_name_mid_moisture = "fates_mid_moisture" + character(len=param_string_length),parameter :: SF_name_low_moisture_C = "fates_low_moisture_C" + character(len=param_string_length),parameter :: SF_name_low_moisture_S = "fates_low_moisture_S" + character(len=param_string_length),parameter :: SF_name_mid_moisture_C = "fates_mid_moisture_C" + character(len=param_string_length),parameter :: SF_name_mid_moisture_S = "fates_mid_moisture_S" public :: SpitFireRegisterParams public :: SpitFireReceiveParams diff --git a/main/EDParamsMod.F90 b/main/EDParamsMod.F90 index dc67ebd8..eda22e0b 100644 --- a/main/EDParamsMod.F90 +++ b/main/EDParamsMod.F90 @@ -27,17 +27,17 @@ module EDParamsMod real(r8),protected :: ED_val_profile_tol real(r8),protected :: ED_val_ag_biomass - character(len=param_string_length),parameter :: ED_name_grass_spread = "grass_spread" - character(len=param_string_length),parameter :: ED_name_comp_excln = "comp_excln" - character(len=param_string_length),parameter :: ED_name_stress_mort = "stress_mort" - character(len=param_string_length),parameter :: ED_name_dispersal = "dispersal" - character(len=param_string_length),parameter :: ED_name_maxspread = "maxspread" - character(len=param_string_length),parameter :: ED_name_minspread = "minspread" - character(len=param_string_length),parameter :: ED_name_init_litter = "init_litter" - character(len=param_string_length),parameter :: ED_name_nfires = "nfires" - character(len=param_string_length),parameter :: ED_name_understorey_death = "understorey_death" - character(len=param_string_length),parameter :: ED_name_profile_tol = "profile_tol" - character(len=param_string_length),parameter :: ED_name_ag_biomass= "ag_biomass" + character(len=param_string_length),parameter :: ED_name_grass_spread = "fates_grass_spread" + character(len=param_string_length),parameter :: ED_name_comp_excln = "fates_comp_excln" + character(len=param_string_length),parameter :: ED_name_stress_mort = "fates_stress_mort" + character(len=param_string_length),parameter :: ED_name_dispersal = "fates_dispersal" + character(len=param_string_length),parameter :: ED_name_maxspread = "fates_maxspread" + character(len=param_string_length),parameter :: ED_name_minspread = "fates_minspread" + character(len=param_string_length),parameter :: ED_name_init_litter = "fates_init_litter" + character(len=param_string_length),parameter :: ED_name_nfires = "fates_nfires" + character(len=param_string_length),parameter :: ED_name_understorey_death = "fates_understorey_death" + character(len=param_string_length),parameter :: ED_name_profile_tol = "fates_profile_tol" + character(len=param_string_length),parameter :: ED_name_ag_biomass= "fates_ag_biomass" public :: FatesParamsInit public :: FatesRegisterParams diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index b5eb1ff9..ea53b660 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -160,183 +160,183 @@ subroutine Register_PFT(this, fates_params) !X! call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & !X! dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'max_dbh' + name = 'fates_max_dbh' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'freezetol' + name = 'fates_freezetol' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'wood_density' + name = 'fates_wood_density' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'alpha_stem' + name = 'fates_alpha_stem' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'hgt_min' + name = 'fates_hgt_min' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'cushion' + name = 'fates_cushion' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'leaf_stor_priority' + name = 'fates_leaf_stor_priority' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'leafwatermax' + name = 'fates_leafwatermax' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'rootresist' + name = 'fates_rootresist' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'soilbeta' + name = 'fates_soilbeta' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'crown' + name = 'fates_crown' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'bark_scaler' + name = 'fates_bark_scaler' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'crown_kill' + name = 'fates_crown_kill' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'initd' + name = 'fates_initd' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'sd_mort' + name = 'fates_sd_mort' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'seed_rain' + name = 'fates_seed_rain' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'BB_slope' + name = 'fates_BB_slope' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'root_long' + name = 'fates_root_long' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'clone_alloc' + name = 'fates_clone_alloc' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'seed_alloc' + name = 'fates_seed_alloc' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'sapwood_ratio' + name = 'fates_sapwood_ratio' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'woody' + name = 'fates_woody' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'stress_decid' + name = 'fates_stress_decid' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'season_decid' + name = 'fates_season_decid' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'evergreen' + name = 'fates_evergreen' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'froot_leaf' + name = 'fates_froot_leaf' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'slatop' + name = 'fates_slatop' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'leaf_long' + name = 'fates_leaf_long' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'roota_par' + name = 'fates_roota_par' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'rootb_par' + name = 'fates_rootb_par' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'lf_flab' + name = 'fates_lf_flab' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'lf_fcel' + name = 'fates_lf_fcel' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'lf_flig' + name = 'fates_lf_flig' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'fr_flab' + name = 'fates_fr_flab' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'fr_fcel' + name = 'fates_fr_fcel' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'fr_flig' + name = 'fates_fr_flig' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'xl' + name = 'fates_xl' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'c3psn' + name = 'fates_c3psn' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'flnr' + name = 'fates_flnr' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'fnitr' + name = 'fates_fnitr' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'leafcn' + name = 'fates_leafcn' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'frootcn' + name = 'fates_frootcn' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'smpso' + name = 'fates_smpso' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'smpsc' + name = 'fates_smpsc' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'grperc' + name = 'fates_grperc' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) @@ -359,183 +359,183 @@ subroutine Receive_PFT(this, fates_params) !X! call fates_params%RetreiveParameter(name=name, & !X! data=this%) - name = 'max_dbh' + name = 'fates_max_dbh' call fates_params%RetreiveParameterAllocate(name=name, & data=this%max_dbh) - name = 'freezetol' + name = 'fates_freezetol' call fates_params%RetreiveParameterAllocate(name=name, & data=this%freezetol) - name = 'wood_density' + name = 'fates_wood_density' call fates_params%RetreiveParameterAllocate(name=name, & data=this%wood_density) - name = 'alpha_stem' + name = 'fates_alpha_stem' call fates_params%RetreiveParameterAllocate(name=name, & data=this%alpha_stem) - name = 'hgt_min' + name = 'fates_hgt_min' call fates_params%RetreiveParameterAllocate(name=name, & data=this%hgt_min) - name = 'cushion' + name = 'fates_cushion' call fates_params%RetreiveParameterAllocate(name=name, & data=this%cushion) - name = 'leaf_stor_priority' + name = 'fates_leaf_stor_priority' call fates_params%RetreiveParameterAllocate(name=name, & data=this%leaf_stor_priority) - name = 'leafwatermax' + name = 'fates_leafwatermax' call fates_params%RetreiveParameterAllocate(name=name, & data=this%leafwatermax) - name = 'rootresist' + name = 'fates_rootresist' call fates_params%RetreiveParameterAllocate(name=name, & data=this%rootresist) - name = 'soilbeta' + name = 'fates_soilbeta' call fates_params%RetreiveParameterAllocate(name=name, & data=this%soilbeta) - name = 'crown' + name = 'fates_crown' call fates_params%RetreiveParameterAllocate(name=name, & data=this%crown) - name = 'bark_scaler' + name = 'fates_bark_scaler' call fates_params%RetreiveParameterAllocate(name=name, & data=this%bark_scaler) - name = 'crown_kill' + name = 'fates_crown_kill' call fates_params%RetreiveParameterAllocate(name=name, & data=this%crown_kill) - name = 'initd' + name = 'fates_initd' call fates_params%RetreiveParameterAllocate(name=name, & data=this%initd) - name = 'sd_mort' + name = 'fates_sd_mort' call fates_params%RetreiveParameterAllocate(name=name, & data=this%sd_mort) - name = 'seed_rain' + name = 'fates_seed_rain' call fates_params%RetreiveParameterAllocate(name=name, & data=this%seed_rain) - name = 'BB_slope' + name = 'fates_BB_slope' call fates_params%RetreiveParameterAllocate(name=name, & data=this%BB_slope) - name = 'root_long' + name = 'fates_root_long' call fates_params%RetreiveParameterAllocate(name=name, & data=this%root_long) - name = 'clone_alloc' + name = 'fates_clone_alloc' call fates_params%RetreiveParameterAllocate(name=name, & data=this%clone_alloc) - name = 'seed_alloc' + name = 'fates_seed_alloc' call fates_params%RetreiveParameterAllocate(name=name, & data=this%seed_alloc) - name = 'sapwood_ratio' + name = 'fates_sapwood_ratio' call fates_params%RetreiveParameterAllocate(name=name, & data=this%sapwood_ratio) - name = 'woody' + name = 'fates_woody' call fates_params%RetreiveParameterAllocate(name=name, & data=this%woody) - name = 'stress_decid' + name = 'fates_stress_decid' call fates_params%RetreiveParameterAllocate(name=name, & data=this%stress_decid) - name = 'season_decid' + name = 'fates_season_decid' call fates_params%RetreiveParameterAllocate(name=name, & data=this%season_decid) - name = 'evergreen' + name = 'fates_evergreen' call fates_params%RetreiveParameterAllocate(name=name, & data=this%evergreen) - name = 'froot_leaf' + name = 'fates_froot_leaf' call fates_params%RetreiveParameterAllocate(name=name, & data=this%froot_leaf) - name = 'slatop' + name = 'fates_slatop' call fates_params%RetreiveParameterAllocate(name=name, & data=this%slatop) - name = 'leaf_long' + name = 'fates_leaf_long' call fates_params%RetreiveParameterAllocate(name=name, & data=this%leaf_long) - name = 'roota_par' + name = 'fates_roota_par' call fates_params%RetreiveParameterAllocate(name=name, & data=this%roota_par) - name = 'rootb_par' + name = 'fates_rootb_par' call fates_params%RetreiveParameterAllocate(name=name, & data=this%rootb_par) - name = 'lf_flab' + name = 'fates_lf_flab' call fates_params%RetreiveParameterAllocate(name=name, & data=this%lf_flab) - name = 'lf_fcel' + name = 'fates_lf_fcel' call fates_params%RetreiveParameterAllocate(name=name, & data=this%lf_fcel) - name = 'lf_flig' + name = 'fates_lf_flig' call fates_params%RetreiveParameterAllocate(name=name, & data=this%lf_flig) - name = 'fr_flab' + name = 'fates_fr_flab' call fates_params%RetreiveParameterAllocate(name=name, & data=this%fr_flab) - name = 'fr_fcel' + name = 'fates_fr_fcel' call fates_params%RetreiveParameterAllocate(name=name, & data=this%fr_fcel) - name = 'fr_flig' + name = 'fates_fr_flig' call fates_params%RetreiveParameterAllocate(name=name, & data=this%fr_flig) - name = 'xl' + name = 'fates_xl' call fates_params%RetreiveParameterAllocate(name=name, & data=this%xl) - name = 'c3psn' + name = 'fates_c3psn' call fates_params%RetreiveParameterAllocate(name=name, & data=this%c3psn) - name = 'flnr' + name = 'fates_flnr' call fates_params%RetreiveParameterAllocate(name=name, & data=this%flnr) - name = 'fnitr' + name = 'fates_fnitr' call fates_params%RetreiveParameterAllocate(name=name, & data=this%fnitr) - name = 'leafcn' + name = 'fates_leafcn' call fates_params%RetreiveParameterAllocate(name=name, & data=this%leafcn) - name = 'frootcn' + name = 'fates_frootcn' call fates_params%RetreiveParameterAllocate(name=name, & data=this%frootcn) - name = 'smpso' + name = 'fates_smpso' call fates_params%RetreiveParameterAllocate(name=name, & data=this%smpso) - name = 'smpsc' + name = 'fates_smpsc' call fates_params%RetreiveParameterAllocate(name=name, & data=this%smpsc) - name = 'grperc' + name = 'fates_grperc' call fates_params%RetreiveParameterAllocate(name=name, & data=this%grperc) @@ -563,35 +563,35 @@ subroutine Register_PFT_numrad(this, fates_params) !X! call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & !X! dimension_names=dim_names) - name = 'rholvis' + name = 'fates_rholvis' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names) - name = 'rholnir' + name = 'fates_rholnir' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names) - name = 'rhosvis' + name = 'fates_rhosvis' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names) - name = 'rhosnir' + name = 'fates_rhosnir' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names) - name = 'taulvis' + name = 'fates_taulvis' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names) - name = 'taulnir' + name = 'fates_taulnir' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names) - name = 'tausvis' + name = 'fates_tausvis' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names) - name = 'tausnir' + name = 'fates_tausnir' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names) @@ -632,7 +632,7 @@ subroutine Receive_PFT_numrad(this, fates_params) ! Fetch metadata from a representative variable. All variables ! called by this subroutine must be dimensioned the same way! - name = 'rholvis' + name = 'fates_rholvis' index = fates_params%FindIndex(name) call fates_params%GetMetaData(index, name, dimension_shape, dimension_sizes, dimension_names, is_host_param) lower_bound_1 = lower_bound_pft @@ -647,12 +647,12 @@ subroutine Receive_PFT_numrad(this, fates_params) ! allocate(this%rhol(lower_bound_1:upper_bound_1, lower_bound_2:upper_bound_2)) - name = 'rholvis' + name = 'fates_rholvis' call fates_params%RetreiveParameter(name=name, & data=dummy_data) this%rhol(lower_bound_1:upper_bound_1, ivis) = dummy_data - name = 'rholnir' + name = 'fates_rholnir' call fates_params%RetreiveParameter(name=name, & data=dummy_data) this%rhol(lower_bound_1:upper_bound_1, inir) = dummy_data @@ -662,12 +662,12 @@ subroutine Receive_PFT_numrad(this, fates_params) ! allocate(this%rhos(lower_bound_1:upper_bound_1, lower_bound_2:upper_bound_2)) - name = 'rhosvis' + name = 'fates_rhosvis' call fates_params%RetreiveParameter(name=name, & data=dummy_data) this%rhos(lower_bound_1:upper_bound_1, ivis) = dummy_data - name = 'rhosnir' + name = 'fates_rhosnir' call fates_params%RetreiveParameter(name=name, & data=dummy_data) this%rhos(lower_bound_1:upper_bound_1, inir) = dummy_data @@ -677,12 +677,12 @@ subroutine Receive_PFT_numrad(this, fates_params) ! allocate(this%taul(lower_bound_1:upper_bound_1, lower_bound_2:upper_bound_2)) - name = 'taulvis' + name = 'fates_taulvis' call fates_params%RetreiveParameter(name=name, & data=dummy_data) this%taul(lower_bound_1:upper_bound_1, ivis) = dummy_data - name = 'taulnir' + name = 'fates_taulnir' call fates_params%RetreiveParameter(name=name, & data=dummy_data) this%taul(lower_bound_1:upper_bound_1, inir) = dummy_data @@ -692,12 +692,12 @@ subroutine Receive_PFT_numrad(this, fates_params) ! allocate(this%taus(lower_bound_1:upper_bound_1, lower_bound_2:upper_bound_2)) - name = 'tausvis' + name = 'fates_tausvis' call fates_params%RetreiveParameter(name=name, & data=dummy_data) this%taus(lower_bound_1:upper_bound_1, ivis) = dummy_data - name = 'tausnir' + name = 'fates_tausnir' call fates_params%RetreiveParameter(name=name, & data=dummy_data) this%taus(lower_bound_1:upper_bound_1, inir) = dummy_data @@ -728,7 +728,7 @@ subroutine Register_PFT_nvariants(this, fates_params) !X! call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & !X! dimension_names=dim_names) - name = 'rootprof_beta' + name = 'fates_rootprof_beta' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) @@ -751,7 +751,7 @@ subroutine Receive_PFT_nvariants(this, fates_params) !X! call fates_params%RetreiveParameter(name=name, & !X! data=this%) - name = 'rootprof_beta' + name = 'fates_rootprof_beta' call fates_params%RetreiveParameterAllocate(name=name, & data=this%rootprof_beta) diff --git a/main/FatesParametersInterface.F90 b/main/FatesParametersInterface.F90 index 9daef59a..007dd78d 100644 --- a/main/FatesParametersInterface.F90 +++ b/main/FatesParametersInterface.F90 @@ -18,21 +18,19 @@ module FatesParametersInterface integer, parameter, public :: dimension_shape_1d = 1 integer, parameter, public :: dimension_shape_2d = 2 - ! FIXME(bja, 2017-01) these strings need to be changed to 'fates_' - ! to namespace dimonsions and prevent name collisions if someone - ! wants to write a single netcdf file containing host and fates - ! parameters. Can't be done easily until this framework is being - ! used to read variables. - ! FIXME(bja, 2017-01) change 'param' to 'scalar'! + ! Dimensions in the fates namespace: character(len=*), parameter, public :: dimension_name_scalar = '' - character(len=*), parameter, public :: dimension_name_scalar1d = 'param' - character(len=*), parameter, public :: dimension_name_pft = 'pft' - character(len=*), parameter, public :: dimension_name_segment = 'segment' - character(len=*), parameter, public :: dimension_name_cwd = 'NCWD' - character(len=*), parameter, public :: dimension_name_lsc = 'litterclass' - character(len=*), parameter, public :: dimension_name_fsc = 'litterclass' - character(len=*), parameter, public :: dimension_name_allpfts = 'allpfts' - character(len=*), parameter, public :: dimension_name_variants = 'variants' + character(len=*), parameter, public :: dimension_name_scalar1d = 'fates_scalar' + character(len=*), parameter, public :: dimension_name_pft = 'fates_pft' + character(len=*), parameter, public :: dimension_name_segment = 'fates_segment' + character(len=*), parameter, public :: dimension_name_cwd = 'fates_NCWD' + character(len=*), parameter, public :: dimension_name_lsc = 'fates_litterclass' + character(len=*), parameter, public :: dimension_name_fsc = 'fates_litterclass' + character(len=*), parameter, public :: dimension_name_allpfts = 'fates_allpfts' + character(len=*), parameter, public :: dimension_name_variants = 'fates_variants' + + ! Dimensions in the host namespace: + character(len=*), parameter, public :: dimension_name_host_allpfts = 'allpfts' type, private :: parameter_type character(len=param_string_length) :: name From 805d046096c077456dc7057e4358789c83575006 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 14 Feb 2017 10:41:43 -0800 Subject: [PATCH 327/437] Fixed some long-names in SCPF type history variables. --- main/FatesHistoryInterfaceMod.F90 | 80 +++++++++++++++---------------- 1 file changed, 40 insertions(+), 40 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index b2634f13..d26cc82f 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -1726,168 +1726,168 @@ subroutine define_history_vars(this, initialize_variables) ! =================================================================================== call this%set_history_var(vname='GPP_SCPF', units='kgC/m2/yr', & - long='gross primary production', use_default='inactive', & + long='gross primary production by pft/size', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_gpp_si_scpf ) call this%set_history_var(vname='GPP_CANOPY_SCPF', units='kgC/m2/yr', & - long='gross primary production of canopy plants', use_default='inactive', & + long='gross primary production of canopy plants by pft/size ', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_gpp_canopy_si_scpf ) call this%set_history_var(vname='AR_CANOPY_SCPF', units='kgC/m2/yr', & - long='autotrophic respiration of canopy plants', use_default='inactive', & + long='autotrophic respiration of canopy plants by pft/size', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ar_canopy_si_scpf ) call this%set_history_var(vname='GPP_UNDERSTORY_SCPF', units='kgC/m2/yr', & - long='gross primary production of understory plants', use_default='inactive', & + long='gross primary production of understory plants by pft/size', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_gpp_understory_si_scpf ) call this%set_history_var(vname='AR_UNDERSTORY_SCPF', units='kgC/m2/yr', & - long='autotrophic respiration of understory plants', use_default='inactive', & + long='autotrophic respiration of understory plants by pft/size', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ar_understory_si_scpf ) call this%set_history_var(vname='NPP_SCPF', units='kgC/m2/yr', & - long='total net primary production', use_default='inactive', & + long='total net primary production by pft/size', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_totl_si_scpf ) call this%set_history_var(vname='NPP_LEAF_SCPF', units='kgC/m2/yr', & - long='NPP flux into leaves', use_default='inactive', & + long='NPP flux into leaves by pft/size', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_leaf_si_scpf ) call this%set_history_var(vname='NPP_SEED_SCPF', units='kgC/m2/yr', & - long='NPP flux into seeds', use_default='inactive', & + long='NPP flux into seeds by pft/size', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_seed_si_scpf ) call this%set_history_var(vname='NPP_FNRT_SCPF', units='kgC/m2/yr', & - long='NPP flux into fine roots', use_default='inactive', & + long='NPP flux into fine roots by pft/size', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_fnrt_si_scpf ) call this%set_history_var(vname='NPP_BGSW_SCPF', units='kgC/m2/yr', & - long='NPP flux into below-ground sapwood', use_default='inactive', & + long='NPP flux into below-ground sapwood by pft/size', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_bgsw_si_scpf ) call this%set_history_var(vname='NPP_BGDW_SCPF', units='kgC/m2/yr', & - long='NPP flux into below-ground deadwood', use_default='inactive', & + long='NPP flux into below-ground deadwood by pft/size', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_bgdw_si_scpf ) call this%set_history_var(vname='NPP_AGSW_SCPF', units='kgC/m2/yr', & - long='NPP flux into above-ground sapwood', use_default='inactive', & + long='NPP flux into above-ground sapwood by pft/size', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_agsw_si_scpf ) call this%set_history_var(vname = 'NPP_AGDW_SCPF', units='kgC/m2/yr', & - long='NPP flux into above-ground deadwood', use_default='inactive', & + long='NPP flux into above-ground deadwood by pft/size', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_agdw_si_scpf ) call this%set_history_var(vname = 'NPP_STOR_SCPF', units='kgC/m2/yr', & - long='NPP flux into storage', use_default='inactive', & + long='NPP flux into storage by pft/size', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_stor_si_scpf ) call this%set_history_var(vname='DDBH_SCPF', units = 'cm/yr/ha', & - long='diameter growth increment and pft/size',use_default='inactive', & + long='diameter growth increment by pft/size',use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ddbh_si_scpf ) call this%set_history_var(vname='DDBH_CANOPY_SCPF', units = 'cm/yr/ha', & - long='diameter growth increment and pft/size',use_default='inactive', & + long='diameter growth increment by pft/size',use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ddbh_canopy_si_scpf ) call this%set_history_var(vname='DDBH_UNDERSTORY_SCPF', units = 'cm/yr/ha', & - long='diameter growth increment and pft/size',use_default='inactive', & + long='diameter growth increment by pft/size',use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ddbh_understory_si_scpf ) call this%set_history_var(vname='BA_SCPF', units = 'm2/ha', & - long='basal area by patch and pft/size', use_default='inactive', & + long='basal area by pft/size', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ba_si_scpf ) call this%set_history_var(vname='NPLANT_SCPF', units = 'N/ha', & - long='stem number density by patch and pft/size', use_default='inactive', & + long='stem number density by pft/size', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_si_scpf ) call this%set_history_var(vname='M1_SCPF', units = 'N/ha/yr', & - long='background mortality by patch and pft/size', use_default='inactive', & + long='background mortality by pft/size', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m1_si_scpf ) call this%set_history_var(vname='M2_SCPF', units = 'N/ha/yr', & - long='hydraulic mortality by patch and pft/size',use_default='inactive', & + long='hydraulic mortality by pft/size',use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m2_si_scpf ) call this%set_history_var(vname='M3_SCPF', units = 'N/ha/yr', & - long='carbon starvation mortality by patch and pft/size', use_default='inactive', & + long='carbon starvation mortality by pft/size', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m3_si_scpf ) call this%set_history_var(vname='M4_SCPF', units = 'N/ha/yr', & - long='impact mortality by patch and pft/size',use_default='inactive', & + long='impact mortality by pft/size',use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m4_si_scpf ) call this%set_history_var(vname='M5_SCPF', units = 'N/ha/yr', & - long='fire mortality by patch and pft/size',use_default='inactive', & + long='fire mortality by pft/size',use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m5_si_scpf ) call this%set_history_var(vname='M6_SCPF', units = 'N/ha/yr', & - long='termination mortality by patch and pft/size',use_default='inactive', & + long='termination mortality by pft/size',use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m6_si_scpf ) call this%set_history_var(vname='MORTALITY_CANOPY_SCPF', units = 'N/ha/yr', & - long='total mortality of canopy plants by patch and pft/size', use_default='inactive', & + long='total mortality of canopy plants by pft/size', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_mortality_canopy_si_scpf ) call this%set_history_var(vname='BSTOR_CANOPY_SCPF', units = 'kgC/ha', & - long='biomass carbon in storage pools of canopy plants by patch and pft/size', use_default='inactive', & + long='biomass carbon in storage pools of canopy plants by pft/size', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_bstor_canopy_si_scpf ) call this%set_history_var(vname='BLEAF_CANOPY_SCPF', units = 'kgC/ha', & - long='biomass carbon in leaf of canopy plants by patch and pft/size', use_default='inactive', & + long='biomass carbon in leaf of canopy plants by pft/size', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_bleaf_canopy_si_scpf ) call this%set_history_var(vname='NPLANT_CANOPY_SCPF', units = 'N/ha', & - long='stem number of canopy plants density by patch and pft/size', use_default='inactive', & + long='stem number of canopy plants density by pft/size', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_canopy_si_scpf ) call this%set_history_var(vname='MORTALITY_UNDERSTORY_SCPF', units = 'N/ha/yr', & - long='total mortality of understory plants by patch and pft/size', use_default='inactive', & + long='total mortality of understory plants by pft/size', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_mortality_understory_si_scpf ) call this%set_history_var(vname='BSTOR_UNDERSTORY_SCPF', units = 'kgC/ha', & - long='biomass carbon in storage pools of understory plants by patch and pft/size', use_default='inactive', & + long='biomass carbon in storage pools of understory plants by pft/size', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_bstor_understory_si_scpf ) call this%set_history_var(vname='BLEAF_UNDERSTORY_SCPF', units = 'kgC/ha', & - long='biomass carbon in leaf of understory plants by patch and pft/size', use_default='inactive', & + long='biomass carbon in leaf of understory plants by pft/size', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_bleaf_understory_si_scpf ) call this%set_history_var(vname='NPLANT_UNDERSTORY_SCPF', units = 'N/ha', & - long='stem number of understory plants density by patch and pft/size', use_default='inactive', & + long='stem number of understory plants density by pft/size', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_understory_si_scpf ) @@ -1895,37 +1895,37 @@ subroutine define_history_vars(this, initialize_variables) ! Size structured diagnostics that require rapid updates (upfreq=2) call this%set_history_var(vname='AR_SCPF',units = 'kgC/m2/yr', & - long='total autotrophic respiration per m2 per year',use_default='inactive',& + long='total autotrophic respiration per m2 per year by pft/size',use_default='inactive',& avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_ar_si_scpf ) call this%set_history_var(vname='AR_GROW_SCPF',units = 'kgC/m2/yr', & - long='growth autotrophic respiration per m2 per year',use_default='inactive',& + long='growth autotrophic respiration per m2 per year by pft/size',use_default='inactive',& avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_ar_grow_si_scpf ) call this%set_history_var(vname='AR_MAINT_SCPF',units = 'kgC/m2/yr', & - long='maintenance autotrophic respiration per m2 per year',use_default='inactive',& + long='maintenance autotrophic respiration per m2 per year by pft/size',use_default='inactive',& avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_ar_maint_si_scpf ) call this%set_history_var(vname='AR_DARKM_SCPF',units = 'kgC/m2/yr', & - long='dark portion of maintenance autotrophic respiration per m2 per year',use_default='inactive',& + long='dark portion of maintenance autotrophic respiration per m2 per year by pft/size',use_default='inactive',& avgflag='A', vtype=site_size_pft_r8,hlms='CLM:ALM', flushval=0.0_r8, & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_ar_darkm_si_scpf ) call this%set_history_var(vname='AR_AGSAPM_SCPF',units = 'kgC/m2/yr', & - long='above-ground sapwood maintenance autotrophic respiration per m2 per year',use_default='inactive',& + long='above-ground sapwood maintenance autotrophic respiration per m2 per year by pft/size',use_default='inactive',& avgflag='A', vtype=site_size_pft_r8,hlms='CLM:ALM', flushval=0.0_r8, & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_ar_agsapm_si_scpf ) call this%set_history_var(vname='AR_CROOTM_SCPF',units = 'kgC/m2/yr', & - long='below-ground sapwood maintenance autotrophic respiration per m2 per year',use_default='inactive',& + long='below-ground sapwood maintenance autotrophic respiration per m2 per year by pft/size',use_default='inactive',& avgflag='A', vtype=site_size_pft_r8,hlms='CLM:ALM', flushval=0.0_r8, & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_ar_crootm_si_scpf ) call this%set_history_var(vname='AR_FROOTM_SCPF',units = 'kgC/m2/yr', & - long='fine root maintenance autotrophic respiration per m2 per year',use_default='inactive',& + long='fine root maintenance autotrophic respiration per m2 per year by pft/size',use_default='inactive',& avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_ar_frootm_si_scpf ) From d8b7d08dc5cf9a893cadfd2efbfd34ce86f9476c Mon Sep 17 00:00:00 2001 From: ckoven Date: Tue, 14 Feb 2017 11:23:05 -0800 Subject: [PATCH 328/437] added yet more diagnostics to disaggregate the canopy/understory and size-resolved cohort carbon budgets --- main/FatesHistoryInterfaceMod.F90 | 370 +++++++++++++++++++++++++++++- 1 file changed, 369 insertions(+), 1 deletion(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index b2634f13..c01b6641 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -144,6 +144,49 @@ module FatesHistoryInterfaceMod integer, private :: ih_mortality_canopy_si_scls integer, private :: ih_mortality_understory_si_scls + ! lots of non-default diagnostics for understanding canopy versus understory carbon balances + integer, private :: ih_rdark_canopy_si_scls + integer, private :: ih_livestem_mr_canopy_si_scls + integer, private :: ih_livecroot_mr_canopy_si_scls + integer, private :: ih_froot_mr_canopy_si_scls + integer, private :: ih_resp_g_canopy_si_scls + integer, private :: ih_resp_m_canopy_si_scls + integer, private :: ih_leaf_md_canopy_si_scls + integer, private :: ih_root_md_canopy_si_scls + integer, private :: ih_carbon_balance_canopy_si_scls + integer, private :: ih_seed_prod_canopy_si_scls + integer, private :: ih_dbalivedt_canopy_si_scls + integer, private :: ih_dbdeaddt_canopy_si_scls + integer, private :: ih_dbstoredt_canopy_si_scls + integer, private :: ih_storage_flux_canopy_si_scls + integer, private :: ih_npp_leaf_canopy_si_scls + integer, private :: ih_npp_froot_canopy_si_scls + integer, private :: ih_npp_bsw_canopy_si_scls + integer, private :: ih_npp_bdead_canopy_si_scls + integer, private :: ih_npp_bseed_canopy_si_scls + integer, private :: ih_npp_store_canopy_si_scls + + integer, private :: ih_rdark_understory_si_scls + integer, private :: ih_livestem_mr_understory_si_scls + integer, private :: ih_livecroot_mr_understory_si_scls + integer, private :: ih_froot_mr_understory_si_scls + integer, private :: ih_resp_g_understory_si_scls + integer, private :: ih_resp_m_understory_si_scls + integer, private :: ih_leaf_md_understory_si_scls + integer, private :: ih_root_md_understory_si_scls + integer, private :: ih_carbon_balance_understory_si_scls + integer, private :: ih_seed_prod_understory_si_scls + integer, private :: ih_dbalivedt_understory_si_scls + integer, private :: ih_dbdeaddt_understory_si_scls + integer, private :: ih_dbstoredt_understory_si_scls + integer, private :: ih_storage_flux_understory_si_scls + integer, private :: ih_npp_leaf_understory_si_scls + integer, private :: ih_npp_froot_understory_si_scls + integer, private :: ih_npp_bsw_understory_si_scls + integer, private :: ih_npp_bdead_understory_si_scls + integer, private :: ih_npp_bseed_understory_si_scls + integer, private :: ih_npp_store_understory_si_scls + ! indices to (site x pft) variables integer, private :: ih_biomass_si_pft integer, private :: ih_leafbiomass_si_pft @@ -844,6 +887,34 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_nplant_understory_si_scls => this%hvars(ih_nplant_understory_si_scls)%r82d, & hio_mortality_canopy_si_scls => this%hvars(ih_mortality_canopy_si_scls)%r82d, & hio_mortality_understory_si_scls => this%hvars(ih_mortality_understory_si_scls)%r82d, & + hio_leaf_md_canopy_si_scls => this%hvars(ih_leaf_md_canopy_si_scls)%r82d, & + hio_root_md_canopy_si_scls => this%hvars(ih_root_md_canopy_si_scls)%r82d, & + hio_carbon_balance_canopy_si_scls => this%hvars(ih_carbon_balance_canopy_si_scls)%r82d, & + hio_seed_prod_canopy_si_scls => this%hvars(ih_seed_prod_canopy_si_scls)%r82d, & + hio_dbalivedt_canopy_si_scls => this%hvars(ih_dbalivedt_canopy_si_scls)%r82d, & + hio_dbdeaddt_canopy_si_scls => this%hvars(ih_dbdeaddt_canopy_si_scls)%r82d, & + hio_dbstoredt_canopy_si_scls => this%hvars(ih_dbstoredt_canopy_si_scls)%r82d, & + hio_storage_flux_canopy_si_scls => this%hvars(ih_storage_flux_canopy_si_scls)%r82d, & + hio_npp_leaf_canopy_si_scls => this%hvars(ih_npp_leaf_canopy_si_scls)%r82d, & + hio_npp_froot_canopy_si_scls => this%hvars(ih_npp_froot_canopy_si_scls)%r82d, & + hio_npp_bsw_canopy_si_scls => this%hvars(ih_npp_bsw_canopy_si_scls)%r82d, & + hio_npp_bdead_canopy_si_scls => this%hvars(ih_npp_bdead_canopy_si_scls)%r82d, & + hio_npp_bseed_canopy_si_scls => this%hvars(ih_npp_bseed_canopy_si_scls)%r82d, & + hio_npp_store_canopy_si_scls => this%hvars(ih_npp_store_canopy_si_scls)%r82d, & + hio_leaf_md_understory_si_scls => this%hvars(ih_leaf_md_understory_si_scls)%r82d, & + hio_root_md_understory_si_scls => this%hvars(ih_root_md_understory_si_scls)%r82d, & + hio_carbon_balance_understory_si_scls=> this%hvars(ih_carbon_balance_understory_si_scls)%r82d, & + hio_seed_prod_understory_si_scls => this%hvars(ih_seed_prod_understory_si_scls)%r82d, & + hio_dbalivedt_understory_si_scls => this%hvars(ih_dbalivedt_understory_si_scls)%r82d, & + hio_dbdeaddt_understory_si_scls => this%hvars(ih_dbdeaddt_understory_si_scls)%r82d, & + hio_dbstoredt_understory_si_scls => this%hvars(ih_dbstoredt_understory_si_scls)%r82d, & + hio_storage_flux_understory_si_scls => this%hvars(ih_storage_flux_understory_si_scls)%r82d, & + hio_npp_leaf_understory_si_scls => this%hvars(ih_npp_leaf_understory_si_scls)%r82d, & + hio_npp_froot_understory_si_scls => this%hvars(ih_npp_froot_understory_si_scls)%r82d, & + hio_npp_bsw_understory_si_scls => this%hvars(ih_npp_bsw_understory_si_scls)%r82d, & + hio_npp_bdead_understory_si_scls => this%hvars(ih_npp_bdead_understory_si_scls)%r82d, & + hio_npp_bseed_understory_si_scls => this%hvars(ih_npp_bseed_understory_si_scls)%r82d, & + hio_npp_store_understory_si_scls => this%hvars(ih_npp_store_understory_si_scls)%r82d, & hio_area_si_age => this%hvars(ih_area_si_age)%r82d, & hio_lai_si_age => this%hvars(ih_lai_si_age)%r82d, & hio_canopy_area_si_age => this%hvars(ih_canopy_area_si_age)%r82d, & @@ -1048,6 +1119,35 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! sum of all mortality hio_mortality_canopy_si_scls(io_si,scls) = hio_mortality_canopy_si_scls(io_si,scls) + & (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%imort + ccohort%fmort) * n_perm2*AREA + ! + hio_leaf_md_canopy_si_scls(io_si,scls) = hio_leaf_md_canopy_si_scls(io_si,scls) + & + ccohort%leaf_md * n_perm2 * AREA + hio_root_md_canopy_si_scls(io_si,scls) = hio_root_md_canopy_si_scls(io_si,scls) + & + ccohort%root_md * n_perm2 * AREA + hio_carbon_balance_canopy_si_scls(io_si,scls) = hio_carbon_balance_canopy_si_scls(io_si,scls) + & + ccohort%carbon_balance * n_perm2 * AREA + hio_seed_prod_canopy_si_scls(io_si,scls) = hio_seed_prod_canopy_si_scls(io_si,scls) + & + ccohort%seed_prod * n_perm2 * AREA + hio_dbalivedt_canopy_si_scls(io_si,scls) = hio_dbalivedt_canopy_si_scls(io_si,scls) + & + ccohort%dbalivedt * n_perm2 * AREA + hio_dbdeaddt_canopy_si_scls(io_si,scls) = hio_dbdeaddt_canopy_si_scls(io_si,scls) + & + ccohort%dbdeaddt * n_perm2 * AREA + hio_dbstoredt_canopy_si_scls(io_si,scls) = hio_dbstoredt_canopy_si_scls(io_si,scls) + & + ccohort%dbstoredt * n_perm2 * AREA + hio_storage_flux_canopy_si_scls(io_si,scls) = hio_storage_flux_canopy_si_scls(io_si,scls) + & + ccohort%storage_flux * n_perm2 * AREA + hio_npp_leaf_canopy_si_scls(io_si,scls) = hio_npp_leaf_canopy_si_scls(io_si,scls) + & + ccohort%npp_leaf * n_perm2 * AREA * yeardays + hio_npp_froot_canopy_si_scls(io_si,scls) = hio_npp_froot_canopy_si_scls(io_si,scls) + & + ccohort%npp_froot * n_perm2 * AREA * yeardays + hio_npp_bsw_canopy_si_scls(io_si,scls) = hio_npp_bsw_canopy_si_scls(io_si,scls) + & + ccohort%npp_bsw * n_perm2 * AREA * yeardays + hio_npp_bdead_canopy_si_scls(io_si,scls) = hio_npp_bdead_canopy_si_scls(io_si,scls) + & + ccohort%npp_bdead * n_perm2 * AREA * yeardays + hio_npp_bseed_canopy_si_scls(io_si,scls) = hio_npp_bseed_canopy_si_scls(io_si,scls) + & + ccohort%npp_bseed * n_perm2 * AREA * yeardays + hio_npp_store_canopy_si_scls(io_si,scls) = hio_npp_store_canopy_si_scls(io_si,scls) + & + ccohort%npp_store * n_perm2 * AREA * yeardays else hio_bstor_understory_si_scpf(io_si,scpf) = hio_bstor_understory_si_scpf(io_si,scpf) + & ccohort%bstore * n_perm2 * AREA @@ -1067,6 +1167,35 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! sum of all mortality hio_mortality_understory_si_scls(io_si,scls) = hio_mortality_understory_si_scls(io_si,scls) + & (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%imort + ccohort%fmort) * n_perm2*AREA + ! + hio_leaf_md_understory_si_scls(io_si,scls) = hio_leaf_md_understory_si_scls(io_si,scls) + & + ccohort%leaf_md * n_perm2 * AREA + hio_root_md_understory_si_scls(io_si,scls) = hio_root_md_understory_si_scls(io_si,scls) + & + ccohort%root_md * n_perm2 * AREA + hio_carbon_balance_understory_si_scls(io_si,scls) = hio_carbon_balance_understory_si_scls(io_si,scls) + & + ccohort%carbon_balance * n_perm2 * AREA + hio_seed_prod_understory_si_scls(io_si,scls) = hio_seed_prod_understory_si_scls(io_si,scls) + & + ccohort%seed_prod * n_perm2 * AREA + hio_dbalivedt_understory_si_scls(io_si,scls) = hio_dbalivedt_understory_si_scls(io_si,scls) + & + ccohort%dbalivedt * n_perm2 * AREA + hio_dbdeaddt_understory_si_scls(io_si,scls) = hio_dbdeaddt_understory_si_scls(io_si,scls) + & + ccohort%dbdeaddt * n_perm2 * AREA + hio_dbstoredt_understory_si_scls(io_si,scls) = hio_dbstoredt_understory_si_scls(io_si,scls) + & + ccohort%dbstoredt * n_perm2 * AREA + hio_storage_flux_understory_si_scls(io_si,scls) = hio_storage_flux_understory_si_scls(io_si,scls) + & + ccohort%storage_flux * n_perm2 * AREA + hio_npp_leaf_understory_si_scls(io_si,scls) = hio_npp_leaf_understory_si_scls(io_si,scls) + & + ccohort%npp_leaf * n_perm2 * AREA * yeardays + hio_npp_froot_understory_si_scls(io_si,scls) = hio_npp_froot_understory_si_scls(io_si,scls) + & + ccohort%npp_froot * n_perm2 * AREA * yeardays + hio_npp_bsw_understory_si_scls(io_si,scls) = hio_npp_bsw_understory_si_scls(io_si,scls) + & + ccohort%npp_bsw * n_perm2 * AREA * yeardays + hio_npp_bdead_understory_si_scls(io_si,scls) = hio_npp_bdead_understory_si_scls(io_si,scls) + & + ccohort%npp_bdead * n_perm2 * AREA * yeardays + hio_npp_bseed_understory_si_scls(io_si,scls) = hio_npp_bseed_understory_si_scls(io_si,scls) + & + ccohort%npp_bseed * n_perm2 * AREA * yeardays + hio_npp_store_understory_si_scls(io_si,scls) = hio_npp_store_understory_si_scls(io_si,scls) + & + ccohort%npp_store * n_perm2 * AREA * yeardays endif end associate @@ -1240,6 +1369,18 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) hio_ar_canopy_pa => this%hvars(ih_ar_canopy_pa)%r81d, & hio_gpp_understory_pa => this%hvars(ih_gpp_understory_pa)%r81d, & hio_ar_understory_pa => this%hvars(ih_ar_understory_pa)%r81d, & + hio_rdark_canopy_si_scls => this%hvars(ih_rdark_canopy_si_scls)%r82d, & + hio_livestem_mr_canopy_si_scls => this%hvars(ih_livestem_mr_canopy_si_scls)%r82d, & + hio_livecroot_mr_canopy_si_scls => this%hvars(ih_livecroot_mr_canopy_si_scls)%r82d, & + hio_froot_mr_canopy_si_scls => this%hvars(ih_froot_mr_canopy_si_scls)%r82d, & + hio_resp_g_canopy_si_scls => this%hvars(ih_resp_g_canopy_si_scls)%r82d, & + hio_resp_m_canopy_si_scls => this%hvars(ih_resp_m_canopy_si_scls)%r82d, & + hio_rdark_understory_si_scls => this%hvars(ih_rdark_understory_si_scls)%r82d, & + hio_livestem_mr_understory_si_scls => this%hvars(ih_livestem_mr_understory_si_scls)%r82d, & + hio_livecroot_mr_understory_si_scls => this%hvars(ih_livecroot_mr_understory_si_scls)%r82d, & + hio_froot_mr_understory_si_scls => this%hvars(ih_froot_mr_understory_si_scls)%r82d, & + hio_resp_g_understory_si_scls => this%hvars(ih_resp_g_understory_si_scls)%r82d, & + hio_resp_m_understory_si_scls => this%hvars(ih_resp_m_understory_si_scls)%r82d, & hio_gpp_si_age => this%hvars(ih_gpp_si_age)%r82d, & hio_npp_si_age => this%hvars(ih_npp_si_age)%r82d & ) @@ -1280,7 +1421,8 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) if ( .not. ccohort%isnew ) then ! Calculate index for the scpf class - associate( scpf => ccohort%size_by_pft_class ) + associate( scpf => ccohort%size_by_pft_class, & + scls => ccohort%size_class ) ! scale up cohort fluxes to their patches hio_npp_pa(io_pa) = hio_npp_pa(io_pa) + & @@ -1339,11 +1481,37 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) ccohort%gpp_tstep * 1.e3_r8 * n_density / dt_tstep hio_ar_canopy_pa(io_pa) = hio_ar_canopy_pa(io_pa) + & ccohort%resp_tstep * 1.e3_r8 * n_density / dt_tstep + ! + hio_rdark_canopy_si_scls(io_si,scls) = hio_rdark_canopy_si_scls(io_si,scls) + & + ccohort%rdark * 1.e3_r8 * n_density * daysecs * yeardays + hio_livestem_mr_canopy_si_scls(io_si,scls) = hio_livestem_mr_canopy_si_scls(io_si,scls) + & + ccohort%livestem_mr * 1.e3_r8 * n_density * daysecs * yeardays + hio_livecroot_mr_canopy_si_scls(io_si,scls) = hio_livecroot_mr_canopy_si_scls(io_si,scls) + & + ccohort%livecroot_mr * 1.e3_r8 * n_density * daysecs * yeardays + hio_froot_mr_canopy_si_scls(io_si,scls) = hio_froot_mr_canopy_si_scls(io_si,scls) + & + ccohort%froot_mr * 1.e3_r8 * n_density * daysecs * yeardays + hio_resp_g_canopy_si_scls(io_si,scls) = hio_resp_g_canopy_si_scls(io_si,scls) + & + ccohort%resp_g * 1.e3_r8 * n_density * daysecs * yeardays / dt_tstep + hio_resp_m_canopy_si_scls(io_si,scls) = hio_resp_m_canopy_si_scls(io_si,scls) + & + ccohort%resp_m * 1.e3_r8 * n_density * daysecs * yeardays / dt_tstep else hio_gpp_understory_pa(io_pa) = hio_gpp_understory_pa(io_pa) + & ccohort%gpp_tstep * 1.e3_r8 * n_density / dt_tstep hio_ar_understory_pa(io_pa) = hio_ar_understory_pa(io_pa) + & ccohort%resp_tstep * 1.e3_r8 * n_density / dt_tstep + ! + hio_rdark_understory_si_scls(io_si,scls) = hio_rdark_understory_si_scls(io_si,scls) + & + ccohort%rdark * 1.e3_r8 * n_density * daysecs * yeardays + hio_livestem_mr_understory_si_scls(io_si,scls) = hio_livestem_mr_understory_si_scls(io_si,scls) + & + ccohort%livestem_mr * 1.e3_r8 * n_density * daysecs * yeardays + hio_livecroot_mr_understory_si_scls(io_si,scls) = hio_livecroot_mr_understory_si_scls(io_si,scls) + & + ccohort%livecroot_mr * 1.e3_r8 * n_density * daysecs * yeardays + hio_froot_mr_understory_si_scls(io_si,scls) = hio_froot_mr_understory_si_scls(io_si,scls) + & + ccohort%froot_mr * 1.e3_r8 * n_density * daysecs * yeardays + hio_resp_g_understory_si_scls(io_si,scls) = hio_resp_g_understory_si_scls(io_si,scls) + & + ccohort%resp_g * 1.e3_r8 * n_density * daysecs * yeardays / dt_tstep + hio_resp_m_understory_si_scls(io_si,scls) = hio_resp_m_understory_si_scls(io_si,scls) + & + ccohort%resp_m * 1.e3_r8 * n_density * daysecs * yeardays / dt_tstep endif end associate endif @@ -1955,6 +2123,206 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_mortality_understory_si_scls ) + call this%set_history_var(vname='LEAF_MD_CANOPY_SCLS', units = 'kg C / ha / yr', & + long='LEAF_MD for canopy plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_leaf_md_canopy_si_scls ) + + call this%set_history_var(vname='ROOT_MD_CANOPY_SCLS', units = 'kg C / ha / yr', & + long='ROOT_MD for canopy plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_root_md_canopy_si_scls ) + + call this%set_history_var(vname='CARBON_BALANCE_CANOPY_SCLS', units = 'kg C / ha / yr', & + long='CARBON_BALANCE for canopy plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_carbon_balance_canopy_si_scls ) + + call this%set_history_var(vname='SEED_PROD_CANOPY_SCLS', units = 'kg C / ha / yr', & + long='SEED_PROD for canopy plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_seed_prod_canopy_si_scls ) + + call this%set_history_var(vname='DBALIVEDT_CANOPY_SCLS', units = 'kg C / ha / yr', & + long='DBALIVEDT for canopy plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_dbalivedt_canopy_si_scls ) + + call this%set_history_var(vname='DBDEADDT_CANOPY_SCLS', units = 'kg C / ha / yr', & + long='DBDEADDT for canopy plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_dbdeaddt_canopy_si_scls ) + + call this%set_history_var(vname='DBSTOREDT_CANOPY_SCLS', units = 'kg C / ha / yr', & + long='DBSTOREDT for canopy plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_dbstoredt_canopy_si_scls ) + + call this%set_history_var(vname='STORAGE_FLUX_CANOPY_SCLS', units = 'kg C / ha / yr', & + long='STORAGE_FLUX for canopy plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_storage_flux_canopy_si_scls ) + + call this%set_history_var(vname='NPP_LEAF_CANOPY_SCLS', units = 'kg C / ha / yr', & + long='NPP_LEAF for canopy plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_leaf_canopy_si_scls ) + + call this%set_history_var(vname='NPP_FROOT_CANOPY_SCLS', units = 'kg C / ha / yr', & + long='NPP_FROOT for canopy plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_froot_canopy_si_scls ) + + call this%set_history_var(vname='NPP_BSW_CANOPY_SCLS', units = 'kg C / ha / yr', & + long='NPP_BSW for canopy plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_bsw_canopy_si_scls ) + + call this%set_history_var(vname='NPP_BDEAD_CANOPY_SCLS', units = 'kg C / ha / yr', & + long='NPP_BDEAD for canopy plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_bdead_canopy_si_scls ) + + call this%set_history_var(vname='NPP_BSEED_CANOPY_SCLS', units = 'kg C / ha / yr', & + long='NPP_BSEED for canopy plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_bseed_canopy_si_scls ) + + call this%set_history_var(vname='NPP_STORE_CANOPY_SCLS', units = 'kg C / ha / yr', & + long='NPP_STORE for canopy plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_store_canopy_si_scls ) + + call this%set_history_var(vname='RDARK_CANOPY_SCLS', units = 'kg C / ha / yr', & + long='RDARK for canopy plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_rdark_canopy_si_scls ) + + call this%set_history_var(vname='LIVESTEM_MR_CANOPY_SCLS', units = 'kg C / ha / yr', & + long='LIVESTEM_MR for canopy plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_livestem_mr_canopy_si_scls ) + + call this%set_history_var(vname='LIVECROOT_MR_CANOPY_SCLS', units = 'kg C / ha / yr', & + long='LIVECROOT_MR for canopy plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_livecroot_mr_canopy_si_scls ) + + call this%set_history_var(vname='FROOT_MR_CANOPY_SCLS', units = 'kg C / ha / yr', & + long='FROOT_MR for canopy plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_froot_mr_canopy_si_scls ) + + call this%set_history_var(vname='RESP_G_CANOPY_SCLS', units = 'kg C / ha / yr', & + long='RESP_G for canopy plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_resp_g_canopy_si_scls ) + + call this%set_history_var(vname='RESP_M_CANOPY_SCLS', units = 'kg C / ha / yr', & + long='RESP_M for canopy plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_resp_m_canopy_si_scls ) + + call this%set_history_var(vname='LEAF_MD_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & + long='LEAF_MD for understory plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_leaf_md_understory_si_scls ) + + call this%set_history_var(vname='ROOT_MD_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & + long='ROOT_MD for understory plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_root_md_understory_si_scls ) + + call this%set_history_var(vname='CARBON_BALANCE_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & + long='CARBON_BALANCE for understory plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_carbon_balance_understory_si_scls ) + + call this%set_history_var(vname='SEED_PROD_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & + long='SEED_PROD for understory plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_seed_prod_understory_si_scls ) + + call this%set_history_var(vname='DBALIVEDT_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & + long='DBALIVEDT for understory plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_dbalivedt_understory_si_scls ) + + call this%set_history_var(vname='DBDEADDT_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & + long='DBDEADDT for understory plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_dbdeaddt_understory_si_scls ) + + call this%set_history_var(vname='DBSTOREDT_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & + long='DBSTOREDT for understory plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_dbstoredt_understory_si_scls ) + + call this%set_history_var(vname='STORAGE_FLUX_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & + long='STORAGE_FLUX for understory plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_storage_flux_understory_si_scls ) + + call this%set_history_var(vname='NPP_LEAF_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & + long='NPP_LEAF for understory plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_leaf_understory_si_scls ) + + call this%set_history_var(vname='NPP_FROOT_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & + long='NPP_FROOT for understory plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_froot_understory_si_scls ) + + call this%set_history_var(vname='NPP_BSW_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & + long='NPP_BSW for understory plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_bsw_understory_si_scls ) + + call this%set_history_var(vname='NPP_BDEAD_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & + long='NPP_BDEAD for understory plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_bdead_understory_si_scls ) + + call this%set_history_var(vname='NPP_BSEED_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & + long='NPP_BSEED for understory plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_bseed_understory_si_scls ) + + call this%set_history_var(vname='NPP_STORE_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & + long='NPP_STORE for understory plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_store_understory_si_scls ) + + call this%set_history_var(vname='RDARK_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & + long='RDARK for understory plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_rdark_understory_si_scls ) + + call this%set_history_var(vname='LIVESTEM_MR_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & + long='LIVESTEM_MR for understory plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_livestem_mr_understory_si_scls ) + + call this%set_history_var(vname='LIVECROOT_MR_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & + long='LIVECROOT_MR for understory plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_livecroot_mr_understory_si_scls ) + + call this%set_history_var(vname='FROOT_MR_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & + long='FROOT_MR for understory plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_froot_mr_understory_si_scls ) + + call this%set_history_var(vname='RESP_G_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & + long='RESP_G for understory plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_resp_g_understory_si_scls ) + + call this%set_history_var(vname='RESP_M_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & + long='RESP_M for understory plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_resp_m_understory_si_scls ) + ! CARBON BALANCE VARIABLES THAT DEPEND ON HLM BGC INPUTS From 684e7ab7c35e5d53bd7ab1245e3394b269699a16 Mon Sep 17 00:00:00 2001 From: ckoven Date: Tue, 14 Feb 2017 16:22:02 -0800 Subject: [PATCH 329/437] fixed 2 bugs: one unit and one restart --- main/FatesHistoryInterfaceMod.F90 | 24 ++++++++++++------------ main/FatesRestartInterfaceMod.F90 | 30 ++++++++++++++++++++++++++++++ 2 files changed, 42 insertions(+), 12 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 89c8cfb3..d38c9679 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -1483,17 +1483,17 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) ccohort%resp_tstep * 1.e3_r8 * n_density / dt_tstep ! hio_rdark_canopy_si_scls(io_si,scls) = hio_rdark_canopy_si_scls(io_si,scls) + & - ccohort%rdark * 1.e3_r8 * n_density * daysecs * yeardays + ccohort%rdark * 1.e3_r8 * ccohort%n * daysecs * yeardays hio_livestem_mr_canopy_si_scls(io_si,scls) = hio_livestem_mr_canopy_si_scls(io_si,scls) + & - ccohort%livestem_mr * 1.e3_r8 * n_density * daysecs * yeardays + ccohort%livestem_mr * 1.e3_r8 * ccohort%n * daysecs * yeardays hio_livecroot_mr_canopy_si_scls(io_si,scls) = hio_livecroot_mr_canopy_si_scls(io_si,scls) + & - ccohort%livecroot_mr * 1.e3_r8 * n_density * daysecs * yeardays + ccohort%livecroot_mr * 1.e3_r8 * ccohort%n * daysecs * yeardays hio_froot_mr_canopy_si_scls(io_si,scls) = hio_froot_mr_canopy_si_scls(io_si,scls) + & - ccohort%froot_mr * 1.e3_r8 * n_density * daysecs * yeardays + ccohort%froot_mr * 1.e3_r8 * ccohort%n * daysecs * yeardays hio_resp_g_canopy_si_scls(io_si,scls) = hio_resp_g_canopy_si_scls(io_si,scls) + & - ccohort%resp_g * 1.e3_r8 * n_density * daysecs * yeardays / dt_tstep + ccohort%resp_g * 1.e3_r8 * ccohort%n * daysecs * yeardays / dt_tstep hio_resp_m_canopy_si_scls(io_si,scls) = hio_resp_m_canopy_si_scls(io_si,scls) + & - ccohort%resp_m * 1.e3_r8 * n_density * daysecs * yeardays / dt_tstep + ccohort%resp_m * 1.e3_r8 * ccohort%n * daysecs * yeardays / dt_tstep else hio_gpp_understory_pa(io_pa) = hio_gpp_understory_pa(io_pa) + & ccohort%gpp_tstep * 1.e3_r8 * n_density / dt_tstep @@ -1501,17 +1501,17 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) ccohort%resp_tstep * 1.e3_r8 * n_density / dt_tstep ! hio_rdark_understory_si_scls(io_si,scls) = hio_rdark_understory_si_scls(io_si,scls) + & - ccohort%rdark * 1.e3_r8 * n_density * daysecs * yeardays + ccohort%rdark * 1.e3_r8 * ccohort%n * daysecs * yeardays hio_livestem_mr_understory_si_scls(io_si,scls) = hio_livestem_mr_understory_si_scls(io_si,scls) + & - ccohort%livestem_mr * 1.e3_r8 * n_density * daysecs * yeardays + ccohort%livestem_mr * 1.e3_r8 * ccohort%n * daysecs * yeardays hio_livecroot_mr_understory_si_scls(io_si,scls) = hio_livecroot_mr_understory_si_scls(io_si,scls) + & - ccohort%livecroot_mr * 1.e3_r8 * n_density * daysecs * yeardays + ccohort%livecroot_mr * 1.e3_r8 * ccohort%n * daysecs * yeardays hio_froot_mr_understory_si_scls(io_si,scls) = hio_froot_mr_understory_si_scls(io_si,scls) + & - ccohort%froot_mr * 1.e3_r8 * n_density * daysecs * yeardays + ccohort%froot_mr * 1.e3_r8 * ccohort%n * daysecs * yeardays hio_resp_g_understory_si_scls(io_si,scls) = hio_resp_g_understory_si_scls(io_si,scls) + & - ccohort%resp_g * 1.e3_r8 * n_density * daysecs * yeardays / dt_tstep + ccohort%resp_g * 1.e3_r8 * ccohort%n * daysecs * yeardays / dt_tstep hio_resp_m_understory_si_scls(io_si,scls) = hio_resp_m_understory_si_scls(io_si,scls) + & - ccohort%resp_m * 1.e3_r8 * n_density * daysecs * yeardays / dt_tstep + ccohort%resp_m * 1.e3_r8 * ccohort%n * daysecs * yeardays / dt_tstep endif end associate endif diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 18b77bc6..90b9dd21 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -98,6 +98,9 @@ module FatesRestartInterfaceMod integer, private :: ir_imort_co integer, private :: ir_fmort_co integer, private :: ir_ddbhdt_co + integer, private :: ir_dbalivedt_co + integer, private :: ir_dbdeaddt_co + integer, private :: ir_dbstoredt_co integer, private :: ir_resp_tstep_co integer, private :: ir_pft_co integer, private :: ir_status_co @@ -731,6 +734,21 @@ subroutine define_restart_vars(this, initialize_variables) units='cm/year', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_ddbhdt_co ) + call this%set_restart_var(vname='fates_dbalivedt', vtype=cohort_r8, & + long_name='ed cohort - differential: ddbh/dt', & + units='cm/year', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_dbalivedt_co ) + + call this%set_restart_var(vname='fates_dbdeaddt', vtype=cohort_r8, & + long_name='ed cohort - differential: ddbh/dt', & + units='cm/year', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_dbdeaddt_co ) + + call this%set_restart_var(vname='fates_dbstoredt', vtype=cohort_r8, & + long_name='ed cohort - differential: ddbh/dt', & + units='cm/year', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_dbstoredt_co ) + call this%set_restart_var(vname='fates_resp_tstep', vtype=cohort_r8, & long_name='ed cohort - autotrophic respiration over timestep', & units='kgC/indiv/timestep', flushval = flushzero, & @@ -1008,6 +1026,9 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_imort_co => this%rvars(ir_imort_co)%r81d, & rio_fmort_co => this%rvars(ir_fmort_co)%r81d, & rio_ddbhdt_co => this%rvars(ir_ddbhdt_co)%r81d, & + rio_dbalivedt_co => this%rvars(ir_dbalivedt_co)%r81d, & + rio_dbdeaddt_co => this%rvars(ir_dbdeaddt_co)%r81d, & + rio_dbstoredt_co => this%rvars(ir_dbstoredt_co)%r81d, & rio_resp_tstep_co => this%rvars(ir_resp_tstep_co)%r81d, & rio_pft_co => this%rvars(ir_pft_co)%int1d, & rio_status_co => this%rvars(ir_status_co)%int1d, & @@ -1116,6 +1137,9 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_imort_co(io_idx_co) = ccohort%imort rio_fmort_co(io_idx_co) = ccohort%fmort rio_ddbhdt_co(io_idx_co) = ccohort%ddbhdt + rio_dbalivedt_co(io_idx_co) = ccohort%dbalivedt + rio_dbdeaddt_co(io_idx_co) = ccohort%dbdeaddt + rio_dbstoredt_co(io_idx_co) = ccohort%dbstoredt rio_resp_tstep_co(io_idx_co) = ccohort%resp_tstep rio_pft_co(io_idx_co) = ccohort%pft rio_status_co(io_idx_co) = ccohort%status_coh @@ -1570,6 +1594,9 @@ subroutine get_restart_vectors(this, nc, nsites, sites) rio_imort_co => this%rvars(ir_imort_co)%r81d, & rio_fmort_co => this%rvars(ir_fmort_co)%r81d, & rio_ddbhdt_co => this%rvars(ir_ddbhdt_co)%r81d, & + rio_dbalivedt_co => this%rvars(ir_dbalivedt_co)%r81d, & + rio_dbdeaddt_co => this%rvars(ir_dbdeaddt_co)%r81d, & + rio_dbstoredt_co => this%rvars(ir_dbstoredt_co)%r81d, & rio_resp_tstep_co => this%rvars(ir_resp_tstep_co)%r81d, & rio_pft_co => this%rvars(ir_pft_co)%int1d, & rio_status_co => this%rvars(ir_status_co)%int1d, & @@ -1663,6 +1690,9 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ccohort%imort = rio_imort_co(io_idx_co) ccohort%fmort = rio_fmort_co(io_idx_co) ccohort%ddbhdt = rio_ddbhdt_co(io_idx_co) + ccohort%dbalivedt = rio_dbalivedt_co(io_idx_co) + ccohort%dbdeaddt = rio_dbdeaddt_co(io_idx_co) + ccohort%dbstoredt = rio_dbstoredt_co(io_idx_co) ccohort%resp_tstep = rio_resp_tstep_co(io_idx_co) ccohort%pft = rio_pft_co(io_idx_co) ccohort%status_coh = rio_status_co(io_idx_co) From 120c8e27c0ae344b944f79be6144b53d8380b195 Mon Sep 17 00:00:00 2001 From: ckoven Date: Thu, 16 Feb 2017 13:42:15 -0800 Subject: [PATCH 330/437] added a diagnostic to track the relative fraction of understory individuals of a given size class who were demoted on a given timestep --- biogeochem/EDCohortDynamicsMod.F90 | 3 +++ biogeochem/EDPatchDynamicsMod.F90 | 1 + main/EDTypesMod.F90 | 1 + main/FatesHistoryInterfaceMod.F90 | 22 ++++++++++++++++++++++ main/FatesRestartInterfaceMod.F90 | 10 ++++++++++ 5 files changed, 37 insertions(+) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index edbfdd34..6fbdb337 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -94,6 +94,7 @@ subroutine create_cohort(patchptr, pft, nn, hite, dbh, & new_cohort%dbh = dbh new_cohort%canopy_trim = ctrim new_cohort%canopy_layer = clayer + new_cohort%canopy_layer_yesterday = clayer new_cohort%laimemory = laimemory new_cohort%bdead = bdead new_cohort%balive = balive @@ -334,6 +335,7 @@ subroutine nan_cohort(cc_p) currentCohort%pft = fates_unset_int ! pft number currentCohort%indexnumber = fates_unset_int ! unique number for each cohort. (within clump?) currentCohort%canopy_layer = fates_unset_int ! canopy status of cohort (1 = canopy, 2 = understorey, etc.) + currentCohort%canopy_layer_yesterday = fates_unset_int ! canopy status of cohort (1 = canopy, 2 = understorey, etc.) currentCohort%NV = fates_unset_int ! Number of leaf layers: - currentCohort%status_coh = fates_unset_int ! growth status of plant (2 = leaves on , 1 = leaves off) currentCohort%size_class = fates_unset_int ! size class index @@ -1041,6 +1043,7 @@ subroutine copy_cohort( currentCohort,copyc ) n%gscan = o%gscan n%leaf_cost = o%leaf_cost n%canopy_layer = o%canopy_layer + n%canopy_layer_yesterday = o%canopy_layer_yesterday n%nv = o%nv n%status_coh = o%status_coh n%canopy_trim = o%canopy_trim diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index df283d6c..049a1e8a 100755 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -262,6 +262,7 @@ subroutine spawn_patches( currentSite ) !this is the case as the new patch probably doesn't have a closed canopy, and ! even if it does, that will be sorted out in canopy_structure. nc%canopy_layer = 1 + nc%canopy_layer_yesterday = 1 !mortality is dominant disturbance if(currentPatch%disturbance_rates(1) > currentPatch%disturbance_rates(2))then diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 79386f3e..c83fc0bf 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -191,6 +191,7 @@ module EDTypesMod 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.) + integer :: canopy_layer_yesterday ! 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 diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index d38c9679..038ec665 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -187,6 +187,9 @@ module FatesHistoryInterfaceMod integer, private :: ih_npp_bseed_understory_si_scls integer, private :: ih_npp_store_understory_si_scls + integer, private :: ih_yesterdaycanopylevel_canopy_si_scls + integer, private :: ih_yesterdaycanopylevel_understory_si_scls + ! indices to (site x pft) variables integer, private :: ih_biomass_si_pft integer, private :: ih_leafbiomass_si_pft @@ -915,6 +918,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_npp_bdead_understory_si_scls => this%hvars(ih_npp_bdead_understory_si_scls)%r82d, & hio_npp_bseed_understory_si_scls => this%hvars(ih_npp_bseed_understory_si_scls)%r82d, & hio_npp_store_understory_si_scls => this%hvars(ih_npp_store_understory_si_scls)%r82d, & + hio_yesterdaycanopylevel_canopy_si_scls => this%hvars(ih_yesterdaycanopylevel_canopy_si_scls)%r82d, & + hio_yesterdaycanopylevel_understory_si_scls => this%hvars(ih_yesterdaycanopylevel_understory_si_scls)%r82d, & hio_area_si_age => this%hvars(ih_area_si_age)%r82d, & hio_lai_si_age => this%hvars(ih_lai_si_age)%r82d, & hio_canopy_area_si_age => this%hvars(ih_canopy_area_si_age)%r82d, & @@ -1148,6 +1153,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) ccohort%npp_bseed * n_perm2 * AREA * yeardays hio_npp_store_canopy_si_scls(io_si,scls) = hio_npp_store_canopy_si_scls(io_si,scls) + & ccohort%npp_store * n_perm2 * AREA * yeardays + hio_yesterdaycanopylevel_canopy_si_scls(io_si,scls) = hio_yesterdaycanopylevel_canopy_si_scls(io_si,scls) + & + real(ccohort%canopy_layer_yesterday, r8) * n_perm2 * AREA else hio_bstor_understory_si_scpf(io_si,scpf) = hio_bstor_understory_si_scpf(io_si,scpf) + & ccohort%bstore * n_perm2 * AREA @@ -1196,7 +1203,11 @@ subroutine update_history_dyn(this,nc,nsites,sites) ccohort%npp_bseed * n_perm2 * AREA * yeardays hio_npp_store_understory_si_scls(io_si,scls) = hio_npp_store_understory_si_scls(io_si,scls) + & ccohort%npp_store * n_perm2 * AREA * yeardays + hio_yesterdaycanopylevel_understory_si_scls(io_si,scls) = hio_yesterdaycanopylevel_understory_si_scls(io_si,scls) + & + real(ccohort%canopy_layer_yesterday, r8) * n_perm2 * AREA endif + ! + ccohort%canopy_layer_yesterday = ccohort%canopy_layer end associate end if @@ -2098,6 +2109,17 @@ subroutine define_history_vars(this, initialize_variables) upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_ar_frootm_si_scpf ) ! size-class only variables + + call this%set_history_var(vname='YESTERDAYCANLEV_CANOPY_SCLS', units = 'indiv/ha', & + long='Yesterdays canopy level for canopy plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_yesterdaycanopylevel_canopy_si_scls ) + + call this%set_history_var(vname='YESTERDAYCANLEV_UNDERSTORY_SCLS', units = 'indiv/ha', & + long='Yesterdays canopy level for understory plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_yesterdaycanopylevel_understory_si_scls ) + call this%set_history_var(vname='BA_SCLS', units = 'm2/ha', & long='basal area by size class', use_default='active', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 90b9dd21..d6459927 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -75,6 +75,7 @@ module FatesRestartInterfaceMod integer, private :: ir_broot_co integer, private :: ir_bstore_co integer, private :: ir_canopy_layer_co + integer, private :: ir_canopy_layer_yesterday_co integer, private :: ir_canopy_trim_co integer, private :: ir_dbh_co integer, private :: ir_height_co @@ -622,6 +623,10 @@ subroutine define_restart_vars(this, initialize_variables) long_name='ed cohort - canopy_layer', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_canopy_layer_co ) + call this%set_restart_var(vname='fates_canopy_layer_yesterday', vtype=cohort_r8, & + long_name='ed cohort - canopy_layer_yesterday', units='unitless', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_canopy_layer_yesterday_co ) + call this%set_restart_var(vname='fates_canopy_trim', vtype=cohort_r8, & long_name='ed cohort - canopy_trim', units='fraction', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_canopy_trim_co ) @@ -1003,6 +1008,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_broot_co => this%rvars(ir_broot_co)%r81d, & rio_bstore_co => this%rvars(ir_bstore_co)%r81d, & rio_canopy_layer_co => this%rvars(ir_canopy_layer_co)%r81d, & + rio_canopy_layer_yesterday_co => this%rvars(ir_canopy_layer_yesterday_co)%r81d, & rio_canopy_trim_co => this%rvars(ir_canopy_trim_co)%r81d, & rio_dbh_co => this%rvars(ir_dbh_co)%r81d, & rio_height_co => this%rvars(ir_height_co)%r81d, & @@ -1114,6 +1120,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_broot_co(io_idx_co) = ccohort%br rio_bstore_co(io_idx_co) = ccohort%bstore rio_canopy_layer_co(io_idx_co) = ccohort%canopy_layer + rio_canopy_layer_yesterday_co(io_idx_co) = ccohort%canopy_layer_yesterday rio_canopy_trim_co(io_idx_co) = ccohort%canopy_trim rio_dbh_co(io_idx_co) = ccohort%dbh rio_height_co(io_idx_co) = ccohort%hite @@ -1410,6 +1417,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites ) temp_cohort%laimemory = 0.0_r8 temp_cohort%canopy_trim = 0.0_r8 temp_cohort%canopy_layer = 1.0_r8 + temp_cohort%canopy_layer_yesterday = 1.0_r8 ! set the pft (only 2 used in ed) based on odd/even cohort ! number @@ -1571,6 +1579,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) rio_broot_co => this%rvars(ir_broot_co)%r81d, & rio_bstore_co => this%rvars(ir_bstore_co)%r81d, & rio_canopy_layer_co => this%rvars(ir_canopy_layer_co)%r81d, & + rio_canopy_layer_yesterday_co => this%rvars(ir_canopy_layer_yesterday_co)%r81d, & rio_canopy_trim_co => this%rvars(ir_canopy_trim_co)%r81d, & rio_dbh_co => this%rvars(ir_dbh_co)%r81d, & rio_height_co => this%rvars(ir_height_co)%r81d, & @@ -1667,6 +1676,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ccohort%br = rio_broot_co(io_idx_co) ccohort%bstore = rio_bstore_co(io_idx_co) ccohort%canopy_layer = rio_canopy_layer_co(io_idx_co) + ccohort%canopy_layer_yesterday = rio_canopy_layer_yesterday_co(io_idx_co) ccohort%canopy_trim = rio_canopy_trim_co(io_idx_co) ccohort%dbh = rio_dbh_co(io_idx_co) ccohort%hite = rio_height_co(io_idx_co) From 73ae2082b21424bd17665e70c719a0eff1bc0c2a Mon Sep 17 00:00:00 2001 From: ckoven Date: Tue, 21 Feb 2017 12:19:53 -0800 Subject: [PATCH 331/437] added new vars on demotion rates and updated prior canopy level to allow fusion --- biogeochem/EDCanopyStructureMod.F90 | 17 +++++++++++ biogeochem/EDCohortDynamicsMod.F90 | 7 +++-- biogeochem/EDPatchDynamicsMod.F90 | 2 +- main/EDInitMod.F90 | 4 +++ main/EDTypesMod.F90 | 6 ++-- main/FatesHistoryInterfaceMod.F90 | 44 ++++++++++++++++++++++++++--- 6 files changed, 71 insertions(+), 9 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 3b8d94e6..f0f9511e 100755 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -110,6 +110,8 @@ subroutine canopy_structure( currentSite ) ! Section 1: Check total canopy area. new_total_area_check = 0._r8 + currentSite%demotion_rate(:) = 0._r8 + currentSite%demotion_carbonflux = 0._r8 do while (associated(currentPatch)) ! Patch loop if (currentPatch%area .gt. min_patch_area) then ! avoid numerical weirdness that shouldn't be happening anyway @@ -198,6 +200,14 @@ subroutine canopy_structure( currentSite ) ! causing non-linearity issues with c_area. is this really required? currentCohort%dbh = currentCohort%dbh copyc%dbh = copyc%dbh !+ 0.000000000001_r8 + + ! keep track of number and biomass of demoted cohort + currentSite%demotion_rate(currentCohort%size_class) = & + currentSite%demotion_rate(currentCohort%size_class) + currentCohort%n + currentSite%demotion_carbonflux = currentSite%demotion_carbonflux + & + (currentCohort%bdead + currentCohort%bsw + currentCohort%bl + currentCohort%br + & + currentCohort%bstore) * currentCohort%n + !kill the ones which go into canopy layers that are not allowed... (default nclmax=2) if(i+1 > cp_nclmax)then !put the litter from the terminated cohorts into the fragmenting pools @@ -244,6 +254,13 @@ subroutine canopy_structure( currentSite ) currentCohort%canopy_layer = i + 1 !the whole cohort becomes demoted sumloss = sumloss + currentCohort%c_area + ! keep track of number and biomass of demoted cohort + currentSite%demotion_rate(currentCohort%size_class) = & + currentSite%demotion_rate(currentCohort%size_class) + currentCohort%n + currentSite%demotion_carbonflux = currentSite%demotion_carbonflux + & + (currentCohort%bdead + currentCohort%bsw + currentCohort%bl + currentCohort%br + & + currentCohort%bstore) * currentCohort%n + !kill the ones which go into canopy layers that are not allowed... (default cp_nclmax=2) if(i+1 > cp_nclmax)then !put the litter from the terminated cohorts into the fragmenting pools diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 6fbdb337..0cb1f5d7 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -94,7 +94,7 @@ subroutine create_cohort(patchptr, pft, nn, hite, dbh, & new_cohort%dbh = dbh new_cohort%canopy_trim = ctrim new_cohort%canopy_layer = clayer - new_cohort%canopy_layer_yesterday = clayer + new_cohort%canopy_layer_yesterday = real(clayer, r8) new_cohort%laimemory = laimemory new_cohort%bdead = bdead new_cohort%balive = balive @@ -335,7 +335,7 @@ subroutine nan_cohort(cc_p) currentCohort%pft = fates_unset_int ! pft number currentCohort%indexnumber = fates_unset_int ! unique number for each cohort. (within clump?) currentCohort%canopy_layer = fates_unset_int ! canopy status of cohort (1 = canopy, 2 = understorey, etc.) - currentCohort%canopy_layer_yesterday = fates_unset_int ! canopy status of cohort (1 = canopy, 2 = understorey, etc.) + currentCohort%canopy_layer_yesterday = nan ! recent canopy status of cohort (1 = canopy, 2 = understorey, etc.) currentCohort%NV = fates_unset_int ! Number of leaf layers: - currentCohort%status_coh = fates_unset_int ! growth status of plant (2 = leaves on , 1 = leaves off) currentCohort%size_class = fates_unset_int ! size class index @@ -766,6 +766,9 @@ subroutine fuse_cohorts(patchptr) currentCohort%npp_bseed = (currentCohort%n*currentCohort%npp_bseed + nextc%n*nextc%npp_bseed)/newn currentCohort%npp_store = (currentCohort%n*currentCohort%npp_store + nextc%n*nextc%npp_store)/newn + ! recent canopy history + currentCohort%canopy_layer_yesterday = (currentCohort%n*currentCohort%canopy_layer_yesterday + nextc%n*nextc%canopy_layer_yesterday)/newn + do i=1, cp_nlevcan 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)) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 049a1e8a..a0136bb1 100755 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -262,7 +262,7 @@ subroutine spawn_patches( currentSite ) !this is the case as the new patch probably doesn't have a closed canopy, and ! even if it does, that will be sorted out in canopy_structure. nc%canopy_layer = 1 - nc%canopy_layer_yesterday = 1 + nc%canopy_layer_yesterday = 1._r8 !mortality is dominant disturbance if(currentPatch%disturbance_rates(1) > currentPatch%disturbance_rates(2))then diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index a9b9a987..4bf0ea8a 100755 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -83,6 +83,10 @@ subroutine zero_site( site_in ) site_in%terminated_nindivs(:,:,:) = 0._r8 site_in%recruitment_rate(:) = 0._r8 + ! demotion info + site_in%demotion_rate(:) = 0._r8 + site_in%demotion_carbonflux = 0._r8 + end subroutine zero_site ! ============================================================================ diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index c83fc0bf..74123bac 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -191,7 +191,7 @@ module EDTypesMod 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.) - integer :: canopy_layer_yesterday ! canopy status of cohort (1 = canopy, 2 = understorey, etc.) + real(r8) :: canopy_layer_yesterday ! recent canopy status of cohort (1 = canopy, 2 = understorey, etc.) real to be conservative during fusion 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 @@ -559,9 +559,11 @@ module EDTypesMod real(r8) :: cwd_ag_burned(ncwd) real(r8) :: leaf_litter_burned(numpft_ed) - ! TERMINATION AND RECRUITMENT~ + ! TERMINATION, RECRUITMENT, AND DEMOTION real(r8) :: terminated_nindivs(1:nlevsclass_ed,1:mxpft,2) ! number of individuals that were in cohorts which were terminated this timestep, on size x pft x canopy array. real(r8) :: recruitment_rate(1:mxpft) ! number of individuals that were recruited into new cohorts + real(r8) :: demotion_rate(1:nlevsclass_ed) ! rate of individuals demoted from canopy to understory per FATES timestep + real(r8) :: demotion_carbonflux ! biomass of demoted individuals from canopy to understory [gC/m2/s] end type ed_site_type diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 038ec665..b6f0d2bd 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -66,6 +66,8 @@ module FatesHistoryInterfaceMod integer, private :: ih_gpp_canopy_pa integer, private :: ih_ar_understory_pa integer, private :: ih_gpp_understory_pa + integer, private :: ih_canopy_biomass_pa + integer, private :: ih_understory_biomass_pa ! Indices to (site) variables integer, private :: ih_nep_si @@ -91,6 +93,7 @@ module FatesHistoryInterfaceMod integer, private :: ih_cbal_err_tot_si integer, private :: ih_npatches_si integer, private :: ih_ncohorts_si + integer, private :: ih_demotion_carbonflux_si ! Indices to (site x scpf) variables integer, private :: ih_nplant_si_scpf @@ -143,6 +146,7 @@ module FatesHistoryInterfaceMod integer, private :: ih_nplant_understory_si_scls integer, private :: ih_mortality_canopy_si_scls integer, private :: ih_mortality_understory_si_scls + integer, private :: ih_demotion_rate_si_scls ! lots of non-default diagnostics for understanding canopy versus understory carbon balances integer, private :: ih_rdark_canopy_si_scls @@ -852,6 +856,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_balive_pa => this%hvars(ih_balive_pa)%r81d, & hio_bleaf_pa => this%hvars(ih_bleaf_pa)%r81d, & hio_btotal_pa => this%hvars(ih_btotal_pa)%r81d, & + hio_canopy_biomass_pa => this%hvars(ih_canopy_biomass_pa)%r81d, & + hio_understory_biomass_pa => this%hvars(ih_understory_biomass_pa)%r81d, & hio_gpp_si_scpf => this%hvars(ih_gpp_si_scpf)%r82d, & hio_npp_totl_si_scpf => this%hvars(ih_npp_totl_si_scpf)%r82d, & hio_npp_leaf_si_scpf => this%hvars(ih_npp_leaf_si_scpf)%r82d, & @@ -890,6 +896,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_nplant_understory_si_scls => this%hvars(ih_nplant_understory_si_scls)%r82d, & hio_mortality_canopy_si_scls => this%hvars(ih_mortality_canopy_si_scls)%r82d, & hio_mortality_understory_si_scls => this%hvars(ih_mortality_understory_si_scls)%r82d, & + hio_demotion_rate_si_scls => this%hvars(ih_demotion_rate_si_scls)%r82d, & + hio_demotion_carbonflux_si => this%hvars(ih_demotion_carbonflux_si)%r81d, & hio_leaf_md_canopy_si_scls => this%hvars(ih_leaf_md_canopy_si_scls)%r82d, & hio_root_md_canopy_si_scls => this%hvars(ih_root_md_canopy_si_scls)%r82d, & hio_carbon_balance_canopy_si_scls => this%hvars(ih_carbon_balance_canopy_si_scls)%r82d, & @@ -1110,6 +1118,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) ccohort%bstore * n_perm2 * AREA hio_bleaf_canopy_si_scpf(io_si,scpf) = hio_bleaf_canopy_si_scpf(io_si,scpf) + & ccohort%bl * n_perm2 * AREA + hio_canopy_biomass_pa(io_pa) = hio_canopy_biomass_pa(io_pa) + n_density * ccohort%b * 1.e3_r8 hio_mortality_canopy_si_scpf(io_si,scpf) = hio_mortality_canopy_si_scpf(io_si,scpf)+ & (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%imort + ccohort%fmort) * n_perm2*AREA hio_nplant_canopy_si_scpf(io_si,scpf) = hio_nplant_canopy_si_scpf(io_si,scpf) + AREA*n_perm2 @@ -1154,12 +1163,13 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_npp_store_canopy_si_scls(io_si,scls) = hio_npp_store_canopy_si_scls(io_si,scls) + & ccohort%npp_store * n_perm2 * AREA * yeardays hio_yesterdaycanopylevel_canopy_si_scls(io_si,scls) = hio_yesterdaycanopylevel_canopy_si_scls(io_si,scls) + & - real(ccohort%canopy_layer_yesterday, r8) * n_perm2 * AREA + ccohort%canopy_layer_yesterday * n_perm2 * AREA else hio_bstor_understory_si_scpf(io_si,scpf) = hio_bstor_understory_si_scpf(io_si,scpf) + & ccohort%bstore * n_perm2 * AREA hio_bleaf_understory_si_scpf(io_si,scpf) = hio_bleaf_understory_si_scpf(io_si,scpf) + & ccohort%bl * n_perm2 * AREA + hio_understory_biomass_pa(io_pa) = hio_understory_biomass_pa(io_pa) + n_density * ccohort%b * 1.e3_r8 hio_mortality_understory_si_scpf(io_si,scpf) = hio_mortality_understory_si_scpf(io_si,scpf)+ & (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%imort + ccohort%fmort) * n_perm2*AREA hio_nplant_understory_si_scpf(io_si,scpf) = hio_nplant_understory_si_scpf(io_si,scpf) + AREA*n_perm2 @@ -1204,10 +1214,10 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_npp_store_understory_si_scls(io_si,scls) = hio_npp_store_understory_si_scls(io_si,scls) + & ccohort%npp_store * n_perm2 * AREA * yeardays hio_yesterdaycanopylevel_understory_si_scls(io_si,scls) = hio_yesterdaycanopylevel_understory_si_scls(io_si,scls) + & - real(ccohort%canopy_layer_yesterday, r8) * n_perm2 * AREA + ccohort%canopy_layer_yesterday * n_perm2 * AREA endif ! - ccohort%canopy_layer_yesterday = ccohort%canopy_layer + ccohort%canopy_layer_yesterday = real(ccohort%canopy_layer, r8) end associate end if @@ -1309,7 +1319,13 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_m6_si_scpf(io_si,i_scpf) end do end do - + + ! pass demotion rates and associated carbon fluxes to history + do i_scls = 1,nlevsclass_ed + hio_demotion_rate_si_scls(io_si,i_scls) = sites(s)%demotion_rate(i_scls) * yeardays + end do + hio_demotion_carbonflux_si(io_si) = sites(s)%demotion_carbonflux * 1e3 / (1e-4 * daysecs) + enddo ! site loop end associate @@ -1834,6 +1850,16 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_btotal_pa ) + call this%set_history_var(vname='CANOPY_BIOMASS', units='gC m-2', & + long='Biomass of canopy plants', use_default='active', & + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_canopy_biomass_pa ) + + call this%set_history_var(vname='UNDERSTORY_BIOMASS', units='gC m-2', & + long='Biomass of understory plants', use_default='active', & + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_understory_biomass_pa ) + ! Ecosystem Carbon Fluxes (updated rapidly, upfreq=2) @@ -2125,6 +2151,16 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ba_si_scls ) + call this%set_history_var(vname='DEMOTION_RATE_SCLS', units = 'indiv/ha/yr', & + long='demotion rate from canopy to understory by size class', use_default='active', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_demotion_rate_si_scls ) + + call this%set_history_var(vname='DEMOTION_CARBONFLUX', units = 'gC/m2/s', & + long='demotion-associated biomass carbon flux from canopy to understory', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_demotion_carbonflux_si ) + call this%set_history_var(vname='NPLANT_CANOPY_SCLS', units = 'indiv/ha', & long='number of canopy plants by size class', use_default='active', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & From 11bd0485a8f04d68d9b6c1f99b06d8af90b7a539 Mon Sep 17 00:00:00 2001 From: ckoven Date: Tue, 21 Feb 2017 22:01:19 -0800 Subject: [PATCH 332/437] fixed unit error and also added new diagnsotics on carbon fluxes from mortality and promotion --- biogeochem/EDCanopyStructureMod.F90 | 40 +++++++++++++++++++++-------- biogeochem/EDCohortDynamicsMod.F90 | 4 ++- main/EDInitMod.F90 | 5 +++- main/EDTypesMod.F90 | 5 +++- main/FatesHistoryInterfaceMod.F90 | 38 ++++++++++++++++++++++++++- 5 files changed, 78 insertions(+), 14 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index f0f9511e..148e53b1 100755 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -105,13 +105,17 @@ subroutine canopy_structure( currentSite ) integer :: count_mi !---------------------------------------------------------------------- - currentPatch => currentSite%oldest_patch - - ! Section 1: Check total canopy area. - - new_total_area_check = 0._r8 + currentPatch => currentSite%oldest_patch + ! + ! zero site-level demotion / promotion tracking info currentSite%demotion_rate(:) = 0._r8 + currentSite%promotion_rate(:) = 0._r8 currentSite%demotion_carbonflux = 0._r8 + currentSite%promotion_carbonflux = 0._r8 + ! + ! Section 1: Check total canopy area. + ! + new_total_area_check = 0._r8 do while (associated(currentPatch)) ! Patch loop if (currentPatch%area .gt. min_patch_area) then ! avoid numerical weirdness that shouldn't be happening anyway @@ -205,8 +209,7 @@ subroutine canopy_structure( currentSite ) currentSite%demotion_rate(currentCohort%size_class) = & currentSite%demotion_rate(currentCohort%size_class) + currentCohort%n currentSite%demotion_carbonflux = currentSite%demotion_carbonflux + & - (currentCohort%bdead + currentCohort%bsw + currentCohort%bl + currentCohort%br + & - currentCohort%bstore) * currentCohort%n + currentCohort%b * currentCohort%n !kill the ones which go into canopy layers that are not allowed... (default nclmax=2) if(i+1 > cp_nclmax)then @@ -258,8 +261,7 @@ subroutine canopy_structure( currentSite ) currentSite%demotion_rate(currentCohort%size_class) = & currentSite%demotion_rate(currentCohort%size_class) + currentCohort%n currentSite%demotion_carbonflux = currentSite%demotion_carbonflux + & - (currentCohort%bdead + currentCohort%bsw + currentCohort%bl + currentCohort%br + & - currentCohort%bstore) * currentCohort%n + currentCohort%b * currentCohort%n !kill the ones which go into canopy layers that are not allowed... (default cp_nclmax=2) if(i+1 > cp_nclmax)then @@ -383,6 +385,12 @@ subroutine canopy_structure( currentSite ) currentCohort%canopy_layer = i currentCohort%c_area = c_area(currentCohort) + ! keep track of number and biomass of promoted cohort + currentSite%promotion_rate(currentCohort%size_class) = & + currentSite%promotion_rate(currentCohort%size_class) + currentCohort%n + currentSite%promotion_carbonflux = currentSite%promotion_carbonflux + & + currentCohort%b * currentCohort%n + ! write(fates_log(),*) 'promoting very small cohort', currentCohort%c_area,currentCohort%canopy_layer endif arealayer(currentCohort%canopy_layer) = arealayer(currentCohort%canopy_layer)+currentCohort%c_area @@ -442,12 +450,18 @@ subroutine canopy_structure( currentSite ) 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 + ! number of individuals in cohort remaining 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. + ! keep track of number and biomass of promoted cohort + currentSite%promotion_rate(copyc%size_class) = & + currentSite%promotion_rate(copyc%size_class) + copyc%n + currentSite%promotion_carbonflux = currentSite%promotion_carbonflux + & + copyc%b * copyc%n + ! seperate cohorts. ! needs to be a very small number to avoid causing non-linearity issues with c_area. ! is this really required? @@ -474,6 +488,12 @@ subroutine canopy_structure( currentSite ) ! if the upper canopy spread is smaller. this shold be dealt with by the 'excess area' loop. currentCohort%c_area = c_area(currentCohort) + ! keep track of number and biomass of promoted cohort + currentSite%promotion_rate(currentCohort%size_class) = & + currentSite%promotion_rate(currentCohort%size_class) + currentCohort%n + currentSite%promotion_carbonflux = currentSite%promotion_carbonflux + & + currentCohort%b * currentCohort%n + promswitch = 1 ! write(fates_log(),*) 'promoting whole cohort', currentCohort%c_area,cc_gain,currentCohort%canopy_layer, & diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 0cb1f5d7..3c3247bd 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -570,7 +570,9 @@ subroutine terminate_cohorts( patchptr ) endif currentPatch%siteptr%terminated_nindivs(currentCohort%size_class,currentCohort%pft,levcan) = & currentPatch%siteptr%terminated_nindivs(currentCohort%size_class,currentCohort%pft,levcan) + currentCohort%n - + ! + currentPatch%siteptr%termination_carbonflux(levcan) = currentPatch%siteptr%termination_carbonflux(levcan) + & + currentCohort%n * currentCohort%b if (.not. associated(currentCohort%taller)) then currentPatch%tallest => currentCohort%shorter else diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 4bf0ea8a..4d12e266 100755 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -81,11 +81,14 @@ subroutine zero_site( site_in ) ! termination and recruitment info site_in%terminated_nindivs(:,:,:) = 0._r8 + site_in%termination_carbonflux(:) = 0._r8 site_in%recruitment_rate(:) = 0._r8 - ! demotion info + ! demotion/promotion info site_in%demotion_rate(:) = 0._r8 site_in%demotion_carbonflux = 0._r8 + site_in%promotion_rate(:) = 0._r8 + site_in%promotion_carbonflux = 0._r8 end subroutine zero_site diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 74123bac..6fe9171d 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -561,9 +561,12 @@ module EDTypesMod ! TERMINATION, RECRUITMENT, AND DEMOTION real(r8) :: terminated_nindivs(1:nlevsclass_ed,1:mxpft,2) ! number of individuals that were in cohorts which were terminated this timestep, on size x pft x canopy array. + real(r8) :: termination_carbonflux(2) ! carbon flux from live to dead pools associated with termination mortality, per canopy level real(r8) :: recruitment_rate(1:mxpft) ! number of individuals that were recruited into new cohorts real(r8) :: demotion_rate(1:nlevsclass_ed) ! rate of individuals demoted from canopy to understory per FATES timestep - real(r8) :: demotion_carbonflux ! biomass of demoted individuals from canopy to understory [gC/m2/s] + real(r8) :: demotion_carbonflux ! biomass of demoted individuals from canopy to understory [kgC/ha/day] + real(r8) :: promotion_rate(1:nlevsclass_ed) ! rate of individuals promoted from understory to canopy per FATES timestep + real(r8) :: promotion_carbonflux ! biomass of promoted individuals from understory to canopy [kgC/ha/day] end type ed_site_type diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index b6f0d2bd..9029eec5 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -94,6 +94,9 @@ module FatesHistoryInterfaceMod integer, private :: ih_npatches_si integer, private :: ih_ncohorts_si integer, private :: ih_demotion_carbonflux_si + integer, private :: ih_promotion_carbonflux_si + integer, private :: ih_canopy_mortality_carbonflux_si + integer, private :: ih_understory_mortality_carbonflux_si ! Indices to (site x scpf) variables integer, private :: ih_nplant_si_scpf @@ -147,6 +150,7 @@ module FatesHistoryInterfaceMod integer, private :: ih_mortality_canopy_si_scls integer, private :: ih_mortality_understory_si_scls integer, private :: ih_demotion_rate_si_scls + integer, private :: ih_promotion_rate_si_scls ! lots of non-default diagnostics for understanding canopy versus understory carbon balances integer, private :: ih_rdark_canopy_si_scls @@ -898,6 +902,10 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_mortality_understory_si_scls => this%hvars(ih_mortality_understory_si_scls)%r82d, & hio_demotion_rate_si_scls => this%hvars(ih_demotion_rate_si_scls)%r82d, & hio_demotion_carbonflux_si => this%hvars(ih_demotion_carbonflux_si)%r81d, & + hio_promotion_rate_si_scls => this%hvars(ih_promotion_rate_si_scls)%r82d, & + hio_promotion_carbonflux_si => this%hvars(ih_promotion_carbonflux_si)%r81d, & + hio_canopy_mortality_carbonflux_si => this%hvars(ih_canopy_mortality_carbonflux_si)%r81d, & + hio_understory_mortality_carbonflux_si => this%hvars(ih_understory_mortality_carbonflux_si)%r81d, & hio_leaf_md_canopy_si_scls => this%hvars(ih_leaf_md_canopy_si_scls)%r82d, & hio_root_md_canopy_si_scls => this%hvars(ih_root_md_canopy_si_scls)%r82d, & hio_carbon_balance_canopy_si_scls => this%hvars(ih_carbon_balance_canopy_si_scls)%r82d, & @@ -1133,6 +1141,9 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! sum of all mortality hio_mortality_canopy_si_scls(io_si,scls) = hio_mortality_canopy_si_scls(io_si,scls) + & (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%imort + ccohort%fmort) * n_perm2*AREA + hio_canopy_mortality_carbonflux_si(io_si) = hio_canopy_mortality_carbonflux_si(io_si) + & + (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%imort + ccohort%fmort) * & + ccohort%b * ccohort%n * 1e3 / (1e4 * daysecs) ! hio_leaf_md_canopy_si_scls(io_si,scls) = hio_leaf_md_canopy_si_scls(io_si,scls) + & ccohort%leaf_md * n_perm2 * AREA @@ -1184,6 +1195,9 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! sum of all mortality hio_mortality_understory_si_scls(io_si,scls) = hio_mortality_understory_si_scls(io_si,scls) + & (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%imort + ccohort%fmort) * n_perm2*AREA + hio_understory_mortality_carbonflux_si(io_si) = hio_understory_mortality_carbonflux_si(io_si) + & + (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%imort + ccohort%fmort) * & + ccohort%b * ccohort%n * 1e3 / (1e4 * daysecs) ! hio_leaf_md_understory_si_scls(io_si,scls) = hio_leaf_md_understory_si_scls(io_si,scls) + & ccohort%leaf_md * n_perm2 * AREA @@ -1323,8 +1337,20 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! pass demotion rates and associated carbon fluxes to history do i_scls = 1,nlevsclass_ed hio_demotion_rate_si_scls(io_si,i_scls) = sites(s)%demotion_rate(i_scls) * yeardays + hio_promotion_rate_si_scls(io_si,i_scls) = sites(s)%promotion_rate(i_scls) * yeardays end do - hio_demotion_carbonflux_si(io_si) = sites(s)%demotion_carbonflux * 1e3 / (1e-4 * daysecs) + ! + ! convert kg C / ha / day to gc / m2 / sec + hio_demotion_carbonflux_si(io_si) = sites(s)%demotion_carbonflux * 1e3 / (1e4 * daysecs) + hio_promotion_carbonflux_si(io_si) = sites(s)%promotion_carbonflux * 1e3 / (1e4 * daysecs) + ! + ! mortality-associated carbon fluxes + hio_canopy_mortality_carbonflux_si(io_si) = hio_canopy_mortality_carbonflux_si(io_si) + & + sites(s)%termination_carbonflux(1) * 1e3 / (1e4 * daysecs) + hio_understory_mortality_carbonflux_si(io_si) = hio_understory_mortality_carbonflux_si(io_si) + & + sites(s)%termination_carbonflux(2) * 1e3 / (1e4 * daysecs) + ! and zero the site-level termination carbon flux variable + sites(s)%termination_carbonflux(:) = 0._r8 enddo ! site loop @@ -2161,6 +2187,16 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_demotion_carbonflux_si ) + call this%set_history_var(vname='PROMOTION_RATE_SCLS', units = 'indiv/ha/yr', & + long='promotion rate from understory to canopy by size class', use_default='active', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_promotion_rate_si_scls ) + + call this%set_history_var(vname='PROMOTION_CARBONFLUX', units = 'gC/m2/s', & + long='promotion-associated biomass carbon flux from understory to canopy', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_promotion_carbonflux_si ) + call this%set_history_var(vname='NPLANT_CANOPY_SCLS', units = 'indiv/ha', & long='number of canopy plants by size class', use_default='active', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & From fb3548534e1cf2224621368434535b0f00d409b2 Mon Sep 17 00:00:00 2001 From: ckoven Date: Wed, 22 Feb 2017 09:45:03 -0800 Subject: [PATCH 333/437] bufix and some cleanup --- main/FatesHistoryInterfaceMod.F90 | 35 ++++++++++++++++++++----------- 1 file changed, 23 insertions(+), 12 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 9029eec5..25614f5a 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -1876,12 +1876,12 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_btotal_pa ) - call this%set_history_var(vname='CANOPY_BIOMASS', units='gC m-2', & + call this%set_history_var(vname='BIOMASS_CANOPY', units='gC m-2', & long='Biomass of canopy plants', use_default='active', & avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_canopy_biomass_pa ) - call this%set_history_var(vname='UNDERSTORY_BIOMASS', units='gC m-2', & + call this%set_history_var(vname='BIOMASS_UNDERSTORY', units='gC m-2', & long='Biomass of understory plants', use_default='active', & avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_understory_biomass_pa ) @@ -1951,6 +1951,27 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & ivar=ivar, initialize=initialize_variables, index = ih_ar_understory_pa ) + ! slow carbon fluxes associated with mortality from or transfer betweeen canopy and understory + call this%set_history_var(vname='DEMOTION_CARBONFLUX', units = 'gC/m2/s', & + long='demotion-associated biomass carbon flux from canopy to understory', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_demotion_carbonflux_si ) + + call this%set_history_var(vname='PROMOTION_CARBONFLUX', units = 'gC/m2/s', & + long='promotion-associated biomass carbon flux from understory to canopy', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_promotion_carbonflux_si ) + + call this%set_history_var(vname='MORTALITY_CARBONFLUX_CANOPY', units = 'gC/m2/s', & + long='flux of biomass carbon from live to dead pools from mortality of canopy plants', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_canopy_mortality_carbonflux_si ) + + call this%set_history_var(vname='MORTALITY_CARBONFLUX_UNDERSTORY', units = 'gC/m2/s', & + long='flux of biomass carbon from live to dead pools from mortality of understory plants', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_understory_mortality_carbonflux_si ) + ! Carbon Flux (grid dimension x scpf) (THESE ARE DEFAULT INACTIVE!!! ! (BECAUSE THEY TAKE UP SPACE!!! @@ -2182,21 +2203,11 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_demotion_rate_si_scls ) - call this%set_history_var(vname='DEMOTION_CARBONFLUX', units = 'gC/m2/s', & - long='demotion-associated biomass carbon flux from canopy to understory', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_demotion_carbonflux_si ) - call this%set_history_var(vname='PROMOTION_RATE_SCLS', units = 'indiv/ha/yr', & long='promotion rate from understory to canopy by size class', use_default='active', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_promotion_rate_si_scls ) - call this%set_history_var(vname='PROMOTION_CARBONFLUX', units = 'gC/m2/s', & - long='promotion-associated biomass carbon flux from understory to canopy', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_promotion_carbonflux_si ) - call this%set_history_var(vname='NPLANT_CANOPY_SCLS', units = 'indiv/ha', & long='number of canopy plants by size class', use_default='active', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & From 40f10eeaef80feba84da6d315830112c181195ac Mon Sep 17 00:00:00 2001 From: ckoven Date: Wed, 22 Feb 2017 10:26:45 -0800 Subject: [PATCH 334/437] reduced thresholds for cohort termination due to small number densities to allow cohorts to demote successfully --- main/EDTypesMod.F90 | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 6fe9171d..bef4d13b 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -67,12 +67,12 @@ module EDTypesMod integer , parameter :: N_DBH_BINS = 5 ! no. of dbh bins used when comparing patches - real(r8), parameter :: min_npm2 = 1.0d-5 ! minimum cohort number density per m2 before termination - real(r8), parameter :: min_patch_area = 0.001_r8 ! smallest allowable patch area before termination - real(r8), parameter :: min_nppatch = 1.0d-8 ! minimum number of cohorts per patch (min_npm2*min_patch_area) - real(r8), parameter :: min_n_safemath = 1.0d-15 ! in some cases, we want to immediately remove super small - ! number densities of cohorts to prevent FPEs, this is usually - ! just relevant in the first day after recruitment + real(r8), parameter :: min_npm2 = 1.0E-8_r8 ! minimum cohort number density per m2 before termination + real(r8), parameter :: min_patch_area = 0.001_r8 ! smallest allowable patch area before termination + real(r8), parameter :: min_nppatch = 1.0E-11_r8 ! minimum number of cohorts per patch (min_npm2*min_patch_area) + real(r8), parameter :: min_n_safemath = 1.0E-15_r8 ! in some cases, we want to immediately remove super small + ! number densities of cohorts to prevent FPEs, this is usually + ! just relevant in the first day after recruitment character*4 yearchar From e93fdc837ba357d7f3567be91d92a05e44cc4c64 Mon Sep 17 00:00:00 2001 From: ckoven Date: Wed, 22 Feb 2017 11:04:27 -0800 Subject: [PATCH 335/437] removed calls to terminate_cohorts in EDCanopyStructureMod.F90 --- biogeochem/EDCanopyStructureMod.F90 | 5 ----- 1 file changed, 5 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 148e53b1..ae656286 100755 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -295,7 +295,6 @@ subroutine canopy_structure( currentSite ) !currentCohort%canopy_layer,currentCohort%dbh endif - ! call terminate_cohorts(currentPatch) !----------- End of cohort splitting ------------------------------! endif !canopy layer = i @@ -304,7 +303,6 @@ subroutine canopy_structure( currentSite ) 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 @@ -340,7 +338,6 @@ subroutine canopy_structure( currentSite ) enddo !is there still excess area in any layer? - call terminate_cohorts(currentPatch) call fuse_cohorts(currentPatch) call terminate_cohorts(currentPatch) @@ -500,7 +497,6 @@ subroutine canopy_structure( currentSite ) !currentCohort%pft,currentPatch%patchno endif - !call terminate_cohorts(currentPatch) if(promswitch == 1)then ! write(fates_log(),*) 'cohort loop',currentCohort%pft,currentPatch%patchno endif @@ -562,7 +558,6 @@ subroutine canopy_structure( currentSite ) endif enddo !is there still not enough canopy area in any layer? - call terminate_cohorts(currentPatch) call fuse_cohorts(currentPatch) call terminate_cohorts(currentPatch) From d270ddc84a8c90a9ea7208b010123024660b8ce4 Mon Sep 17 00:00:00 2001 From: Ben Andre Date: Wed, 22 Feb 2017 13:46:24 -0700 Subject: [PATCH 336/437] Dead code removal of edpftconrd EDpftconrd was commented out in a previous commit, but it is no longer needed and should have been completely removed. Test suite: ed - yellowstone gnu, intel, pgi Test baseline: ed-clm-3f3f16f Test namelist changes: none Test answer changes: bit for bit Test summary: all tests pass --- main/EDPftvarcon.F90 | 190 ------------------------------------------- 1 file changed, 190 deletions(-) diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index ea53b660..b60586c8 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -90,7 +90,6 @@ module EDPftvarcon __FILE__ ! ! !PUBLIC MEMBER FUNCTIONS: - public :: EDpftconrd ! Read and initialize vegetation (PFT) constants !----------------------------------------------------------------------- @@ -757,194 +756,5 @@ subroutine Receive_PFT_nvariants(this, fates_params) end subroutine Receive_PFT_nvariants - !----------------------------------------------------------------------- - subroutine EDpftconrd( ncid ) - ! - ! !DESCRIPTION: - ! Read and initialize vegetation (PFT) constants - ! - ! !USES: - use ncdio_pio , only : file_desc_t, ncd_io - use abortutils , only : endrun - use shr_log_mod , only : errMsg => shr_log_errMsg - ! - ! !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 - - !X! call ncd_io('max_dbh',EDPftvarcon_inst%max_dbh, 'read', ncid, readvar=readv) - !X! if ( .not. readv ) call endrun( trim(subname)//' ERROR: error in reading in pft data' ) - - !X! call ncd_io('freezetol',EDPftvarcon_inst%freezetol, 'read', ncid, readvar=readv) - !X! if ( .not. readv ) call endrun( trim(subname)//' ERROR: error in reading in pft data' ) - !X! - !X! call ncd_io('wood_density',EDPftvarcon_inst%wood_density, 'read', ncid, readvar=readv) - !X! if ( .not. readv ) call endrun( trim(subname)//' ERROR: error in reading in pft data' ) - !X! - !X! call ncd_io('alpha_stem',EDPftvarcon_inst%alpha_stem, 'read', ncid, readvar=readv) - !X! if ( .not. readv ) call endrun( trim(subname)//' ERROR: error in reading in pft data' ) - !X! - !X! call ncd_io('hgt_min',EDPftvarcon_inst%hgt_min, 'read', ncid, readvar=readv) - !X! if ( .not. readv ) call endrun( trim(subname)//' ERROR: error in reading in pft data' ) - !X! - !X! call ncd_io('cushion',EDPftvarcon_inst%cushion, 'read', ncid, readvar=readv) - !X! if ( .not. readv ) call endrun( trim(subname)//' ERROR: error in reading in pft data' ) - !X! - !X! call ncd_io('leaf_stor_priority',EDPftvarcon_inst%leaf_stor_priority, 'read', ncid, readvar=readv) - !X! if ( .not. readv ) call endrun( trim(subname)//' ERROR: error in reading in pft data' ) - !X! - !X! call ncd_io('leafwatermax',EDPftvarcon_inst%leafwatermax, 'read', ncid, readvar=readv) - !X! if ( .not. readv ) call endrun( trim(subname)//' ERROR: error in reading in pft data' ) - !X! - !X! call ncd_io('rootresist',EDPftvarcon_inst%rootresist,'read', ncid, readvar=readv) - !X! if ( .not. readv ) call endrun( trim(subname)//' ERROR: error in reading in pft data' ) - !X! - !X! call ncd_io('soilbeta',EDPftvarcon_inst%soilbeta,'read', ncid, readvar=readv) - !X! if ( .not. readv) call endrun(trim(subname)// ' ERROR : error in reading in pft data') - !X! - !X! call ncd_io('crown',EDPftvarcon_inst%crown,'read', ncid, readvar=readv) - !X! if ( .not. readv) call endrun(trim(subname)// ' ERROR : error in reading in pft data') - !X! - !X! call ncd_io('bark_scaler',EDPftvarcon_inst%bark_scaler,'read', ncid, readvar=readv) - !X! if ( .not. readv) call endrun(trim(subname)// ' ERROR : error in reading in pft data') - !X! - !X! call ncd_io('crown_kill',EDPftvarcon_inst%crown_kill,'read', ncid, readvar=readv) - !X! if ( .not. readv) call endrun(trim(subname)// ' ERROR : error in reading in pft data') - !X! - !X! call ncd_io('initd',EDPftvarcon_inst%initd,'read', ncid, readvar=readv) - !X! if ( .not. readv) call endrun(trim(subname)// ' ERROR : error in reading in pft data') - !X! - !X! call ncd_io('sd_mort',EDPftvarcon_inst%sd_mort,'read', ncid, readvar=readv) - !X! if ( .not. readv) call endrun(trim(subname)// ' ERROR : error in reading in pft data') - !X! - !X! call ncd_io('seed_rain',EDPftvarcon_inst%seed_rain,'read', ncid, readvar=readv) - !X! if ( .not. readv) call endrun(trim(subname)// ' ERROR : error in reading in pft data') - !X! - !X! call ncd_io('BB_slope',EDPftvarcon_inst%BB_slope,'read', ncid, readvar=readv) - !X! if ( .not. readv) call endrun(trim(subname)// ' ERROR : error in reading in pft data') - !X! - !X! call ncd_io('root_long',EDPftvarcon_inst%root_long, 'read', ncid, readvar=readv) - !X! if ( .not. readv) call endrun(trim(subname)// ' ERROR : error in reading in pft data') - !X! - !X! call ncd_io('seed_alloc',EDPftvarcon_inst%seed_alloc, 'read', ncid, readvar=readv) - !X! if ( .not. readv) call endrun(trim(subname)// ' ERROR : error in reading in pft data') - !X! - !X! call ncd_io('clone_alloc',EDPftvarcon_inst%clone_alloc, 'read', ncid, readvar=readv) - !X! if ( .not. readv) call endrun(trim(subname)// ' ERROR : error in reading in pft data') - !X! - !X! call ncd_io('sapwood_ratio',EDPftvarcon_inst%sapwood_ratio, 'read', ncid, readvar=readv) - !X! if ( .not. readv) call endrun(trim(subname)// ' ERROR : error in reading in pft data') - !X! - !X! call ncd_io('woody', EDPftvarcon_inst%woody, 'read', ncid, readvar=readv, posNOTonfile=.true.) - !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) - !X! - !X! call ncd_io('stress_decid', EDPftvarcon_inst%stress_decid, 'read', ncid, readvar=readv, posNOTonfile=.true.) - !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) - !X! - !X! call ncd_io('season_decid', EDPftvarcon_inst%season_decid, 'read', ncid, readvar=readv, posNOTonfile=.true.) - !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) - !X! - !X! call ncd_io('evergreen', EDPftvarcon_inst%evergreen, 'read', ncid, readvar=readv, posNOTonfile=.true.) - !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) - !X! - !X! call ncd_io('froot_leaf', EDPftvarcon_inst%froot_leaf, 'read', ncid, readvar=readv, posNOTonfile=.true.) - !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) - !X! - !X! call ncd_io('slatop', EDPftvarcon_inst%slatop, 'read', ncid, readvar=readv, posNOTonfile=.true.) - !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) - !X! - !X! call ncd_io('leaf_long', EDPftvarcon_inst%leaf_long, 'read', ncid, readvar=readv, posNOTonfile=.true.) - !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) - - !X! call ncd_io('rootprof_beta', EDPftvarcon_inst%rootprof_beta, 'read', ncid, readvar=readv, posNOTonfile=.true.) - !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) - - !X! call ncd_io('roota_par', EDPftvarcon_inst%roota_par, 'read', ncid, readvar=readv, posNOTonfile=.true.) - !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) - !X! - !X! call ncd_io('rootb_par', EDPftvarcon_inst%rootb_par, 'read', ncid, readvar=readv, posNOTonfile=.true.) - !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) - !X! - !X! call ncd_io('lf_flab', EDPftvarcon_inst%lf_flab, 'read', ncid, readvar=readv, posNOTonfile=.true.) - !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) - !X! - !X! call ncd_io('lf_fcel', EDPftvarcon_inst%lf_fcel, 'read', ncid, readvar=readv, posNOTonfile=.true.) - !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) - !X! - !X! call ncd_io('lf_flig', EDPftvarcon_inst%lf_flig, 'read', ncid, readvar=readv, posNOTonfile=.true.) - !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) - !X! - !X! call ncd_io('fr_flab', EDPftvarcon_inst%fr_flab, 'read', ncid, readvar=readv, posNOTonfile=.true.) - !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) - !X! - !X! call ncd_io('fr_fcel', EDPftvarcon_inst%fr_fcel, 'read', ncid, readvar=readv, posNOTonfile=.true.) - !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) - !X! - !X! call ncd_io('fr_flig', EDPftvarcon_inst%fr_flig, 'read', ncid, readvar=readv, posNOTonfile=.true.) - !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) - - !X! call ncd_io('rholvis', EDPftvarcon_inst%rhol(:,ivis), 'read', ncid, readvar=readv, posNOTonfile=.true.) - !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) - !X! - !X! call ncd_io('rholnir', EDPftvarcon_inst%rhol(:,inir), 'read', ncid, readvar=readv, posNOTonfile=.true.) - !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) - !X! - !X! call ncd_io('rhosvis', EDPftvarcon_inst%rhos(:,ivis), 'read', ncid, readvar=readv, posNOTonfile=.true.) - !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) - !X! - !X! call ncd_io('rhosnir', EDPftvarcon_inst% rhos(:,inir), 'read', ncid, readvar=readv, posNOTonfile=.true.) - !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) - !X! - !X! call ncd_io('taulvis', EDPftvarcon_inst%taul(:,ivis), 'read', ncid, readvar=readv, posNOTonfile=.true.) - !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) - !X! - !X! call ncd_io('taulnir', EDPftvarcon_inst%taul(:,inir), 'read', ncid, readvar=readv, posNOTonfile=.true.) - !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) - !X! - !X! call ncd_io('tausvis', EDPftvarcon_inst%taus(:,ivis), 'read', ncid, readvar=readv, posNOTonfile=.true.) - !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) - !X! - !X! call ncd_io('tausnir', EDPftvarcon_inst%taus(:,inir), 'read', ncid, readvar=readv, posNOTonfile=.true.) - !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) - - !X! call ncd_io('xl', EDPftvarcon_inst%xl, 'read', ncid, readvar=readv, posNOTonfile=.true.) - !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) - !X! - !X! call ncd_io('c3psn', EDPftvarcon_inst%c3psn, 'read', ncid, readvar=readv, posNOTonfile=.true.) - !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) - !X! - !X! call ncd_io('flnr', EDPftvarcon_inst%flnr, 'read', ncid, readvar=readv, posNOTonfile=.true.) - !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) - !X! - !X! call ncd_io('fnitr', EDPftvarcon_inst%fnitr, 'read', ncid, readvar=readv, posNOTonfile=.true.) - !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) - !X! - !X! call ncd_io('leafcn', EDPftvarcon_inst%leafcn, 'read', ncid, readvar=readv, posNOTonfile=.true.) - !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) - !X! - !X! call ncd_io('frootcn', EDPftvarcon_inst%frootcn, 'read', ncid, readvar=readv, posNOTonfile=.true.) - !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) - !X! - !X! call ncd_io('smpso', EDPftvarcon_inst%smpso, 'read', ncid, readvar=readv, posNOTonfile=.true.) - !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) - !X! - !X! call ncd_io('smpsc', EDPftvarcon_inst%smpsc, 'read', ncid, readvar=readv, posNOTonfile=.true.) - !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) - !X! - !X! call ncd_io('grperc', EDPftvarcon_inst%grperc, 'read', ncid, readvar=readv, posNOTonfile=.true.) - !X! if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) - - ! HOLDING ON SEW ENSITIVITY-ANALYSIS PARAMETERS UNTIL MACHINE CONFIGS SET RGK/CX - ! call ncd_io('dbh2h_m',EDPftvarcon_inst%dbh2h_m, 'read', ncid, readvar=readv) - ! if ( .not. readv) call endrun(trim(subname)// ' ERROR : error in reading in pft data') - - end subroutine EDpftconrd - end module EDPftvarcon From bb6b472fe149f9a7a7283958fc41ec19aae42fe7 Mon Sep 17 00:00:00 2001 From: ckoven Date: Wed, 22 Feb 2017 12:47:33 -0800 Subject: [PATCH 337/437] fixed unit error on mortality_carbonflux_canopy and mortality_carbonflux_understory --- main/FatesHistoryInterfaceMod.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 25614f5a..f6583253 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -1143,7 +1143,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%imort + ccohort%fmort) * n_perm2*AREA hio_canopy_mortality_carbonflux_si(io_si) = hio_canopy_mortality_carbonflux_si(io_si) + & (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%imort + ccohort%fmort) * & - ccohort%b * ccohort%n * 1e3 / (1e4 * daysecs) + ccohort%b * ccohort%n * 1e3 / (1e4 * daysecs * yeardays) ! hio_leaf_md_canopy_si_scls(io_si,scls) = hio_leaf_md_canopy_si_scls(io_si,scls) + & ccohort%leaf_md * n_perm2 * AREA @@ -1197,7 +1197,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%imort + ccohort%fmort) * n_perm2*AREA hio_understory_mortality_carbonflux_si(io_si) = hio_understory_mortality_carbonflux_si(io_si) + & (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%imort + ccohort%fmort) * & - ccohort%b * ccohort%n * 1e3 / (1e4 * daysecs) + ccohort%b * ccohort%n * 1e3 / (1e4 * daysecs * yeardays) ! hio_leaf_md_understory_si_scls(io_si,scls) = hio_leaf_md_understory_si_scls(io_si,scls) + & ccohort%leaf_md * n_perm2 * AREA From cc1b341d36803ceb52e3527dfbda2d5694a5d839 Mon Sep 17 00:00:00 2001 From: ckoven Date: Wed, 22 Feb 2017 13:49:07 -0800 Subject: [PATCH 338/437] fixed a unit error on the canopy/understory-reoslved tissue npp fluxes, which was traced back to a wrong description in EDTypesMod. Also cleanup. --- main/EDTypesMod.F90 | 12 ++-- main/FatesHistoryInterfaceMod.F90 | 106 +++++++++++++++--------------- 2 files changed, 59 insertions(+), 59 deletions(-) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 6fe9171d..326126a5 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -250,12 +250,12 @@ module EDTypesMod ! Net Primary Production Partitions - real(r8) :: npp_leaf ! NPP into leaves (includes replacement of turnover): KgC/indiv/day - real(r8) :: npp_froot ! NPP into fine roots (includes replacement of turnover): KgC/indiv/day - real(r8) :: npp_bsw ! NPP into sapwood: KgC/indiv/day - real(r8) :: npp_bdead ! NPP into deadwood (structure): KgC/indiv/day - real(r8) :: npp_bseed ! NPP into seeds: KgC/indiv/day - real(r8) :: npp_store ! NPP into storage: KgC/indiv/day + real(r8) :: npp_leaf ! NPP into leaves (includes replacement of turnover): KgC/indiv/year + real(r8) :: npp_froot ! NPP into fine roots (includes replacement of turnover): KgC/indiv/year + real(r8) :: npp_bsw ! NPP into sapwood: KgC/indiv/year + real(r8) :: npp_bdead ! NPP into deadwood (structure): KgC/indiv/year + real(r8) :: npp_bseed ! NPP into seeds: KgC/indiv/year + real(r8) :: npp_store ! NPP into storage: KgC/indiv/year real(r8) :: ts_net_uptake(cp_nlevcan) ! Net uptake of leaf layers: kgC/m2/s real(r8) :: year_net_uptake(cp_nlevcan) ! Net uptake of leaf layers: kgC/m2/year diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index f6583253..774c6308 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -1099,136 +1099,136 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! Woody State Variables (basal area and number density and mortality) if (pftcon%woody(ft) == 1) then - hio_m1_si_scpf(io_si,scpf) = hio_m1_si_scpf(io_si,scpf) + ccohort%bmort*n_perm2*AREA - hio_m2_si_scpf(io_si,scpf) = hio_m2_si_scpf(io_si,scpf) + ccohort%hmort*n_perm2*AREA - hio_m3_si_scpf(io_si,scpf) = hio_m3_si_scpf(io_si,scpf) + ccohort%cmort*n_perm2*AREA - hio_m4_si_scpf(io_si,scpf) = hio_m4_si_scpf(io_si,scpf) + ccohort%imort*n_perm2*AREA - hio_m5_si_scpf(io_si,scpf) = hio_m5_si_scpf(io_si,scpf) + ccohort%fmort*n_perm2*AREA + hio_m1_si_scpf(io_si,scpf) = hio_m1_si_scpf(io_si,scpf) + ccohort%bmort*ccohort%n + hio_m2_si_scpf(io_si,scpf) = hio_m2_si_scpf(io_si,scpf) + ccohort%hmort*ccohort%n + hio_m3_si_scpf(io_si,scpf) = hio_m3_si_scpf(io_si,scpf) + ccohort%cmort*ccohort%n + hio_m4_si_scpf(io_si,scpf) = hio_m4_si_scpf(io_si,scpf) + ccohort%imort*ccohort%n + hio_m5_si_scpf(io_si,scpf) = hio_m5_si_scpf(io_si,scpf) + ccohort%fmort*ccohort%n ! basal area [m2/ha] hio_ba_si_scpf(io_si,scpf) = hio_ba_si_scpf(io_si,scpf) + & - 0.25_r8*3.14159_r8*((dbh/100.0_r8)**2.0_r8)*n_perm2*AREA + 0.25_r8*3.14159_r8*((dbh/100.0_r8)**2.0_r8)*ccohort%n ! also by size class only hio_ba_si_scls(io_si,scls) = hio_ba_si_scls(io_si,scls) + & - 0.25_r8*3.14159_r8*((dbh/100.0_r8)**2.0_r8)*n_perm2*AREA + 0.25_r8*3.14159_r8*((dbh/100.0_r8)**2.0_r8)*ccohort%n ! number density [/ha] - hio_nplant_si_scpf(io_si,scpf) = hio_nplant_si_scpf(io_si,scpf) + AREA*n_perm2 + hio_nplant_si_scpf(io_si,scpf) = hio_nplant_si_scpf(io_si,scpf) + ccohort%n ! growth increment hio_ddbh_si_scpf(io_si,scpf) = hio_ddbh_si_scpf(io_si,scpf) + & - ccohort%ddbhdt*n_perm2*AREA + ccohort%ddbhdt*ccohort%n end if ! update SCPF/SCLS- and canopy/subcanopy- partitioned quantities if (ccohort%canopy_layer .eq. 1) then hio_bstor_canopy_si_scpf(io_si,scpf) = hio_bstor_canopy_si_scpf(io_si,scpf) + & - ccohort%bstore * n_perm2 * AREA + ccohort%bstore * ccohort%n hio_bleaf_canopy_si_scpf(io_si,scpf) = hio_bleaf_canopy_si_scpf(io_si,scpf) + & - ccohort%bl * n_perm2 * AREA + ccohort%bl * ccohort%n hio_canopy_biomass_pa(io_pa) = hio_canopy_biomass_pa(io_pa) + n_density * ccohort%b * 1.e3_r8 hio_mortality_canopy_si_scpf(io_si,scpf) = hio_mortality_canopy_si_scpf(io_si,scpf)+ & - (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%imort + ccohort%fmort) * n_perm2*AREA - hio_nplant_canopy_si_scpf(io_si,scpf) = hio_nplant_canopy_si_scpf(io_si,scpf) + AREA*n_perm2 - hio_nplant_canopy_si_scls(io_si,scls) = hio_nplant_canopy_si_scls(io_si,scls) + AREA*n_perm2 + (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%imort + ccohort%fmort) * ccohort%n + hio_nplant_canopy_si_scpf(io_si,scpf) = hio_nplant_canopy_si_scpf(io_si,scpf) + ccohort%n + hio_nplant_canopy_si_scls(io_si,scls) = hio_nplant_canopy_si_scls(io_si,scls) + ccohort%n hio_gpp_canopy_si_scpf(io_si,scpf) = hio_gpp_canopy_si_scpf(io_si,scpf) + & n_perm2*ccohort%gpp_acc_hold hio_ar_canopy_si_scpf(io_si,scpf) = hio_ar_canopy_si_scpf(io_si,scpf) + & n_perm2*ccohort%resp_acc_hold ! growth increment hio_ddbh_canopy_si_scpf(io_si,scpf) = hio_ddbh_canopy_si_scpf(io_si,scpf) + & - ccohort%ddbhdt*n_perm2*AREA + ccohort%ddbhdt*ccohort%n ! sum of all mortality hio_mortality_canopy_si_scls(io_si,scls) = hio_mortality_canopy_si_scls(io_si,scls) + & - (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%imort + ccohort%fmort) * n_perm2*AREA + (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%imort + ccohort%fmort) * ccohort%n hio_canopy_mortality_carbonflux_si(io_si) = hio_canopy_mortality_carbonflux_si(io_si) + & (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%imort + ccohort%fmort) * & ccohort%b * ccohort%n * 1e3 / (1e4 * daysecs * yeardays) ! hio_leaf_md_canopy_si_scls(io_si,scls) = hio_leaf_md_canopy_si_scls(io_si,scls) + & - ccohort%leaf_md * n_perm2 * AREA + ccohort%leaf_md * ccohort%n hio_root_md_canopy_si_scls(io_si,scls) = hio_root_md_canopy_si_scls(io_si,scls) + & - ccohort%root_md * n_perm2 * AREA + ccohort%root_md * ccohort%n hio_carbon_balance_canopy_si_scls(io_si,scls) = hio_carbon_balance_canopy_si_scls(io_si,scls) + & - ccohort%carbon_balance * n_perm2 * AREA + ccohort%carbon_balance * ccohort%n hio_seed_prod_canopy_si_scls(io_si,scls) = hio_seed_prod_canopy_si_scls(io_si,scls) + & - ccohort%seed_prod * n_perm2 * AREA + ccohort%seed_prod * ccohort%n hio_dbalivedt_canopy_si_scls(io_si,scls) = hio_dbalivedt_canopy_si_scls(io_si,scls) + & - ccohort%dbalivedt * n_perm2 * AREA + ccohort%dbalivedt * ccohort%n hio_dbdeaddt_canopy_si_scls(io_si,scls) = hio_dbdeaddt_canopy_si_scls(io_si,scls) + & - ccohort%dbdeaddt * n_perm2 * AREA + ccohort%dbdeaddt * ccohort%n hio_dbstoredt_canopy_si_scls(io_si,scls) = hio_dbstoredt_canopy_si_scls(io_si,scls) + & - ccohort%dbstoredt * n_perm2 * AREA + ccohort%dbstoredt * ccohort%n hio_storage_flux_canopy_si_scls(io_si,scls) = hio_storage_flux_canopy_si_scls(io_si,scls) + & - ccohort%storage_flux * n_perm2 * AREA + ccohort%storage_flux * ccohort%n hio_npp_leaf_canopy_si_scls(io_si,scls) = hio_npp_leaf_canopy_si_scls(io_si,scls) + & - ccohort%npp_leaf * n_perm2 * AREA * yeardays + ccohort%npp_leaf * ccohort%n hio_npp_froot_canopy_si_scls(io_si,scls) = hio_npp_froot_canopy_si_scls(io_si,scls) + & - ccohort%npp_froot * n_perm2 * AREA * yeardays + ccohort%npp_froot * ccohort%n hio_npp_bsw_canopy_si_scls(io_si,scls) = hio_npp_bsw_canopy_si_scls(io_si,scls) + & - ccohort%npp_bsw * n_perm2 * AREA * yeardays + ccohort%npp_bsw * ccohort%n hio_npp_bdead_canopy_si_scls(io_si,scls) = hio_npp_bdead_canopy_si_scls(io_si,scls) + & - ccohort%npp_bdead * n_perm2 * AREA * yeardays + ccohort%npp_bdead * ccohort%n hio_npp_bseed_canopy_si_scls(io_si,scls) = hio_npp_bseed_canopy_si_scls(io_si,scls) + & - ccohort%npp_bseed * n_perm2 * AREA * yeardays + ccohort%npp_bseed * ccohort%n hio_npp_store_canopy_si_scls(io_si,scls) = hio_npp_store_canopy_si_scls(io_si,scls) + & - ccohort%npp_store * n_perm2 * AREA * yeardays + ccohort%npp_store * ccohort%n hio_yesterdaycanopylevel_canopy_si_scls(io_si,scls) = hio_yesterdaycanopylevel_canopy_si_scls(io_si,scls) + & - ccohort%canopy_layer_yesterday * n_perm2 * AREA + ccohort%canopy_layer_yesterday * ccohort%n else hio_bstor_understory_si_scpf(io_si,scpf) = hio_bstor_understory_si_scpf(io_si,scpf) + & - ccohort%bstore * n_perm2 * AREA + ccohort%bstore * ccohort%n hio_bleaf_understory_si_scpf(io_si,scpf) = hio_bleaf_understory_si_scpf(io_si,scpf) + & - ccohort%bl * n_perm2 * AREA + ccohort%bl * ccohort%n hio_understory_biomass_pa(io_pa) = hio_understory_biomass_pa(io_pa) + n_density * ccohort%b * 1.e3_r8 hio_mortality_understory_si_scpf(io_si,scpf) = hio_mortality_understory_si_scpf(io_si,scpf)+ & - (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%imort + ccohort%fmort) * n_perm2*AREA - hio_nplant_understory_si_scpf(io_si,scpf) = hio_nplant_understory_si_scpf(io_si,scpf) + AREA*n_perm2 - hio_nplant_understory_si_scls(io_si,scls) = hio_nplant_understory_si_scls(io_si,scls) + AREA*n_perm2 + (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%imort + ccohort%fmort) * ccohort%n + hio_nplant_understory_si_scpf(io_si,scpf) = hio_nplant_understory_si_scpf(io_si,scpf) + ccohort%n + hio_nplant_understory_si_scls(io_si,scls) = hio_nplant_understory_si_scls(io_si,scls) + ccohort%n hio_gpp_understory_si_scpf(io_si,scpf) = hio_gpp_understory_si_scpf(io_si,scpf) + & n_perm2*ccohort%gpp_acc_hold hio_ar_understory_si_scpf(io_si,scpf) = hio_ar_understory_si_scpf(io_si,scpf) + & n_perm2*ccohort%resp_acc_hold ! growth increment hio_ddbh_understory_si_scpf(io_si,scpf) = hio_ddbh_understory_si_scpf(io_si,scpf) + & - ccohort%ddbhdt*n_perm2*AREA + ccohort%ddbhdt*ccohort%n ! sum of all mortality hio_mortality_understory_si_scls(io_si,scls) = hio_mortality_understory_si_scls(io_si,scls) + & - (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%imort + ccohort%fmort) * n_perm2*AREA + (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%imort + ccohort%fmort) * ccohort%n hio_understory_mortality_carbonflux_si(io_si) = hio_understory_mortality_carbonflux_si(io_si) + & (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%imort + ccohort%fmort) * & ccohort%b * ccohort%n * 1e3 / (1e4 * daysecs * yeardays) ! hio_leaf_md_understory_si_scls(io_si,scls) = hio_leaf_md_understory_si_scls(io_si,scls) + & - ccohort%leaf_md * n_perm2 * AREA + ccohort%leaf_md * ccohort%n hio_root_md_understory_si_scls(io_si,scls) = hio_root_md_understory_si_scls(io_si,scls) + & - ccohort%root_md * n_perm2 * AREA + ccohort%root_md * ccohort%n hio_carbon_balance_understory_si_scls(io_si,scls) = hio_carbon_balance_understory_si_scls(io_si,scls) + & - ccohort%carbon_balance * n_perm2 * AREA + ccohort%carbon_balance * ccohort%n hio_seed_prod_understory_si_scls(io_si,scls) = hio_seed_prod_understory_si_scls(io_si,scls) + & - ccohort%seed_prod * n_perm2 * AREA + ccohort%seed_prod * ccohort%n hio_dbalivedt_understory_si_scls(io_si,scls) = hio_dbalivedt_understory_si_scls(io_si,scls) + & - ccohort%dbalivedt * n_perm2 * AREA + ccohort%dbalivedt * ccohort%n hio_dbdeaddt_understory_si_scls(io_si,scls) = hio_dbdeaddt_understory_si_scls(io_si,scls) + & - ccohort%dbdeaddt * n_perm2 * AREA + ccohort%dbdeaddt * ccohort%n hio_dbstoredt_understory_si_scls(io_si,scls) = hio_dbstoredt_understory_si_scls(io_si,scls) + & - ccohort%dbstoredt * n_perm2 * AREA + ccohort%dbstoredt * ccohort%n hio_storage_flux_understory_si_scls(io_si,scls) = hio_storage_flux_understory_si_scls(io_si,scls) + & - ccohort%storage_flux * n_perm2 * AREA + ccohort%storage_flux * ccohort%n hio_npp_leaf_understory_si_scls(io_si,scls) = hio_npp_leaf_understory_si_scls(io_si,scls) + & - ccohort%npp_leaf * n_perm2 * AREA * yeardays + ccohort%npp_leaf * ccohort%n hio_npp_froot_understory_si_scls(io_si,scls) = hio_npp_froot_understory_si_scls(io_si,scls) + & - ccohort%npp_froot * n_perm2 * AREA * yeardays + ccohort%npp_froot * ccohort%n hio_npp_bsw_understory_si_scls(io_si,scls) = hio_npp_bsw_understory_si_scls(io_si,scls) + & - ccohort%npp_bsw * n_perm2 * AREA * yeardays + ccohort%npp_bsw * ccohort%n hio_npp_bdead_understory_si_scls(io_si,scls) = hio_npp_bdead_understory_si_scls(io_si,scls) + & - ccohort%npp_bdead * n_perm2 * AREA * yeardays + ccohort%npp_bdead * ccohort%n hio_npp_bseed_understory_si_scls(io_si,scls) = hio_npp_bseed_understory_si_scls(io_si,scls) + & - ccohort%npp_bseed * n_perm2 * AREA * yeardays + ccohort%npp_bseed * ccohort%n hio_npp_store_understory_si_scls(io_si,scls) = hio_npp_store_understory_si_scls(io_si,scls) + & - ccohort%npp_store * n_perm2 * AREA * yeardays + ccohort%npp_store * ccohort%n hio_yesterdaycanopylevel_understory_si_scls(io_si,scls) = hio_yesterdaycanopylevel_understory_si_scls(io_si,scls) + & - ccohort%canopy_layer_yesterday * n_perm2 * AREA + ccohort%canopy_layer_yesterday * ccohort%n endif ! ccohort%canopy_layer_yesterday = real(ccohort%canopy_layer, r8) From b52f091a598021a5c7e9e3f348bb99d8cd299482 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 1 Mar 2017 12:06:47 -0800 Subject: [PATCH 339/437] Made a fix to indexing and storage of water-memory. --- biogeochem/EDPhysiologyMod.F90 | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 2eb77c48..0e9b0286 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -427,10 +427,11 @@ subroutine phenology( currentSite, bc_in ) ! distinction actually matter??).... !Accumulate surface water memory of last 10 days. - currentSite%water_memory(1) = bc_in%h2osoi_vol_si !waterstate_inst%h2osoi_vol_col(coli,1) - do i = 1,numWaterMem !shift memory along one + + do i = 1,numWaterMem-1 !shift memory along one currentSite%water_memory(numWaterMem+1-i) = currentSite%water_memory(numWaterMem-i) enddo + currentSite%water_memory(1) = bc_in%h2osoi_vol_si !waterstate_inst%h2osoi_vol_col(coli,1) !In drought phenology, we often need to force the leaves to stay on or off as moisture fluctuates... timesincedleafoff = 0 From d1be5a26510e85173342079516005caaa5d58661 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 2 Mar 2017 13:53:56 -0800 Subject: [PATCH 340/437] Cleaned up endrun use statements in EDAccumulateFluxes, also removed unnecessary call to IEEE arithmetic. --- biogeophys/EDAccumulateFluxesMod.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/biogeophys/EDAccumulateFluxesMod.F90 b/biogeophys/EDAccumulateFluxesMod.F90 index f0570352..f782a219 100644 --- a/biogeophys/EDAccumulateFluxesMod.F90 +++ b/biogeophys/EDAccumulateFluxesMod.F90 @@ -9,8 +9,10 @@ module EDAccumulateFluxesMod ! Rosie Fisher. March 2014. ! ! !USES: - use abortutils, only : endrun + use FatesGlobals, only : fates_endrun + use FatesGlobals, only : fates_log use shr_log_mod , only : errMsg => shr_log_errMsg + use FatesConstantsMod , only : r8 => fates_r8 implicit none private ! @@ -32,12 +34,10 @@ subroutine AccumulateFluxes_ED(nsites, sites, bc_in, bc_out, dt_time) ! see above ! ! !USES: - use FatesConstantsMod , only : r8 => fates_r8 - use FatesGlobals , only : fates_log + use EDTypesMod , only : ed_patch_type, ed_cohort_type, & ed_site_type, AREA use FatesInterfaceMod , only : bc_in_type,bc_out_type - use, intrinsic :: IEEE_ARITHMETIC ! ! !ARGUMENTS From 5d0267fe0aba9350f6c01f270428219f94dfd63f Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 2 Mar 2017 14:24:40 -0800 Subject: [PATCH 341/437] Changed endrun in EDPhysiology to point to fates_endrun() in FatesGlobals. --- biogeochem/EDPhysiologyMod.F90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 0e9b0286..2d78b278 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -27,9 +27,8 @@ module EDPhysiologyMod use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type use shr_log_mod , only : errMsg => shr_log_errMsg - use abortutils , only : endrun use FatesGlobals , only : fates_log - + use FatesGlobals , only : endrun => fates_endrun implicit none From 8df637eb1a86e16ac8e8162fba41d7e6431a5f3d Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 3 Mar 2017 11:23:43 -0800 Subject: [PATCH 342/437] Swapped indices on terminated_nindivs array, bugfix. --- main/FatesHistoryInterfaceMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 774c6308..4892de2d 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -1300,7 +1300,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) do i_pft = 1, mxpft do i_scls = 1,nlevsclass_ed i_scpf = (i_pft-1)*nlevsclass_ed + i_scls - hio_m6_si_scpf(io_si,i_scpf) = (sites(s)%terminated_nindivs(i_pft,i_scls,1) + & + hio_m6_si_scpf(io_si,i_scpf) = (sites(s)%terminated_nindivs(i_scls,i_pft,1) + & sites(s)%terminated_nindivs(i_scls,i_pft,2)) * yeardays hio_mortality_canopy_si_scls(io_si,i_scls) = hio_mortality_canopy_si_scls(io_si,i_scls) + & sites(s)%terminated_nindivs(i_scls,i_pft,1) * yeardays From f8f9918ac7417b737467f6d24439cda2f285032d Mon Sep 17 00:00:00 2001 From: ckoven Date: Sat, 4 Mar 2017 14:22:11 -0800 Subject: [PATCH 343/437] new dimensions for fuel and cwd, with new vars and code cleanup --- fire/SFMainMod.F90 | 17 +++-- fire/SFParamsMod.F90 | 6 +- main/EDTypesMod.F90 | 24 ++++-- main/FatesHistoryInterfaceMod.F90 | 117 ++++++++++++++++++++++++++++-- main/FatesHistoryVariableType.F90 | 14 ++++ main/FatesIODimensionsMod.F90 | 12 +++ main/FatesIOVariableKindMod.F90 | 2 + 7 files changed, 170 insertions(+), 22 deletions(-) diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index b6ff07c7..e562f009 100755 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -23,6 +23,7 @@ module SFMainMod use EDtypesMod , only : LB_SF use EDtypesMod , only : LG_SF use EDtypesMod , only : NCWD + use EDtypesMod , only : NFSC use EDtypesMod , only : TR_SF implicit none @@ -152,8 +153,8 @@ subroutine charecteristics_of_fuel ( currentSite ) 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 + real(r8) fuel_moisture(nfsc) ! Scaled moisture content of small litter fuels. + real(r8) MEF(nfsc) ! Moisture extinction factor of fuels integer n fuel_moisture(:) = 0.0_r8 @@ -210,7 +211,7 @@ subroutine charecteristics_of_fuel ( currentSite ) 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)) + MEF(1:nfsc) = 0.524_r8 - 0.066_r8 * log10(SF_val_SAV(1:nfsc)) !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) @@ -264,7 +265,7 @@ subroutine charecteristics_of_fuel ( currentSite ) 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. + currentPatch%fuel_sav = sum(SF_val_SAV(1:nfsc))/(nfsc) ! make average sav to avoid crashing code. if ( cp_masterproc == 1 ) write(fates_log(),*) 'problem with spitfire fuel averaging' @@ -508,8 +509,8 @@ subroutine ground_fuel_consumption ( 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 + real(r8) :: tau_b(nfsc) !lethal heating rates for each fuel class (min) + real(r8) :: fc_ground(nfsc) !propn of fuel consumed integer :: c @@ -519,7 +520,7 @@ subroutine ground_fuel_consumption ( currentSite ) 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. + do c = 1, nfsc !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 @@ -560,7 +561,7 @@ subroutine ground_fuel_consumption ( currentSite ) ! 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 + do c = 1,nfsc 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 diff --git a/fire/SFParamsMod.F90 b/fire/SFParamsMod.F90 index 3caa526a..4e3a6a42 100644 --- a/fire/SFParamsMod.F90 +++ b/fire/SFParamsMod.F90 @@ -3,7 +3,7 @@ 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 + use EDtypesMod , only: NFSC,NCWD implicit none save @@ -23,9 +23,9 @@ module SFParamsMod 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_alpha_FMC(NFSC) real(r8),protected :: SF_val_CWD_frac(NCWD) - real(r8),protected :: SF_val_max_decomp(NLSC) + real(r8),protected :: SF_val_max_decomp(NFSC) real(r8),protected :: SF_val_SAV(NFSC) real(r8),protected :: SF_val_FBD(NFSC) real(r8),protected :: SF_val_min_moisture(NFSC) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 326126a5..b28d68c9 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -45,10 +45,8 @@ module EDTypesMod ! SPITFIRE - integer , parameter :: NLSC = 6 ! 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 :: NFSC = NCWD+2 ! number fuel size classes (really this is a mix of cwd size classes, leaf litter, and grass types) 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 @@ -114,6 +112,8 @@ module EDTypesMod integer , allocatable :: scls_levscpf_ed(:) real(r8), allocatable :: levage_ed(:) integer , allocatable :: levpft_ed(:) + integer , allocatable :: levfuel_ed(:) + integer , allocatable :: levcwdsc_ed(:) ! Control Parameters (cp_) @@ -442,7 +442,7 @@ module EDTypesMod !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) :: fuel_frac(nfsc) ! 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 @@ -452,7 +452,7 @@ module EDTypesMod ! 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) + real(r8) :: litter_moisture(nfsc) ! FIRE SPREAD real(r8) :: ros_front ! rate of forward spread of fire: m/min @@ -598,11 +598,15 @@ subroutine ed_hist_scpfmaps integer :: i integer :: isc integer :: ipft + integer :: icwd + integer :: ifuel allocate( levsclass_ed(1:nlevsclass_ed )) allocate( pft_levscpf_ed(1:nlevsclass_ed*mxpft)) allocate(scls_levscpf_ed(1:nlevsclass_ed*mxpft)) allocate( levpft_ed(1:mxpft )) + allocate( levfuel_ed(1:NFSC )) + allocate( levcwdsc_ed(1:NCWD )) allocate( levage_ed(1:nlevage_ed )) ! Fill the IO array of plant size classes @@ -617,6 +621,16 @@ subroutine ed_hist_scpfmaps levpft_ed(ipft) = ipft end do + ! make fuel array + do ifuel=1,NFSC + levfuel_ed(ifuel) = ifuel + end do + + ! make cwd array + do icwd=1,NCWD + levcwdsc_ed(icwd) = icwd + end do + ! Fill the IO arrays that match pft and size class to their combined array i=0 do ipft=1,mxpft diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 4892de2d..077244f8 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -216,9 +216,16 @@ module FatesHistoryInterfaceMod integer, private :: ih_ncl_si_age integer, private :: ih_npatches_si_age + ! indices to (site x fuel class) variables + integer, private :: ih_litter_moisture_si_fuel + + ! indices to (site x cwd size class) variables + integer, private :: ih_cwd_ag_si_cwdsc + integer, private :: ih_cwd_bg_si_cwdsc + ! The number of variable dim/kind types we have defined (static) - integer, parameter :: fates_history_num_dimensions = 7 - integer, parameter :: fates_history_num_dim_kinds = 9 + integer, parameter :: fates_history_num_dimensions = 9 + integer, parameter :: fates_history_num_dim_kinds = 11 @@ -253,6 +260,7 @@ module FatesHistoryInterfaceMod integer, private :: patch_index_, column_index_, levgrnd_index_, levscpf_index_ integer, private :: levscls_index_, levpft_index_, levage_index_ + integer, private :: levfuel_index_, levcwdsc_index_ contains procedure, public :: Init @@ -273,6 +281,8 @@ module FatesHistoryInterfaceMod procedure, public :: levscls_index procedure, public :: levpft_index procedure, public :: levage_index + procedure, public :: levfuel_index + procedure, public :: levcwdsc_index ! private work functions procedure, private :: define_history_vars @@ -288,6 +298,8 @@ module FatesHistoryInterfaceMod procedure, private :: set_levscls_index procedure, private :: set_levpft_index procedure, private :: set_levage_index + procedure, private :: set_levfuel_index + procedure, private :: set_levcwdsc_index end type fates_history_interface_type @@ -301,6 +313,7 @@ subroutine Init(this, num_threads, fates_bounds) use FatesIODimensionsMod, only : patch, column, levgrnd, levscpf use FatesIODimensionsMod, only : levscls, levpft, levage + use FatesIODimensionsMod, only : levfuel, levcwdsc use FatesIODimensionsMod, only : fates_bounds_type implicit none @@ -345,6 +358,17 @@ subroutine Init(this, num_threads, fates_bounds) call this%set_levage_index(dim_count) call this%dim_bounds(dim_count)%Init(levage, num_threads, & fates_bounds%age_class_begin, fates_bounds%age_class_end) + + dim_count = dim_count + 1 + call this%set_levfuel_index(dim_count) + call this%dim_bounds(dim_count)%Init(levfuel, num_threads, & + fates_bounds%fuel_begin, fates_bounds%fuel_end) + + dim_count = dim_count + 1 + call this%set_levcwdsc_index(dim_count) + call this%dim_bounds(dim_count)%Init(levcwdsc, num_threads, & + fates_bounds%cwdsc_begin, fates_bounds%cwdsc_end) + ! FIXME(bja, 2016-10) assert(dim_count == FatesHistorydimensionmod::num_dimension_types) ! Allocate the mapping between FATES indices and the IO indices @@ -394,6 +418,14 @@ subroutine SetThreadBoundsEach(this, thread_index, thread_bounds) call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%age_class_begin, thread_bounds%age_class_end) + index = this%levfuel_index() + call this%dim_bounds(index)%SetThreadBounds(thread_index, & + thread_bounds%fuel_begin, thread_bounds%fuel_end) + + index = this%levcwdsc_index() + call this%dim_bounds(index)%SetThreadBounds(thread_index, & + thread_bounds%cwdsc_begin, thread_bounds%cwdsc_end) + end subroutine SetThreadBoundsEach ! =================================================================================== @@ -402,6 +434,7 @@ subroutine assemble_history_output_types(this) use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8 use FatesIOVariableKindMod, only : site_size_r8, site_pft_r8, site_age_r8 + use FatesIOVariableKindMod, only : site_fuel_r8, site_cwdsc_r8 implicit none @@ -434,6 +467,12 @@ subroutine assemble_history_output_types(this) call this%set_dim_indices(site_age_r8, 1, this%column_index()) call this%set_dim_indices(site_age_r8, 2, this%levage_index()) + call this%set_dim_indices(site_fuel_r8, 1, this%column_index()) + call this%set_dim_indices(site_fuel_r8, 2, this%levfuel_index()) + + call this%set_dim_indices(site_cwdsc_r8, 1, this%column_index()) + call this%set_dim_indices(site_cwdsc_r8, 2, this%levcwdsc_index()) + end subroutine assemble_history_output_types ! =================================================================================== @@ -575,6 +614,34 @@ integer function levage_index(this) levage_index = this%levage_index_ end function levage_index + ! ======================================================================= + subroutine set_levfuel_index(this, index) + implicit none + class(fates_history_interface_type), intent(inout) :: this + integer, intent(in) :: index + this%levfuel_index_ = index + end subroutine set_levfuel_index + + integer function levfuel_index(this) + implicit none + class(fates_history_interface_type), intent(in) :: this + levfuel_index = this%levfuel_index_ + end function levfuel_index + + ! ======================================================================= + subroutine set_levcwdsc_index(this, index) + implicit none + class(fates_history_interface_type), intent(inout) :: this + integer, intent(in) :: index + this%levcwdsc_index_ = index + end subroutine set_levcwdsc_index + + integer function levcwdsc_index(this) + implicit none + class(fates_history_interface_type), intent(in) :: this + levcwdsc_index = this%levcwdsc_index_ + end function levcwdsc_index + ! ====================================================================================== subroutine flush_hvars(this,nc,upfreq_in) @@ -669,6 +736,7 @@ subroutine init_dim_kinds_maps(this) use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8 use FatesIOVariableKindMod, only : site_size_r8, site_pft_r8, site_age_r8 + use FatesIOVariableKindMod, only : site_fuel_r8, site_cwdsc_r8 implicit none @@ -710,10 +778,18 @@ subroutine init_dim_kinds_maps(this) index = index + 1 call this%dim_kinds(index)%Init(site_pft_r8, 2) - ! site x patch-age clase + ! site x patch-age class index = index + 1 call this%dim_kinds(index)%Init(site_age_r8, 2) + ! site x fuel size class + index = index + 1 + call this%dim_kinds(index)%Init(site_fuel_r8, 2) + + ! site x cwd size class class + index = index + 1 + call this%dim_kinds(index)%Init(site_cwdsc_r8, 2) + ! FIXME(bja, 2016-10) assert(index == fates_history_num_dim_kinds) end subroutine init_dim_kinds_maps @@ -791,7 +867,9 @@ subroutine update_history_dyn(this,nc,nsites,sites) levage_ed, & nlevage_ed, & mxpft, & - levpft_ed + levpft_ed, & + nfsc, & + ncwd use EDParamsMod , only : ED_val_ag_biomass ! Arguments @@ -811,6 +889,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) integer :: ivar ! index of IO variable object vector integer :: ft ! functional type index integer :: i_scpf,i_pft,i_scls ! iterators for scpf, pft, and scls dims + integer :: i_cwd,i_fuel ! iterators for cwd and fuel dims real(r8) :: n_density ! individual of cohort per m2. real(r8) :: n_perm2 ! individuals per m2 for the whole column @@ -940,7 +1019,10 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_lai_si_age => this%hvars(ih_lai_si_age)%r82d, & hio_canopy_area_si_age => this%hvars(ih_canopy_area_si_age)%r82d, & hio_ncl_si_age => this%hvars(ih_ncl_si_age)%r82d, & - hio_npatches_si_age => this%hvars(ih_npatches_si_age)%r82d) + hio_npatches_si_age => this%hvars(ih_npatches_si_age)%r82d, & + hio_litter_moisture_si_fuel => this%hvars(ih_litter_moisture_si_fuel)%r82d, & + hio_cwd_ag_si_cwdsc => this%hvars(ih_cwd_ag_si_cwdsc)%r82d, & + hio_cwd_bg_si_cwdsc => this%hvars(ih_cwd_bg_si_cwdsc)%r82d) ! --------------------------------------------------------------------------------- @@ -1263,6 +1345,10 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_fire_fuel_mef_pa(io_pa) = cpatch%fuel_mef hio_sum_fuel_pa(io_pa) = cpatch%sum_fuel * 1.e3_r8 * patch_scaling_scalar + do i_fuel = 1,nfsc + hio_litter_moisture_si_fuel(io_si, i_fuel) = cpatch%litter_moisture(i_fuel) * cpatch%area/AREA + end do + ! Update Litter Flux Variables hio_litter_in_pa(io_pa) = (sum(cpatch%CWD_AG_in) +sum(cpatch%leaf_litter_in)) & * 1.e3_r8 * 365.0_r8 * daysecs * patch_scaling_scalar @@ -1279,7 +1365,11 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_canopy_spread_pa(io_pa) = cpatch%spread(1) - + do i_cwd = 1, ncwd + hio_cwd_ag_si_cwdsc(io_si, i_cwd) = cpatch%CWD_AG_out(i_cwd)*cpatch%area/AREA * 1e3 + hio_cwd_bg_si_cwdsc(io_si, i_cwd) = cpatch%CWD_BG_out(i_cwd)*cpatch%area/AREA * 1e3 + end do + ipa = ipa + 1 cpatch => cpatch%younger end do !patch loop @@ -1656,6 +1746,7 @@ subroutine define_history_vars(this, initialize_variables) use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8 use FatesIOVariableKindMod, only : site_size_r8, site_pft_r8, site_age_r8 + use FatesIOVariableKindMod, only : site_fuel_r8, site_cwdsc_r8 implicit none class(fates_history_interface_type), intent(inout) :: this @@ -1818,6 +1909,11 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_sum_fuel_pa ) + call this%set_history_var(vname='FUEL_MOISTURE_NFSC', units='-', & + long='spitfire size-resolved fuel moisture', use_default='active', & + avgflag='A', vtype=site_fuel_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_litter_moisture_si_fuel ) + ! Litter Variables call this%set_history_var(vname='LITTER_IN', units='gC m-2 s-1', & @@ -2143,6 +2239,15 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_understory_si_scpf ) + call this%set_history_var(vname='CWD_AG_CWDSC', units='gC/m^2', & + long='size-resolved AG CWD stocks', use_default='active', & + avgflag='A', vtype=site_cwdsc_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_ag_si_cwdsc ) + + call this%set_history_var(vname='CWD_BG_CWDSC', units='gC/m^2', & + long='size-resolved BG CWD stocks', use_default='active', & + avgflag='A', vtype=site_cwdsc_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_bg_si_cwdsc ) ! Size structured diagnostics that require rapid updates (upfreq=2) diff --git a/main/FatesHistoryVariableType.F90 b/main/FatesHistoryVariableType.F90 index 20abd41f..f6b2011d 100644 --- a/main/FatesHistoryVariableType.F90 +++ b/main/FatesHistoryVariableType.F90 @@ -46,6 +46,7 @@ subroutine Init(this, vname, units, long, use_default, & use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8 use FatesIOVariableKindMod, only : site_size_r8, site_pft_r8, site_age_r8 + use FatesIOVariableKindMod, only : site_fuel_r8, site_cwdsc_r8 use FatesIOVariableKindMod, only : iotype_index implicit none @@ -131,6 +132,14 @@ subroutine Init(this, vname, units, long, use_default, & allocate(this%r82d(lb1:ub1, lb2:ub2)) this%r82d(:,:) = flushval + case(site_fuel_r8) + allocate(this%r82d(lb1:ub1, lb2:ub2)) + this%r82d(:,:) = flushval + + case(site_cwdsc_r8) + allocate(this%r82d(lb1:ub1, lb2:ub2)) + this%r82d(:,:) = flushval + case default write(fates_log(),*) 'Incompatible vtype passed to set_history_var' write(fates_log(),*) 'vtype = ',trim(vtype),' ?' @@ -197,6 +206,7 @@ subroutine Flush(this, thread, dim_bounds, dim_kinds) use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8, patch_int use FatesIOVariableKindMod, only : site_size_r8, site_pft_r8, site_age_r8 + use FatesIOVariableKindMod, only : site_fuel_r8, site_cwdsc_r8 implicit none @@ -228,6 +238,10 @@ subroutine Flush(this, thread, dim_bounds, dim_kinds) this%r82d(lb1:ub1, lb2:ub2) = this%flushval case(site_age_r8) this%r82d(lb1:ub1, lb2:ub2) = this%flushval + case(site_fuel_r8) + this%r82d(lb1:ub1, lb2:ub2) = this%flushval + case(site_cwdsc_r8) + this%r82d(lb1:ub1, lb2:ub2) = this%flushval case(patch_int) this%int1d(lb1:ub1) = nint(this%flushval) case default diff --git a/main/FatesIODimensionsMod.F90 b/main/FatesIODimensionsMod.F90 index 83b2475a..a14a0134 100644 --- a/main/FatesIODimensionsMod.F90 +++ b/main/FatesIODimensionsMod.F90 @@ -12,6 +12,8 @@ module FatesIODimensionsMod character(*), parameter :: levscls = 'levscls' character(*), parameter :: levpft = 'levpft' character(*), parameter :: levage = 'levage' + character(*), parameter :: levfuel = 'levfuel' + character(*), parameter :: levcwdsc = 'levcwdsc' ! patch = This is a structure that records where FATES patch boundaries ! on each thread point to in the host IO array, this structure @@ -36,6 +38,12 @@ module FatesIODimensionsMod ! levage = This is a structure that records the boundaries for the ! number of patch-age-class dimension + ! levfuel = This is a structure that records the boundaries for the + ! number of fuel-size-class dimension + + ! levcwdsc = This is a structure that records the boundaries for the + ! number of coarse-woody-debris-size-class dimension + type, public :: fates_bounds_type integer :: patch_begin @@ -54,6 +62,10 @@ module FatesIODimensionsMod integer :: pft_class_end integer :: age_class_begin integer :: age_class_end + integer :: fuel_begin + integer :: fuel_end + integer :: cwdsc_begin + integer :: cwdsc_end end type fates_bounds_type diff --git a/main/FatesIOVariableKindMod.F90 b/main/FatesIOVariableKindMod.F90 index 2c8eb982..71d1ab98 100644 --- a/main/FatesIOVariableKindMod.F90 +++ b/main/FatesIOVariableKindMod.F90 @@ -22,6 +22,8 @@ module FatesIOVariableKindMod character(*), parameter :: cohort_int = 'CO_INT' character(*), parameter :: site_pft_r8 = 'SI_PFT_R8' character(*), parameter :: site_age_r8 = 'SI_AGE_R8' + character(*), parameter :: site_fuel_r8 = 'SI_FUEL_R8' + character(*), parameter :: site_cwdsc_r8 = 'SI_CWDSC_R8' ! NOTE(RGK, 2016) %active is not used yet. Was intended as a check on the HLM->FATES From 8e02e77b05a02cd659ac1be5281e8ea90add1eaa Mon Sep 17 00:00:00 2001 From: ckoven Date: Sat, 4 Mar 2017 22:27:17 -0800 Subject: [PATCH 344/437] first attempt to put in canopy, canopy*leaf, & canopy*leaf*pft dimensions --- main/EDTypesMod.F90 | 41 +++++++++++ main/FatesHistoryInterfaceMod.F90 | 112 +++++++++++++++++++++++++++++- main/FatesHistoryVariableType.F90 | 20 ++++++ main/FatesIODimensionsMod.F90 | 18 +++++ main/FatesIOVariableKindMod.F90 | 4 +- 5 files changed, 191 insertions(+), 4 deletions(-) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index b28d68c9..ee30de42 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -114,6 +114,12 @@ module EDTypesMod integer , allocatable :: levpft_ed(:) integer , allocatable :: levfuel_ed(:) integer , allocatable :: levcwdsc_ed(:) + integer , allocatable :: levcan_ed(:) + integer , allocatable :: can_levcnlf_ed(:) + integer , allocatable :: lf_levcnlf_ed(:) + integer , allocatable :: can_levcnlfpft_ed(:) + integer , allocatable :: lf_levcnlfpft_ed(:) + integer , allocatable :: pft_levcnlfpft_ed(:) ! Control Parameters (cp_) @@ -600,6 +606,8 @@ subroutine ed_hist_scpfmaps integer :: ipft integer :: icwd integer :: ifuel + integer :: ican + integer :: ileaf allocate( levsclass_ed(1:nlevsclass_ed )) allocate( pft_levscpf_ed(1:nlevsclass_ed*mxpft)) @@ -609,6 +617,13 @@ subroutine ed_hist_scpfmaps allocate( levcwdsc_ed(1:NCWD )) allocate( levage_ed(1:nlevage_ed )) + allocate(levcan_ed(cp_nlevcan)) + allocate(can_levcnlf_ed(cp_nlevcan*cp_nclmax)) + allocate(lf_levcnlf_ed(cp_nlevcan*cp_nclmax)) + allocate(can_levcnlfpft_ed(cp_nlevcan*cp_nclmax*numpft_ed)) + allocate(lf_levcnlfpft_ed(cp_nlevcan*cp_nclmax*numpft_ed)) + allocate(pft_levcnlfpft_ed(cp_nlevcan*cp_nclmax*numpft_ed)) + ! Fill the IO array of plant size classes ! For some reason the history files did not like ! a hard allocation of sclass_ed @@ -631,6 +646,11 @@ subroutine ed_hist_scpfmaps levcwdsc_ed(icwd) = icwd end do + ! make canopy array + do ican = 1,cp_nlevcan + levcan_ed(ican) = ican + end do + ! Fill the IO arrays that match pft and size class to their combined array i=0 do ipft=1,mxpft @@ -641,6 +661,27 @@ subroutine ed_hist_scpfmaps end do end do + i=0 + do ican=1,cp_nlevcan + do ileaf=1,cp_nclmax + i=i+1 + can_levcnlf_ed(i) = ican + lf_levcnlf_ed(i) = ileaf + end do + end do + + i=0 + do ican=1,cp_nlevcan + do ileaf=1,cp_nclmax + do ipft=1,numpft_ed + i=i+1 + can_levcnlfpft_ed(i) = ican + lf_levcnlfpft_ed(i) = ileaf + pft_levcnlfpft_ed(i) = ipft + end do + end do + end do + end subroutine ed_hist_scpfmaps !-------------------------------------------------------------------------------------! diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 077244f8..e53d4e9b 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -223,9 +223,15 @@ module FatesHistoryInterfaceMod integer, private :: ih_cwd_ag_si_cwdsc integer, private :: ih_cwd_bg_si_cwdsc + ! indices to (site x [canopy layer x leaf layer]) variables + + ! indices to (site x [canopy layer x leaf layer x pft]) variables + + ! indices to (site x canopy layer) variables + ! The number of variable dim/kind types we have defined (static) - integer, parameter :: fates_history_num_dimensions = 9 - integer, parameter :: fates_history_num_dim_kinds = 11 + integer, parameter :: fates_history_num_dimensions = 12 + integer, parameter :: fates_history_num_dim_kinds = 14 @@ -261,6 +267,7 @@ module FatesHistoryInterfaceMod integer, private :: patch_index_, column_index_, levgrnd_index_, levscpf_index_ integer, private :: levscls_index_, levpft_index_, levage_index_ integer, private :: levfuel_index_, levcwdsc_index_ + integer, private :: levcan_index_, levcnlf_index_, levcnlfpft_index_ contains procedure, public :: Init @@ -283,6 +290,9 @@ module FatesHistoryInterfaceMod procedure, public :: levage_index procedure, public :: levfuel_index procedure, public :: levcwdsc_index + procedure, public :: levcan_index + procedure, public :: levcnlf_index + procedure, public :: levcnlfpft_index ! private work functions procedure, private :: define_history_vars @@ -300,6 +310,9 @@ module FatesHistoryInterfaceMod procedure, private :: set_levage_index procedure, private :: set_levfuel_index procedure, private :: set_levcwdsc_index + procedure, private :: set_levcan_index + procedure, private :: set_levcnlf_index + procedure, private :: set_levcnlfpft_index end type fates_history_interface_type @@ -314,6 +327,7 @@ subroutine Init(this, num_threads, fates_bounds) use FatesIODimensionsMod, only : patch, column, levgrnd, levscpf use FatesIODimensionsMod, only : levscls, levpft, levage use FatesIODimensionsMod, only : levfuel, levcwdsc + use FatesIODimensionsMod, only : levcan, levcnlf, levcnlfpft use FatesIODimensionsMod, only : fates_bounds_type implicit none @@ -369,6 +383,21 @@ subroutine Init(this, num_threads, fates_bounds) call this%dim_bounds(dim_count)%Init(levcwdsc, num_threads, & fates_bounds%cwdsc_begin, fates_bounds%cwdsc_end) + dim_count = dim_count + 1 + call this%set_levcan_index(dim_count) + call this%dim_bounds(dim_count)%Init(levcan, num_threads, & + fates_bounds%can_begin, fates_bounds%can_end) + + dim_count = dim_count + 1 + call this%set_levcnlf_index(dim_count) + call this%dim_bounds(dim_count)%Init(levcnlf, num_threads, & + fates_bounds%cnlf_begin, fates_bounds%cnlf_end) + + dim_count = dim_count + 1 + call this%set_levcnlfpft_index(dim_count) + call this%dim_bounds(dim_count)%Init(levcnlfpft, num_threads, & + fates_bounds%cnlfpft_begin, fates_bounds%cnlfpft_end) + ! FIXME(bja, 2016-10) assert(dim_count == FatesHistorydimensionmod::num_dimension_types) ! Allocate the mapping between FATES indices and the IO indices @@ -426,6 +455,18 @@ subroutine SetThreadBoundsEach(this, thread_index, thread_bounds) call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%cwdsc_begin, thread_bounds%cwdsc_end) + index = this%levcan_index() + call this%dim_bounds(index)%SetThreadBounds(thread_index, & + thread_bounds%can_begin, thread_bounds%can_end) + + index = this%levcnlf_index() + call this%dim_bounds(index)%SetThreadBounds(thread_index, & + thread_bounds%cnlf_begin, thread_bounds%cnlf_end) + + index = this%levcnlfpft_index() + call this%dim_bounds(index)%SetThreadBounds(thread_index, & + thread_bounds%cnlfpft_begin, thread_bounds%cnlfpft_end) + end subroutine SetThreadBoundsEach ! =================================================================================== @@ -435,6 +476,7 @@ subroutine assemble_history_output_types(this) use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8 use FatesIOVariableKindMod, only : site_size_r8, site_pft_r8, site_age_r8 use FatesIOVariableKindMod, only : site_fuel_r8, site_cwdsc_r8 + use FatesIOVariableKindMod, only : site_can_r8, site_cnlf_r8, site_cnlfpft_r8 implicit none @@ -473,6 +515,15 @@ subroutine assemble_history_output_types(this) call this%set_dim_indices(site_cwdsc_r8, 1, this%column_index()) call this%set_dim_indices(site_cwdsc_r8, 2, this%levcwdsc_index()) + call this%set_dim_indices(site_can_r8, 1, this%column_index()) + call this%set_dim_indices(site_can_r8, 2, this%levcan_index()) + + call this%set_dim_indices(site_cnlf_r8, 1, this%column_index()) + call this%set_dim_indices(site_cnlf_r8, 2, this%levcnlf_index()) + + call this%set_dim_indices(site_cnlfpft_r8, 1, this%column_index()) + call this%set_dim_indices(site_cnlfpft_r8, 2, this%levcnlfpft_index()) + end subroutine assemble_history_output_types ! =================================================================================== @@ -642,6 +693,47 @@ integer function levcwdsc_index(this) levcwdsc_index = this%levcwdsc_index_ end function levcwdsc_index + ! ======================================================================= + subroutine set_levcan_index(this, index) + implicit none + class(fates_history_interface_type), intent(inout) :: this + integer, intent(in) :: index + this%levcan_index_ = index + end subroutine set_levcan_index + + integer function levcan_index(this) + implicit none + class(fates_history_interface_type), intent(in) :: this + levcan_index = this%levcan_index_ + end function levcan_index + + ! ======================================================================= + subroutine set_levcnlf_index(this, index) + implicit none + class(fates_history_interface_type), intent(inout) :: this + integer, intent(in) :: index + this%levcnlf_index_ = index + end subroutine set_levcnlf_index + + integer function levcnlf_index(this) + implicit none + class(fates_history_interface_type), intent(in) :: this + levcnlf_index = this%levcnlf_index_ + end function levcnlf_index + + ! ======================================================================= + subroutine set_levcnlfpft_index(this, index) + implicit none + class(fates_history_interface_type), intent(inout) :: this + integer, intent(in) :: index + this%levcnlfpft_index_ = index + end subroutine set_levcnlfpft_index + + integer function levcnlfpft_index(this) + implicit none + class(fates_history_interface_type), intent(in) :: this + levcnlfpft_index = this%levcnlfpft_index_ + end function levcnlfpft_index ! ====================================================================================== subroutine flush_hvars(this,nc,upfreq_in) @@ -737,6 +829,7 @@ subroutine init_dim_kinds_maps(this) use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8 use FatesIOVariableKindMod, only : site_size_r8, site_pft_r8, site_age_r8 use FatesIOVariableKindMod, only : site_fuel_r8, site_cwdsc_r8 + use FatesIOVariableKindMod, only : site_can_r8, site_cnlf_r8, site_cnlfpft_r8 implicit none @@ -786,10 +879,22 @@ subroutine init_dim_kinds_maps(this) index = index + 1 call this%dim_kinds(index)%Init(site_fuel_r8, 2) - ! site x cwd size class class + ! site x cwd size class index = index + 1 call this%dim_kinds(index)%Init(site_cwdsc_r8, 2) + ! site x can class + index = index + 1 + call this%dim_kinds(index)%Init(site_can_r8, 2) + + ! site x cnlf class + index = index + 1 + call this%dim_kinds(index)%Init(site_cnlf_r8, 2) + + ! site x cnlfpft class + index = index + 1 + call this%dim_kinds(index)%Init(site_cnlfpft_r8, 2) + ! FIXME(bja, 2016-10) assert(index == fates_history_num_dim_kinds) end subroutine init_dim_kinds_maps @@ -1747,6 +1852,7 @@ subroutine define_history_vars(this, initialize_variables) use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8 use FatesIOVariableKindMod, only : site_size_r8, site_pft_r8, site_age_r8 use FatesIOVariableKindMod, only : site_fuel_r8, site_cwdsc_r8 + use FatesIOVariableKindMod, only : site_can_r8, site_cnlf_r8, site_cnlfpft_r8 implicit none class(fates_history_interface_type), intent(inout) :: this diff --git a/main/FatesHistoryVariableType.F90 b/main/FatesHistoryVariableType.F90 index f6b2011d..cbcc25b8 100644 --- a/main/FatesHistoryVariableType.F90 +++ b/main/FatesHistoryVariableType.F90 @@ -47,6 +47,7 @@ subroutine Init(this, vname, units, long, use_default, & use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8 use FatesIOVariableKindMod, only : site_size_r8, site_pft_r8, site_age_r8 use FatesIOVariableKindMod, only : site_fuel_r8, site_cwdsc_r8 + use FatesIOVariableKindMod, only : site_can_r8, site_cnlf_r8, site_cnlfpft_r8 use FatesIOVariableKindMod, only : iotype_index implicit none @@ -140,6 +141,18 @@ subroutine Init(this, vname, units, long, use_default, & allocate(this%r82d(lb1:ub1, lb2:ub2)) this%r82d(:,:) = flushval + case(site_can_r8) + allocate(this%r82d(lb1:ub1, lb2:ub2)) + this%r82d(:,:) = flushval + + case(site_cnlf_r8) + allocate(this%r82d(lb1:ub1, lb2:ub2)) + this%r82d(:,:) = flushval + + case(site_cnlfpft_r8) + allocate(this%r82d(lb1:ub1, lb2:ub2)) + this%r82d(:,:) = flushval + case default write(fates_log(),*) 'Incompatible vtype passed to set_history_var' write(fates_log(),*) 'vtype = ',trim(vtype),' ?' @@ -207,6 +220,7 @@ subroutine Flush(this, thread, dim_bounds, dim_kinds) use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8, patch_int use FatesIOVariableKindMod, only : site_size_r8, site_pft_r8, site_age_r8 use FatesIOVariableKindMod, only : site_fuel_r8, site_cwdsc_r8 + use FatesIOVariableKindMod, only : site_can_r8, site_cnlf_r8, site_cnlfpft_r8 implicit none @@ -242,6 +256,12 @@ subroutine Flush(this, thread, dim_bounds, dim_kinds) this%r82d(lb1:ub1, lb2:ub2) = this%flushval case(site_cwdsc_r8) this%r82d(lb1:ub1, lb2:ub2) = this%flushval + case(site_can_r8) + this%r82d(lb1:ub1, lb2:ub2) = this%flushval + case(site_cnlf_r8) + this%r82d(lb1:ub1, lb2:ub2) = this%flushval + case(site_cnlfpft_r8) + this%r82d(lb1:ub1, lb2:ub2) = this%flushval case(patch_int) this%int1d(lb1:ub1) = nint(this%flushval) case default diff --git a/main/FatesIODimensionsMod.F90 b/main/FatesIODimensionsMod.F90 index a14a0134..c118849d 100644 --- a/main/FatesIODimensionsMod.F90 +++ b/main/FatesIODimensionsMod.F90 @@ -14,6 +14,9 @@ module FatesIODimensionsMod character(*), parameter :: levage = 'levage' character(*), parameter :: levfuel = 'levfuel' character(*), parameter :: levcwdsc = 'levcwdsc' + character(*), parameter :: levcan = 'levcan' + character(*), parameter :: levcnlf = 'levcnlf' + character(*), parameter :: levcnlfpft = 'lvcnlfpf' ! patch = This is a structure that records where FATES patch boundaries ! on each thread point to in the host IO array, this structure @@ -44,6 +47,15 @@ module FatesIODimensionsMod ! levcwdsc = This is a structure that records the boundaries for the ! number of coarse-woody-debris-size-class dimension + ! levcan = This is a structure that records the boundaries for the + ! number of canopy layer dimension + + ! levcnlf = This is a structure that records the boundaries for the + ! number of cnanopy layer x leaf layer dimension + + ! levcnlfpft = This is a structure that records the boundaries for the + ! number of canopy layer x leaf layer x pft dimension + type, public :: fates_bounds_type integer :: patch_begin @@ -66,6 +78,12 @@ module FatesIODimensionsMod integer :: fuel_end integer :: cwdsc_begin integer :: cwdsc_end + integer :: can_begin + integer :: can_end + integer :: cnlf_begin + integer :: cnlf_end + integer :: cnlfpft_begin + integer :: cnlfpft_end end type fates_bounds_type diff --git a/main/FatesIOVariableKindMod.F90 b/main/FatesIOVariableKindMod.F90 index 71d1ab98..3261c35d 100644 --- a/main/FatesIOVariableKindMod.F90 +++ b/main/FatesIOVariableKindMod.F90 @@ -24,7 +24,9 @@ module FatesIOVariableKindMod character(*), parameter :: site_age_r8 = 'SI_AGE_R8' character(*), parameter :: site_fuel_r8 = 'SI_FUEL_R8' character(*), parameter :: site_cwdsc_r8 = 'SI_CWDSC_R8' - + character(*), parameter :: site_can_r8 = 'SI_CAN_R8' + character(*), parameter :: site_cnlf_r8 = 'SI_CNLF_R8' + character(*), parameter :: site_cnlfpft_r8 = 'SI_CNLFPFT_R8' ! NOTE(RGK, 2016) %active is not used yet. Was intended as a check on the HLM->FATES ! control parameter passing to ensure all active dimension types received all From a6860d8bc7bb3f92bfcccda52ceeabe6dd6b449a Mon Sep 17 00:00:00 2001 From: ckoven Date: Sun, 5 Mar 2017 11:06:19 -0800 Subject: [PATCH 345/437] added vars on new canopy vertical radiation dimensions --- main/EDTypesMod.F90 | 14 +-- main/FatesHistoryInterfaceMod.F90 | 160 +++++++++++++++++++++++++++++- 2 files changed, 165 insertions(+), 9 deletions(-) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index ee30de42..69cc974d 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -617,7 +617,7 @@ subroutine ed_hist_scpfmaps allocate( levcwdsc_ed(1:NCWD )) allocate( levage_ed(1:nlevage_ed )) - allocate(levcan_ed(cp_nlevcan)) + allocate(levcan_ed(cp_nclmax)) allocate(can_levcnlf_ed(cp_nlevcan*cp_nclmax)) allocate(lf_levcnlf_ed(cp_nlevcan*cp_nclmax)) allocate(can_levcnlfpft_ed(cp_nlevcan*cp_nclmax*numpft_ed)) @@ -647,7 +647,7 @@ subroutine ed_hist_scpfmaps end do ! make canopy array - do ican = 1,cp_nlevcan + do ican = 1,cp_nclmax levcan_ed(ican) = ican end do @@ -662,8 +662,8 @@ subroutine ed_hist_scpfmaps end do i=0 - do ican=1,cp_nlevcan - do ileaf=1,cp_nclmax + do ican=1,cp_nclmax + do ileaf=1,cp_nlevcan i=i+1 can_levcnlf_ed(i) = ican lf_levcnlf_ed(i) = ileaf @@ -671,9 +671,9 @@ subroutine ed_hist_scpfmaps end do i=0 - do ican=1,cp_nlevcan - do ileaf=1,cp_nclmax - do ipft=1,numpft_ed + do ipft=1,numpft_ed + do ican=1,cp_nclmax + do ileaf=1,cp_nlevcan i=i+1 can_levcnlfpft_ed(i) = ican lf_levcnlfpft_ed(i) = ileaf diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index e53d4e9b..129ccdd3 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -224,10 +224,24 @@ module FatesHistoryInterfaceMod integer, private :: ih_cwd_bg_si_cwdsc ! indices to (site x [canopy layer x leaf layer]) variables + integer, private :: ih_parsun_z_si_cnlf + integer, private :: ih_parsha_z_si_cnlf + integer, private :: ih_laisun_z_si_cnlf + integer, private :: ih_laisha_z_si_cnlf ! indices to (site x [canopy layer x leaf layer x pft]) variables + integer, private :: ih_parsun_z_si_cnlfpft + integer, private :: ih_parsha_z_si_cnlfpft + integer, private :: ih_laisun_z_si_cnlfpft + integer, private :: ih_laisha_z_si_cnlfpft + integer, private :: ih_fabd_sun_si_cnlfpft + integer, private :: ih_fabd_sha_si_cnlfpft + integer, private :: ih_fabi_sun_si_cnlfpft + integer, private :: ih_fabi_sha_si_cnlfpft ! indices to (site x canopy layer) variables + integer, private :: ih_parsuntop_si_can + integer, private :: ih_parshatop_si_can ! The number of variable dim/kind types we have defined (static) integer, parameter :: fates_history_num_dimensions = 12 @@ -1570,6 +1584,8 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) nlevage_ed, & sclass_ed, & nlevsclass_ed + use EDTypesMod, only : numpft_ed, cp_nclmax, cp_nlevcan + ! ! Arguments class(fates_history_interface_type) :: this integer , intent(in) :: nc ! clump index @@ -1592,7 +1608,7 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) real(r8) :: patch_area_by_age(nlevage_ed) ! patch area in each bin for normalizing purposes real(r8), parameter :: tiny = 1.e-5_r8 ! some small number integer :: ipa2 ! patch incrementer - + integer :: cnlfpft_indx, cnlf_indx, ipft, ican, ileaf ! more iterators and indices type(fates_history_variable_type),pointer :: hvar type(ed_patch_type),pointer :: cpatch type(ed_cohort_type),pointer :: ccohort @@ -1630,7 +1646,21 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) hio_resp_g_understory_si_scls => this%hvars(ih_resp_g_understory_si_scls)%r82d, & hio_resp_m_understory_si_scls => this%hvars(ih_resp_m_understory_si_scls)%r82d, & hio_gpp_si_age => this%hvars(ih_gpp_si_age)%r82d, & - hio_npp_si_age => this%hvars(ih_npp_si_age)%r82d & + hio_npp_si_age => this%hvars(ih_npp_si_age)%r82d, & + hio_parsun_z_si_cnlf => this%hvars(ih_parsun_z_si_cnlf)%r82d, & + hio_parsha_z_si_cnlf => this%hvars(ih_parsha_z_si_cnlf)%r82d, & + hio_parsun_z_si_cnlfpft => this%hvars(ih_parsun_z_si_cnlfpft)%r82d, & + hio_parsha_z_si_cnlfpft => this%hvars(ih_parsha_z_si_cnlfpft)%r82d, & + hio_laisun_z_si_cnlf => this%hvars(ih_laisun_z_si_cnlf)%r82d, & + hio_laisha_z_si_cnlf => this%hvars(ih_laisha_z_si_cnlf)%r82d, & + hio_laisun_z_si_cnlfpft => this%hvars(ih_laisun_z_si_cnlfpft)%r82d, & + hio_laisha_z_si_cnlfpft => this%hvars(ih_laisha_z_si_cnlfpft)%r82d, & + hio_fabd_sun_si_cnlfpft => this%hvars(ih_fabd_sun_si_cnlfpft)%r82d, & + hio_fabd_sha_si_cnlfpft => this%hvars(ih_fabd_sha_si_cnlfpft)%r82d, & + hio_fabi_sun_si_cnlfpft => this%hvars(ih_fabi_sun_si_cnlfpft)%r82d, & + hio_fabi_sha_si_cnlfpft => this%hvars(ih_fabi_sha_si_cnlfpft)%r82d, & + hio_parsuntop_si_can => this%hvars(ih_parsuntop_si_can)%r82d, & + hio_parshatop_si_can => this%hvars(ih_parshatop_si_can)%r82d & ) @@ -1766,6 +1796,47 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) ccohort => ccohort%taller enddo ! cohort loop + + ! summarize radiation profiles through the canopy + do ipft=1,numpft_ed + do ican=1,cp_nclmax + do ileaf=1,cp_nlevcan + ! calculate where we are on multiplexed dimensions + cnlfpft_indx = ileaf + (ican-1) * cp_nlevcan + (ipft-1) * cp_nlevcan * cp_nclmax + cnlf_indx = ileaf + (ican-1) * cp_nlevcan + ! + hio_parsun_z_si_cnlfpft(io_si,cnlfpft_indx) = cpatch%ed_parsun_z(ican,ipft,ileaf) * cpatch%area/AREA + hio_parsha_z_si_cnlfpft(io_si,cnlfpft_indx) = cpatch%ed_parsha_z(ican,ipft,ileaf) * cpatch%area/AREA + ! + hio_laisun_z_si_cnlfpft(io_si,cnlfpft_indx) = cpatch%ed_laisun_z(ican,ipft,ileaf) * cpatch%area/AREA + hio_laisha_z_si_cnlfpft(io_si,cnlfpft_indx) = cpatch%ed_laisha_z(ican,ipft,ileaf) * cpatch%area/AREA + ! + hio_fabd_sun_si_cnlfpft(io_si,cnlfpft_indx) = cpatch%fabd_sun_z(ican,ipft,ileaf) * cpatch%area/AREA + hio_fabd_sha_si_cnlfpft(io_si,cnlfpft_indx) = cpatch%fabd_sha_z(ican,ipft,ileaf) * cpatch%area/AREA + hio_fabi_sun_si_cnlfpft(io_si,cnlfpft_indx) = cpatch%fabi_sun_z(ican,ipft,ileaf) * cpatch%area/AREA + hio_fabi_sha_si_cnlfpft(io_si,cnlfpft_indx) = cpatch%fabi_sha_z(ican,ipft,ileaf) * cpatch%area/AREA + ! + ! summarize across all PFTs + hio_parsun_z_si_cnlf(io_si,cnlf_indx) = hio_parsun_z_si_cnlf(io_si,cnlf_indx) + & + cpatch%ed_parsun_z(ican,ipft,ileaf) * cpatch%area/AREA + hio_parsha_z_si_cnlf(io_si,cnlf_indx) = hio_parsha_z_si_cnlf(io_si,cnlf_indx) + & + cpatch%ed_parsha_z(ican,ipft,ileaf) * cpatch%area/AREA + ! + hio_laisun_z_si_cnlf(io_si,cnlf_indx) = hio_laisun_z_si_cnlf(io_si,cnlf_indx) + & + cpatch%ed_laisun_z(ican,ipft,ileaf) * cpatch%area/AREA + hio_laisha_z_si_cnlf(io_si,cnlf_indx) = hio_laisha_z_si_cnlf(io_si,cnlf_indx) + & + cpatch%ed_laisha_z(ican,ipft,ileaf) * cpatch%area/AREA + end do + ! + ! summarize just the top leaf level across all PFTs, for each canopy level + hio_parsuntop_si_can(io_si,ican) = hio_parsuntop_si_can(io_si,ican) + & + cpatch%ed_parsun_z(ican,ipft,1) * cpatch%area/AREA + hio_parshatop_si_can(io_si,ican) = hio_parshatop_si_can(io_si,ican) + & + cpatch%ed_parsha_z(ican,ipft,1) * cpatch%area/AREA + end do + end do + + ipa = ipa + 1 cpatch => cpatch%younger end do !patch loop @@ -2153,6 +2224,91 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & ivar=ivar, initialize=initialize_variables, index = ih_ar_understory_pa ) + ! fast radiative fluxes resolved through the canopy + call this%set_history_var(vname='PARSUN_Z_CNLF', units='fraction', & + long='PAR absorbed in the sun by each canopy and leaf layer', & + use_default='active', & + avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_parsun_z_si_cnlf ) + + call this%set_history_var(vname='PARSHA_Z_CNLF', units='fraction', & + long='PAR absorbed in the shade by each canopy and leaf layer', & + use_default='active', & + avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_parsha_z_si_cnlf ) + + call this%set_history_var(vname='PARSUN_Z_CNLFPFT', units='fraction', & + long='PAR absorbed in the sun by each canopy, leaf, and PFT', & + use_default='active', & + avgflag='A', vtype=site_cnlfpft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_parsun_z_si_cnlfpft ) + + call this%set_history_var(vname='PARSHA_Z_CNLFPFT', units='fraction', & + long='PAR absorbed in the shade by each canopy, leaf, and PFT', & + use_default='active', & + avgflag='A', vtype=site_cnlfpft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_parsha_z_si_cnlfpft ) + + call this%set_history_var(vname='PARSUN_Z_CAN', units='fraction', & + long='PAR absorbed in the sun by top leaf layer in each canopy layer', & + use_default='active', & + avgflag='A', vtype=site_can_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_parsuntop_si_can ) + + call this%set_history_var(vname='PARSHA_Z_CAN', units='fraction', & + long='PAR absorbed in the shade by top leaf layer in each canopy layer', & + use_default='active', & + avgflag='A', vtype=site_can_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_parshatop_si_can ) + + call this%set_history_var(vname='LAISUN_Z_CNLF', units='fraction', & + long='LAI in the sun by each canopy and leaf layer', & + use_default='active', & + avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_laisun_z_si_cnlf ) + + call this%set_history_var(vname='LAISHA_Z_CNLF', units='fraction', & + long='LAI in the shade by each canopy and leaf layer', & + use_default='active', & + avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_laisha_z_si_cnlf ) + + call this%set_history_var(vname='LAISUN_Z_CNLFPFT', units='fraction', & + long='LAI in the sun by each canopy, leaf, and PFT', & + use_default='active', & + avgflag='A', vtype=site_cnlfpft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_laisun_z_si_cnlfpft ) + + call this%set_history_var(vname='LAISHA_Z_CNLFPFT', units='fraction', & + long='LAI in the shade by each canopy, leaf, and PFT', & + use_default='active', & + avgflag='A', vtype=site_cnlfpft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_laisha_z_si_cnlfpft ) + + call this%set_history_var(vname='FABD_SUN_CNLFPFT', units='fraction', & + long='sun fraction of direct light absorbed by each canopy, leaf, and PFT', & + use_default='active', & + avgflag='A', vtype=site_cnlfpft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_fabd_sun_si_cnlfpft ) + + call this%set_history_var(vname='FABD_SHA_CNLFPFT', units='fraction', & + long='shade fraction of direct light absorbed by each canopy, leaf, and PFT', & + use_default='active', & + avgflag='A', vtype=site_cnlfpft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_fabd_sha_si_cnlfpft ) + + call this%set_history_var(vname='FABI_SUN_CNLFPFT', units='fraction', & + long='sun fraction of indirect light absorbed by each canopy, leaf, and PFT', & + use_default='active', & + avgflag='A', vtype=site_cnlfpft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_fabi_sun_si_cnlfpft ) + + call this%set_history_var(vname='FABI_SHA_CNLFPFT', units='fraction', & + long='shade fraction of indirect light absorbed by each canopy, leaf, and PFT', & + use_default='active', & + avgflag='A', vtype=site_cnlfpft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_fabi_sha_si_cnlfpft ) + ! slow carbon fluxes associated with mortality from or transfer betweeen canopy and understory call this%set_history_var(vname='DEMOTION_CARBONFLUX', units = 'gC/m2/s', & long='demotion-associated biomass carbon flux from canopy to understory', use_default='active', & From 1119938d190164a977c3759bdb37e5af01754b5d Mon Sep 17 00:00:00 2001 From: ckoven Date: Sun, 5 Mar 2017 14:38:46 -0800 Subject: [PATCH 346/437] bugfixes to loop over patches correctly and also a variable definition --- main/FatesHistoryInterfaceMod.F90 | 33 ++++++++++++++++++++----------- 1 file changed, 22 insertions(+), 11 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 129ccdd3..1d37a968 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -1465,7 +1465,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_sum_fuel_pa(io_pa) = cpatch%sum_fuel * 1.e3_r8 * patch_scaling_scalar do i_fuel = 1,nfsc - hio_litter_moisture_si_fuel(io_si, i_fuel) = cpatch%litter_moisture(i_fuel) * cpatch%area/AREA + hio_litter_moisture_si_fuel(io_si, i_fuel) = hio_litter_moisture_si_fuel(io_si, i_fuel) + & + cpatch%litter_moisture(i_fuel) * cpatch%area/AREA end do ! Update Litter Flux Variables @@ -1485,8 +1486,10 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_canopy_spread_pa(io_pa) = cpatch%spread(1) do i_cwd = 1, ncwd - hio_cwd_ag_si_cwdsc(io_si, i_cwd) = cpatch%CWD_AG_out(i_cwd)*cpatch%area/AREA * 1e3 - hio_cwd_bg_si_cwdsc(io_si, i_cwd) = cpatch%CWD_BG_out(i_cwd)*cpatch%area/AREA * 1e3 + hio_cwd_ag_si_cwdsc(io_si, i_cwd) = hio_cwd_ag_si_cwdsc(io_si, i_cwd) + & + cpatch%CWD_AG(i_cwd)*cpatch%area/AREA * 1e3 + hio_cwd_bg_si_cwdsc(io_si, i_cwd) = hio_cwd_bg_si_cwdsc(io_si, i_cwd) + & + cpatch%CWD_BG(i_cwd)*cpatch%area/AREA * 1e3 end do ipa = ipa + 1 @@ -1805,16 +1808,24 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) cnlfpft_indx = ileaf + (ican-1) * cp_nlevcan + (ipft-1) * cp_nlevcan * cp_nclmax cnlf_indx = ileaf + (ican-1) * cp_nlevcan ! - hio_parsun_z_si_cnlfpft(io_si,cnlfpft_indx) = cpatch%ed_parsun_z(ican,ipft,ileaf) * cpatch%area/AREA - hio_parsha_z_si_cnlfpft(io_si,cnlfpft_indx) = cpatch%ed_parsha_z(ican,ipft,ileaf) * cpatch%area/AREA + hio_parsun_z_si_cnlfpft(io_si,cnlfpft_indx) = hio_parsun_z_si_cnlfpft(io_si,cnlfpft_indx) + & + cpatch%ed_parsun_z(ican,ipft,ileaf) * cpatch%area/AREA + hio_parsha_z_si_cnlfpft(io_si,cnlfpft_indx) = hio_parsha_z_si_cnlfpft(io_si,cnlfpft_indx) + & + cpatch%ed_parsha_z(ican,ipft,ileaf) * cpatch%area/AREA ! - hio_laisun_z_si_cnlfpft(io_si,cnlfpft_indx) = cpatch%ed_laisun_z(ican,ipft,ileaf) * cpatch%area/AREA - hio_laisha_z_si_cnlfpft(io_si,cnlfpft_indx) = cpatch%ed_laisha_z(ican,ipft,ileaf) * cpatch%area/AREA + hio_laisun_z_si_cnlfpft(io_si,cnlfpft_indx) = hio_laisun_z_si_cnlfpft(io_si,cnlfpft_indx) + & + cpatch%ed_laisun_z(ican,ipft,ileaf) * cpatch%area/AREA + hio_laisha_z_si_cnlfpft(io_si,cnlfpft_indx) = hio_laisha_z_si_cnlfpft(io_si,cnlfpft_indx) + & + cpatch%ed_laisha_z(ican,ipft,ileaf) * cpatch%area/AREA ! - hio_fabd_sun_si_cnlfpft(io_si,cnlfpft_indx) = cpatch%fabd_sun_z(ican,ipft,ileaf) * cpatch%area/AREA - hio_fabd_sha_si_cnlfpft(io_si,cnlfpft_indx) = cpatch%fabd_sha_z(ican,ipft,ileaf) * cpatch%area/AREA - hio_fabi_sun_si_cnlfpft(io_si,cnlfpft_indx) = cpatch%fabi_sun_z(ican,ipft,ileaf) * cpatch%area/AREA - hio_fabi_sha_si_cnlfpft(io_si,cnlfpft_indx) = cpatch%fabi_sha_z(ican,ipft,ileaf) * cpatch%area/AREA + hio_fabd_sun_si_cnlfpft(io_si,cnlfpft_indx) = hio_fabd_sun_si_cnlfpft(io_si,cnlfpft_indx) + & + cpatch%fabd_sun_z(ican,ipft,ileaf) * cpatch%area/AREA + hio_fabd_sha_si_cnlfpft(io_si,cnlfpft_indx) = hio_fabd_sha_si_cnlfpft(io_si,cnlfpft_indx) + & + cpatch%fabd_sha_z(ican,ipft,ileaf) * cpatch%area/AREA + hio_fabi_sun_si_cnlfpft(io_si,cnlfpft_indx) = hio_fabi_sun_si_cnlfpft(io_si,cnlfpft_indx) + & + cpatch%fabi_sun_z(ican,ipft,ileaf) * cpatch%area/AREA + hio_fabi_sha_si_cnlfpft(io_si,cnlfpft_indx) = hio_fabi_sha_si_cnlfpft(io_si,cnlfpft_indx) + & + cpatch%fabi_sha_z(ican,ipft,ileaf) * cpatch%area/AREA ! ! summarize across all PFTs hio_parsun_z_si_cnlf(io_si,cnlf_indx) = hio_parsun_z_si_cnlf(io_si,cnlf_indx) + & From 95df6b5a30efe25c2ca72844fa632c70ac4bb1aa Mon Sep 17 00:00:00 2001 From: ckoven Date: Sun, 5 Mar 2017 17:06:38 -0800 Subject: [PATCH 347/437] fix to units and history updating --- main/FatesHistoryInterfaceMod.F90 | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 1d37a968..bb76f244 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -2236,61 +2236,61 @@ subroutine define_history_vars(this, initialize_variables) ivar=ivar, initialize=initialize_variables, index = ih_ar_understory_pa ) ! fast radiative fluxes resolved through the canopy - call this%set_history_var(vname='PARSUN_Z_CNLF', units='fraction', & + call this%set_history_var(vname='PARSUN_Z_CNLF', units='W/m2', & long='PAR absorbed in the sun by each canopy and leaf layer', & use_default='active', & avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & ivar=ivar, initialize=initialize_variables, index = ih_parsun_z_si_cnlf ) - call this%set_history_var(vname='PARSHA_Z_CNLF', units='fraction', & + call this%set_history_var(vname='PARSHA_Z_CNLF', units='W/m2', & long='PAR absorbed in the shade by each canopy and leaf layer', & use_default='active', & avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & ivar=ivar, initialize=initialize_variables, index = ih_parsha_z_si_cnlf ) - call this%set_history_var(vname='PARSUN_Z_CNLFPFT', units='fraction', & + call this%set_history_var(vname='PARSUN_Z_CNLFPFT', units='W/m2', & long='PAR absorbed in the sun by each canopy, leaf, and PFT', & use_default='active', & avgflag='A', vtype=site_cnlfpft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & ivar=ivar, initialize=initialize_variables, index = ih_parsun_z_si_cnlfpft ) - call this%set_history_var(vname='PARSHA_Z_CNLFPFT', units='fraction', & + call this%set_history_var(vname='PARSHA_Z_CNLFPFT', units='W/m2', & long='PAR absorbed in the shade by each canopy, leaf, and PFT', & use_default='active', & avgflag='A', vtype=site_cnlfpft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & ivar=ivar, initialize=initialize_variables, index = ih_parsha_z_si_cnlfpft ) - call this%set_history_var(vname='PARSUN_Z_CAN', units='fraction', & + call this%set_history_var(vname='PARSUN_Z_CAN', units='W/m2', & long='PAR absorbed in the sun by top leaf layer in each canopy layer', & use_default='active', & avgflag='A', vtype=site_can_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & ivar=ivar, initialize=initialize_variables, index = ih_parsuntop_si_can ) - call this%set_history_var(vname='PARSHA_Z_CAN', units='fraction', & + call this%set_history_var(vname='PARSHA_Z_CAN', units='W/m2', & long='PAR absorbed in the shade by top leaf layer in each canopy layer', & use_default='active', & avgflag='A', vtype=site_can_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & ivar=ivar, initialize=initialize_variables, index = ih_parshatop_si_can ) - call this%set_history_var(vname='LAISUN_Z_CNLF', units='fraction', & + call this%set_history_var(vname='LAISUN_Z_CNLF', units='m2/m2', & long='LAI in the sun by each canopy and leaf layer', & use_default='active', & avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & ivar=ivar, initialize=initialize_variables, index = ih_laisun_z_si_cnlf ) - call this%set_history_var(vname='LAISHA_Z_CNLF', units='fraction', & + call this%set_history_var(vname='LAISHA_Z_CNLF', units='m2/m2', & long='LAI in the shade by each canopy and leaf layer', & use_default='active', & avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & ivar=ivar, initialize=initialize_variables, index = ih_laisha_z_si_cnlf ) - call this%set_history_var(vname='LAISUN_Z_CNLFPFT', units='fraction', & + call this%set_history_var(vname='LAISUN_Z_CNLFPFT', units='m2/m2', & long='LAI in the sun by each canopy, leaf, and PFT', & use_default='active', & avgflag='A', vtype=site_cnlfpft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & ivar=ivar, initialize=initialize_variables, index = ih_laisun_z_si_cnlfpft ) - call this%set_history_var(vname='LAISHA_Z_CNLFPFT', units='fraction', & + call this%set_history_var(vname='LAISHA_Z_CNLFPFT', units='m2/m2', & long='LAI in the shade by each canopy, leaf, and PFT', & use_default='active', & avgflag='A', vtype=site_cnlfpft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & @@ -2514,12 +2514,12 @@ subroutine define_history_vars(this, initialize_variables) call this%set_history_var(vname='CWD_AG_CWDSC', units='gC/m^2', & long='size-resolved AG CWD stocks', use_default='active', & - avgflag='A', vtype=site_cwdsc_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & + avgflag='A', vtype=site_cwdsc_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_ag_si_cwdsc ) call this%set_history_var(vname='CWD_BG_CWDSC', units='gC/m^2', & long='size-resolved BG CWD stocks', use_default='active', & - avgflag='A', vtype=site_cwdsc_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & + avgflag='A', vtype=site_cwdsc_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_bg_si_cwdsc ) ! Size structured diagnostics that require rapid updates (upfreq=2) From dda6ff75d4e282b2db9096d6d9f34d74787c0f62 Mon Sep 17 00:00:00 2001 From: ckoven Date: Sun, 5 Mar 2017 19:46:25 -0800 Subject: [PATCH 348/437] added more cwd vars to understand size-resolved fluxes & turnovers --- main/FatesHistoryInterfaceMod.F90 | 38 ++++++++++++++++++++++++++++++- 1 file changed, 37 insertions(+), 1 deletion(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index bb76f244..88e57ec5 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -222,6 +222,10 @@ module FatesHistoryInterfaceMod ! indices to (site x cwd size class) variables integer, private :: ih_cwd_ag_si_cwdsc integer, private :: ih_cwd_bg_si_cwdsc + integer, private :: ih_cwd_ag_in_si_cwdsc + integer, private :: ih_cwd_bg_in_si_cwdsc + integer, private :: ih_cwd_ag_out_si_cwdsc + integer, private :: ih_cwd_bg_out_si_cwdsc ! indices to (site x [canopy layer x leaf layer]) variables integer, private :: ih_parsun_z_si_cnlf @@ -1141,7 +1145,11 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_npatches_si_age => this%hvars(ih_npatches_si_age)%r82d, & hio_litter_moisture_si_fuel => this%hvars(ih_litter_moisture_si_fuel)%r82d, & hio_cwd_ag_si_cwdsc => this%hvars(ih_cwd_ag_si_cwdsc)%r82d, & - hio_cwd_bg_si_cwdsc => this%hvars(ih_cwd_bg_si_cwdsc)%r82d) + hio_cwd_bg_si_cwdsc => this%hvars(ih_cwd_bg_si_cwdsc)%r82d, & + hio_cwd_ag_in_si_cwdsc => this%hvars(ih_cwd_ag_in_si_cwdsc)%r82d, & + hio_cwd_bg_in_si_cwdsc => this%hvars(ih_cwd_bg_in_si_cwdsc)%r82d, & + hio_cwd_ag_out_si_cwdsc => this%hvars(ih_cwd_ag_out_si_cwdsc)%r82d, & + hio_cwd_bg_out_si_cwdsc => this%hvars(ih_cwd_bg_out_si_cwdsc)%r82d) ! --------------------------------------------------------------------------------- @@ -1490,6 +1498,14 @@ subroutine update_history_dyn(this,nc,nsites,sites) cpatch%CWD_AG(i_cwd)*cpatch%area/AREA * 1e3 hio_cwd_bg_si_cwdsc(io_si, i_cwd) = hio_cwd_bg_si_cwdsc(io_si, i_cwd) + & cpatch%CWD_BG(i_cwd)*cpatch%area/AREA * 1e3 + hio_cwd_ag_in_si_cwdsc(io_si, i_cwd) = hio_cwd_ag_in_si_cwdsc(io_si, i_cwd) + & + cpatch%CWD_AG_IN(i_cwd)*cpatch%area/AREA * 1e3 + hio_cwd_bg_in_si_cwdsc(io_si, i_cwd) = hio_cwd_bg_in_si_cwdsc(io_si, i_cwd) + & + cpatch%CWD_BG_IN(i_cwd)*cpatch%area/AREA * 1e3 + hio_cwd_ag_out_si_cwdsc(io_si, i_cwd) = hio_cwd_ag_out_si_cwdsc(io_si, i_cwd) + & + cpatch%CWD_AG_OUT(i_cwd)*cpatch%area/AREA * 1e3 + hio_cwd_bg_out_si_cwdsc(io_si, i_cwd) = hio_cwd_bg_out_si_cwdsc(io_si, i_cwd) + & + cpatch%CWD_BG_OUT(i_cwd)*cpatch%area/AREA * 1e3 end do ipa = ipa + 1 @@ -2522,6 +2538,26 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_cwdsc_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_bg_si_cwdsc ) + call this%set_history_var(vname='CWD_AG_IN_CWDSC', units='kgC/m^2/y', & + long='size-resolved AG CWD input', use_default='active', & + avgflag='A', vtype=site_cwdsc_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_ag_in_si_cwdsc ) + + call this%set_history_var(vname='CWD_BG_IN_CWDSC', units='kgC/m^2/y', & + long='size-resolved BG CWD input', use_default='active', & + avgflag='A', vtype=site_cwdsc_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_bg_in_si_cwdsc ) + + call this%set_history_var(vname='CWD_AG_OUT_CWDSC', units='kgC/m^2/y', & + long='size-resolved AG CWD output', use_default='active', & + avgflag='A', vtype=site_cwdsc_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_ag_out_si_cwdsc ) + + call this%set_history_var(vname='CWD_BG_OUT_CWDSC', units='kgC/m^2/y', & + long='size-resolved BG CWD output', use_default='active', & + avgflag='A', vtype=site_cwdsc_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_bg_out_si_cwdsc ) + ! Size structured diagnostics that require rapid updates (upfreq=2) call this%set_history_var(vname='AR_SCPF',units = 'kgC/m2/yr', & From 9c639ec0b5f59e2cd42a5f7ec39d46243e4c8480 Mon Sep 17 00:00:00 2001 From: ckoven Date: Mon, 6 Mar 2017 09:27:40 -0800 Subject: [PATCH 349/437] added first set of params (allometric only) --- biogeochem/EDGrowthFunctionsMod.F90 | 114 ++++++++++++++++++++-------- 1 file changed, 83 insertions(+), 31 deletions(-) diff --git a/biogeochem/EDGrowthFunctionsMod.F90 b/biogeochem/EDGrowthFunctionsMod.F90 index 3a371b58..b1f8241b 100755 --- a/biogeochem/EDGrowthFunctionsMod.F90 +++ b/biogeochem/EDGrowthFunctionsMod.F90 @@ -48,8 +48,8 @@ real(r8) function Dbh( cohort_in ) 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 + m = EDecophyscon%dbh2h_m(cohort_in%pft) + c = EDecophyscon%dbh2h_c(cohort_in%pft) dbh = (10.0_r8**((log10(cohort_in%hite) - c)/m)) @@ -72,8 +72,8 @@ real(r8) function Hite( cohort_in ) real(r8) :: c real(r8) :: h - m = 0.64_r8 - c = 0.37_r8 + m = EDecophyscon%dbh2h_m(cohort_in%pft) + c = EDecophyscon%dbh2h_c(cohort_in%pft) if(cohort_in%dbh <= 0._r8)then write(fates_log(),*) 'ED: dbh less than zero problem!' @@ -103,18 +103,27 @@ real(r8) function Bleaf( cohort_in ) ! ============================================================================ type(ed_cohort_type), intent(in) :: cohort_in + + real(r8) :: dbh2bl_a + real(r8) :: dbh2bl_b + real(r8) :: dbh2bl_c real(r8) :: slascaler ! changes the target biomass according to the SLA - + + dbh2bl_a = EDecophyscon%dbh2bl_a(cohort_in%pft) + dbh2bl_b = EDecophyscon%dbh2bl_b(cohort_in%pft) + dbh2bl_c = EDecophyscon%dbh2bl_c(cohort_in%pft) + slascaler = EDecophyscon%dbh2bl_slascaler(cohort_in%pft)/pftcon%slatop(cohort_in%pft) ! 0.03_r8/pftcon%slatop(cohort_in%pft) + if(cohort_in%dbh < 0._r8.or.cohort_in%pft == 0.or.cohort_in%dbh > 1000.0_r8)then write(fates_log(),*) '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 + bleaf = dbh2bl_a * (cohort_in%dbh**dbh2bl_b) * EDecophyscon%wood_density(cohort_in%pft)**dbh2bl_c else - bleaf = 0.0419_r8 * (EDecophyscon%max_dbh(cohort_in%pft)**1.56) * EDecophyscon%wood_density(cohort_in%pft)**0.55_r8 + bleaf = dbh2bl_a * (EDecophyscon%max_dbh(cohort_in%pft)**dbh2bl_b) * EDecophyscon%wood_density(cohort_in%pft)**dbh2bl_c endif - slascaler = 0.03_r8/EDPftvarcon_inst%slatop(cohort_in%pft) + bleaf = bleaf * slascaler !write(fates_log(),*) 'bleaf',bleaf, slascaler,cohort_in%pft @@ -180,10 +189,9 @@ real(r8) function tree_sai( cohort_in ) 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. + real(r8) :: sai_scaler - sai_scaler = 0.05_r8 ! here, a high biomass of 20KgC per m2 gives us a high SAI of 1.0. + sai_scaler = EDecophyscon%sai_scaler(cohort_in%pft) if( cohort_in%bdead < 0._r8 .or. cohort_in%pft == 0 ) then write(fates_log(),*) 'problem in treesai',cohort_in%bdead,cohort_in%pft @@ -248,14 +256,24 @@ 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 + ! default params 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) + real(r8) :: dbh2bd_a + real(r8) :: dbh2bd_b + real(r8) :: dbh2bd_c + real(r8) :: dbh2bd_d + + dbh2bd_a = EDecophyscon%dbh2bd_a(cohort_in%pft) + dbh2bd_b = EDecophyscon%dbh2bd_b(cohort_in%pft) + dbh2bd_c = EDecophyscon%dbh2bd_c(cohort_in%pft) + dbh2bd_d = EDecophyscon%dbh2bd_d(cohort_in%pft) + + bdead = dbh2bd_a*(cohort_in%hite**dbh2bd_b)*(cohort_in%dbh**dbh2bd_c)* & + (EDecophyscon%wood_density(cohort_in%pft)** dbh2bd_d) end function Bdead @@ -271,11 +289,20 @@ real(r8) function dHdBd( cohort_in ) 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) + real(r8) :: dbh2bd_a + real(r8) :: dbh2bd_b + real(r8) :: dbh2bd_c + real(r8) :: dbh2bd_d + + dbh2bd_a = EDecophyscon%dbh2bd_a(cohort_in%pft) + dbh2bd_b = EDecophyscon%dbh2bd_b(cohort_in%pft) + dbh2bd_c = EDecophyscon%dbh2bd_c(cohort_in%pft) + dbh2bd_d = EDecophyscon%dbh2bd_d(cohort_in%pft) + + dbddh = dbh2bd_a*dbh2bd_b*(cohort_in%hite**(dbh2bd_b-1.0_r8))*(cohort_in%dbh**dbh2bd_c)* & + (EDecophyscon%wood_density(cohort_in%pft)**dbh2bd_d) dHdBd = 1.0_r8/dbddh !m/KgC - + return end function dHdBd @@ -288,20 +315,37 @@ real(r8) function dDbhdBd( cohort_in ) ! consistent with Bstem and h-dbh allometries ! ============================================================================ - type(ed_cohort_type), intent(in) :: cohort_in + 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) + real(r8) :: m + real(r8) :: c + real(r8) :: h + real(r8) :: dbh2bd_a + real(r8) :: dbh2bd_b + real(r8) :: dbh2bd_c + real(r8) :: dbh2bd_d + + m = EDecophyscon%dbh2h_m(cohort_in%pft) + c = EDecophyscon%dbh2h_c(cohort_in%pft) + + dbh2bd_a = EDecophyscon%dbh2bd_a(cohort_in%pft) + dbh2bd_b = EDecophyscon%dbh2bd_b(cohort_in%pft) + dbh2bd_c = EDecophyscon%dbh2bd_c(cohort_in%pft) + dbh2bd_d = EDecophyscon%dbh2bd_d(cohort_in%pft) + + dBD_dDBH = dbh2bd_c*dbh2bd_a*(cohort_in%hite**dbh2bd_b)*(cohort_in%dbh**(dbh2bd_c-1.0_r8))* & + (EDecophyscon%wood_density(cohort_in%pft)**dbh2bd_d) - 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 + dH_dDBH = (10.0_r8**c)*m*(cohort_in%dbh**(m-1.0_r8)) + + dBD_dDBH = dBD_dDBH + dbh2bd_b*dbh2bd_a*(cohort_in%hite**(dbh2bd_b - 1.0_r8))* & + (cohort_in%dbh**dbh2bd_c)*(EDecophyscon%wood_density(cohort_in%pft)**dbh2bd_d)*dH_dDBH endif - dDbhdBd = 1.0/dBD_dDBH + dDbhdBd = 1.0_r8/dBD_dDBH return @@ -318,8 +362,14 @@ real(r8) function dDbhdBl( cohort_in ) 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) + real(r8) :: dbh2bl_a + real(r8) :: dbh2bl_b + real(r8) :: dbh2bl_c + + dbh2bl_a = EDecophyscon%dbh2bl_a(cohort_in%pft) + dbh2bl_b = EDecophyscon%dbh2bl_b(cohort_in%pft) + dbh2bl_c = EDecophyscon%dbh2bl_c(cohort_in%pft) + dblddbh = dbh2bl_b*dbh2bl_a*(cohort_in%dbh**dbh2bl_b)*(EDecophyscon%wood_density(cohort_in%pft)**dbh2bl_c) dblddbh = dblddbh*cohort_in%canopy_trim if( cohort_in%dbh Date: Mon, 6 Mar 2017 14:48:21 -0800 Subject: [PATCH 350/437] resolved some naming conflicts from merge of Ryans PR --- main/EDTypesMod.F90 | 22 +++++++++++----------- main/FatesHistoryInterfaceMod.F90 | 10 +++++----- 2 files changed, 16 insertions(+), 16 deletions(-) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 4381fc60..246ff6b7 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -551,12 +551,12 @@ subroutine ed_hist_scpfmaps allocate( levcwdsc_ed(1:NCWD )) allocate( levage_ed(1:nlevage_ed )) - allocate(levcan_ed(cp_nclmax)) - allocate(can_levcnlf_ed(cp_nlevcan*cp_nclmax)) - allocate(lf_levcnlf_ed(cp_nlevcan*cp_nclmax)) - allocate(can_levcnlfpft_ed(cp_nlevcan*cp_nclmax*numpft_ed)) - allocate(lf_levcnlfpft_ed(cp_nlevcan*cp_nclmax*numpft_ed)) - allocate(pft_levcnlfpft_ed(cp_nlevcan*cp_nclmax*numpft_ed)) + allocate(levcan_ed(nclmax)) + allocate(can_levcnlf_ed(nlevcan*nclmax)) + allocate(lf_levcnlf_ed(nlevcan*nclmax)) + allocate(can_levcnlfpft_ed(nlevcan*nclmax*numpft_ed)) + allocate(lf_levcnlfpft_ed(nlevcan*nclmax*numpft_ed)) + allocate(pft_levcnlfpft_ed(nlevcan*nclmax*numpft_ed)) ! Fill the IO array of plant size classes ! For some reason the history files did not like @@ -581,7 +581,7 @@ subroutine ed_hist_scpfmaps end do ! make canopy array - do ican = 1,cp_nclmax + do ican = 1,nclmax levcan_ed(ican) = ican end do @@ -596,8 +596,8 @@ subroutine ed_hist_scpfmaps end do i=0 - do ican=1,cp_nclmax - do ileaf=1,cp_nlevcan + do ican=1,nclmax + do ileaf=1,nlevcan i=i+1 can_levcnlf_ed(i) = ican lf_levcnlf_ed(i) = ileaf @@ -606,8 +606,8 @@ subroutine ed_hist_scpfmaps i=0 do ipft=1,numpft_ed - do ican=1,cp_nclmax - do ileaf=1,cp_nlevcan + do ican=1,nclmax + do ileaf=1,nlevcan i=i+1 can_levcnlfpft_ed(i) = ican lf_levcnlfpft_ed(i) = ileaf diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 5ad97fe7..10926fde 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -1603,7 +1603,7 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) nlevage_ed, & sclass_ed, & nlevsclass_ed - use EDTypesMod, only : numpft_ed, cp_nclmax, cp_nlevcan + use EDTypesMod, only : numpft_ed, nclmax, nlevcan ! ! Arguments class(fates_history_interface_type) :: this @@ -1818,11 +1818,11 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) ! summarize radiation profiles through the canopy do ipft=1,numpft_ed - do ican=1,cp_nclmax - do ileaf=1,cp_nlevcan + do ican=1,nclmax + do ileaf=1,nlevcan ! calculate where we are on multiplexed dimensions - cnlfpft_indx = ileaf + (ican-1) * cp_nlevcan + (ipft-1) * cp_nlevcan * cp_nclmax - cnlf_indx = ileaf + (ican-1) * cp_nlevcan + cnlfpft_indx = ileaf + (ican-1) * nlevcan + (ipft-1) * nlevcan * nclmax + cnlf_indx = ileaf + (ican-1) * nlevcan ! hio_parsun_z_si_cnlfpft(io_si,cnlfpft_indx) = hio_parsun_z_si_cnlfpft(io_si,cnlfpft_indx) + & cpatch%ed_parsun_z(ican,ipft,ileaf) * cpatch%area/AREA From 4fdb22a620d15d3dac351e79e8820c9f9d8f781b Mon Sep 17 00:00:00 2001 From: ckoven Date: Mon, 6 Mar 2017 20:37:37 -0800 Subject: [PATCH 351/437] fixed unit error in CWD flux variables --- main/FatesHistoryInterfaceMod.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 10926fde..29d4074f 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -2538,22 +2538,22 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_cwdsc_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_bg_si_cwdsc ) - call this%set_history_var(vname='CWD_AG_IN_CWDSC', units='kgC/m^2/y', & + call this%set_history_var(vname='CWD_AG_IN_CWDSC', units='gC/m^2/y', & long='size-resolved AG CWD input', use_default='active', & avgflag='A', vtype=site_cwdsc_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_ag_in_si_cwdsc ) - call this%set_history_var(vname='CWD_BG_IN_CWDSC', units='kgC/m^2/y', & + call this%set_history_var(vname='CWD_BG_IN_CWDSC', units='gC/m^2/y', & long='size-resolved BG CWD input', use_default='active', & avgflag='A', vtype=site_cwdsc_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_bg_in_si_cwdsc ) - call this%set_history_var(vname='CWD_AG_OUT_CWDSC', units='kgC/m^2/y', & + call this%set_history_var(vname='CWD_AG_OUT_CWDSC', units='gC/m^2/y', & long='size-resolved AG CWD output', use_default='active', & avgflag='A', vtype=site_cwdsc_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_ag_out_si_cwdsc ) - call this%set_history_var(vname='CWD_BG_OUT_CWDSC', units='kgC/m^2/y', & + call this%set_history_var(vname='CWD_BG_OUT_CWDSC', units='gC/m^2/y', & long='size-resolved BG CWD output', use_default='active', & avgflag='A', vtype=site_cwdsc_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_bg_out_si_cwdsc ) From db44ea9170fd5bea397c4f9ce87e1a8918564750 Mon Sep 17 00:00:00 2001 From: ckoven Date: Tue, 7 Mar 2017 16:41:33 -0800 Subject: [PATCH 352/437] added site-level variables to track CWD_in from disturbance --- biogeochem/EDCanopyStructureMod.F90 | 65 +++++++++++++++++++++------ biogeochem/EDCohortDynamicsMod.F90 | 26 +++++++++-- biogeochem/EDPatchDynamicsMod.F90 | 68 +++++++++++++++++++++++------ main/EDInitMod.F90 | 6 +++ main/EDTypesMod.F90 | 12 ++--- main/FatesHistoryInterfaceMod.F90 | 44 ++++++++++++++----- 6 files changed, 173 insertions(+), 48 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 23368746..903627d7 100755 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -14,7 +14,9 @@ module EDCanopyStructureMod use EDTypesMod , only : nclmax use EDTypesMod , only : nlevcan use EDTypesMod , only : numpft_ed + use EDtypesMod , only : AREA use FatesGlobals , only : endrun => fates_endrun + use FatesInterfaceMod , only : hlm_days_per_year ! CIME Globals use shr_log_mod , only : errMsg => shr_log_errMsg @@ -229,14 +231,31 @@ subroutine canopy_structure( currentSite ) 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 - + 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 + + ! keep track of the above fluxes at the site level as a CWD/litter input flux (in kg / site-m2 / yr) + do c=1,ncwd + currentSite%CWD_AG_diagnostic_input_carbonflux(c) = currentSite%CWD_AG_diagnostic_input_carbonflux(c) & + + currentCohort%n*(currentCohort%bdead+currentCohort%bsw) * & + SF_val_CWD_frac(c) * ED_val_ag_biomass * hlm_days_per_year / AREA + currentSite%CWD_BG_diagnostic_input_carbonflux(c) = currentSite%CWD_BG_diagnostic_input_carbonflux(c) & + + currentCohort%n*(currentCohort%bdead+currentCohort%bsw) * & + SF_val_CWD_frac(c) * (1.0_r8 - ED_val_ag_biomass) * hlm_days_per_year / AREA + enddo + + currentSite%leaf_litter_diagnostic_input_carbonflux(currentCohort%pft) = & + currentSite%leaf_litter_diagnostic_input_carbonflux(currentCohort%pft) + & + currentCohort%n * (currentCohort%bl) * hlm_days_per_year / AREA + currentSite%root_litter_diagnostic_input_carbonflux(currentCohort%pft) = & + currentSite%root_litter_diagnostic_input_carbonflux(currentCohort%pft) + & + currentCohort%n * (currentCohort%br+currentCohort%bstore) * hlm_days_per_year / AREA + currentCohort%n = 0.0_r8 currentCohort%c_area = 0._r8 else @@ -280,13 +299,31 @@ subroutine canopy_structure( currentSite ) enddo - currentPatch%leaf_litter(currentCohort%pft) = & - currentPatch%leaf_litter(currentCohort%pft) + currentCohort%bl* & - currentCohort%n/currentPatch%area ! leaf litter flux per m2. + 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 + + ! keep track of the above fluxes at the site level as a CWD/litter input flux (in kg / site-m2 / yr) + do c=1,ncwd + currentSite%CWD_AG_diagnostic_input_carbonflux(c) = currentSite%CWD_AG_diagnostic_input_carbonflux(c) & + + currentCohort%n*(currentCohort%bdead+currentCohort%bsw) * & + SF_val_CWD_frac(c) * ED_val_ag_biomass * hlm_days_per_year / AREA + currentSite%CWD_BG_diagnostic_input_carbonflux(c) = currentSite%CWD_BG_diagnostic_input_carbonflux(c) & + + currentCohort%n*(currentCohort%bdead+currentCohort%bsw) * & + SF_val_CWD_frac(c) * (1.0_r8 - ED_val_ag_biomass) * hlm_days_per_year / AREA + enddo + + currentSite%leaf_litter_diagnostic_input_carbonflux(currentCohort%pft) = & + currentSite%leaf_litter_diagnostic_input_carbonflux(currentCohort%pft) + & + currentCohort%n * (currentCohort%bl) * hlm_days_per_year / AREA + currentSite%root_litter_diagnostic_input_carbonflux(currentCohort%pft) = & + currentSite%root_litter_diagnostic_input_carbonflux(currentCohort%pft) + & + currentCohort%n * (currentCohort%br+currentCohort%bstore) * hlm_days_per_year / AREA - 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 diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 1ff9971d..a709336a 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -9,6 +9,7 @@ module EDCohortDynamicsMod use FatesInterfaceMod , only : hlm_freq_day use FatesConstantsMod , only : r8 => fates_r8 use FatesConstantsMod , only : fates_unset_int + use FatesInterfaceMod , only : hlm_days_per_year use pftconMod , only : pftcon use EDEcophysContype , only : EDecophyscon use EDGrowthFunctionsMod , only : c_area, tree_lai @@ -498,6 +499,7 @@ subroutine terminate_cohorts( patchptr ) type (ed_patch_type), intent(inout), target :: patchptr ! ! !LOCAL VARIABLES: + type (ed_site_type) , pointer :: currentSite type (ed_patch_type) , pointer :: currentPatch type (ed_cohort_type) , pointer :: currentCohort type (ed_cohort_type) , pointer :: nextc @@ -508,6 +510,7 @@ subroutine terminate_cohorts( patchptr ) currentPatch => patchptr currentCohort => currentPatch%tallest + currentSite => currentPatch%siteptr do while (associated(currentCohort)) nextc => currentCohort%shorter @@ -571,10 +574,10 @@ subroutine terminate_cohorts( patchptr ) else levcan = 2 endif - currentPatch%siteptr%terminated_nindivs(currentCohort%size_class,currentCohort%pft,levcan) = & - currentPatch%siteptr%terminated_nindivs(currentCohort%size_class,currentCohort%pft,levcan) + currentCohort%n + currentSite%terminated_nindivs(currentCohort%size_class,currentCohort%pft,levcan) = & + currentSite%terminated_nindivs(currentCohort%size_class,currentCohort%pft,levcan) + currentCohort%n ! - currentPatch%siteptr%termination_carbonflux(levcan) = currentPatch%siteptr%termination_carbonflux(levcan) + & + currentSite%termination_carbonflux(levcan) = currentSite%termination_carbonflux(levcan) + & currentCohort%n * currentCohort%b if (.not. associated(currentCohort%taller)) then currentPatch%tallest => currentCohort%shorter @@ -604,6 +607,23 @@ subroutine terminate_cohorts( patchptr ) currentPatch%root_litter(currentCohort%pft) = currentPatch%root_litter(currentCohort%pft) + currentCohort%n* & (currentCohort%br+currentCohort%bstore)/currentPatch%area + ! keep track of the above fluxes at the site level as a CWD/litter input flux (in kg / site-m2 / yr) + do c=1,ncwd + currentSite%CWD_AG_diagnostic_input_carbonflux(c) = currentSite%CWD_AG_diagnostic_input_carbonflux(c) & + + currentCohort%n*(currentCohort%bdead+currentCohort%bsw) * & + SF_val_CWD_frac(c) * ED_val_ag_biomass * hlm_days_per_year / AREA + currentSite%CWD_BG_diagnostic_input_carbonflux(c) = currentSite%CWD_BG_diagnostic_input_carbonflux(c) & + + currentCohort%n*(currentCohort%bdead+currentCohort%bsw) * & + SF_val_CWD_frac(c) * (1.0_r8 - ED_val_ag_biomass) * hlm_days_per_year / AREA + enddo + + currentSite%leaf_litter_diagnostic_input_carbonflux(currentCohort%pft) = & + currentSite%leaf_litter_diagnostic_input_carbonflux(currentCohort%pft) + & + currentCohort%n * (currentCohort%bl) * hlm_days_per_year / AREA + currentSite%root_litter_diagnostic_input_carbonflux(currentCohort%pft) = & + currentSite%root_litter_diagnostic_input_carbonflux(currentCohort%pft) + & + currentCohort%n * (currentCohort%br+currentCohort%bstore) * hlm_days_per_year / AREA + deallocate(currentCohort) endif endif diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 237c831a..694c547e 100755 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -17,6 +17,7 @@ module EDPatchDynamicsMod use FatesInterfaceMod , only : hlm_numlevgrnd use FatesInterfaceMod , only : hlm_numlevsoil use FatesInterfaceMod , only : hlm_numSWb + use FatesInterfaceMod , only : hlm_days_per_year use FatesGlobals , only : endrun => fates_endrun use FatesConstantsMod , only : r8 => fates_r8 @@ -600,11 +601,24 @@ subroutine fire_litter_fluxes(cp_target, new_patch_target, patch_site_areadis) (currentCohort%bl) * (1.0_r8-currentCohort%cfa) currentPatch%root_litter(p) = currentPatch%root_litter(p) + dead_tree_density * & (currentCohort%br+currentCohort%bstore) + + ! track as diagnostic fluxes + currentSite%leaf_litter_diagnostic_input_carbonflux(p) = currentSite%leaf_litter_diagnostic_input_carbonflux(p) + & + (currentCohort%bl) * (1.0_r8-currentCohort%cfa) * currentCohort%fire_mort * currentCohort%n * & + hlm_days_per_year / AREA + currentSite%root_litter_diagnostic_input_carbonflux(p) = currentSite%root_litter_diagnostic_input_carbonflux(p) + & + (currentCohort%br+currentCohort%bstore) * (1.0_r8-currentCohort%cfa) * currentCohort%fire_mort * & + currentCohort%n * hlm_days_per_year / AREA ! 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 + + ! track as diagnostic fluxes + currentSite%CWD_BG_diagnostic_input_carbonflux(c) = currentSite%CWD_BG_diagnostic_input_carbonflux(c) + & + SF_val_CWD_frac(c) * bcroot * currentCohort%fire_mort * currentCohort%n * & + hlm_days_per_year / AREA enddo ! above ground coarse woody debris from unburned twigs and small branches @@ -613,12 +627,22 @@ subroutine fire_litter_fluxes(cp_target, new_patch_target, patch_site_areadis) * (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) + + ! track as diagnostic fluxes + currentSite%CWD_AG_diagnostic_input_carbonflux(c) = currentSite%CWD_AG_diagnostic_input_carbonflux(c) + & + SF_val_CWD_frac(c) * bstem * (1.0_r8-currentCohort%cfa) * currentCohort%fire_mort * currentCohort%n * & + hlm_days_per_year / AREA 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 + + ! track as diagnostic fluxes + currentSite%CWD_AG_diagnostic_input_carbonflux(c) = currentSite%CWD_AG_diagnostic_input_carbonflux(c) + & + SF_val_CWD_frac(c) * bstem * currentCohort%fire_mort * currentCohort%n * & + hlm_days_per_year / AREA enddo ! Burned parts of dead tree pool. @@ -705,6 +729,7 @@ subroutine mortality_litter_fluxes(cp_target, new_patch_target, patch_site_aread ! !LOCAL VARIABLES: real(r8) :: cwd_litter_density real(r8) :: litter_area ! area over which to distribute this litter. + type(ed_site_type) , pointer :: currentSite type(ed_cohort_type), pointer :: currentCohort type(ed_patch_type) , pointer :: currentPatch type(ed_patch_type) , pointer :: new_patch @@ -712,13 +737,17 @@ subroutine mortality_litter_fluxes(cp_target, new_patch_target, patch_site_aread 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 + real(r8) :: canopy_mortality_woody_litter ! flux of wood litter in to litter pool: KgC/m2/day + real(r8) :: canopy_mortality_leaf_litter(numpft_ed) ! flux in to leaf litter from tree death: KgC/m2/day + real(r8) :: canopy_mortality_root_litter(numpft_ed) ! flux in to froot litter from tree death: KgC/m2/day !--------------------------------------------------------------------- currentPatch => cp_target + currentSite => currentPatch%siteptr 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 + canopy_mortality_woody_litter = 0.0_r8 ! mortality generated litter. KgC/m2/day + canopy_mortality_leaf_litter(:) = 0.0_r8 + canopy_mortality_root_litter(:) = 0.0_r8 currentCohort => currentPatch%shortest do while(associated(currentCohort)) @@ -730,22 +759,22 @@ subroutine mortality_litter_fluxes(cp_target, new_patch_target, patch_site_aread !not right to recalcualte dmort here. canopy_dead = currentCohort%n * min(1.0_r8,currentCohort%dmort * hlm_freq_day) - currentPatch%canopy_mortality_woody_litter = currentPatch%canopy_mortality_woody_litter + & + canopy_mortality_woody_litter = canopy_mortality_woody_litter + & canopy_dead*(currentCohort%bdead+currentCohort%bsw) - currentPatch%canopy_mortality_leaf_litter(p) = currentPatch%canopy_mortality_leaf_litter(p)+ & + canopy_mortality_leaf_litter(p) = canopy_mortality_leaf_litter(p)+ & canopy_dead*(currentCohort%bl) - currentPatch%canopy_mortality_root_litter(p) = currentPatch%canopy_mortality_root_litter(p)+ & + canopy_mortality_root_litter(p) = 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 + & + canopy_mortality_woody_litter = canopy_mortality_woody_litter + & understorey_dead*(currentCohort%bdead+currentCohort%bsw) - currentPatch%canopy_mortality_leaf_litter(p)= currentPatch%canopy_mortality_leaf_litter(p)+ & + canopy_mortality_leaf_litter(p)= canopy_mortality_leaf_litter(p)+ & understorey_dead* currentCohort%bl - currentPatch%canopy_mortality_root_litter(p)= currentPatch%canopy_mortality_root_litter(p)+ & + canopy_mortality_root_litter(p)= canopy_mortality_root_litter(p)+ & understorey_dead*(currentCohort%br+currentCohort%bstore) ! FIX(SPM,040114) - clarify this comment @@ -777,22 +806,33 @@ subroutine mortality_litter_fluxes(cp_target, new_patch_target, patch_site_aread ! 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 + cwd_litter_density = SF_val_CWD_frac(c) * 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 + ! track as diagnostic fluxes + currentSite%CWD_AG_diagnostic_input_carbonflux(c) = currentSite%CWD_AG_diagnostic_input_carbonflux(c) + & + SF_val_CWD_frac(c) * canopy_mortality_woody_litter * hlm_days_per_year * ED_val_ag_biomass/ AREA + currentSite%CWD_BG_diagnostic_input_carbonflux(c) = currentSite%CWD_BG_diagnostic_input_carbonflux(c) + & + SF_val_CWD_frac(c) * canopy_mortality_woody_litter * hlm_days_per_year * (1.0_r8 - ED_val_ag_biomass) / AREA 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 + new_patch%leaf_litter(p) = new_patch%leaf_litter(p) + canopy_mortality_leaf_litter(p) / litter_area * np_mult + new_patch%root_litter(p) = new_patch%root_litter(p) + canopy_mortality_root_litter(p) / litter_area * np_mult + currentPatch%leaf_litter(p) = currentPatch%leaf_litter(p) + canopy_mortality_leaf_litter(p) / litter_area + currentPatch%root_litter(p) = currentPatch%root_litter(p) + canopy_mortality_root_litter(p) / litter_area + ! track as diagnostic fluxes + currentSite%leaf_litter_diagnostic_input_carbonflux(p) = currentSite%leaf_litter_diagnostic_input_carbonflux(p) + & + canopy_mortality_leaf_litter(p) * hlm_days_per_year / AREA + + currentSite%root_litter_diagnostic_input_carbonflux(p) = currentSite%root_litter_diagnostic_input_carbonflux(p) + & + canopy_mortality_root_litter(p) * hlm_days_per_year / AREA enddo end subroutine mortality_litter_fluxes diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 4f949ba7..5519c452 100755 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -92,6 +92,12 @@ subroutine zero_site( site_in ) site_in%promotion_rate(:) = 0._r8 site_in%promotion_carbonflux = 0._r8 + ! diagnostic site-level cwd and litter fluxes + site_in%CWD_AG_diagnostic_input_carbonflux(:) = 0._r8 + site_in%CWD_BG_diagnostic_input_carbonflux(:) = 0._r8 + site_in%leaf_litter_diagnostic_input_carbonflux(:) = 0._r8 + site_in%root_litter_diagnostic_input_carbonflux(:) = 0._r8 + end subroutine zero_site ! ============================================================================ diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 246ff6b7..2636e1ee 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -390,10 +390,6 @@ module EDTypesMod 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 @@ -513,7 +509,7 @@ module EDTypesMod real(r8) :: cwd_ag_burned(ncwd) real(r8) :: leaf_litter_burned(numpft_ed) - ! TERMINATION, RECRUITMENT, AND DEMOTION + ! TERMINATION, RECRUITMENT, DEMOTION, and DISTURBANCE real(r8) :: terminated_nindivs(1:nlevsclass_ed,1:mxpft,2) ! number of individuals that were in cohorts which were terminated this timestep, on size x pft x canopy array. real(r8) :: termination_carbonflux(2) ! carbon flux from live to dead pools associated with termination mortality, per canopy level real(r8) :: recruitment_rate(1:mxpft) ! number of individuals that were recruited into new cohorts @@ -522,6 +518,12 @@ module EDTypesMod real(r8) :: promotion_rate(1:nlevsclass_ed) ! rate of individuals promoted from understory to canopy per FATES timestep real(r8) :: promotion_carbonflux ! biomass of promoted individuals from understory to canopy [kgC/ha/day] + ! some diagnostic-only (i.e. not resolved by ODE solver) flux of carbon to CWD and litter pools from termination and canopy mortality + real(r8) :: CWD_AG_diagnostic_input_carbonflux(1:ncwd) ! diagnostic flux to AG CWD [kg C / m2 / yr] + real(r8) :: CWD_BG_diagnostic_input_carbonflux(1:ncwd) ! diagnostic flux to BG CWD [kg C / m2 / yr] + real(r8) :: leaf_litter_diagnostic_input_carbonflux(1:mxpft) ! diagnostic flux to AG litter [kg C / m2 / yr] + real(r8) :: root_litter_diagnostic_input_carbonflux(1:mxpft) ! diagnostic flux to BG litter [kg C / m2 / yr] + end type ed_site_type public :: ed_hist_scpfmaps diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 10926fde..25a12b2d 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -39,7 +39,7 @@ module FatesHistoryInterfaceMod integer, private :: ih_fire_fuel_sav_pa integer, private :: ih_fire_fuel_mef_pa integer, private :: ih_sum_fuel_pa - integer, private :: ih_litter_in_pa + integer, private :: ih_litter_in_si integer, private :: ih_litter_out_pa integer, private :: ih_efpot_pa ! NA @@ -1051,7 +1051,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_fire_fuel_sav_pa => this%hvars(ih_fire_fuel_sav_pa)%r81d, & hio_fire_fuel_mef_pa => this%hvars(ih_fire_fuel_mef_pa)%r81d, & hio_sum_fuel_pa => this%hvars(ih_sum_fuel_pa)%r81d, & - hio_litter_in_pa => this%hvars(ih_litter_in_pa)%r81d, & + hio_litter_in_si => this%hvars(ih_litter_in_si)%r81d, & hio_litter_out_pa => this%hvars(ih_litter_out_pa)%r81d, & hio_seed_bank_si => this%hvars(ih_seed_bank_si)%r81d, & hio_seeds_in_pa => this%hvars(ih_seeds_in_pa)%r81d, & @@ -1478,9 +1478,13 @@ subroutine update_history_dyn(this,nc,nsites,sites) end do ! Update Litter Flux Variables - hio_litter_in_pa(io_pa) = (sum(cpatch%CWD_AG_in) +sum(cpatch%leaf_litter_in)) & - * 1.e3_r8 * 365.0_r8 * daysecs * patch_scaling_scalar - hio_litter_out_pa(io_pa) = (sum(cpatch%CWD_AG_out)+sum(cpatch%leaf_litter_out)) & + ! put litter_in flux onto site level variable so as to be able to append site-level distubance-related input flux after patch loop + hio_litter_in_si(io_si) = hio_litter_in_si(io_si) + & + (sum(cpatch%CWD_AG_in) +sum(cpatch%leaf_litter_in) + sum(cpatch%root_litter_in)) & + * 1.e3_r8 * 365.0_r8 * daysecs * cpatch%area/AREA + ! keep litter_out at patch level + hio_litter_out_pa(io_pa) = (sum(cpatch%CWD_AG_out)+sum(cpatch%leaf_litter_out) & + + sum(cpatch%root_litter_out)) & * 1.e3_r8 * 365.0_r8 * daysecs * patch_scaling_scalar hio_seeds_in_pa(io_pa) = sum(cpatch%seeds_in) * & @@ -1579,7 +1583,23 @@ subroutine update_history_dyn(this,nc,nsites,sites) sites(s)%termination_carbonflux(2) * 1e3 / (1e4 * daysecs) ! and zero the site-level termination carbon flux variable sites(s)%termination_carbonflux(:) = 0._r8 - + ! + ! add the site-level disturbance-associated cwd and litter input fluxes to thir respective flux fields + do i_cwd = 1, ncwd + hio_cwd_ag_in_si_cwdsc(io_si, i_cwd) = hio_cwd_ag_in_si_cwdsc(io_si, i_cwd) + & + sites(s)%CWD_AG_diagnostic_input_carbonflux(i_cwd) * 1e3 + hio_cwd_bg_in_si_cwdsc(io_si, i_cwd) = hio_cwd_bg_in_si_cwdsc(io_si, i_cwd) + & + sites(s)%CWD_BG_diagnostic_input_carbonflux(i_cwd) * 1e3 + end do + hio_litter_in_si(io_si) = hio_litter_in_si(io_si) + & + (sum(sites(s)%leaf_litter_diagnostic_input_carbonflux) + & + sum(sites(s)%root_litter_diagnostic_input_carbonflux)) * 1e3 + ! and reset the disturbance-related field buffers + sites(s)%CWD_AG_diagnostic_input_carbonflux(:) = 0._r8 + sites(s)%CWD_BG_diagnostic_input_carbonflux(:) = 0._r8 + sites(s)%leaf_litter_diagnostic_input_carbonflux(:) = 0._r8 + sites(s)%root_litter_diagnostic_input_carbonflux(:) = 0._r8 + enddo ! site loop end associate @@ -2122,8 +2142,8 @@ subroutine define_history_vars(this, initialize_variables) call this%set_history_var(vname='LITTER_IN', units='gC m-2 s-1', & long='Litter flux in leaves', use_default='active', & - avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_litter_in_pa ) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_litter_in_si ) call this%set_history_var(vname='LITTER_OUT', units='gC m-2 s-1', & long='Litter flux out leaves', use_default='active', & @@ -2538,22 +2558,22 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_cwdsc_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_bg_si_cwdsc ) - call this%set_history_var(vname='CWD_AG_IN_CWDSC', units='kgC/m^2/y', & + call this%set_history_var(vname='CWD_AG_IN_CWDSC', units='gC/m^2/y', & long='size-resolved AG CWD input', use_default='active', & avgflag='A', vtype=site_cwdsc_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_ag_in_si_cwdsc ) - call this%set_history_var(vname='CWD_BG_IN_CWDSC', units='kgC/m^2/y', & + call this%set_history_var(vname='CWD_BG_IN_CWDSC', units='gC/m^2/y', & long='size-resolved BG CWD input', use_default='active', & avgflag='A', vtype=site_cwdsc_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_bg_in_si_cwdsc ) - call this%set_history_var(vname='CWD_AG_OUT_CWDSC', units='kgC/m^2/y', & + call this%set_history_var(vname='CWD_AG_OUT_CWDSC', units='gC/m^2/y', & long='size-resolved AG CWD output', use_default='active', & avgflag='A', vtype=site_cwdsc_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_ag_out_si_cwdsc ) - call this%set_history_var(vname='CWD_BG_OUT_CWDSC', units='kgC/m^2/y', & + call this%set_history_var(vname='CWD_BG_OUT_CWDSC', units='gC/m^2/y', & long='size-resolved BG CWD output', use_default='active', & avgflag='A', vtype=site_cwdsc_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_bg_out_si_cwdsc ) From 366e73f87ad5d27033dfb0ce200f2cc60d24867c Mon Sep 17 00:00:00 2001 From: ckoven Date: Tue, 7 Mar 2017 18:23:49 -0800 Subject: [PATCH 353/437] changed nlevcan to nlevleaf to avoid a name conflict with CLM's own different nlevcan --- biogeochem/EDCanopyStructureMod.F90 | 18 ++++---- biogeochem/EDCohortDynamicsMod.F90 | 4 +- biogeochem/EDGrowthFunctionsMod.F90 | 14 +++--- biogeochem/EDPhysiologyMod.F90 | 8 ++-- biogeophys/EDSurfaceAlbedoMod.F90 | 24 +++++----- biogeophys/FatesPlantRespPhotosynthMod.F90 | 10 ++--- main/EDTypesMod.F90 | 52 +++++++++++----------- main/FatesHistoryInterfaceMod.F90 | 8 ++-- main/FatesInterfaceMod.F90 | 4 +- main/FatesRestartInterfaceMod.F90 | 12 ++--- 10 files changed, 77 insertions(+), 77 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 23368746..7302c7bd 100755 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -12,7 +12,7 @@ module EDCanopyStructureMod use EDCohortDynamicsMod , only : copy_cohort, terminate_cohorts, fuse_cohorts use EDtypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type, ncwd use EDTypesMod , only : nclmax - use EDTypesMod , only : nlevcan + use EDTypesMod , only : nlevleaf use EDTypesMod , only : numpft_ed use FatesGlobals , only : endrun => fates_endrun @@ -96,10 +96,10 @@ subroutine canopy_structure( currentSite ) real(r8) :: cc_loss real(r8) :: lossarea real(r8) :: newarea - real(r8) :: arealayer(nlevcan) ! Amount of plant area currently in each canopy layer - real(r8) :: sumdiff(nlevcan) ! The total of the exclusion weights for all cohorts in layer z + real(r8) :: arealayer(nlevleaf) ! Amount of plant area currently in each canopy layer + real(r8) :: sumdiff(nlevleaf) ! 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) + real(r8) :: sum_weights(nlevleaf) real(r8) :: new_total_area_check real(r8) :: missing_area, promarea,cc_gain,sumgain integer :: promswitch,lower_cohort_switch @@ -640,7 +640,7 @@ subroutine canopy_spread( currentSite ) ! !LOCAL VARIABLES: type (ed_cohort_type), pointer :: currentCohort type (ed_patch_type) , pointer :: currentPatch - real(r8) :: arealayer(nlevcan) ! Amount of canopy in each layer. + real(r8) :: arealayer(nlevleaf) ! Amount of canopy in each layer. real(r8) :: inc ! Arbitrary daily incremental change in canopy area integer :: z !---------------------------------------------------------------------- @@ -1141,10 +1141,10 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) /currentPatch%tlai_profile(L,ft,iv) enddo - currentPatch%tlai_profile(L,ft,currentPatch%nrad(L,ft)+1: nlevcan) = 0._r8 - currentPatch%tsai_profile(L,ft,currentPatch%nrad(L,ft)+1: nlevcan) = 0._r8 - currentPatch%elai_profile(L,ft,currentPatch%nrad(L,ft)+1: nlevcan) = 0._r8 - currentPatch%esai_profile(L,ft,currentPatch%nrad(L,ft)+1: nlevcan) = 0._r8 + currentPatch%tlai_profile(L,ft,currentPatch%nrad(L,ft)+1: nlevleaf) = 0._r8 + currentPatch%tsai_profile(L,ft,currentPatch%nrad(L,ft)+1: nlevleaf) = 0._r8 + currentPatch%elai_profile(L,ft,currentPatch%nrad(L,ft)+1: nlevleaf) = 0._r8 + currentPatch%esai_profile(L,ft,currentPatch%nrad(L,ft)+1: nlevleaf) = 0._r8 enddo enddo diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 1ff9971d..a3c64b46 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -619,7 +619,7 @@ subroutine fuse_cohorts(patchptr) ! Join similar cohorts to reduce total number ! ! !USES: - use EDTypesMod , only : nlevcan + use EDTypesMod , only : nlevleaf ! ! !ARGUMENTS type (ed_patch_type), intent(inout), target :: patchptr @@ -774,7 +774,7 @@ subroutine fuse_cohorts(patchptr) ! recent canopy history currentCohort%canopy_layer_yesterday = (currentCohort%n*currentCohort%canopy_layer_yesterday + nextc%n*nextc%canopy_layer_yesterday)/newn - do i=1, nlevcan + do i=1, nlevleaf 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 diff --git a/biogeochem/EDGrowthFunctionsMod.F90 b/biogeochem/EDGrowthFunctionsMod.F90 index cd330f1c..3059b7b4 100755 --- a/biogeochem/EDGrowthFunctionsMod.F90 +++ b/biogeochem/EDGrowthFunctionsMod.F90 @@ -10,7 +10,7 @@ module EDGrowthFunctionsMod use FatesGlobals , only : fates_log use pftconMod , only : pftcon use EDEcophysContype , only : EDecophyscon - use EDTypesMod , only : ed_cohort_type, nlevcan, dinc_ed + use EDTypesMod , only : ed_cohort_type, nlevleaf, dinc_ed implicit none private @@ -159,10 +159,10 @@ real(r8) function tree_lai( cohort_in ) 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 default is 40, which is very large, so exceeding this would clearly illustrate a + ! at the moments nlevleaf default is 40, which is very large, so exceeding this would clearly illustrate a ! huge error - if(cohort_in%treelai > nlevcan*dinc_ed)then - write(fates_log(),*) 'too much lai' , cohort_in%treelai , cohort_in%pft , nlevcan * dinc_ed + if(cohort_in%treelai > nlevleaf*dinc_ed)then + write(fates_log(),*) 'too much lai' , cohort_in%treelai , cohort_in%pft , nlevleaf * dinc_ed endif return @@ -196,10 +196,10 @@ real(r8) function tree_sai( cohort_in ) 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 default is 40, which is very large, so exceeding this would clearly illustrate a + ! at the moments nlevleaf default is 40, which is very large, so exceeding this would clearly illustrate a ! huge error - if(cohort_in%treesai > nlevcan*dinc_ed)then - write(fates_log(),*) 'too much sai' , cohort_in%treesai , cohort_in%pft , nlevcan * dinc_ed + if(cohort_in%treesai > nlevleaf*dinc_ed)then + write(fates_log(),*) 'too much sai' , cohort_in%treesai , cohort_in%pft , nlevleaf * dinc_ed endif return diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 0cdd2390..ae264b7b 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -21,7 +21,7 @@ module EDPhysiologyMod use EDTypesMod , only : dg_sf, dinc_ed use EDTypesMod , only : external_recruitment use EDTypesMod , only : ncwd - use EDTypesMod , only : nlevcan + use EDTypesMod , only : nlevleaf use EDTypesMod , only : numpft_ed use EDTypesMod , only : senes use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type @@ -183,13 +183,13 @@ subroutine trim_canopy( currentSite ) trimmed = 0 currentCohort%treelai = tree_lai(currentCohort) currentCohort%nv = ceiling((currentCohort%treelai+currentCohort%treesai)/dinc_ed) - if (currentCohort%nv > nlevcan)then - write(fates_log(),*) 'nv > nlevcan',currentCohort%nv,currentCohort%treelai,currentCohort%treesai, & + if (currentCohort%nv > nlevleaf)then + write(fates_log(),*) 'nv > nlevleaf',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 + do z = 1,nlevleaf 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. diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index 130b093d..c4400041 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -20,7 +20,7 @@ module EDSurfaceRadiationMod use EDTypesMod , only : maxSWb use EDTypesMod , only : nclmax use EDTypesMod , only : numpft_ed - use EDTypesMod , only : nlevcan + use EDTypesMod , only : nlevleaf use EDCanopyStructureMod, only: calc_areaindex use FatesGlobals , only : fates_log @@ -74,10 +74,10 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) 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) + real(r8) :: ftweight(nclmax,numpft_ed,nlevleaf) real(r8) :: k_dir(numpft_ed) ! Direct beam extinction coefficient - real(r8) :: tr_dir_z(nclmax,numpft_ed,nlevcan) ! Exponential transmittance of direct beam radiation through a single layer - real(r8) :: tr_dif_z(nclmax,numpft_ed,nlevcan) ! Exponential transmittance of diffuse radiation through a single layer + real(r8) :: tr_dir_z(nclmax,numpft_ed,nlevleaf) ! Exponential transmittance of direct beam radiation through a single layer + real(r8) :: tr_dif_z(nclmax,numpft_ed,nlevleaf) ! Exponential transmittance of diffuse radiation through a single layer real(r8) :: forc_dir(maxPatchesPerSite,maxSWb) real(r8) :: forc_dif(maxPatchesPerSite,maxSWb) real(r8) :: weighted_dir_tr(nclmax) @@ -85,15 +85,15 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) real(r8) :: weighted_dif_ratio(nclmax,maxSWb) real(r8) :: weighted_dif_down(nclmax) real(r8) :: weighted_dif_up(nclmax) - real(r8) :: refl_dif(nclmax,numpft_ed,nlevcan,maxSWb) ! Term for diffuse radiation reflected by laye - real(r8) :: tran_dif(nclmax,numpft_ed,nlevcan,maxSWb) ! Term for diffuse radiation transmitted by layer - real(r8) :: dif_ratio(nclmax,numpft_ed,nlevcan,maxSWb) ! Ratio of upward to forward diffuse fluxes - real(r8) :: Dif_dn(nclmax,numpft_ed,nlevcan) ! Forward diffuse flux onto canopy layer J (W/m**2 ground area) - real(r8) :: Dif_up(nclmax,numpft_ed,nlevcan) ! Upward diffuse flux above canopy layer J (W/m**2 ground area) - real(r8) :: lai_change(nclmax,numpft_ed,nlevcan) ! Forward diffuse flux onto canopy layer J (W/m**2 ground area) + real(r8) :: refl_dif(nclmax,numpft_ed,nlevleaf,maxSWb) ! Term for diffuse radiation reflected by laye + real(r8) :: tran_dif(nclmax,numpft_ed,nlevleaf,maxSWb) ! Term for diffuse radiation transmitted by layer + real(r8) :: dif_ratio(nclmax,numpft_ed,nlevleaf,maxSWb) ! Ratio of upward to forward diffuse fluxes + real(r8) :: Dif_dn(nclmax,numpft_ed,nlevleaf) ! Forward diffuse flux onto canopy layer J (W/m**2 ground area) + real(r8) :: Dif_up(nclmax,numpft_ed,nlevleaf) ! Upward diffuse flux above canopy layer J (W/m**2 ground area) + real(r8) :: lai_change(nclmax,numpft_ed,nlevleaf) ! Forward diffuse flux onto canopy layer J (W/m**2 ground area) real(r8) :: f_not_abs(numpft_ed,maxSWb) ! Fraction reflected + transmitted. 1-absorbtion. - real(r8) :: Abs_dir_z(numpft_ed,nlevcan) - real(r8) :: Abs_dif_z(numpft_ed,nlevcan) + real(r8) :: Abs_dir_z(numpft_ed,nlevleaf) + real(r8) :: Abs_dif_z(numpft_ed,nlevleaf) real(r8) :: abs_rad(maxSWb) !radiation absorbed by soil real(r8) :: tr_soili ! Radiation transmitted to the soil surface. real(r8) :: tr_soild ! Radiation transmitted to the soil surface. diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index 6dd2592c..17f9d599 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -25,7 +25,7 @@ module FATESPlantRespPhotosynthMod use FatesConstantsMod, only : r8 => fates_r8 use EDTypesMod, only : use_fates_plant_hydro use EDTypesMod, only : numpft_ed - use EDTypesMod, only : nlevcan + use EDTypesMod, only : nlevleaf use EDTypesMod, only : nclmax ! CIME Globals @@ -116,17 +116,17 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! ----------------------------------------------------------------------------------- ! leaf maintenance (dark) respiration (umol CO2/m**2/s) Double check this - real(r8) :: lmr_z(nlevcan,mxpft,nclmax) + real(r8) :: lmr_z(nlevleaf,mxpft,nclmax) ! stomatal resistance s/m - real(r8) :: rs_z(nlevcan,mxpft,nclmax) + real(r8) :: rs_z(nlevleaf,mxpft,nclmax) ! net leaf photosynthesis averaged over sun and shade leaves. (umol CO2/m**2/s) - real(r8) :: anet_av_z(nlevcan,mxpft,nclmax) + real(r8) :: anet_av_z(nlevleaf,mxpft,nclmax) ! Mask used to determine which leaf-layer biophysical rates have been ! used already - logical :: rate_mask_z(nlevcan,mxpft,nclmax) + logical :: rate_mask_z(nlevleaf,mxpft,nclmax) real(r8) :: vcmax_z ! leaf layer maximum rate of carboxylation ! (umol co2/m**2/s) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 246ff6b7..25c30201 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -10,7 +10,7 @@ module EDTypesMod integer, parameter :: maxPatchesPerSite = 10 ! maximum number of patches to live on a site integer, parameter :: maxCohortsPerPatch = 160 ! maximum number of cohorts to live on a patch integer, parameter :: nclmax = 2 ! Maximum number of canopy layers - integer, parameter :: nlevcan = 40 ! number of leaf layers in canopy layer + integer, parameter :: nlevleaf = 40 ! number of leaf layers in canopy layer integer, parameter :: maxpft = 10 ! maximum number of PFTs allowed ! the parameter file may determine that fewer ! are used, but this helps allocate scratch @@ -213,8 +213,8 @@ module EDTypesMod real(r8) :: npp_bseed ! NPP into seeds: KgC/indiv/year real(r8) :: npp_store ! NPP into storage: KgC/indiv/year - real(r8) :: ts_net_uptake(nlevcan) ! Net uptake of leaf layers: kgC/m2/s - real(r8) :: year_net_uptake(nlevcan) ! Net uptake of leaf layers: kgC/m2/year + real(r8) :: ts_net_uptake(nlevleaf) ! Net uptake of leaf layers: kgC/m2/s + real(r8) :: year_net_uptake(nlevleaf) ! Net uptake of leaf layers: kgC/m2/year ! RESPIRATION COMPONENTS real(r8) :: rdark ! Dark respiration: kgC/indiv/s @@ -302,33 +302,33 @@ module EDTypesMod 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) ! total leaf area in each canopy layer, pft, and leaf layer. m2/m2 - real(r8) :: elai_profile(nclmax,numpft_ed,nlevcan) ! exposed leaf area in each canopy layer, pft, and leaf layer. m2/m2 - real(r8) :: tsai_profile(nclmax,numpft_ed,nlevcan) ! total stem area in each canopy layer, pft, and leaf layer. m2/m2 - real(r8) :: esai_profile(nclmax,numpft_ed,nlevcan) ! exposed stem area in each canopy layer, pft, and leaf layer. m2/m2 - real(r8) :: layer_height_profile(nclmax,numpft_ed,nlevcan) - real(r8) :: canopy_area_profile(nclmax,numpft_ed,nlevcan) ! fraction of canopy in each canopy + real(r8) :: tlai_profile(nclmax,numpft_ed,nlevleaf) ! total leaf area in each canopy layer, pft, and leaf layer. m2/m2 + real(r8) :: elai_profile(nclmax,numpft_ed,nlevleaf) ! exposed leaf area in each canopy layer, pft, and leaf layer. m2/m2 + real(r8) :: tsai_profile(nclmax,numpft_ed,nlevleaf) ! total stem area in each canopy layer, pft, and leaf layer. m2/m2 + real(r8) :: esai_profile(nclmax,numpft_ed,nlevleaf) ! exposed stem area in each canopy layer, pft, and leaf layer. m2/m2 + real(r8) :: layer_height_profile(nclmax,numpft_ed,nlevleaf) + real(r8) :: canopy_area_profile(nclmax,numpft_ed,nlevleaf) ! 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) ! sun fraction of direct light absorbed by each canopy + real(r8) :: fabd_sun_z(nclmax,numpft_ed,nlevleaf) ! sun fraction of direct light absorbed by each canopy ! layer, pft, and leaf layer:- - real(r8) :: fabd_sha_z(nclmax,numpft_ed,nlevcan) ! shade fraction of direct light absorbed by each canopy + real(r8) :: fabd_sha_z(nclmax,numpft_ed,nlevleaf) ! shade fraction of direct light absorbed by each canopy ! layer, pft, and leaf layer:- - real(r8) :: fabi_sun_z(nclmax,numpft_ed,nlevcan) ! sun fraction of indirect light absorbed by each canopy + real(r8) :: fabi_sun_z(nclmax,numpft_ed,nlevleaf) ! sun fraction of indirect light absorbed by each canopy ! layer, pft, and leaf layer:- - real(r8) :: fabi_sha_z(nclmax,numpft_ed,nlevcan) ! shade fraction of indirect light absorbed by each canopy + real(r8) :: fabi_sha_z(nclmax,numpft_ed,nlevleaf) ! shade fraction of indirect light absorbed by each canopy ! layer, pft, and leaf layer:- - real(r8) :: ed_laisun_z(nclmax,numpft_ed,nlevcan) ! amount of LAI in the sun in each canopy layer, + real(r8) :: ed_laisun_z(nclmax,numpft_ed,nlevleaf) ! 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) ! amount of LAI in the shade in each canopy layer, - real(r8) :: ed_parsun_z(nclmax,numpft_ed,nlevcan) ! PAR absorbed in the sun in each canopy layer, - real(r8) :: ed_parsha_z(nclmax,numpft_ed,nlevcan) ! PAR absorbed in the shade in each canopy layer, - real(r8) :: f_sun(nclmax,numpft_ed,nlevcan) ! fraction of leaves in the sun in each canopy layer, pft, + real(r8) :: ed_laisha_z(nclmax,numpft_ed,nlevleaf) ! amount of LAI in the shade in each canopy layer, + real(r8) :: ed_parsun_z(nclmax,numpft_ed,nlevleaf) ! PAR absorbed in the sun in each canopy layer, + real(r8) :: ed_parsha_z(nclmax,numpft_ed,nlevleaf) ! PAR absorbed in the shade in each canopy layer, + real(r8) :: f_sun(nclmax,numpft_ed,nlevleaf) ! fraction of leaves in the sun in each canopy layer, pft, ! and leaf layer. m2/m2 real(r8),allocatable :: tr_soil_dir(:) ! fraction of incoming direct radiation that (cm_numSWb) @@ -351,7 +351,7 @@ module EDTypesMod ! PHOTOSYNTHESIS - real(r8) :: psn_z(nclmax,numpft_ed,nlevcan) ! carbon assimilation in each canopy layer, pft, and leaf layer. umolC/m2/s + real(r8) :: psn_z(nclmax,numpft_ed,nlevleaf) ! 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 @@ -552,11 +552,11 @@ subroutine ed_hist_scpfmaps allocate( levage_ed(1:nlevage_ed )) allocate(levcan_ed(nclmax)) - allocate(can_levcnlf_ed(nlevcan*nclmax)) - allocate(lf_levcnlf_ed(nlevcan*nclmax)) - allocate(can_levcnlfpft_ed(nlevcan*nclmax*numpft_ed)) - allocate(lf_levcnlfpft_ed(nlevcan*nclmax*numpft_ed)) - allocate(pft_levcnlfpft_ed(nlevcan*nclmax*numpft_ed)) + allocate(can_levcnlf_ed(nlevleaf*nclmax)) + allocate(lf_levcnlf_ed(nlevleaf*nclmax)) + allocate(can_levcnlfpft_ed(nlevleaf*nclmax*numpft_ed)) + allocate(lf_levcnlfpft_ed(nlevleaf*nclmax*numpft_ed)) + allocate(pft_levcnlfpft_ed(nlevleaf*nclmax*numpft_ed)) ! Fill the IO array of plant size classes ! For some reason the history files did not like @@ -597,7 +597,7 @@ subroutine ed_hist_scpfmaps i=0 do ican=1,nclmax - do ileaf=1,nlevcan + do ileaf=1,nlevleaf i=i+1 can_levcnlf_ed(i) = ican lf_levcnlf_ed(i) = ileaf @@ -607,7 +607,7 @@ subroutine ed_hist_scpfmaps i=0 do ipft=1,numpft_ed do ican=1,nclmax - do ileaf=1,nlevcan + do ileaf=1,nlevleaf i=i+1 can_levcnlfpft_ed(i) = ican lf_levcnlfpft_ed(i) = ileaf diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 29d4074f..ee2a48ab 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -1603,7 +1603,7 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) nlevage_ed, & sclass_ed, & nlevsclass_ed - use EDTypesMod, only : numpft_ed, nclmax, nlevcan + use EDTypesMod, only : numpft_ed, nclmax, nlevleaf ! ! Arguments class(fates_history_interface_type) :: this @@ -1819,10 +1819,10 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) ! summarize radiation profiles through the canopy do ipft=1,numpft_ed do ican=1,nclmax - do ileaf=1,nlevcan + do ileaf=1,nlevleaf ! calculate where we are on multiplexed dimensions - cnlfpft_indx = ileaf + (ican-1) * nlevcan + (ipft-1) * nlevcan * nclmax - cnlf_indx = ileaf + (ican-1) * nlevcan + cnlfpft_indx = ileaf + (ican-1) * nlevleaf + (ipft-1) * nlevleaf * nclmax + cnlf_indx = ileaf + (ican-1) * nlevleaf ! hio_parsun_z_si_cnlfpft(io_si,cnlfpft_indx) = hio_parsun_z_si_cnlfpft(io_si,cnlfpft_indx) + & cpatch%ed_parsun_z(ican,ipft,ileaf) * cpatch%area/AREA diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 79279454..3a1e2576 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -14,7 +14,7 @@ module FatesInterfaceMod use EDTypesMod , only : maxCohortsPerPatch use EDTypesMod , only : maxSWb use EDTypesMod , only : nclmax - use EDTypesMod , only : nlevcan + use EDTypesMod , only : nlevleaf use EDTypesMod , only : numpft_ed use FatesConstantsMod , only : r8 => fates_r8 use FatesGlobals , only : fates_global_verbose @@ -646,7 +646,7 @@ subroutine set_fates_global_elements(use_fates) if (use_fates) then fates_maxElementsPerPatch = max(maxCohortsPerPatch, & - numpft_ed * nclmax * nlevcan) + numpft_ed * nclmax * nlevleaf) fates_maxElementsPerSite = maxPatchesPerSite * fates_maxElementsPerPatch diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index f15ff350..d8aa0e8c 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -929,7 +929,7 @@ end subroutine set_restart_var subroutine set_restart_vectors(this,nc,nsites,sites) use EDTypesMod, only : nclmax - use EDTypesMod, only : nlevcan + use EDTypesMod, only : nlevleaf use FatesInterfaceMod, only : fates_maxElementsPerPatch use EDTypesMod, only : numpft_ed use EDTypesMod, only : ed_site_type @@ -1206,9 +1206,9 @@ subroutine set_restart_vectors(this,nc,nsites,sites) if ( DEBUG ) write(fates_log(),*) 'CLTV io_idx_pa_sunz 1 ',io_idx_pa_sunz - if ( DEBUG ) write(fates_log(),*) 'CLTV 1186 ',nlevcan,numpft_ed,nclmax + if ( DEBUG ) write(fates_log(),*) 'CLTV 1186 ',nlevleaf,numpft_ed,nclmax - do k = 1,nlevcan ! nlevcan currently 40 + do k = 1,nlevleaf ! nlevleaf currently 40 do j = 1,numpft_ed ! numpft_ed currently 2 do i = 1,nclmax ! nclmax currently 2 rio_fsun_paclftls(io_idx_pa_sunz) = cpatch%f_sun(i,j,k) @@ -1304,7 +1304,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites ) use EDTypesMod, only : ed_cohort_type use EDTypesMod, only : ed_patch_type use EDTypesMod, only : ncwd - use EDTypesMod, only : nlevcan + use EDTypesMod, only : nlevleaf use EDTypesMod, only : nclmax use FatesInterfaceMod, only : fates_maxElementsPerPatch use EDTypesMod, only : numpft_ed @@ -1501,7 +1501,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) use EDTypesMod, only : ed_patch_type use EDTypesMod, only : numpft_ed use EDTypesMod, only : ncwd - use EDTypesMod, only : nlevcan + use EDTypesMod, only : nlevleaf use EDTypesMod, only : nclmax use FatesInterfaceMod, only : fates_maxElementsPerPatch use EDTypesMod, only : numWaterMem @@ -1765,7 +1765,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) if ( DEBUG ) write(fates_log(),*) 'CVTL io_idx_pa_sunz 1 ',io_idx_pa_sunz - do k = 1,nlevcan ! nlevcan currently 40 + do k = 1,nlevleaf ! nlevleaf currently 40 do j = 1,numpft_ed ! numpft_ed currently 2 do i = 1,nclmax ! nclmax currently 2 cpatch%f_sun(i,j,k) = rio_fsun_paclftls(io_idx_pa_sunz) From c4ccd474cbcc3d3ee0928ec5d84e1b72bd02ffab Mon Sep 17 00:00:00 2001 From: ckoven Date: Tue, 7 Mar 2017 20:19:56 -0800 Subject: [PATCH 354/437] assorted unit fixes --- main/FatesHistoryInterfaceMod.F90 | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 30f727e9..3444835d 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -1481,18 +1481,18 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! put litter_in flux onto site level variable so as to be able to append site-level distubance-related input flux after patch loop hio_litter_in_si(io_si) = hio_litter_in_si(io_si) + & (sum(cpatch%CWD_AG_in) +sum(cpatch%leaf_litter_in) + sum(cpatch%root_litter_in)) & - * 1.e3_r8 * 365.0_r8 * daysecs * cpatch%area/AREA + * 1.e3_r8 * cpatch%area / ( AREA * 365.0_r8 * daysecs ) ! keep litter_out at patch level hio_litter_out_pa(io_pa) = (sum(cpatch%CWD_AG_out)+sum(cpatch%leaf_litter_out) & + sum(cpatch%root_litter_out)) & - * 1.e3_r8 * 365.0_r8 * daysecs * patch_scaling_scalar + * 1.e3_r8 * patch_scaling_scalar / ( 365.0_r8 * daysecs ) hio_seeds_in_pa(io_pa) = sum(cpatch%seeds_in) * & - 1.e3_r8 * 365.0_r8 * daysecs * patch_scaling_scalar + 1.e3_r8 * patch_scaling_scalar / ( 365.0_r8 * daysecs ) hio_seed_decay_pa(io_pa) = sum(cpatch%seed_decay) & - * 1.e3_r8 * 365.0_r8 * daysecs * patch_scaling_scalar + * 1.e3_r8 * patch_scaling_scalar / ( 365.0_r8 * daysecs ) hio_seed_germination_pa(io_pa) = sum(cpatch%seed_germination) & - * 1.e3_r8 * 365.0_r8 * daysecs * patch_scaling_scalar + * 1.e3_r8 * patch_scaling_scalar / ( 365.0_r8 * daysecs ) hio_canopy_spread_pa(io_pa) = cpatch%spread(1) @@ -1593,7 +1593,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) end do hio_litter_in_si(io_si) = hio_litter_in_si(io_si) + & (sum(sites(s)%leaf_litter_diagnostic_input_carbonflux) + & - sum(sites(s)%root_litter_diagnostic_input_carbonflux)) * 1e3 + sum(sites(s)%root_litter_diagnostic_input_carbonflux)) * 1e3 / ( daysecs * yeardays ) ! and reset the disturbance-related field buffers sites(s)%CWD_AG_diagnostic_input_carbonflux(:) = 0._r8 sites(s)%CWD_BG_diagnostic_input_carbonflux(:) = 0._r8 @@ -2141,12 +2141,12 @@ subroutine define_history_vars(this, initialize_variables) ! Litter Variables call this%set_history_var(vname='LITTER_IN', units='gC m-2 s-1', & - long='Litter flux in leaves', use_default='active', & + long='FATES litter flux in', use_default='active', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_litter_in_si ) call this%set_history_var(vname='LITTER_OUT', units='gC m-2 s-1', & - long='Litter flux out leaves', use_default='active', & + long='FATES litter flux out', use_default='active', & avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_litter_out_pa ) From 1460c0e310a9b8fdf134dc107ea46b202546c257 Mon Sep 17 00:00:00 2001 From: ckoven Date: Tue, 7 Mar 2017 20:26:05 -0800 Subject: [PATCH 355/437] reverted changes to litter_in and litter_out variables so as to pass tests --- main/FatesHistoryInterfaceMod.F90 | 33 +++++++++++++++++++------------ 1 file changed, 20 insertions(+), 13 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 3444835d..5467aeca 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -1476,16 +1476,21 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_litter_moisture_si_fuel(io_si, i_fuel) = hio_litter_moisture_si_fuel(io_si, i_fuel) + & cpatch%litter_moisture(i_fuel) * cpatch%area/AREA end do - + !!! +++ cdk +++ commenting out the below changes to revert for bit-for-bit passing !!! ! Update Litter Flux Variables - ! put litter_in flux onto site level variable so as to be able to append site-level distubance-related input flux after patch loop - hio_litter_in_si(io_si) = hio_litter_in_si(io_si) + & - (sum(cpatch%CWD_AG_in) +sum(cpatch%leaf_litter_in) + sum(cpatch%root_litter_in)) & - * 1.e3_r8 * cpatch%area / ( AREA * 365.0_r8 * daysecs ) - ! keep litter_out at patch level - hio_litter_out_pa(io_pa) = (sum(cpatch%CWD_AG_out)+sum(cpatch%leaf_litter_out) & - + sum(cpatch%root_litter_out)) & - * 1.e3_r8 * patch_scaling_scalar / ( 365.0_r8 * daysecs ) + ! ! put litter_in flux onto site level variable so as to be able to append site-level distubance-related input flux after patch loop + ! hio_litter_in_si(io_si) = hio_litter_in_si(io_si) + & + ! (sum(cpatch%CWD_AG_in) +sum(cpatch%leaf_litter_in) + sum(cpatch%root_litter_in)) & + ! * 1.e3_r8 * cpatch%area / ( AREA * 365.0_r8 * daysecs ) + ! ! keep litter_out at patch level + ! hio_litter_out_pa(io_pa) = (sum(cpatch%CWD_AG_out)+sum(cpatch%leaf_litter_out) & + ! + sum(cpatch%root_litter_out)) & + ! * 1.e3_r8 * patch_scaling_scalar / ( 365.0_r8 * daysecs ) + !!! --- cdk --- !!! + hio_litter_in_si(io_pa) = (sum(cpatch%CWD_AG_in) +sum(cpatch%leaf_litter_in)) & + * 1.e3_r8 * 365.0_r8 * daysecs * patch_scaling_scalar + hio_litter_out_pa(io_pa) = (sum(cpatch%CWD_AG_out)+sum(cpatch%leaf_litter_out)) & + !!! --- cdk --- !!! hio_seeds_in_pa(io_pa) = sum(cpatch%seeds_in) * & 1.e3_r8 * patch_scaling_scalar / ( 365.0_r8 * daysecs ) @@ -1591,9 +1596,10 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_cwd_bg_in_si_cwdsc(io_si, i_cwd) = hio_cwd_bg_in_si_cwdsc(io_si, i_cwd) + & sites(s)%CWD_BG_diagnostic_input_carbonflux(i_cwd) * 1e3 end do - hio_litter_in_si(io_si) = hio_litter_in_si(io_si) + & - (sum(sites(s)%leaf_litter_diagnostic_input_carbonflux) + & - sum(sites(s)%root_litter_diagnostic_input_carbonflux)) * 1e3 / ( daysecs * yeardays ) + !!! cdk comment out below line for bit-for-bitness + ! hio_litter_in_si(io_si) = hio_litter_in_si(io_si) + & + ! (sum(sites(s)%leaf_litter_diagnostic_input_carbonflux) + & + ! sum(sites(s)%root_litter_diagnostic_input_carbonflux)) * 1e3 / ( daysecs * yeardays ) ! and reset the disturbance-related field buffers sites(s)%CWD_AG_diagnostic_input_carbonflux(:) = 0._r8 sites(s)%CWD_BG_diagnostic_input_carbonflux(:) = 0._r8 @@ -2142,7 +2148,8 @@ subroutine define_history_vars(this, initialize_variables) call this%set_history_var(vname='LITTER_IN', units='gC m-2 s-1', & long='FATES litter flux in', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + !!! cdk reverted to pass bit-for-bitness avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_litter_in_si ) call this%set_history_var(vname='LITTER_OUT', units='gC m-2 s-1', & From 91ab92a6e2bd2816a3ff66ec2fc7188687609811 Mon Sep 17 00:00:00 2001 From: ckoven Date: Tue, 7 Mar 2017 20:51:26 -0800 Subject: [PATCH 356/437] bugfix on the prior --- main/FatesHistoryInterfaceMod.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 5467aeca..7f84e0ff 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -1490,6 +1490,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_litter_in_si(io_pa) = (sum(cpatch%CWD_AG_in) +sum(cpatch%leaf_litter_in)) & * 1.e3_r8 * 365.0_r8 * daysecs * patch_scaling_scalar hio_litter_out_pa(io_pa) = (sum(cpatch%CWD_AG_out)+sum(cpatch%leaf_litter_out)) & + * 1.e3_r8 * 365.0_r8 * daysecs * patch_scaling_scalar !!! --- cdk --- !!! hio_seeds_in_pa(io_pa) = sum(cpatch%seeds_in) * & From d1435589443b8b8c58a241bb0ce18aa45c50c77c Mon Sep 17 00:00:00 2001 From: ckoven Date: Wed, 8 Mar 2017 09:05:25 -0800 Subject: [PATCH 357/437] reinstated fixes to litter_in and litter_out fluxes --- main/FatesHistoryInterfaceMod.F90 | 33 +++++++++++-------------------- 1 file changed, 12 insertions(+), 21 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 7f84e0ff..466a3c00 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -1476,22 +1476,15 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_litter_moisture_si_fuel(io_si, i_fuel) = hio_litter_moisture_si_fuel(io_si, i_fuel) + & cpatch%litter_moisture(i_fuel) * cpatch%area/AREA end do - !!! +++ cdk +++ commenting out the below changes to revert for bit-for-bit passing !!! ! Update Litter Flux Variables - ! ! put litter_in flux onto site level variable so as to be able to append site-level distubance-related input flux after patch loop - ! hio_litter_in_si(io_si) = hio_litter_in_si(io_si) + & - ! (sum(cpatch%CWD_AG_in) +sum(cpatch%leaf_litter_in) + sum(cpatch%root_litter_in)) & - ! * 1.e3_r8 * cpatch%area / ( AREA * 365.0_r8 * daysecs ) - ! ! keep litter_out at patch level - ! hio_litter_out_pa(io_pa) = (sum(cpatch%CWD_AG_out)+sum(cpatch%leaf_litter_out) & - ! + sum(cpatch%root_litter_out)) & - ! * 1.e3_r8 * patch_scaling_scalar / ( 365.0_r8 * daysecs ) - !!! --- cdk --- !!! - hio_litter_in_si(io_pa) = (sum(cpatch%CWD_AG_in) +sum(cpatch%leaf_litter_in)) & - * 1.e3_r8 * 365.0_r8 * daysecs * patch_scaling_scalar - hio_litter_out_pa(io_pa) = (sum(cpatch%CWD_AG_out)+sum(cpatch%leaf_litter_out)) & - * 1.e3_r8 * 365.0_r8 * daysecs * patch_scaling_scalar - !!! --- cdk --- !!! + ! put litter_in flux onto site level variable so as to be able to append site-level distubance-related input flux after patch loop + hio_litter_in_si(io_si) = hio_litter_in_si(io_si) + & + (sum(cpatch%CWD_AG_in) +sum(cpatch%leaf_litter_in) + sum(cpatch%root_litter_in)) & + * 1.e3_r8 * cpatch%area / ( AREA * 365.0_r8 * daysecs ) + ! keep litter_out at patch level + hio_litter_out_pa(io_pa) = (sum(cpatch%CWD_AG_out)+sum(cpatch%leaf_litter_out) & + + sum(cpatch%root_litter_out)) & + * 1.e3_r8 * patch_scaling_scalar / ( 365.0_r8 * daysecs ) hio_seeds_in_pa(io_pa) = sum(cpatch%seeds_in) * & 1.e3_r8 * patch_scaling_scalar / ( 365.0_r8 * daysecs ) @@ -1597,10 +1590,9 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_cwd_bg_in_si_cwdsc(io_si, i_cwd) = hio_cwd_bg_in_si_cwdsc(io_si, i_cwd) + & sites(s)%CWD_BG_diagnostic_input_carbonflux(i_cwd) * 1e3 end do - !!! cdk comment out below line for bit-for-bitness - ! hio_litter_in_si(io_si) = hio_litter_in_si(io_si) + & - ! (sum(sites(s)%leaf_litter_diagnostic_input_carbonflux) + & - ! sum(sites(s)%root_litter_diagnostic_input_carbonflux)) * 1e3 / ( daysecs * yeardays ) + hio_litter_in_si(io_si) = hio_litter_in_si(io_si) + & + (sum(sites(s)%leaf_litter_diagnostic_input_carbonflux) + & + sum(sites(s)%root_litter_diagnostic_input_carbonflux)) * 1e3 / ( daysecs * yeardays ) ! and reset the disturbance-related field buffers sites(s)%CWD_AG_diagnostic_input_carbonflux(:) = 0._r8 sites(s)%CWD_BG_diagnostic_input_carbonflux(:) = 0._r8 @@ -2149,8 +2141,7 @@ subroutine define_history_vars(this, initialize_variables) call this%set_history_var(vname='LITTER_IN', units='gC m-2 s-1', & long='FATES litter flux in', use_default='active', & - avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - !!! cdk reverted to pass bit-for-bitness avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_litter_in_si ) call this%set_history_var(vname='LITTER_OUT', units='gC m-2 s-1', & From 442306ca60966f31fc137ffa18ef044543d67023 Mon Sep 17 00:00:00 2001 From: ckoven Date: Wed, 8 Mar 2017 19:07:35 -0800 Subject: [PATCH 358/437] cleaned up site pointer issues --- biogeochem/EDCanopyStructureMod.F90 | 10 +++++----- biogeochem/EDCohortDynamicsMod.F90 | 9 +++++---- biogeochem/EDPatchDynamicsMod.F90 | 4 ++-- biogeochem/EDPhysiologyMod.F90 | 2 +- main/EDMainMod.F90 | 4 ++-- 5 files changed, 15 insertions(+), 14 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 23368746..2516b18d 100755 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -307,7 +307,7 @@ subroutine canopy_structure( currentSite ) enddo !currentCohort - call terminate_cohorts(currentPatch) + call terminate_cohorts(currentSite, currentPatch) arealayer(i) = arealayer(i) - sumloss !Update arealayer for diff calculations of layer below. arealayer(i + 1) = arealayer(i + 1) + sumloss @@ -343,9 +343,9 @@ subroutine canopy_structure( currentSite ) enddo !is there still excess area in any layer? - call terminate_cohorts(currentPatch) + call terminate_cohorts(currentSite, currentPatch) call fuse_cohorts(currentPatch) - call terminate_cohorts(currentPatch) + call terminate_cohorts(currentSite, currentPatch) ! ----------- Check cohort area ------------------------------! do i = 1,z @@ -565,9 +565,9 @@ subroutine canopy_structure( currentSite ) endif enddo !is there still not enough canopy area in any layer? - call terminate_cohorts(currentPatch) + call terminate_cohorts(currentSite, currentPatch) call fuse_cohorts(currentPatch) - call terminate_cohorts(currentPatch) + call terminate_cohorts(currentSite, currentPatch) if(promswitch == 1)then !write(fates_log(),*) 'going into cohort check' diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 1ff9971d..d02f3c03 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -485,7 +485,7 @@ subroutine zero_cohort(cc_p) end subroutine zero_cohort !-------------------------------------------------------------------------------------! - subroutine terminate_cohorts( patchptr ) + subroutine terminate_cohorts( siteptr, patchptr ) ! ! !DESCRIPTION: ! terminates cohorts when they get too small @@ -495,6 +495,7 @@ subroutine terminate_cohorts( patchptr ) use SFParamsMod, only : SF_val_CWD_frac ! ! !ARGUMENTS + type (ed_site_type), intent(inout), target :: siteptr type (ed_patch_type), intent(inout), target :: patchptr ! ! !LOCAL VARIABLES: @@ -571,10 +572,10 @@ subroutine terminate_cohorts( patchptr ) else levcan = 2 endif - currentPatch%siteptr%terminated_nindivs(currentCohort%size_class,currentCohort%pft,levcan) = & - currentPatch%siteptr%terminated_nindivs(currentCohort%size_class,currentCohort%pft,levcan) + currentCohort%n + siteptr%terminated_nindivs(currentCohort%size_class,currentCohort%pft,levcan) = & + siteptr%terminated_nindivs(currentCohort%size_class,currentCohort%pft,levcan) + currentCohort%n ! - currentPatch%siteptr%termination_carbonflux(levcan) = currentPatch%siteptr%termination_carbonflux(levcan) + & + siteptr%termination_carbonflux(levcan) = siteptr%termination_carbonflux(levcan) + & currentCohort%n * currentCohort%b if (.not. associated(currentCohort%taller)) then currentPatch%tallest => currentCohort%shorter diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 237c831a..fd5423ee 100755 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -396,7 +396,7 @@ subroutine spawn_patches( currentSite ) !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 terminate_cohorts(currentSite, currentPatch) call sort_cohorts(currentPatch) currentPatch => currentPatch%younger @@ -413,7 +413,7 @@ subroutine spawn_patches( currentSite ) currentSite%youngest_patch => new_patch call fuse_cohorts(new_patch) - call terminate_cohorts(new_patch) + call terminate_cohorts(currentSite, new_patch) call sort_cohorts(new_patch) endif !end new_patch area diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 0cdd2390..f2ffc055 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1081,7 +1081,7 @@ subroutine recruitment( t, currentSite, currentPatch ) temp_cohort%laimemory, cohortstatus, temp_cohort%canopy_trim, currentPatch%NCL_p) ! keep track of how many individuals were recruited for passing to history - currentPatch%siteptr%recruitment_rate(ft) = currentPatch%siteptr%recruitment_rate(ft) + temp_cohort%n + currentSite%recruitment_rate(ft) = currentSite%recruitment_rate(ft) + temp_cohort%n endif enddo !pft loop diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index d06ff592..780787e2 100755 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -118,7 +118,7 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) call fuse_cohorts(currentPatch) ! kills cohorts that are too small - call terminate_cohorts(currentPatch) + call terminate_cohorts(currentSite, currentPatch) currentPatch => currentPatch%younger @@ -341,7 +341,7 @@ subroutine ed_update_site( currentSite, bc_in ) currentPatch => currentSite%oldest_patch do while(associated(currentPatch)) - call terminate_cohorts(currentPatch) + call terminate_cohorts(currentSite, currentPatch) ! FIX(SPM,040314) why is this needed for BFB restarts? Look into this at some point cohort_number = count_cohorts(currentPatch) From 0a56f79d4b1789d84151c58921d920588e47729e Mon Sep 17 00:00:00 2001 From: ckoven Date: Wed, 8 Mar 2017 20:06:21 -0800 Subject: [PATCH 359/437] fixed some patch%siteptr by replacing with actual currentsite insts --- biogeochem/EDPatchDynamicsMod.F90 | 12 ++++++------ biogeochem/EDPhysiologyMod.F90 | 2 +- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 237c831a..02217e76 100755 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -254,9 +254,9 @@ subroutine spawn_patches( currentSite ) call average_patch_properties(currentPatch, new_patch, patch_site_areadis) ! MAY BE REDUNDANT CALL if (currentSite%disturbance_mortality > currentSite%disturbance_fire) then !mortality is dominant disturbance - call mortality_litter_fluxes(currentPatch, new_patch, patch_site_areadis) + call mortality_litter_fluxes(currentSite, currentPatch, new_patch, patch_site_areadis) else - call fire_litter_fluxes(currentPatch, new_patch, patch_site_areadis) + call fire_litter_fluxes(currentSite, currentPatch, new_patch, patch_site_areadis) endif !INSERT SURVIVORS FROM DISTURBANCE INTO NEW PATCH @@ -513,7 +513,7 @@ subroutine average_patch_properties( currentPatch, newPatch, patch_site_areadis end subroutine average_patch_properties ! ============================================================================ - subroutine fire_litter_fluxes(cp_target, new_patch_target, patch_site_areadis) + subroutine fire_litter_fluxes(currentSite, cp_target, new_patch_target, patch_site_areadis) ! ! !DESCRIPTION: ! CWD pool burned by a fire. @@ -528,12 +528,12 @@ subroutine fire_litter_fluxes(cp_target, new_patch_target, patch_site_areadis) use EDtypesMod , only : dg_sf ! ! !ARGUMENTS: + type(ed_site_type) , intent(inout), target :: currentSite 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 @@ -551,7 +551,6 @@ subroutine fire_litter_fluxes(cp_target, new_patch_target, patch_site_areadis) 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. @@ -688,7 +687,7 @@ subroutine fire_litter_fluxes(cp_target, new_patch_target, patch_site_areadis) end subroutine fire_litter_fluxes ! ============================================================================ - subroutine mortality_litter_fluxes(cp_target, new_patch_target, patch_site_areadis) + subroutine mortality_litter_fluxes(currentSite, cp_target, new_patch_target, patch_site_areadis) ! ! !DESCRIPTION: ! Carbon going from ongoing mortality into CWD pools. @@ -698,6 +697,7 @@ subroutine mortality_litter_fluxes(cp_target, new_patch_target, patch_site_aread use SFParamsMod, only : SF_val_cwd_frac ! ! !ARGUMENTS: + type(ed_site_type) , intent(inout), target :: currentSite 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 diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index ae264b7b..f1bee2b6 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1081,7 +1081,7 @@ subroutine recruitment( t, currentSite, currentPatch ) temp_cohort%laimemory, cohortstatus, temp_cohort%canopy_trim, currentPatch%NCL_p) ! keep track of how many individuals were recruited for passing to history - currentPatch%siteptr%recruitment_rate(ft) = currentPatch%siteptr%recruitment_rate(ft) + temp_cohort%n + currentSite%recruitment_rate(ft) = currentSite%recruitment_rate(ft) + temp_cohort%n endif enddo !pft loop From a55011dbaa5daa320e4bb89848646baa179de5fc Mon Sep 17 00:00:00 2001 From: ckoven Date: Wed, 8 Mar 2017 20:29:13 -0800 Subject: [PATCH 360/437] bugfixes on prior --- biogeochem/EDCohortDynamicsMod.F90 | 1 - biogeochem/EDPatchDynamicsMod.F90 | 2 -- 2 files changed, 3 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index faa92a08..3874df99 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -500,7 +500,6 @@ subroutine terminate_cohorts( currentSite, patchptr ) type (ed_patch_type), intent(inout), target :: patchptr ! ! !LOCAL VARIABLES: - type (ed_site_type) , pointer :: currentSite type (ed_patch_type) , pointer :: currentPatch type (ed_cohort_type) , pointer :: currentCohort type (ed_cohort_type) , pointer :: nextc diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 9ee6a84e..bad5cfc7 100755 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -729,7 +729,6 @@ subroutine mortality_litter_fluxes(currentSite, cp_target, new_patch_target, pat ! !LOCAL VARIABLES: real(r8) :: cwd_litter_density real(r8) :: litter_area ! area over which to distribute this litter. - type(ed_site_type) , pointer :: currentSite type(ed_cohort_type), pointer :: currentCohort type(ed_patch_type) , pointer :: currentPatch type(ed_patch_type) , pointer :: new_patch @@ -743,7 +742,6 @@ subroutine mortality_litter_fluxes(currentSite, cp_target, new_patch_target, pat !--------------------------------------------------------------------- currentPatch => cp_target - currentSite => currentPatch%siteptr new_patch => new_patch_target canopy_mortality_woody_litter = 0.0_r8 ! mortality generated litter. KgC/m2/day canopy_mortality_leaf_litter(:) = 0.0_r8 From 90f21d21aff0a59bac01c77895cdc6daf28cf3f4 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 8 Mar 2017 21:16:46 -0800 Subject: [PATCH 361/437] Fixed some overly long line lengths. --- biogeochem/EDCohortDynamicsMod.F90 | 3 ++- main/FatesHistoryInterfaceMod.F90 | 3 ++- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index d02f3c03..f1bbdde2 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -773,7 +773,8 @@ subroutine fuse_cohorts(patchptr) currentCohort%npp_store = (currentCohort%n*currentCohort%npp_store + nextc%n*nextc%npp_store)/newn ! recent canopy history - currentCohort%canopy_layer_yesterday = (currentCohort%n*currentCohort%canopy_layer_yesterday + nextc%n*nextc%canopy_layer_yesterday)/newn + currentCohort%canopy_layer_yesterday = (currentCohort%n*currentCohort%canopy_layer_yesterday + & + nextc%n*nextc%canopy_layer_yesterday)/newn do i=1, nlevcan if (currentCohort%year_net_uptake(i) == 999._r8 .or. nextc%year_net_uptake(i) == 999._r8) then diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index eb95615a..d7aa01ec 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -1227,7 +1227,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) ccohort%npp_bseed * ccohort%n hio_npp_store_understory_si_scls(io_si,scls) = hio_npp_store_understory_si_scls(io_si,scls) + & ccohort%npp_store * ccohort%n - hio_yesterdaycanopylevel_understory_si_scls(io_si,scls) = hio_yesterdaycanopylevel_understory_si_scls(io_si,scls) + & + hio_yesterdaycanopylevel_understory_si_scls(io_si,scls) = & + hio_yesterdaycanopylevel_understory_si_scls(io_si,scls) + & ccohort%canopy_layer_yesterday * ccohort%n endif ! From c7a137b4ce8491f93e9d8d01cfd7153bf9f64189 Mon Sep 17 00:00:00 2001 From: ckoven Date: Thu, 9 Mar 2017 13:45:11 -0800 Subject: [PATCH 362/437] fixed line length issues --- biogeochem/EDCanopyStructureMod.F90 | 12 ++++++++---- main/FatesHistoryInterfaceMod.F90 | 7 ++++--- 2 files changed, 12 insertions(+), 7 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 9935661d..8bf53962 100755 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -241,10 +241,12 @@ subroutine canopy_structure( currentSite ) ! keep track of the above fluxes at the site level as a CWD/litter input flux (in kg / site-m2 / yr) do c=1,ncwd - currentSite%CWD_AG_diagnostic_input_carbonflux(c) = currentSite%CWD_AG_diagnostic_input_carbonflux(c) & + currentSite%CWD_AG_diagnostic_input_carbonflux(c) = & + currentSite%CWD_AG_diagnostic_input_carbonflux(c) & + currentCohort%n*(currentCohort%bdead+currentCohort%bsw) * & SF_val_CWD_frac(c) * ED_val_ag_biomass * hlm_days_per_year / AREA - currentSite%CWD_BG_diagnostic_input_carbonflux(c) = currentSite%CWD_BG_diagnostic_input_carbonflux(c) & + currentSite%CWD_BG_diagnostic_input_carbonflux(c) = & + currentSite%CWD_BG_diagnostic_input_carbonflux(c) & + currentCohort%n*(currentCohort%bdead+currentCohort%bsw) * & SF_val_CWD_frac(c) * (1.0_r8 - ED_val_ag_biomass) * hlm_days_per_year / AREA enddo @@ -309,10 +311,12 @@ subroutine canopy_structure( currentSite ) ! keep track of the above fluxes at the site level as a CWD/litter input flux (in kg / site-m2 / yr) do c=1,ncwd - currentSite%CWD_AG_diagnostic_input_carbonflux(c) = currentSite%CWD_AG_diagnostic_input_carbonflux(c) & + currentSite%CWD_AG_diagnostic_input_carbonflux(c) = & + currentSite%CWD_AG_diagnostic_input_carbonflux(c) & + currentCohort%n*(currentCohort%bdead+currentCohort%bsw) * & SF_val_CWD_frac(c) * ED_val_ag_biomass * hlm_days_per_year / AREA - currentSite%CWD_BG_diagnostic_input_carbonflux(c) = currentSite%CWD_BG_diagnostic_input_carbonflux(c) & + currentSite%CWD_BG_diagnostic_input_carbonflux(c) = & + currentSite%CWD_BG_diagnostic_input_carbonflux(c) & + currentCohort%n*(currentCohort%bdead+currentCohort%bsw) * & SF_val_CWD_frac(c) * (1.0_r8 - ED_val_ag_biomass) * hlm_days_per_year / AREA enddo diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index b19aaf54..f7ccb64d 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -1136,8 +1136,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_npp_bdead_understory_si_scls => this%hvars(ih_npp_bdead_understory_si_scls)%r82d, & hio_npp_bseed_understory_si_scls => this%hvars(ih_npp_bseed_understory_si_scls)%r82d, & hio_npp_store_understory_si_scls => this%hvars(ih_npp_store_understory_si_scls)%r82d, & - hio_yesterdaycanopylevel_canopy_si_scls => this%hvars(ih_yesterdaycanopylevel_canopy_si_scls)%r82d, & - hio_yesterdaycanopylevel_understory_si_scls => this%hvars(ih_yesterdaycanopylevel_understory_si_scls)%r82d, & + hio_yesterdaycanopylevel_canopy_si_scls => this%hvars(ih_yesterdaycanopylevel_canopy_si_scls)%r82d, & + hio_yesterdaycanopylevel_understory_si_scls => this%hvars(ih_yesterdaycanopylevel_understory_si_scls)%r82d, & hio_area_si_age => this%hvars(ih_area_si_age)%r82d, & hio_lai_si_age => this%hvars(ih_lai_si_age)%r82d, & hio_canopy_area_si_age => this%hvars(ih_canopy_area_si_age)%r82d, & @@ -1382,7 +1382,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) ccohort%npp_bseed * ccohort%n hio_npp_store_canopy_si_scls(io_si,scls) = hio_npp_store_canopy_si_scls(io_si,scls) + & ccohort%npp_store * ccohort%n - hio_yesterdaycanopylevel_canopy_si_scls(io_si,scls) = hio_yesterdaycanopylevel_canopy_si_scls(io_si,scls) + & + hio_yesterdaycanopylevel_canopy_si_scls(io_si,scls) = & + hio_yesterdaycanopylevel_canopy_si_scls(io_si,scls) + & ccohort%canopy_layer_yesterday * ccohort%n else hio_bstor_understory_si_scpf(io_si,scpf) = hio_bstor_understory_si_scpf(io_si,scpf) + & From bf12034ca3c5f2f0734604dc61258d92c5130fec Mon Sep 17 00:00:00 2001 From: Ben Andre Date: Thu, 9 Mar 2017 15:07:14 -0700 Subject: [PATCH 363/437] Bugfix in FatesParameterDerivedMod FatesParameterderivedMod was introduced during a merge, and was using the host verison of fnitr from pftcon. It needed no be updated to point to the fates version in EDPftvarcon. Testing: Manual testing of fates_params_c170308.nc in an SMS_D_Ld5.f10_f10.ICLM45ED.yellowstone_intel.clm-edTest is bit for bit with cdb9db7. --- main/FatesParameterDerivedMod.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/main/FatesParameterDerivedMod.F90 b/main/FatesParameterDerivedMod.F90 index 41641d75..f1000ad1 100644 --- a/main/FatesParameterDerivedMod.F90 +++ b/main/FatesParameterDerivedMod.F90 @@ -53,7 +53,7 @@ end subroutine InitAllocate subroutine Init(this,maxpft) - use pftconMod , only: pftcon + use EDPftvarcon, only: EDPftvarcon_inst class(param_derived_type), intent(inout) :: this integer, intent(in) :: maxpft @@ -63,10 +63,10 @@ subroutine Init(this,maxpft) real(r8) :: lnc ! leaf N concentration (gN leaf/m^2) associate( & - slatop => pftcon%slatop , & ! specific leaf area at top of canopy, + slatop => EDPftvarcon_inst%slatop , & ! specific leaf area at top of canopy, ! projected area basis [m^2/gC] - fnitr => pftcon%fnitr , & ! foliage nitrogen limitation factor (-) - leafcn => pftcon%leafcn ) ! leaf C:N (gC/gN) + fnitr => EDPftvarcon_inst%fnitr , & ! foliage nitrogen limitation factor (-) + leafcn => EDPftvarcon_inst%leafcn ) ! leaf C:N (gC/gN) call this%InitAllocate(maxpft) From 89344a0a25f9cc0c560659e33213402889941b2d Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 9 Mar 2017 16:10:45 -0800 Subject: [PATCH 364/437] Added some logic to controlMod in CLM. Forcing checks on hydstress, crop and methane along with existing use_cn checks. Forcing use_voc off. I would rather a check that forces a failure when VOC is not set correctly (like the others), however megan does not seem to be a namelist parameter (just xml) and is defaulted to true. --- main/FatesParameterDerivedMod.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/main/FatesParameterDerivedMod.F90 b/main/FatesParameterDerivedMod.F90 index 41641d75..9779de47 100644 --- a/main/FatesParameterDerivedMod.F90 +++ b/main/FatesParameterDerivedMod.F90 @@ -64,7 +64,6 @@ subroutine Init(this,maxpft) associate( & slatop => pftcon%slatop , & ! specific leaf area at top of canopy, - ! projected area basis [m^2/gC] fnitr => pftcon%fnitr , & ! foliage nitrogen limitation factor (-) leafcn => pftcon%leafcn ) ! leaf C:N (gC/gN) From f0b45f6e42a42a64c2fddfa375a971a073b12a5d Mon Sep 17 00:00:00 2001 From: ckoven Date: Thu, 9 Mar 2017 16:58:52 -0800 Subject: [PATCH 365/437] pulled out more numbers into parameters --- biogeochem/EDPhysiologyMod.F90 | 30 +++++---- biogeophys/FatesPlantRespPhotosynthMod.F90 | 77 +++++++++++++--------- 2 files changed, 61 insertions(+), 46 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 1bb570d4..f46fa544 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -284,22 +284,24 @@ subroutine phenology( currentSite, bc_in ) 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), parameter :: mindayson = 30.0 + real(r8) :: mindayson ! 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 !ed_ph_chiltemp + drought_threshold = EDecophyscon%fates_ph_drought_threshold + off_time = EDecophyscon%fates_ph_doff_time + + !Parameters: defaults from Botta et al. 2000 GCB,6 709-725 + a = EDecophyscon%fates_ph_a + b = EDecophyscon%fates_ph_b + c = EDecophyscon%fates_ph_c + coldday = EDecophyscon%fates_ph_chiltemp - !Parameters from SDGVM model of senesence - ncolddayslim = 5 - cold_t = 7.5_r8 ! ed_ph_coldtemp + mindayson = EDecophyscon%fates_ph_mindayson + + !Parameters, default from from SDGVM model of senesence + ncolddayslim = EDecophyscon%fates_ph_ncolddayslim + cold_t = EDecophyscon%fates_ph_coldtemp t = day_of_year temp_in_C = bc_in%t_veg24_si - tfrz @@ -677,7 +679,7 @@ subroutine seed_decay( currentSite, currentPatch ) real(r8) :: seed_turnover !complete seed turnover rate in yr-1. !---------------------------------------------------------------------- - seed_turnover = 0.51_r8 ! from Liscke and Loffler 2006 + seed_turnover = EDecophyscon%seed_turnover ! default value from Liscke and Loffler 2006 ! decays the seed pool according to exponential model ! sd_mort is in yr-1 do p = 1,numpft_ed @@ -704,7 +706,7 @@ subroutine seed_germination( currentSite, currentPatch ) real(r8) germination_timescale !yr-1 !---------------------------------------------------------------------- - germination_timescale = 0.5_r8 !this is arbitrary + germination_timescale = EDecophyscon%germination_timescale max_germination = 1.0_r8 !this is arbitrary do p = 1,numpft_ed diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index 8f530d54..0f160b99 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -58,8 +58,8 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) use clm_varpar , only : mxpft ! THIS WILL BE DEPRECATED WHEN PARAMETER ! READS ARE REFACTORED (RGK 10-13-2016) - use EDPftvarcon , only : EDPftvarcon_inst ! THIS WILL BE DEPRECATED WHEN PARAMETER - ! READS ARE REFACTORED (RGK 10-13-2016) + use EDPftvarcon , only : EDPftvarcon_inst + use EDParamsMod , only : ED_val_ag_biomass use EDSharedParamsMod , only : EDParamsShareInst use EDTypesMod , only : ed_patch_type @@ -196,15 +196,15 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) associate( & - c3psn => EDPftvarcon_inst%c3psn , & - slatop => EDPftvarcon_inst%slatop , & ! specific leaf area at top of canopy, + c3psn => EDecophyscon%c3psn , & + slatop => EDecophyscon%slatop , & ! specific leaf area at top of canopy, ! projected area basis [m^2/gC] - flnr => EDPftvarcon_inst%flnr , & ! fraction of leaf N in the Rubisco + flnr => EDecophyscon%flnr , & ! fraction of leaf N in the Rubisco ! enzyme (gN Rubisco / gN leaf) - woody => EDPftvarcon_inst%woody , & ! Is vegetation woody or not? - fnitr => EDPftvarcon_inst%fnitr , & ! foliage nitrogen limitation factor (-) - leafcn => EDPftvarcon_inst%leafcn , & ! leaf C:N (gC/gN) - frootcn => EDPftvarcon_inst%frootcn, & ! froot C:N (gc/gN) ! slope of BB relationship + woody => EDecophyscon%woody , & ! Is vegetation woody or not? + fnitr => EDecophyscon%fnitr , & ! foliage nitrogen limitation factor (-) + leafcn => EDecophyscon%leafcn , & ! leaf C:N (gC/gN) + frootcn => EDecophyscon%frootcn, & ! froot C:N (gc/gN) ! slope of BB relationship q10 => EDParamsShareInst%Q10 ) @@ -496,7 +496,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) leaf_frac = 1.0_r8/(currentCohort%canopy_trim + & EDecophyscon%sapwood_ratio(currentCohort%pft) * & - currentCohort%hite + EDPftvarcon_inst%froot_leaf(currentCohort%pft)) + currentCohort%hite + EDecophyscon%froot_leaf(currentCohort%pft)) currentCohort%bsw = EDecophyscon%sapwood_ratio(currentCohort%pft) * & @@ -582,7 +582,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! no drought response right now.. something like: ! resp_m = resp_m * (1.0_r8 - currentPatch%btran_ft(currentCohort%pft) * & - ! EDPftvarcon_inst%resp_drought_response(ft)) + ! EDecophyscon%resp_drought_response(ft)) currentCohort%resp_m = currentCohort%resp_m + currentCohort%rdark @@ -595,7 +595,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) if ( DEBUG ) write(fates_log(),*) 'EDPhoto 912 ', currentCohort%resp_tstep if ( DEBUG ) write(fates_log(),*) 'EDPhoto 913 ', currentCohort%resp_m - currentCohort%resp_g = EDPftvarcon_inst%grperc(ft) * & + currentCohort%resp_g = EDecophyscon%grperc(ft) * & (max(0._r8,currentCohort%gpp_tstep - & currentCohort%resp_m)) currentCohort%resp_tstep = currentCohort%resp_m + & @@ -684,7 +684,7 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in ! ------------------------------------------------------------------------------------ use EDEcophysContype , only : EDecophyscon - use EDPftvarcon , only : EDPftvarcon_inst + use EDPftvarcon , only : EDecophyscon ! Arguments ! ------------------------------------------------------------------------------------ @@ -780,7 +780,7 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in associate( bb_slope => EDecophyscon%BB_slope ) ! slope of BB relationship - if (nint(EDPftvarcon_inst%c3psn(ft)) == 1) then! photosynthetic pathway: 0. = c4, 1. = c3 + if (nint(EDecophyscon%c3psn(ft)) == 1) then! photosynthetic pathway: 0. = c4, 1. = c3 pp_type = 1 init_co2_intra_c = init_a2l_co2_c3 * can_co2_ppress else @@ -1473,7 +1473,7 @@ subroutine LeafLayerMaintenanceRespiration(lmr25top_ft, & lmr) use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm - use EDPftvarcon , only : EDPftvarcon_inst + use EDPftvarcon , only : EDecophyscon ! Arguments real(r8), intent(in) :: lmr25top_ft ! canopy top leaf maint resp rate at 25C @@ -1540,7 +1540,7 @@ subroutine LeafLayerBiophysicalRates( parsun_lsl, & ! co2_rcurve_islope: initial slope of CO2 response curve (C4 plants) ! --------------------------------------------------------------------------------- - use EDPftvarcon , only : EDPftvarcon_inst + use EDPftvarcon , only : EDecophyscon use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm ! Arguments @@ -1581,21 +1581,34 @@ subroutine LeafLayerBiophysicalRates( parsun_lsl, & ! Parameters ! --------------------------------------------------------------------------------- - real(r8), parameter :: vcmaxha = 65330._r8 ! activation energy for vcmax (J/mol) - real(r8), parameter :: jmaxha = 43540._r8 ! activation energy for jmax (J/mol) - real(r8), parameter :: tpuha = 53100._r8 ! activation energy for tpu (J/mol) - real(r8), parameter :: vcmaxhd = 149250._r8 ! deactivation energy for vcmax (J/mol) - real(r8), parameter :: jmaxhd = 152040._r8 ! deactivation energy for jmax (J/mol) - real(r8), parameter :: tpuhd = 150650._r8 ! deactivation energy for tpu (J/mol) - real(r8), parameter :: vcmaxse = 485._r8 ! entropy term for vcmax (J/mol/K) - real(r8), parameter :: jmaxse = 495._r8 ! entropy term for jmax (J/mol/K) - real(r8), parameter :: tpuse = 490._r8 ! entropy term for tpu (J/mol/K) - real(r8), parameter :: vcmaxc = 1.1534040_r8 ! scaling factor for high - ! temperature inhibition (25 C = 1.0) - real(r8), parameter :: jmaxc = 1.1657242_r8 ! scaling factor for high - ! temperature inhibition (25 C = 1.0) - real(r8), parameter :: tpuc = 1.1591239_r8 ! scaling factor for high - ! temperature inhibition (25 C = 1.0) + real(r8) :: vcmaxha ! activation energy for vcmax (J/mol) + real(r8) :: jmaxha ! activation energy for jmax (J/mol) + real(r8) :: tpuha ! activation energy for tpu (J/mol) + real(r8) :: vcmaxhd ! deactivation energy for vcmax (J/mol) + real(r8) :: jmaxhd ! deactivation energy for jmax (J/mol) + real(r8) :: tpuhd ! deactivation energy for tpu (J/mol) + real(r8) :: vcmaxse ! entropy term for vcmax (J/mol/K) + real(r8) :: jmaxse ! entropy term for jmax (J/mol/K) + real(r8) :: tpuse ! entropy term for tpu (J/mol/K) + real(r8) :: vcmaxc ! scaling factor for high temperature inhibition (25 C = 1.0) + real(r8) :: jmaxc ! scaling factor for high temperature inhibition (25 C = 1.0) + real(r8) :: tpuc ! scaling factor for high temperature inhibition (25 C = 1.0) + + vcmaxha = EDecophyscon%vcmaxha(FT) + jmaxha = EDecophyscon%jmaxha(FT) + tpuha = EDecophyscon%tpuha(FT) + + vcmaxhd = EDecophyscon%vcmaxhd(FT) + jmaxhd = EDecophyscon%jmaxhd(FT) + tpuhd = EDecophyscon%tpuhd(FT) + + vcmaxse = EDecophyscon%vcmaxse(FT) + jmaxse = EDecophyscon%jmaxse(FT) + tpuse = EDecophyscon%tpuse(FT) + + vcmaxc = fth25(vcmaxhd, vcmaxse) + jmaxc = fth25(jmaxhd, jmaxse) + tpuc = fth25(tpuhd, tpuse) if ( parsun_lsl <= 0._r8) then ! night time vcmax = 0._r8 @@ -1613,7 +1626,7 @@ subroutine LeafLayerBiophysicalRates( parsun_lsl, & jmax = jmax25 * ft1_f(veg_tempk, jmaxha) * fth_f(veg_tempk, jmaxhd, jmaxse, jmaxc) tpu = tpu25 * ft1_f(veg_tempk, tpuha) * fth_f(veg_tempk, tpuhd, tpuse, tpuc) - if (nint(EDPftvarcon_inst%c3psn(ft)) /= 1) then + if (nint(EDecophyscon%c3psn(ft)) /= 1) then vcmax = vcmax25 * 2._r8**((veg_tempk-(tfrz+25._r8))/10._r8) vcmax = vcmax / (1._r8 + exp( 0.2_r8*((tfrz+15._r8)-veg_tempk ) )) vcmax = vcmax / (1._r8 + exp( 0.3_r8*(veg_tempk-(tfrz+40._r8)) )) From 7ed0236b23afb832b69598b4d151d53da8e215b3 Mon Sep 17 00:00:00 2001 From: JKShuman Date: Mon, 13 Mar 2017 11:31:02 -0600 Subject: [PATCH 366/437] Add Spitfire equation & var descriptions & units All changes were assocaited with Spitfire routine. Additonal documentation of spitfire varaible units and equation sources were added to spitfire routine. Some variable names were updated for clarity. Fixes: User interface changes?: No Code review: JKShuman Code was tested by creating cases until successful compile. No further testing was completed. Test suite: Test baseline: Test namelist changes: Test answer changes: Test summary: --- biogeochem/EDPatchDynamicsMod.F90 | 4 +- biogeochem/EDPhysiologyMod.F90 | 8 +- fire/SFMainMod.F90 | 141 ++++++++++++++++++------------ main/EDParamsMod.F90 | 4 +- main/EDTypesMod.F90 | 2 +- 5 files changed, 93 insertions(+), 66 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index c7cf190d..5bf2008f 100755 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -513,7 +513,7 @@ subroutine fire_litter_fluxes(cp_target, new_patch_target, patch_site_areadis) use EDParamsMod, only : ED_val_ag_biomass use SFParamsMod, only : SF_VAL_CWD_FRAC use EDGrowthFunctionsMod, only : c_area - use EDtypesMod , only : dg_sf + use EDtypesMod , only : dl_sf ! ! !ARGUMENTS: type(ed_patch_type) , intent(inout), target :: cp_target @@ -552,7 +552,7 @@ subroutine fire_litter_fluxes(cp_target, new_patch_target, patch_site_areadis) 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) + burned_litter = new_patch%leaf_litter(p) * patch_site_areadis/new_patch%area * currentPatch%burnt_frac_litter(dl_sf) new_patch%leaf_litter(p) = new_patch%leaf_litter(p) - burned_litter currentSite%flux_out = currentSite%flux_out + burned_litter * new_patch%area !kG/site/day currentSite%total_burn_flux_to_atm = currentSite%total_burn_flux_to_atm + burned_litter * new_patch%area !kG/site/day diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index fccd8c08..f05f6e82 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -16,7 +16,7 @@ module EDPhysiologyMod use EDEcophysContype , only : EDecophyscon use EDCohortDynamicsMod , only : allocate_live_biomass, zero_cohort use EDCohortDynamicsMod , only : create_cohort, fuse_cohorts, sort_cohorts - use EDTypesMod , only : dg_sf, dinc_ed, external_recruitment + use EDTypesMod , only : dl_sf, dinc_ed, external_recruitment use EDTypesMod , only : ncwd, cp_nlevcan, numpft_ed, senes use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type @@ -1249,12 +1249,12 @@ subroutine cwd_out( currentSite, currentPatch, temperature_inst ) ! 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%leaf_litter_out(ft) = max(0.0_r8,currentPatch%leaf_litter(ft)* SF_val_max_decomp(dl_sf) * & currentPatch%fragmentation_scaler ) - currentPatch%root_litter_out(ft) = max(0.0_r8,currentPatch%root_litter(ft)* SF_val_max_decomp(dg_sf) * & + currentPatch%root_litter_out(ft) = max(0.0_r8,currentPatch%root_litter(ft)* SF_val_max_decomp(dl_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 + write(iulog,*) 'root or leaf out is negative?',SF_val_max_decomp(dl_sf),currentPatch%fragmentation_scaler endif enddo diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index bd8474ee..4efe83c9 100755 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -12,7 +12,7 @@ module SFMainMod 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 : ed_site_type, ed_patch_type, ed_cohort_type, AREA, DL_SF, FIRE_THRESHOLD use EDtypesMod , only : LB_SF, LG_SF, NCWD, TR_SF implicit none @@ -96,7 +96,7 @@ subroutine fire_danger_index ( currentSite, temperature_inst, atm2lnd_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) :: rainfall ! daily precip in mm/day real(r8) :: rh ! daily rh real yipsolon; !intermediate varable for dewpoint calculation @@ -106,7 +106,7 @@ subroutine fire_danger_index ( currentSite, temperature_inst, atm2lnd_inst) 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 + prec24 => atm2lnd_inst%prec24_patch , & ! Input: [real(r8) (:)] avg pft rainfall for last 24 hrs in mm/sec rh24 => atm2lnd_inst%rh24_patch & ! Input: [real(r8) (:)] avg pft relative humidity for last 24 hrs ) @@ -114,7 +114,7 @@ subroutine fire_danger_index ( currentSite, temperature_inst, atm2lnd_inst) ! 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 + 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... @@ -167,11 +167,11 @@ subroutine charecteristics_of_fuel ( currentSite ) ! 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, + ! dl_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_bulkd = 0.0_r8 !this is kgBiomass/m2 for use in rate of spread equations currentPatch%fuel_sav = 0.0_r8 currentPatch%fuel_frac(:) = 0.0_r8 currentPatch%fuel_mef = 0.0_r8 @@ -195,8 +195,8 @@ subroutine charecteristics_of_fuel ( currentSite ) 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 + currentPatch%fuel_frac(dl_sf) = sum(currentPatch%leaf_litter)/ currentPatch%sum_fuel + currentPatch%fuel_frac(dl_sf+1:tr_sf) = currentPatch%CWD_AG / currentPatch%sum_fuel if(write_sf == 1)then if (masterproc) write(iulog,*) 'ff1 ',currentPatch%fuel_frac @@ -207,8 +207,10 @@ subroutine charecteristics_of_fuel ( currentSite ) 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) + !--- weighted average of relative moisture content--- + ! Equation 6 in Thonicke et al. 2010. + fuel_moisture(dl_sf+1:tr_sf) = exp(-1.0_r8 * SF_val_alpha_FMC(dl_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 @@ -219,13 +221,14 @@ subroutine charecteristics_of_fuel ( currentSite ) ! 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 + ! live grass moisture content fuel_moisture(lg_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)) + currentPatch%fuel_bulkd = sum(currentPatch%fuel_frac(dl_sf:lb_sf) * SF_val_FBD(dl_sf:lb_sf)) + currentPatch%fuel_sav = sum(currentPatch%fuel_frac(dl_sf:lb_sf) * SF_val_SAV(dl_sf:lb_sf)) + currentPatch%fuel_mef = sum(currentPatch%fuel_frac(dl_sf:lb_sf) * MEF(dl_sf:lb_sf)) + currentPatch%fuel_eff_moist = sum(currentPatch%fuel_frac(dl_sf:lb_sf) * fuel_moisture(dl_sf:lb_sf)) if(write_sf == 1)then if (masterproc) write(iulog,*) 'ff4 ',currentPatch%fuel_eff_moist endif @@ -239,14 +242,11 @@ subroutine charecteristics_of_fuel ( currentSite ) 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 + currentPatch%fuel_eff_moist = currentPatch%fuel_eff_moist * (1.0_r8/(1.0_r8-currentPatch%fuel_frac(tr_sf))) ! 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(dl_sf:lb_sf) = fuel_moisture(dl_sf:lb_sf)/MEF(dl_sf:lb_sf) currentPatch%litter_moisture(tr_sf) = 0.0_r8 currentPatch%litter_moisture(lg_sf) = fuel_moisture(lg_sf)/MEF(lg_sf) @@ -304,7 +304,7 @@ subroutine wind_effect ( currentSite, atm2lnd_inst) ! unless we decide to ever calculated the NI for each patch. real(r8), pointer :: wind24(:) - real(r8) :: wind ! daily wind + real(r8) :: wind ! daily wind in m/min 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 @@ -359,7 +359,8 @@ subroutine wind_effect ( currentSite, atm2lnd_inst) currentPatch=>currentSite%oldest_patch; do while(associated(currentPatch)) - currentPatch%total_tree_area = min(currentPatch%total_tree_area,currentPatch%area) + currentPatch%total_tree_area = min(currentPatch%total_tree_area,currentPatch%area) + ! effect_wspeed in units m/min currentPatch%effect_wspeed = wind * (tree_fraction*0.4+(grass_fraction+bare_fraction)*0.6) currentPatch => currentPatch%younger @@ -383,13 +384,14 @@ subroutine rate_of_spread ( currentSite ) 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 + real(r8) beta,beta_op !weighted average of packing ratio (unitless) + real(r8) ir !reaction intensity (kJ/m2/min) + real(r8) xi,eps,phi_wind !all are unitless + real(r8) q_ig !heat of pre-ignition (kJ/kg) + real(r8) reaction_v_opt,reaction_v_max !reaction velocity (per min) + real(r8) moist_damp,mw_weight !moisture dampening coefficient and ratio fuel moisture to extinction + real(r8) bet !ratio of beta/beta_op + real(r8) a,b,c,e !function of fuel sav currentPatch=>currentSite%oldest_patch; @@ -397,27 +399,34 @@ subroutine rate_of_spread ( currentSite ) ! ---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 + phi_wind = 0.0_r8; xi = 0.0_r8; reaction_v_max = 0.0_r8; reaction_v_opt = 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 + ! remove mineral content from net fuel load per Thonicke 2010 for ir calculation 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 + + ! beta = packing ratio (unitless) + ! fraction of fuel array volume occupied by fuel or compactness of fuel bed + beta = (currentPatch%fuel_bulkd) / SF_val_part_dens ! Equation A6 in Thonicke et al. 2010 + ! packing ratio (unitless) 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 + bet = beta/beta_op !unitless 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 + ! Equation A4 in Thonicke et al. 2010 + ! conversion of Rohtermal (1972) equation 12 in BTU/lb to current kJ/kg + ! q_ig in kJ/kg q_ig = 581.0_r8 +2594.0_r8 * currentPatch%fuel_eff_moist ! ---effective heating number--- @@ -429,7 +438,6 @@ subroutine rate_of_spread ( currentSite ) 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 @@ -439,11 +447,14 @@ subroutine rate_of_spread ( currentSite ) if (masterproc.and.DEBUG) write(iulog,*) 'SF - e ',e endif - ! convert from m/min to ft/min for Rothermel ROS eqn + ! Equation A5 in Thonicke et al. 2010 + ! convert effect_wspeed from m/min to ft/min for Rothermel ROS eqn + ! phi_wind (unitless) phi_wind = c * ((3.281_r8*currentPatch%effect_wspeed)**b)*(bet**(-e)) ! ---propagating flux---- - ! Equation A2 in Thonicke et al. + ! Equation A2 in Thonicke et al. + ! xi (unitless) 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) @@ -452,13 +463,20 @@ subroutine rate_of_spread ( currentSite ) ! 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 + ! Equation in table A1 Thonicke et al. 2010. + ! reaction_v_max and reaction_v_opt = reaction velocity in units of per min + + ! Equation 36 in Rothermal 1972 12 + reaction_v_max = 1.0_r8 / (0.0591_r8 + 2.926_r8* (currentPatch%fuel_sav**(-1.5_r8))) + ! Equation 38 in Rothermal 1972 and Fig 11 + reaction_v_opt = reaction_v_max*(bet**a)*dummy + ! mw_weight = relative fuel moisture/fuel moisture of extinction + ! average values for litter pools (dead leaves, twigs, small and large branches) plus grass mw_weight = currentPatch%fuel_eff_moist/currentPatch%fuel_mef ! Equation in table A1 Thonicke et al. 2010. + ! moist_damp is unitless 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)))) @@ -466,19 +484,23 @@ subroutine rate_of_spread ( currentSite ) ! if(write_SF == 1)then ! write(iulog,*) 'moist_damp' ,moist_damp,mw_weight,currentPatch%fuel_eff_moist,currentPatch%fuel_mef ! endif + + ! ir = reaction intenisty in kJ/m2/min + ! currentPatch%sum_fuel needs to be converted from kgC/m2 to kgBiomass/m2 for ir calculation + ir = reaction_v_opt*(currentPatch%sum_fuel/0.45_r8)*SF_val_fuel_energy*moist_damp*SF_val_miner_damp + - 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 + ! write(iulog,*) 'ir',reaction_v_opt,moist_damp,SF_val_fuel_energy,SF_val_miner_damp + if ((currentPatch%fuel_bulkd <= 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) + ! forward ROS in m/min + currentPatch%ROS_front = (ir*xi*(1.0_r8+phi_wind)) / (currentPatch%fuel_bulkd*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 + ! backward ROS from Can FBP System (1992) in m/min currentPatch%ROS_back = currentPatch%ROS_front*exp(-0.012_r8*currentPatch%effect_wspeed) currentPatch => currentPatch%younger @@ -542,7 +564,7 @@ subroutine ground_fuel_consumption ( currentSite ) 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(dl_sf) = currentPatch%burnt_frac_litter(dl_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 @@ -588,7 +610,7 @@ subroutine fire_intensity ( currentSite ) type(ed_patch_type), pointer :: currentPatch real(r8) ROS !m/s - real(r8) W ! kgBiomass/m2 + real(r8) W !kgBiomass/m2 real(r8) :: d_fdi !change in the NI on this day to give fire duration. currentPatch => currentSite%oldest_patch; @@ -607,9 +629,10 @@ subroutine fire_intensity ( currentSite ) ! 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 + ! fire duration in minutes 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 + 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 @@ -632,7 +655,7 @@ end subroutine fire_intensity !***************************************************************** subroutine area_burnt ( currentSite ) !***************************************************************** - !currentPatch%AB daily area burnt (m2) + !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 @@ -643,13 +666,17 @@ subroutine area_burnt ( 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 lb !length to breadth ratio of fire ellipse + real df !distance fire has travelled forward + real db !distance fire has travelled backward + real patch_area_in_m2 !'actual' patch area as applied to whole grid cell real(r8) gridarea - real(r8) size_of_fire + real(r8) size_of_fire !in m2 + real(r8) km2_to_m2 integer g, p + + km2_to_m2 = 1000000.0_r8 currentSite%frac_burnt = 0.0_r8 currentPatch => currentSite%oldest_patch; @@ -689,7 +716,7 @@ subroutine area_burnt ( currentSite ) ! INTERF-TODO: ! THIS SHOULD HAVE THE COLUMN AND LU AREA WEIGHT ALSO, NO? - gridarea = ldomain%area(g) *1000000.0_r8 !convert from km2 into m2 + gridarea = ldomain%area(g) * km2_to_m2 currentPatch%NF = ldomain%area(g) * ED_val_nignitions * currentPatch%area/area /365 ! If there are 15 lightening strickes per year, per km2. (approx from NASA product) @@ -698,11 +725,11 @@ subroutine area_burnt ( currentSite ) ! 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 + !currentPatch%AB = currentPatch%AB *3.0_r8 size_of_fire = ((3.1416_r8/(4.0_r8*lb))*((df+db)**2.0_r8)) - ! area of fires in m2. - currentPatch%AB = size_of_fire * currentPatch%nf + !AB is daily area burnt = size of fires in m2 * number of ignitions + currentPatch%AB = size_of_fire * currentPatch%NF patch_area_in_m2 = gridarea*currentPatch%area/area if (currentPatch%AB > patch_area_in_m2 ) then !all of patch burnt. diff --git a/main/EDParamsMod.F90 b/main/EDParamsMod.F90 index 16e2f2f5..634eaade 100644 --- a/main/EDParamsMod.F90 +++ b/main/EDParamsMod.F90 @@ -21,7 +21,7 @@ module EDParamsMod 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_nignitions real(r8),protected :: ED_val_understorey_death real(r8),protected :: ED_val_profile_tol real(r8),protected :: ED_val_ag_biomass @@ -127,7 +127,7 @@ subroutine EDParamsReadLocal(ncid) call readNcdio(ncid = ncid, & varName=ED_name_nfires, & callingName=subname, & - retVal=ED_val_nfires) + retVal=ED_val_nignitions) call readNcdio(ncid = ncid, & varName=ED_name_understorey_death, & diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 6de2f1ea..c8330350 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -50,7 +50,7 @@ module EDTypesMod 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 :: dl_sf = 1 ! array index of dead leaf pool for spitfire (dead grass and dead leaves) 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 From a846aed8f32ca0673ebef9cda43f7d82f045321f Mon Sep 17 00:00:00 2001 From: ckoven Date: Mon, 13 Mar 2017 11:14:40 -0700 Subject: [PATCH 367/437] added same set of vars for each canopy dimension and moved all vars on cnlfpft dimension to be default-off --- main/FatesHistoryInterfaceMod.F90 | 138 ++++++++++++++++++++++++++---- 1 file changed, 122 insertions(+), 16 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index f7ccb64d..e932f3a6 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -232,6 +232,10 @@ module FatesHistoryInterfaceMod integer, private :: ih_parsha_z_si_cnlf integer, private :: ih_laisun_z_si_cnlf integer, private :: ih_laisha_z_si_cnlf + integer, private :: ih_fabd_sun_si_cnlf + integer, private :: ih_fabd_sha_si_cnlf + integer, private :: ih_fabi_sun_si_cnlf + integer, private :: ih_fabi_sha_si_cnlf ! indices to (site x [canopy layer x leaf layer x pft]) variables integer, private :: ih_parsun_z_si_cnlfpft @@ -244,8 +248,14 @@ module FatesHistoryInterfaceMod integer, private :: ih_fabi_sha_si_cnlfpft ! indices to (site x canopy layer) variables - integer, private :: ih_parsuntop_si_can - integer, private :: ih_parshatop_si_can + integer, private :: ih_parsun_top_si_can + integer, private :: ih_parsha_top_si_can + integer, private :: ih_laisun_top_si_can + integer, private :: ih_laisha_top_si_can + integer, private :: ih_fabd_sun_top_si_can + integer, private :: ih_fabd_sha_top_si_can + integer, private :: ih_fabi_sun_top_si_can + integer, private :: ih_fabi_sha_top_si_can ! The number of variable dim/kind types we have defined (static) integer, parameter :: fates_history_num_dimensions = 12 @@ -1703,12 +1713,22 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) hio_laisha_z_si_cnlf => this%hvars(ih_laisha_z_si_cnlf)%r82d, & hio_laisun_z_si_cnlfpft => this%hvars(ih_laisun_z_si_cnlfpft)%r82d, & hio_laisha_z_si_cnlfpft => this%hvars(ih_laisha_z_si_cnlfpft)%r82d, & + hio_laisun_top_si_can => this%hvars(ih_laisun_top_si_can)%r82d, & + hio_laisha_top_si_can => this%hvars(ih_laisha_top_si_can)%r82d, & hio_fabd_sun_si_cnlfpft => this%hvars(ih_fabd_sun_si_cnlfpft)%r82d, & hio_fabd_sha_si_cnlfpft => this%hvars(ih_fabd_sha_si_cnlfpft)%r82d, & hio_fabi_sun_si_cnlfpft => this%hvars(ih_fabi_sun_si_cnlfpft)%r82d, & hio_fabi_sha_si_cnlfpft => this%hvars(ih_fabi_sha_si_cnlfpft)%r82d, & - hio_parsuntop_si_can => this%hvars(ih_parsuntop_si_can)%r82d, & - hio_parshatop_si_can => this%hvars(ih_parshatop_si_can)%r82d & + hio_fabd_sun_si_cnlf => this%hvars(ih_fabd_sun_si_cnlf)%r82d, & + hio_fabd_sha_si_cnlf => this%hvars(ih_fabd_sha_si_cnlf)%r82d, & + hio_fabi_sun_si_cnlf => this%hvars(ih_fabi_sun_si_cnlf)%r82d, & + hio_fabi_sha_si_cnlf => this%hvars(ih_fabi_sha_si_cnlf)%r82d, & + hio_fabd_sun_top_si_can => this%hvars(ih_fabd_sun_top_si_can)%r82d, & + hio_fabd_sha_top_si_can => this%hvars(ih_fabd_sha_top_si_can)%r82d, & + hio_fabi_sun_top_si_can => this%hvars(ih_fabi_sun_top_si_can)%r82d, & + hio_fabi_sha_top_si_can => this%hvars(ih_fabi_sha_top_si_can)%r82d, & + hio_parsun_top_si_can => this%hvars(ih_parsun_top_si_can)%r82d, & + hio_parsha_top_si_can => this%hvars(ih_parsha_top_si_can)%r82d & ) @@ -1853,6 +1873,7 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) cnlfpft_indx = ileaf + (ican-1) * nlevleaf + (ipft-1) * nlevleaf * nclmax cnlf_indx = ileaf + (ican-1) * nlevleaf ! + ! first do all the canopy x leaf x pft calculations hio_parsun_z_si_cnlfpft(io_si,cnlfpft_indx) = hio_parsun_z_si_cnlfpft(io_si,cnlfpft_indx) + & cpatch%ed_parsun_z(ican,ipft,ileaf) * cpatch%area/AREA hio_parsha_z_si_cnlfpft(io_si,cnlfpft_indx) = hio_parsha_z_si_cnlfpft(io_si,cnlfpft_indx) + & @@ -1882,13 +1903,38 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) cpatch%ed_laisun_z(ican,ipft,ileaf) * cpatch%area/AREA hio_laisha_z_si_cnlf(io_si,cnlf_indx) = hio_laisha_z_si_cnlf(io_si,cnlf_indx) + & cpatch%ed_laisha_z(ican,ipft,ileaf) * cpatch%area/AREA + ! + hio_fabd_sun_si_cnlf(io_si,cnlf_indx) = hio_fabd_sun_si_cnlf(io_si,cnlf_indx) + & + cpatch%fabd_sun_z(ican,ipft,ileaf) * cpatch%area/AREA + hio_fabd_sha_si_cnlf(io_si,cnlf_indx) = hio_fabd_sha_si_cnlf(io_si,cnlf_indx) + & + cpatch%fabd_sha_z(ican,ipft,ileaf) * cpatch%area/AREA + hio_fabi_sun_si_cnlf(io_si,cnlf_indx) = hio_fabi_sun_si_cnlf(io_si,cnlf_indx) + & + cpatch%fabi_sun_z(ican,ipft,ileaf) * cpatch%area/AREA + hio_fabi_sha_si_cnlf(io_si,cnlf_indx) = hio_fabi_sha_si_cnlf(io_si,cnlf_indx) + & + cpatch%fabi_sha_z(ican,ipft,ileaf) * cpatch%area/AREA + end do ! ! summarize just the top leaf level across all PFTs, for each canopy level - hio_parsuntop_si_can(io_si,ican) = hio_parsuntop_si_can(io_si,ican) + & + hio_parsun_top_si_can(io_si,ican) = hio_parsun_top_si_can(io_si,ican) + & cpatch%ed_parsun_z(ican,ipft,1) * cpatch%area/AREA - hio_parshatop_si_can(io_si,ican) = hio_parshatop_si_can(io_si,ican) + & + hio_parsha_top_si_can(io_si,ican) = hio_parsha_top_si_can(io_si,ican) + & cpatch%ed_parsha_z(ican,ipft,1) * cpatch%area/AREA + ! + hio_laisun_top_si_can(io_si,ican) = hio_laisun_top_si_can(io_si,ican) + & + cpatch%ed_laisun_z(ican,ipft,1) * cpatch%area/AREA + hio_laisha_top_si_can(io_si,ican) = hio_laisha_top_si_can(io_si,ican) + & + cpatch%ed_laisha_z(ican,ipft,1) * cpatch%area/AREA + ! + hio_fabd_sun_top_si_can(io_si,ican) = hio_fabd_sun_top_si_can(io_si,ican) + & + cpatch%fabd_sun_z(ican,ipft,1) * cpatch%area/AREA + hio_fabd_sha_top_si_can(io_si,ican) = hio_fabd_sha_top_si_can(io_si,ican) + & + cpatch%fabd_sha_z(ican,ipft,1) * cpatch%area/AREA + hio_fabi_sun_top_si_can(io_si,ican) = hio_fabi_sun_top_si_can(io_si,ican) + & + cpatch%fabi_sun_z(ican,ipft,1) * cpatch%area/AREA + hio_fabi_sha_top_si_can(io_si,ican) = hio_fabi_sha_top_si_can(io_si,ican) + & + cpatch%fabi_sha_z(ican,ipft,1) * cpatch%area/AREA + ! end do end do @@ -2296,13 +2342,13 @@ subroutine define_history_vars(this, initialize_variables) call this%set_history_var(vname='PARSUN_Z_CNLFPFT', units='W/m2', & long='PAR absorbed in the sun by each canopy, leaf, and PFT', & - use_default='active', & + use_default='inactive', & avgflag='A', vtype=site_cnlfpft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & ivar=ivar, initialize=initialize_variables, index = ih_parsun_z_si_cnlfpft ) call this%set_history_var(vname='PARSHA_Z_CNLFPFT', units='W/m2', & long='PAR absorbed in the shade by each canopy, leaf, and PFT', & - use_default='active', & + use_default='inactive', & avgflag='A', vtype=site_cnlfpft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & ivar=ivar, initialize=initialize_variables, index = ih_parsha_z_si_cnlfpft ) @@ -2310,13 +2356,13 @@ subroutine define_history_vars(this, initialize_variables) long='PAR absorbed in the sun by top leaf layer in each canopy layer', & use_default='active', & avgflag='A', vtype=site_can_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_parsuntop_si_can ) + ivar=ivar, initialize=initialize_variables, index = ih_parsun_top_si_can ) call this%set_history_var(vname='PARSHA_Z_CAN', units='W/m2', & long='PAR absorbed in the shade by top leaf layer in each canopy layer', & use_default='active', & avgflag='A', vtype=site_can_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_parshatop_si_can ) + ivar=ivar, initialize=initialize_variables, index = ih_parsha_top_si_can ) call this%set_history_var(vname='LAISUN_Z_CNLF', units='m2/m2', & long='LAI in the sun by each canopy and leaf layer', & @@ -2332,40 +2378,100 @@ subroutine define_history_vars(this, initialize_variables) call this%set_history_var(vname='LAISUN_Z_CNLFPFT', units='m2/m2', & long='LAI in the sun by each canopy, leaf, and PFT', & - use_default='active', & + use_default='inactive', & avgflag='A', vtype=site_cnlfpft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & ivar=ivar, initialize=initialize_variables, index = ih_laisun_z_si_cnlfpft ) call this%set_history_var(vname='LAISHA_Z_CNLFPFT', units='m2/m2', & long='LAI in the shade by each canopy, leaf, and PFT', & - use_default='active', & + use_default='inactive', & avgflag='A', vtype=site_cnlfpft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & ivar=ivar, initialize=initialize_variables, index = ih_laisha_z_si_cnlfpft ) + call this%set_history_var(vname='LAISUN_TOP_CAN', units='m2/m2', & + long='LAI in the sun by the top leaf layer of each canopy layer', & + use_default='active', & + avgflag='A', vtype=site_can_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_laisun_top_si_can ) + + call this%set_history_var(vname='LAISHA_TOP_CAN', units='m2/m2', & + long='LAI in the shade by the top leaf layer of each canopy layer', & + use_default='active', & + avgflag='A', vtype=site_can_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_laisha_top_si_can ) + call this%set_history_var(vname='FABD_SUN_CNLFPFT', units='fraction', & long='sun fraction of direct light absorbed by each canopy, leaf, and PFT', & - use_default='active', & + use_default='inactive', & avgflag='A', vtype=site_cnlfpft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & ivar=ivar, initialize=initialize_variables, index = ih_fabd_sun_si_cnlfpft ) call this%set_history_var(vname='FABD_SHA_CNLFPFT', units='fraction', & long='shade fraction of direct light absorbed by each canopy, leaf, and PFT', & - use_default='active', & + use_default='inactive', & avgflag='A', vtype=site_cnlfpft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & ivar=ivar, initialize=initialize_variables, index = ih_fabd_sha_si_cnlfpft ) call this%set_history_var(vname='FABI_SUN_CNLFPFT', units='fraction', & long='sun fraction of indirect light absorbed by each canopy, leaf, and PFT', & - use_default='active', & + use_default='inactive', & avgflag='A', vtype=site_cnlfpft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & ivar=ivar, initialize=initialize_variables, index = ih_fabi_sun_si_cnlfpft ) call this%set_history_var(vname='FABI_SHA_CNLFPFT', units='fraction', & long='shade fraction of indirect light absorbed by each canopy, leaf, and PFT', & - use_default='active', & + use_default='inactive', & avgflag='A', vtype=site_cnlfpft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & ivar=ivar, initialize=initialize_variables, index = ih_fabi_sha_si_cnlfpft ) + call this%set_history_var(vname='FABD_SUN_CNLF', units='fraction', & + long='sun fraction of direct light absorbed by each canopy and leaf layer', & + use_default='active', & + avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_fabd_sun_si_cnlf ) + + call this%set_history_var(vname='FABD_SHA_CNLF', units='fraction', & + long='shade fraction of direct light absorbed by each canopy and leaf layer', & + use_default='active', & + avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_fabd_sha_si_cnlf ) + + call this%set_history_var(vname='FABI_SUN_CNLF', units='fraction', & + long='sun fraction of indirect light absorbed by each canopy and leaf layer', & + use_default='active', & + avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_fabi_sun_si_cnlf ) + + call this%set_history_var(vname='FABI_SHA_CNLF', units='fraction', & + long='shade fraction of indirect light absorbed by each canopy and leaf layer', & + use_default='active', & + avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_fabi_sha_si_cnlf ) + + call this%set_history_var(vname='FABD_SUN_TOPLF_BYCANLAYER', units='fraction', & + long='sun fraction of direct light absorbed by the top leaf layer of each canopy layer', & + use_default='active', & + avgflag='A', vtype=site_can_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_fabd_sun_top_si_can ) + + call this%set_history_var(vname='FABD_SHA_TOPLF_BYCANLAYER', units='fraction', & + long='shade fraction of direct light absorbed by the top leaf layer of each canopy layer', & + use_default='active', & + avgflag='A', vtype=site_can_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_fabd_sha_top_si_can ) + + call this%set_history_var(vname='FABI_SUN_TOPLF_BYCANLAYER', units='fraction', & + long='sun fraction of indirect light absorbed by the top leaf layer of each canopy layer', & + use_default='active', & + avgflag='A', vtype=site_can_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_fabi_sun_top_si_can ) + + call this%set_history_var(vname='FABI_SHA_TOPLF_BYCANLAYER', units='fraction', & + long='shade fraction of indirect light absorbed by the top leaf layer of each canopy layer', & + use_default='active', & + avgflag='A', vtype=site_can_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_fabi_sha_top_si_can ) + ! slow carbon fluxes associated with mortality from or transfer betweeen canopy and understory call this%set_history_var(vname='DEMOTION_CARBONFLUX', units = 'gC/m2/s', & long='demotion-associated biomass carbon flux from canopy to understory', use_default='active', & From 1cf27161c617de79bd7ed5492fef814a0b1ea93b Mon Sep 17 00:00:00 2001 From: ckoven Date: Mon, 13 Mar 2017 11:50:17 -0700 Subject: [PATCH 368/437] added hooks to a couple other parameters --- biogeochem/EDPhysiologyMod.F90 | 8 ++++---- biogeophys/FatesPlantRespPhotosynthMod.F90 | 9 +++++---- 2 files changed, 9 insertions(+), 8 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index f46fa544..f58c92d5 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1351,11 +1351,11 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) real(r8) :: croot_prof(1:nsites, 1:cp_numlevdecomp) real(r8) :: stem_prof(1:nsites, 1:cp_numlevdecomp) - ! INTERF-TODO: THESE PARAMETERS WERE ORIGINALLY SET BY params_inst% - ! THEY NEED THEIR OWN ENTRIES IN THE PARAMETER FILE (RGK) - real(r8), parameter :: cwd_fcel = 0.76 - real(r8), parameter :: cwd_flig = 0.24 + real(r8) :: cwd_fcel + real(r8) :: cwd_flig + cwd_fcel = + cwd_flig = delta = 0.001_r8 !no of seconds in a year. diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index 0f160b99..317a6a74 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -180,7 +180,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! (gC/gN/s) ! ------------------------------------------------------------------------ - real(r8),parameter :: base_mr_20 = 2.525e-6_r8 + real(r8) :: base_mr_20 ! ----------------------------------------------------------------------------------- ! Photosynthesis and stomatal conductance parameters, from: @@ -190,9 +190,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! Ball-Berry minimum leaf conductance, unstressed (umol H2O/m**2/s) ! For C3 and C4 plants ! ----------------------------------------------------------------------------------- - ! TO-DO: bbbopt is slated to be transferred to the parameter file - ! ----------------------------------------------------------------------------------- - real(r8),parameter, dimension(2) :: bbbopt = [10000._r8,40000._r8] + real(r8), dimension(2) :: bbbopt associate( & @@ -207,6 +205,9 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) frootcn => EDecophyscon%frootcn, & ! froot C:N (gc/gN) ! slope of BB relationship q10 => EDParamsShareInst%Q10 ) + base_mr_20 = + bbbopt[1] = + bbbopt[2] = do s = 1,nsites From f6f2d10860e46ec5672e9988a9e0255b5e91c0f2 Mon Sep 17 00:00:00 2001 From: JKShuman Date: Mon, 13 Mar 2017 15:21:36 -0600 Subject: [PATCH 369/437] Spitfire fuel_bulkd update Replaced 0.45 multiplier for fuel_bulkd due to previous test failure. With fuel_bulkd multipliers returned, passes bit for bit testing. Fixes: general spitfire cleanup User interface changes?: No Code review: JK Shuman Test suite: yellowstone Test baseline:ed-clm-5c5928f Test namelist changes: none Test answer changes: bit for bit Test summary: --- fire/SFMainMod.F90 | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index 4efe83c9..5d8a50af 100755 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -242,7 +242,10 @@ subroutine charecteristics_of_fuel ( currentSite ) 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))) + currentPatch%fuel_eff_moist = currentPatch%fuel_eff_moist * (1.0_r8/(1.0_r8-currentPatch%fuel_frac(tr_sf))) + + ! Convert from biomass to carbon. + 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) @@ -411,7 +414,7 @@ subroutine rate_of_spread ( currentSite ) ! beta = packing ratio (unitless) ! fraction of fuel array volume occupied by fuel or compactness of fuel bed - beta = (currentPatch%fuel_bulkd) / SF_val_part_dens + beta = (currentPatch%fuel_bulkd / 0.45_r8) / SF_val_part_dens ! Equation A6 in Thonicke et al. 2010 ! packing ratio (unitless) @@ -491,11 +494,11 @@ subroutine rate_of_spread ( currentSite ) ! write(iulog,*) 'ir',reaction_v_opt,moist_damp,SF_val_fuel_energy,SF_val_miner_damp - if ((currentPatch%fuel_bulkd <= 0.0_r8).or.(eps <= 0.0_r8).or.(q_ig <= 0.0_r8)) then + 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. ! forward ROS in m/min - currentPatch%ROS_front = (ir*xi*(1.0_r8+phi_wind)) / (currentPatch%fuel_bulkd*eps*q_ig) + 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 @@ -672,11 +675,9 @@ subroutine area_burnt ( currentSite ) real patch_area_in_m2 !'actual' patch area as applied to whole grid cell real(r8) gridarea real(r8) size_of_fire !in m2 - real(r8) km2_to_m2 + real(r8),parameter :: km2_to_m2 = 1000000.0_r8 !area conversion for square km to square m integer g, p - - km2_to_m2 = 1000000.0_r8 currentSite%frac_burnt = 0.0_r8 currentPatch => currentSite%oldest_patch; From 7f5d61c826bd2699d42259b45d185a7711481aed Mon Sep 17 00:00:00 2001 From: Ben Andre Date: Tue, 14 Mar 2017 16:42:10 -0600 Subject: [PATCH 370/437] Rename EDSharedParams to FatesSynchronizedParam Test suite: ed - yellowstone gnu, intel, pgi hobart nag Test baseline: ed-clm-cdb9db7 Test namelist changes: add fates_paramfile Test answer changes: bit for bit Test summary: all tests pass Test suite: clm_short - yellowstone gnu, intel, pgi Test baseline: clm4_5_12_r195 Test namelist changes: none Test answer changes: bit for bit Test summary: all tests pass --- biogeochem/EDPhysiologyMod.F90 | 6 ++--- biogeophys/FatesPlantRespPhotosynthMod.F90 | 4 ++-- .../FatesSynchronizedParamsMod.F90 | 22 +++++++++---------- 3 files changed, 16 insertions(+), 16 deletions(-) rename biogeochem/EDSharedParamsMod.F90 => main/FatesSynchronizedParamsMod.F90 (85%) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 1bb570d4..f0e285de 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1140,7 +1140,7 @@ subroutine fragmentation_scaler( currentPatch, bc_in) ! ! !USES: - use EDSharedParamsMod , only : EDParamsShareInst + use FatesSynchronizedParamsMod , only : FatesSynchronizedParamsInst use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm use FatesConstantsMod, only : pi => pi_const ! @@ -1169,8 +1169,8 @@ subroutine fragmentation_scaler( currentPatch, bc_in) ifp = currentPatch%patchno ! set "froz_q10" parameter - froz_q10 = EDParamsShareInst%froz_q10 - Q10 = EDParamsShareInst%Q10 + froz_q10 = FatesSynchronizedParamsInst%froz_q10 + Q10 = FatesSynchronizedParamsInst%Q10 if ( .not. use_century_tfunc ) then !calculate rate constant scalar for soil temperature,assuming that the base rate constants diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index 8f530d54..c30db942 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -61,7 +61,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) use EDPftvarcon , only : EDPftvarcon_inst ! THIS WILL BE DEPRECATED WHEN PARAMETER ! READS ARE REFACTORED (RGK 10-13-2016) use EDParamsMod , only : ED_val_ag_biomass - use EDSharedParamsMod , only : EDParamsShareInst + use FatesSynchronizedParamsMod , only : FatesSynchronizedParamsInst use EDTypesMod , only : ed_patch_type use EDTypesMod , only : ed_cohort_type use EDTypesMod , only : ed_site_type @@ -205,7 +205,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) fnitr => EDPftvarcon_inst%fnitr , & ! foliage nitrogen limitation factor (-) leafcn => EDPftvarcon_inst%leafcn , & ! leaf C:N (gC/gN) frootcn => EDPftvarcon_inst%frootcn, & ! froot C:N (gc/gN) ! slope of BB relationship - q10 => EDParamsShareInst%Q10 ) + q10 => FatesSynchronizedParamsInst%Q10 ) do s = 1,nsites diff --git a/biogeochem/EDSharedParamsMod.F90 b/main/FatesSynchronizedParamsMod.F90 similarity index 85% rename from biogeochem/EDSharedParamsMod.F90 rename to main/FatesSynchronizedParamsMod.F90 index fb0f6c6c..33e50a11 100644 --- a/biogeochem/EDSharedParamsMod.F90 +++ b/main/FatesSynchronizedParamsMod.F90 @@ -1,4 +1,4 @@ -module EDSharedParamsMod +module FatesSynchronizedParamsMod !----------------------------------------------------------------------- ! @@ -6,11 +6,11 @@ module EDSharedParamsMod use shr_kind_mod , only: r8 => shr_kind_r8 implicit none - ! EDParamsShareInst. PGI wants the type decl. public but the instance + ! FatesSynchronizedParamsInst. 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 + type, public :: FatesSynchronizedParamsType real(r8) :: Q10 ! temperature dependence real(r8) :: froz_q10 ! separate q10 for frozen soil respiration rates contains @@ -19,9 +19,9 @@ module EDSharedParamsMod procedure, private :: Init procedure, private :: RegisterParamsScalar procedure, private :: ReceiveParamsScalar - end type EDParamsShareType + end type FatesSynchronizedParamsType - type(EDParamsShareType), public :: EDParamsShareInst + type(FatesSynchronizedParamsType), public :: FatesSynchronizedParamsInst character(len=*), parameter, private :: sourcefile = & __FILE__ @@ -38,7 +38,7 @@ subroutine Init(this) implicit none - class(EDParamsShareType), intent(inout) :: this + class(FatesSynchronizedParamsType), intent(inout) :: this this%Q10 = nan this%froz_q10 = nan @@ -55,7 +55,7 @@ subroutine RegisterParams(this, fates_params) implicit none - class(EDParamsShareType), intent(inout) :: this + class(FatesSynchronizedParamsType), intent(inout) :: this class(fates_parameters_type), intent(inout) :: fates_params call this%Init() @@ -70,7 +70,7 @@ subroutine ReceiveParams(this, fates_params) implicit none - class(EDParamsShareType), intent(inout) :: this + class(FatesSynchronizedParamsType), intent(inout) :: this class(fates_parameters_type), intent(inout) :: fates_params call this%ReceiveParamsScalar(fates_params) @@ -88,7 +88,7 @@ subroutine RegisterParamsScalar(this, fates_params) implicit none - class(EDParamsShareType), intent(inout) :: this + class(FatesSynchronizedParamsType), intent(inout) :: this class(fates_parameters_type), intent(inout) :: fates_params character(len=param_string_length), parameter :: dim_names(1) = (/dimension_name_host_allpfts/) @@ -113,7 +113,7 @@ subroutine ReceiveParamsScalar(this, fates_params) implicit none - class(EDParamsShareType), intent(inout) :: this + class(FatesSynchronizedParamsType), intent(inout) :: this class(fates_parameters_type), intent(inout) :: fates_params character(len=param_string_length) :: name @@ -128,4 +128,4 @@ subroutine ReceiveParamsScalar(this, fates_params) end subroutine ReceiveParamsScalar -end module EDSharedParamsMod +end module FatesSynchronizedParamsMod From 8aaaf1a10f5ff3bf24d7e95aa55ce869a7bef91b Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 14 Mar 2017 18:44:51 -0700 Subject: [PATCH 371/437] Migrated dleaf, z0 and displa to the bc_out structures. Part way through forcing itypes to be incompatible. Next step is to implement two new filters, is_fates_patch and is_fates_active_patch filter. --- biogeochem/EDCanopyStructureMod.F90 | 16 +++++++++++++++- main/FatesInterfaceMod.F90 | 25 +++++++++++++++++++------ 2 files changed, 34 insertions(+), 7 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index f156ed86..be2b8867 100755 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1224,6 +1224,9 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) use EDTypesMod , only : ed_patch_type, ed_cohort_type, & ed_site_type, AREA use FatesInterfaceMod , only : bc_out_type + use PatchType , only : patch + use ColumnType , only : col + use pftconMod , only : pftcon ! ! !ARGUMENTS @@ -1233,7 +1236,7 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) type(bc_out_type), intent(inout) :: bc_out(nsites) ! Locals - integer :: s, ifp, c + integer :: s, ifp, c, p type (ed_patch_type) , pointer :: currentPatch real(r8) :: bare_frac_area real(r8) :: total_patch_area @@ -1262,7 +1265,18 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) bc_out(s)%hbot_pa(ifp) = max(0._r8, min(0.2_r8, bc_out(s)%htop_pa(ifp)- 1.0_r8)) + ! Temporary: Recreate the roughness, leaf width and displacment height of the + ! previous code, before calculating more reasonable values. + p = col%patchi(c) + ifp + !bc_out(s)%z0m_pa(ifp) = pftcon%z0mr(patch%itype(p)) * bc_out(s)%htop_pa(ifp) + !bc_out(s)%displa_pa(ifp) = pftcon%displar(patch%itype(p)) * bc_out(s)%htop_pa(ifp) + !bc_out(s)%dleaf_pa(ifp) = pftcon%dleaf(patch%itype(p)) + + bc_out(s)%z0m_pa(ifp) = pftcon%z0mr(1) * bc_out(s)%htop_pa(ifp) + bc_out(s)%displa_pa(ifp) = pftcon%displar(1) * bc_out(s)%htop_pa(ifp) + bc_out(s)%dleaf_pa(ifp) = pftcon%dleaf(1) + ! We are assuming here that grass is all located underneath tree canopies. ! The alternative is to assume it is all spatial distinct from tree canopies. ! In which case, the bare area would have to be reduced by the grass area... diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 79279454..26139b12 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -367,6 +367,10 @@ module FatesInterfaceMod real(r8), allocatable :: htop_pa(:) ! top of the canopy [m] real(r8), allocatable :: hbot_pa(:) ! bottom of canopy? [m] + real(r8), allocatable :: z0m_pa(:) ! roughness length [m] + real(r8), allocatable :: displa_pa(:) ! displacement height [m] + real(r8), allocatable :: dleaf_pa(:) ! leaf characteristic dimension/width/diameter [m] + real(r8), allocatable :: canopy_fraction_pa(:) ! Area fraction of each patch in the site ! Use most likely for weighting ! This is currently the projected canopy @@ -557,6 +561,11 @@ subroutine allocate_bcout(bc_out) allocate(bc_out%tsai_pa(maxPatchesPerSite)) allocate(bc_out%htop_pa(maxPatchesPerSite)) allocate(bc_out%hbot_pa(maxPatchesPerSite)) + allocate(bc_out%dleaf_pa(maxPatchesPerSite)) + + allocate(bc_out%displa_pa(maxPatchesPerSite)) + allocate(bc_out%z0m_pa(maxPatchesPerSite)) + allocate(bc_out%canopy_fraction_pa(maxPatchesPerSite)) allocate(bc_out%frac_veg_nosno_alb_pa(maxPatchesPerSite)) @@ -623,12 +632,16 @@ subroutine zero_bcs(this,s) this%bc_out(s)%ftid_parb(:,:) = 0.0_r8 this%bc_out(s)%ftii_parb(:,:) = 0.0_r8 - this%bc_out(s)%elai_pa(:) = 0.0_r8 - this%bc_out(s)%esai_pa(:) = 0.0_r8 - this%bc_out(s)%tlai_pa(:) = 0.0_r8 - this%bc_out(s)%tsai_pa(:) = 0.0_r8 - this%bc_out(s)%htop_pa(:) = 0.0_r8 - this%bc_out(s)%hbot_pa(:) = 0.0_r8 + this%bc_out(s)%elai_pa(:) = 0.0_r8 + this%bc_out(s)%esai_pa(:) = 0.0_r8 + this%bc_out(s)%tlai_pa(:) = 0.0_r8 + this%bc_out(s)%tsai_pa(:) = 0.0_r8 + this%bc_out(s)%htop_pa(:) = 0.0_r8 + this%bc_out(s)%hbot_pa(:) = 0.0_r8 + this%bc_out(s)%displa_pa(:) = 0.0_r8 + this%bc_out(s)%z0m_pa(:) = 0.0_r8 + this%bc_out(s)%dleaf_pa(:) = 0.0_r8 + this%bc_out(s)%canopy_fraction_pa(:) = 0.0_r8 this%bc_out(s)%frac_veg_nosno_alb_pa(:) = 0.0_r8 From b9c224a5e5d64e9db2ea4b0a96eedfe37ba63425 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 15 Mar 2017 18:05:37 -0700 Subject: [PATCH 372/437] Finished first pass of converting z0, displar and dleaf to boundary conditions. Added the is_fates patch level logical filter. --- biogeochem/EDCanopyStructureMod.F90 | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index be2b8867..d9c8514d 100755 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1269,13 +1269,13 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) ! previous code, before calculating more reasonable values. p = col%patchi(c) + ifp - !bc_out(s)%z0m_pa(ifp) = pftcon%z0mr(patch%itype(p)) * bc_out(s)%htop_pa(ifp) - !bc_out(s)%displa_pa(ifp) = pftcon%displar(patch%itype(p)) * bc_out(s)%htop_pa(ifp) - !bc_out(s)%dleaf_pa(ifp) = pftcon%dleaf(patch%itype(p)) + bc_out(s)%z0m_pa(ifp) = pftcon%z0mr(patch%itype(p)) * bc_out(s)%htop_pa(ifp) + bc_out(s)%displa_pa(ifp) = pftcon%displar(patch%itype(p)) * bc_out(s)%htop_pa(ifp) + bc_out(s)%dleaf_pa(ifp) = pftcon%dleaf(patch%itype(p)) - bc_out(s)%z0m_pa(ifp) = pftcon%z0mr(1) * bc_out(s)%htop_pa(ifp) - bc_out(s)%displa_pa(ifp) = pftcon%displar(1) * bc_out(s)%htop_pa(ifp) - bc_out(s)%dleaf_pa(ifp) = pftcon%dleaf(1) +! bc_out(s)%z0m_pa(ifp) = pftcon%z0mr(1) * bc_out(s)%htop_pa(ifp) +! bc_out(s)%displa_pa(ifp) = pftcon%displar(1) * bc_out(s)%htop_pa(ifp) +! bc_out(s)%dleaf_pa(ifp) = pftcon%dleaf(1) ! We are assuming here that grass is all located underneath tree canopies. ! The alternative is to assume it is all spatial distinct from tree canopies. From 37b8a546f6f08eb5b102738865c85fb59343fa4d Mon Sep 17 00:00:00 2001 From: ckoven Date: Wed, 15 Mar 2017 22:15:35 -0700 Subject: [PATCH 373/437] bugfix on merge; needed to register heretofore-NLSC-dimensioned parameters --- fire/SFParamsMod.F90 | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/fire/SFParamsMod.F90 b/fire/SFParamsMod.F90 index e159150f..514c58e1 100644 --- a/fire/SFParamsMod.F90 +++ b/fire/SFParamsMod.F90 @@ -288,6 +288,12 @@ subroutine SpitFireRegisterNFSC(fates_params) call fates_params%RegisterParameter(name=SF_name_mid_moisture_S, dimension_shape=dimension_shape_1d, & dimension_names=dim_names) + call fates_params%RegisterParameter(name=SF_name_alpha_FMC, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=SF_name_max_decomp, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + end subroutine SpitFireRegisterNFSC !----------------------------------------------------------------------- @@ -324,6 +330,12 @@ subroutine SpitFireReceiveNFSC(fates_params) call fates_params%RetreiveParameter(name=SF_name_mid_moisture_S, & data=SF_val_mid_moisture_S) + call fates_params%RetreiveParameter(name=SF_name_alpha_FMC, & + data=SF_val_alpha_FMC) + + call fates_params%RetreiveParameter(name=SF_name_max_decomp, & + data=SF_val_max_decomp) + end subroutine SpitFireReceiveNFSC !----------------------------------------------------------------------- From 9f13fc9e3ac1467f8c98b3377d80310ae7d299e7 Mon Sep 17 00:00:00 2001 From: JKShuman Date: Thu, 16 Mar 2017 10:45:48 -0600 Subject: [PATCH 374/437] Update to use_spitfire after merge with master In merge a mismatch between master and branch was identified. (use_spit_fire updated to use_spitfire) This was found in failed testing and corrected. With this change passed the full test suite. Fixes: User interface changes?: No Code review: JK Shuman Test suite: full suite, yellowstone Test baseline:clm4_5_12_r195 Test namelist changes: no Test answer changes: bit for bit Test summary: PASS --- fire/SFMainMod.F90 | 4 ++-- main/EDInitMod.F90 | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index f05c1a64..40e909c5 100755 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -73,10 +73,10 @@ subroutine fire_model( currentSite, bc_in) enddo if(write_SF==1)then - write(fates_log(),*) 'use_ed_spit_fire',use_ed_spit_fire + write(fates_log(),*) 'use_ed_spitfire',use_ed_spitfire endif - if(use_ed_spit_fire)then + if(use_ed_spitfire)then call fire_danger_index(currentSite, bc_in) call wind_effect(currentSite, bc_in) call charecteristics_of_fuel(currentSite) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 4f949ba7..91bd94b2 100755 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -8,7 +8,7 @@ module EDInitMod use FatesGlobals , only : endrun => fates_endrun use EDTypesMod , only : nclmax use FatesGlobals , only : fates_log - use clm_varctl , only : use_ed_spit_fire + use clm_varctl , only : use_ed_spitfire use clm_time_manager , only : is_restart use pftconMod , only : pftcon use EDEcophysConType , only : EDecophyscon From 40b22e3e0b10df707d6e38a1473048b34d93284f Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 16 Mar 2017 13:06:17 -0700 Subject: [PATCH 375/437] Converted a list of hard-coded numbers to defined parameters. Likewise, pre-divided parameters when possible. --- main/EDTypesMod.F90 | 5 + main/FatesConstantsMod.F90 | 16 +- main/FatesHistoryInterfaceMod.F90 | 233 ++++++++++++++++-------------- 3 files changed, 142 insertions(+), 112 deletions(-) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index ce525aac..d9621b67 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -10,6 +10,9 @@ module EDTypesMod integer, parameter :: maxPatchesPerSite = 10 ! maximum number of patches to live on a site integer, parameter :: maxCohortsPerPatch = 160 ! maximum number of cohorts to live on a patch integer, parameter :: nclmax = 2 ! Maximum number of canopy layers + integer, parameter :: ican_upper = 1 ! Nominal index for the upper canopy + integer, parameter :: ican_ustory = 2 ! Nominal index for understory in two-canopy system + integer, parameter :: nlevleaf = 40 ! number of leaf layers in canopy layer integer, parameter :: maxpft = 10 ! maximum number of PFTs allowed ! the parameter file may determine that fewer @@ -35,6 +38,8 @@ module EDTypesMod ! MODEL PARAMETERS real(r8), parameter :: AREA = 10000.0_r8 ! Notional area of simulated forest m2 + real(r8), parameter :: AREA_INV = 1.0e-4_r8 ! Inverse of the notion area (faster math) + integer, parameter :: numWaterMem = 10 ! watermemory saved as site level var ! BIOLOGY/BIOGEOCHEMISTRY diff --git a/main/FatesConstantsMod.F90 b/main/FatesConstantsMod.F90 index 9a9896d2..d48dee8d 100644 --- a/main/FatesConstantsMod.F90 +++ b/main/FatesConstantsMod.F90 @@ -37,15 +37,29 @@ module FatesConstantsMod ! Conversion factor: micromoles per mole real(fates_r8), parameter :: umol_per_mol = 1.0E6_fates_r8 - + + ! Conversion factor: m2 per ha + real(fates_r8), parameter :: m2_per_ha = 1.0e4_fates_r8 + + ! Conversion factor :: ha per m2 + real(fates_r8), parameter :: ha_per_m2 = 1.0e-4_fates_r8 ! Conversion: seconds per minute real(fates_r8), parameter :: sec_per_min = 60.0_fates_r8 ! Conversion: seconds per day real(fates_r8), parameter :: sec_per_day = 86400.0_fates_r8 + + ! Conversion: days per second + real(fates_r8), parameter :: days_per_sec = 1.0_fates_r8/86400.0_fates_r8 + + ! Conversion: days per year + real(fates_r8), parameter :: days_per_year = 365.25_fates_r8 + ! Conversion: years per day + real(fates_r8), parameter :: years_per_day = 1.0_fates_r8/365.25_fates_r8 + ! Physical constants ! universal gas constant [J/K/kmol] diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 9616baba..ea1808c5 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -13,6 +13,13 @@ module FatesHistoryInterfaceMod ! FIXME(bja, 2016-10) need to remove CLM dependancy use EDPftvarcon , only : EDPftvarcon_inst + use FatesConstantsMod, only : g_per_kg + use FatesConstantsMod, only : ha_per_m2 + use FatesConstantsMod, only : days_per_sec + use FatesConstantsMod, only : sec_per_day + use FatesConstantsMod, only : days_per_year + use FatesConstantsMod, only : years_per_day + implicit none ! These variables hold the index of the history output structure so we don't @@ -995,6 +1002,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) ed_cohort_type, & ed_patch_type, & AREA, & + AREA_INV, & sclass_ed, & nlevsclass_ed, & levage_ed, & @@ -1002,7 +1010,10 @@ subroutine update_history_dyn(this,nc,nsites,sites) mxpft, & levpft_ed, & nfsc, & - ncwd + ncwd, & + ican_upper, & + ican_ustory + use EDParamsMod , only : ED_val_ag_biomass ! Arguments @@ -1033,8 +1044,6 @@ subroutine update_history_dyn(this,nc,nsites,sites) type(ed_patch_type),pointer :: cpatch type(ed_cohort_type),pointer :: ccohort - real(r8), parameter :: daysecs = 86400.0_r8 ! What modeler doesn't recognize 86400? - real(r8), parameter :: yeardays = 365.0_r8 ! ALM/CLM do not use leap-years real(r8), parameter :: tiny = 1.e-5_r8 ! some small number associate( hio_npatches_si => this%hvars(ih_npatches_si)%r81d, & @@ -1182,7 +1191,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_trimming_pa(io_soipa) = 1.0_r8 ! The seed bank is a site level variable - hio_seed_bank_si(io_si) = sum(sites(s)%seed_bank) * 1.e3_r8 + hio_seed_bank_si(io_si) = sum(sites(s)%seed_bank) * g_per_kg ipa = 0 cpatch => sites(s)%oldest_patch @@ -1195,7 +1204,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! Increment the fractional area in each age class bin hio_area_si_age(io_si,cpatch%age_class) = hio_area_si_age(io_si,cpatch%age_class) & - + cpatch%area/AREA + + cpatch%area * AREA_INV ! Increment some patch-age-resolved diagnostics hio_lai_si_age(io_si,cpatch%age_class) = hio_lai_si_age(io_si,cpatch%age_class) & @@ -1221,7 +1230,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! for quantities that are natively at column level, calculate plant ! density using whole area - n_perm2 = ccohort%n/AREA + n_perm2 = ccohort%n * AREA_INV else n_density = 0.0_r8 @@ -1244,27 +1253,27 @@ subroutine update_history_dyn(this,nc,nsites,sites) end if hio_canopy_area_si_age(io_si,cpatch%age_class) = hio_canopy_area_si_age(io_si,cpatch%age_class) & - + ccohort%c_area/AREA + + ccohort%c_area * AREA_INV ! Update biomass components - hio_bleaf_pa(io_pa) = hio_bleaf_pa(io_pa) + n_density * ccohort%bl * 1.e3_r8 - hio_bstore_pa(io_pa) = hio_bstore_pa(io_pa) + n_density * ccohort%bstore * 1.e3_r8 - hio_btotal_pa(io_pa) = hio_btotal_pa(io_pa) + n_density * ccohort%b * 1.e3_r8 - hio_bdead_pa(io_pa) = hio_bdead_pa(io_pa) + n_density * ccohort%bdead * 1.e3_r8 - hio_balive_pa(io_pa) = hio_balive_pa(io_pa) + n_density * ccohort%balive * 1.e3_r8 + hio_bleaf_pa(io_pa) = hio_bleaf_pa(io_pa) + n_density * ccohort%bl * g_per_kg + hio_bstore_pa(io_pa) = hio_bstore_pa(io_pa) + n_density * ccohort%bstore * g_per_kg + hio_btotal_pa(io_pa) = hio_btotal_pa(io_pa) + n_density * ccohort%b * g_per_kg + hio_bdead_pa(io_pa) = hio_bdead_pa(io_pa) + n_density * ccohort%bdead * g_per_kg + hio_balive_pa(io_pa) = hio_balive_pa(io_pa) + n_density * ccohort%balive * g_per_kg ! Update PFT partitioned biomass components hio_leafbiomass_si_pft(io_si,ft) = hio_leafbiomass_si_pft(io_si,ft) + & - (ccohort%n / AREA) * ccohort%bl * 1.e3_r8 + (ccohort%n * AREA_INV) * ccohort%bl * g_per_kg hio_storebiomass_si_pft(io_si,ft) = hio_storebiomass_si_pft(io_si,ft) + & - (ccohort%n / AREA) * ccohort%bstore * 1.e3_r8 + (ccohort%n * AREA_INV) * ccohort%bstore * g_per_kg hio_nindivs_si_pft(io_si,ft) = hio_nindivs_si_pft(io_si,ft) + & - ccohort%n / AREA + ccohort%n * AREA_INV hio_biomass_si_pft(io_si, ft) = hio_biomass_si_pft(io_si, ft) + & - (ccohort%n / AREA) * ccohort%b * 1.e3_r8 + (ccohort%n * AREA_INV) * ccohort%b * g_per_kg ! Site by Size-Class x PFT (SCPF) ! ------------------------------------------------------------------------ @@ -1345,7 +1354,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) ccohort%bstore * ccohort%n hio_bleaf_canopy_si_scpf(io_si,scpf) = hio_bleaf_canopy_si_scpf(io_si,scpf) + & ccohort%bl * ccohort%n - hio_canopy_biomass_pa(io_pa) = hio_canopy_biomass_pa(io_pa) + n_density * ccohort%b * 1.e3_r8 + hio_canopy_biomass_pa(io_pa) = hio_canopy_biomass_pa(io_pa) + n_density * ccohort%b * g_per_kg hio_mortality_canopy_si_scpf(io_si,scpf) = hio_mortality_canopy_si_scpf(io_si,scpf)+ & (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%imort + ccohort%fmort) * ccohort%n hio_nplant_canopy_si_scpf(io_si,scpf) = hio_nplant_canopy_si_scpf(io_si,scpf) + ccohort%n @@ -1362,7 +1371,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%imort + ccohort%fmort) * ccohort%n hio_canopy_mortality_carbonflux_si(io_si) = hio_canopy_mortality_carbonflux_si(io_si) + & (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%imort + ccohort%fmort) * & - ccohort%b * ccohort%n * 1e3 / (1e4 * daysecs * yeardays) + ccohort%b * ccohort%n * g_per_kg * days_per_sec * years_per_day * ha_per_m2 ! hio_leaf_md_canopy_si_scls(io_si,scls) = hio_leaf_md_canopy_si_scls(io_si,scls) + & ccohort%leaf_md * ccohort%n @@ -1400,7 +1409,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) ccohort%bstore * ccohort%n hio_bleaf_understory_si_scpf(io_si,scpf) = hio_bleaf_understory_si_scpf(io_si,scpf) + & ccohort%bl * ccohort%n - hio_understory_biomass_pa(io_pa) = hio_understory_biomass_pa(io_pa) + n_density * ccohort%b * 1.e3_r8 + hio_understory_biomass_pa(io_pa) = hio_understory_biomass_pa(io_pa) + n_density * ccohort%b * g_per_kg hio_mortality_understory_si_scpf(io_si,scpf) = hio_mortality_understory_si_scpf(io_si,scpf)+ & (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%imort + ccohort%fmort) * ccohort%n hio_nplant_understory_si_scpf(io_si,scpf) = hio_nplant_understory_si_scpf(io_si,scpf) + ccohort%n @@ -1417,7 +1426,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%imort + ccohort%fmort) * ccohort%n hio_understory_mortality_carbonflux_si(io_si) = hio_understory_mortality_carbonflux_si(io_si) + & (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%imort + ccohort%fmort) * & - ccohort%b * ccohort%n * 1e3 / (1e4 * daysecs * yeardays) + ccohort%b * ccohort%n * g_per_kg * days_per_sec * years_per_day * ha_per_m2 ! hio_leaf_md_understory_si_scls(io_si,scls) = hio_leaf_md_understory_si_scls(io_si,scls) + & ccohort%leaf_md * ccohort%n @@ -1482,52 +1491,52 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_fire_fuel_eff_moist_pa(io_pa) = cpatch%fuel_eff_moist hio_fire_fuel_sav_pa(io_pa) = cpatch%fuel_sav hio_fire_fuel_mef_pa(io_pa) = cpatch%fuel_mef - hio_sum_fuel_pa(io_pa) = cpatch%sum_fuel * 1.e3_r8 * patch_scaling_scalar + hio_sum_fuel_pa(io_pa) = cpatch%sum_fuel * g_per_kg * patch_scaling_scalar do i_fuel = 1,nfsc hio_litter_moisture_si_fuel(io_si, i_fuel) = hio_litter_moisture_si_fuel(io_si, i_fuel) + & - cpatch%litter_moisture(i_fuel) * cpatch%area/AREA + cpatch%litter_moisture(i_fuel) * cpatch%area * AREA_INV end do !!! +++ cdk +++ commenting out the below changes to revert for bit-for-bit passing !!! ! Update Litter Flux Variables ! ! put litter_in flux onto site level variable so as to be able to append site-level distubance-related input flux after patch loop ! hio_litter_in_si(io_si) = hio_litter_in_si(io_si) + & ! (sum(cpatch%CWD_AG_in) +sum(cpatch%leaf_litter_in) + sum(cpatch%root_litter_in)) & - ! * 1.e3_r8 * cpatch%area / ( AREA * 365.0_r8 * daysecs ) + ! * 1.e3_r8 * cpatch%area / ( AREA * 365.0_r8 * sec_per_day ) ! ! keep litter_out at patch level ! hio_litter_out_pa(io_pa) = (sum(cpatch%CWD_AG_out)+sum(cpatch%leaf_litter_out) & ! + sum(cpatch%root_litter_out)) & - ! * 1.e3_r8 * patch_scaling_scalar / ( 365.0_r8 * daysecs ) + ! * 1.e3_r8 * patch_scaling_scalar / ( 365.0_r8 * sec_per_day ) !!! --- cdk --- !!! hio_litter_in_si(io_pa) = (sum(cpatch%CWD_AG_in) +sum(cpatch%leaf_litter_in)) & - * 1.e3_r8 * 365.0_r8 * daysecs * patch_scaling_scalar + * g_per_kg * days_per_year * sec_per_day * patch_scaling_scalar hio_litter_out_pa(io_pa) = (sum(cpatch%CWD_AG_out)+sum(cpatch%leaf_litter_out)) & - * 1.e3_r8 * 365.0_r8 * daysecs * patch_scaling_scalar + * g_per_kg * days_per_year * sec_per_day * patch_scaling_scalar !!! --- cdk --- !!! hio_seeds_in_pa(io_pa) = sum(cpatch%seeds_in) * & - 1.e3_r8 * patch_scaling_scalar / ( 365.0_r8 * daysecs ) - hio_seed_decay_pa(io_pa) = sum(cpatch%seed_decay) & - * 1.e3_r8 * patch_scaling_scalar / ( 365.0_r8 * daysecs ) - hio_seed_germination_pa(io_pa) = sum(cpatch%seed_germination) & - * 1.e3_r8 * patch_scaling_scalar / ( 365.0_r8 * daysecs ) + g_per_kg * patch_scaling_scalar * years_per_day * days_per_sec + hio_seed_decay_pa(io_pa) = sum(cpatch%seed_decay) * & + g_per_kg * patch_scaling_scalar * years_per_day * days_per_sec + hio_seed_germination_pa(io_pa) = sum(cpatch%seed_germination) * & + g_per_kg * patch_scaling_scalar * years_per_day * days_per_sec hio_canopy_spread_pa(io_pa) = cpatch%spread(1) do i_cwd = 1, ncwd hio_cwd_ag_si_cwdsc(io_si, i_cwd) = hio_cwd_ag_si_cwdsc(io_si, i_cwd) + & - cpatch%CWD_AG(i_cwd)*cpatch%area/AREA * 1e3 + cpatch%CWD_AG(i_cwd)*cpatch%area * AREA_INV * g_per_kg hio_cwd_bg_si_cwdsc(io_si, i_cwd) = hio_cwd_bg_si_cwdsc(io_si, i_cwd) + & - cpatch%CWD_BG(i_cwd)*cpatch%area/AREA * 1e3 + cpatch%CWD_BG(i_cwd)*cpatch%area * AREA_INV * g_per_kg hio_cwd_ag_in_si_cwdsc(io_si, i_cwd) = hio_cwd_ag_in_si_cwdsc(io_si, i_cwd) + & - cpatch%CWD_AG_IN(i_cwd)*cpatch%area/AREA * 1e3 + cpatch%CWD_AG_IN(i_cwd)*cpatch%area * AREA_INV * g_per_kg hio_cwd_bg_in_si_cwdsc(io_si, i_cwd) = hio_cwd_bg_in_si_cwdsc(io_si, i_cwd) + & - cpatch%CWD_BG_IN(i_cwd)*cpatch%area/AREA * 1e3 + cpatch%CWD_BG_IN(i_cwd)*cpatch%area * AREA_INV * g_per_kg hio_cwd_ag_out_si_cwdsc(io_si, i_cwd) = hio_cwd_ag_out_si_cwdsc(io_si, i_cwd) + & - cpatch%CWD_AG_OUT(i_cwd)*cpatch%area/AREA * 1e3 + cpatch%CWD_AG_OUT(i_cwd)*cpatch%area * AREA_INV * g_per_kg hio_cwd_bg_out_si_cwdsc(io_si, i_cwd) = hio_cwd_bg_out_si_cwdsc(io_si, i_cwd) + & - cpatch%CWD_BG_OUT(i_cwd)*cpatch%area/AREA * 1e3 + cpatch%CWD_BG_OUT(i_cwd)*cpatch%area * AREA_INV * g_per_kg end do ipa = ipa + 1 @@ -1551,22 +1560,22 @@ subroutine update_history_dyn(this,nc,nsites,sites) do i_scls = 1,nlevsclass_ed i_scpf = (i_pft-1)*nlevsclass_ed + i_scls hio_m6_si_scpf(io_si,i_scpf) = (sites(s)%terminated_nindivs(i_scls,i_pft,1) + & - sites(s)%terminated_nindivs(i_scls,i_pft,2)) * yeardays + sites(s)%terminated_nindivs(i_scls,i_pft,2)) * days_per_year hio_mortality_canopy_si_scls(io_si,i_scls) = hio_mortality_canopy_si_scls(io_si,i_scls) + & - sites(s)%terminated_nindivs(i_scls,i_pft,1) * yeardays + sites(s)%terminated_nindivs(i_scls,i_pft,1) * days_per_year hio_mortality_understory_si_scls(io_si,i_scls) = hio_mortality_understory_si_scls(io_si,i_scls) + & - sites(s)%terminated_nindivs(i_scls,i_pft,2) * yeardays + sites(s)%terminated_nindivs(i_scls,i_pft,2) * days_per_year hio_mortality_canopy_si_scpf(io_si,i_scpf) = hio_mortality_canopy_si_scpf(io_si,i_scpf) + & - sites(s)%terminated_nindivs(i_scls,i_pft,1) * yeardays + sites(s)%terminated_nindivs(i_scls,i_pft,1) * days_per_year hio_mortality_understory_si_scpf(io_si,i_scpf) = hio_mortality_understory_si_scpf(io_si,i_scpf) + & - sites(s)%terminated_nindivs(i_scls,i_pft,2) * yeardays + sites(s)%terminated_nindivs(i_scls,i_pft,2) * days_per_year end do end do sites(s)%terminated_nindivs(:,:,:) = 0._r8 ! pass the recruitment rate as a flux to the history, and then reset the recruitment buffer do i_pft = 1, mxpft - hio_recruitment_si_pft(io_si,i_pft) = sites(s)%recruitment_rate(i_pft) * yeardays + hio_recruitment_si_pft(io_si,i_pft) = sites(s)%recruitment_rate(i_pft) * days_per_year end do sites(s)%recruitment_rate(:) = 0._r8 @@ -1586,33 +1595,34 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! pass demotion rates and associated carbon fluxes to history do i_scls = 1,nlevsclass_ed - hio_demotion_rate_si_scls(io_si,i_scls) = sites(s)%demotion_rate(i_scls) * yeardays - hio_promotion_rate_si_scls(io_si,i_scls) = sites(s)%promotion_rate(i_scls) * yeardays + hio_demotion_rate_si_scls(io_si,i_scls) = sites(s)%demotion_rate(i_scls) * days_per_year + hio_promotion_rate_si_scls(io_si,i_scls) = sites(s)%promotion_rate(i_scls) * days_per_year end do ! ! convert kg C / ha / day to gc / m2 / sec - hio_demotion_carbonflux_si(io_si) = sites(s)%demotion_carbonflux * 1e3 / (1e4 * daysecs) - hio_promotion_carbonflux_si(io_si) = sites(s)%promotion_carbonflux * 1e3 / (1e4 * daysecs) + hio_demotion_carbonflux_si(io_si) = sites(s)%demotion_carbonflux * g_per_kg * ha_per_m2 * days_per_sec + hio_promotion_carbonflux_si(io_si) = sites(s)%promotion_carbonflux * g_per_kg * ha_per_m2 * days_per_sec ! ! mortality-associated carbon fluxes + hio_canopy_mortality_carbonflux_si(io_si) = hio_canopy_mortality_carbonflux_si(io_si) + & - sites(s)%termination_carbonflux(1) * 1e3 / (1e4 * daysecs) + sites(s)%termination_carbonflux(ican_upper) * g_per_kg * days_per_sec * ha_per_m2 hio_understory_mortality_carbonflux_si(io_si) = hio_understory_mortality_carbonflux_si(io_si) + & - sites(s)%termination_carbonflux(2) * 1e3 / (1e4 * daysecs) + sites(s)%termination_carbonflux(ican_ustory) * g_per_kg * days_per_sec * ha_per_m2 ! and zero the site-level termination carbon flux variable sites(s)%termination_carbonflux(:) = 0._r8 ! ! add the site-level disturbance-associated cwd and litter input fluxes to thir respective flux fields do i_cwd = 1, ncwd hio_cwd_ag_in_si_cwdsc(io_si, i_cwd) = hio_cwd_ag_in_si_cwdsc(io_si, i_cwd) + & - sites(s)%CWD_AG_diagnostic_input_carbonflux(i_cwd) * 1e3 + sites(s)%CWD_AG_diagnostic_input_carbonflux(i_cwd) * g_per_kg hio_cwd_bg_in_si_cwdsc(io_si, i_cwd) = hio_cwd_bg_in_si_cwdsc(io_si, i_cwd) + & - sites(s)%CWD_BG_diagnostic_input_carbonflux(i_cwd) * 1e3 + sites(s)%CWD_BG_diagnostic_input_carbonflux(i_cwd) * g_per_kg end do !!! cdk comment out below line for bit-for-bitness ! hio_litter_in_si(io_si) = hio_litter_in_si(io_si) + & ! (sum(sites(s)%leaf_litter_diagnostic_input_carbonflux) + & - ! sum(sites(s)%root_litter_diagnostic_input_carbonflux)) * 1e3 / ( daysecs * yeardays ) + ! sum(sites(s)%root_litter_diagnostic_input_carbonflux)) * g_per_kg / ( sec_per_day * days_per_year ) ! and reset the disturbance-related field buffers sites(s)%CWD_AG_diagnostic_input_carbonflux(:) = 0._r8 sites(s)%CWD_BG_diagnostic_input_carbonflux(:) = 0._r8 @@ -1639,6 +1649,7 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) ed_cohort_type, & ed_patch_type, & AREA, & + AREA_INV, & nlevage_ed, & sclass_ed, & nlevsclass_ed @@ -1670,10 +1681,8 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) type(fates_history_variable_type),pointer :: hvar type(ed_patch_type),pointer :: cpatch type(ed_cohort_type),pointer :: ccohort + real(r8) :: per_dt_tstep ! Time step in frequency units (/s) - real(r8), parameter :: daysecs = 86400.0_r8 ! What modeler doesn't recognize 86400? - real(r8), parameter :: yeardays = 365.0_r8 ! Should this be 365.25? - associate( hio_gpp_pa => this%hvars(ih_gpp_pa)%r81d, & hio_npp_pa => this%hvars(ih_npp_pa)%r81d, & hio_aresp_pa => this%hvars(ih_aresp_pa)%r81d, & @@ -1735,6 +1744,8 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) ! Flush the relevant history variables call this%flush_hvars(nc,upfreq_in=2) + per_dt_tstep = 1.0_r8/dt_tstep + do s = 1,nsites io_si = this%iovar_map(nc)%site_index(s) @@ -1758,7 +1769,7 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) ! TODO: we need a standardized logical function on this (used lots, RGK) if ((cpatch%area .gt. 0._r8) .and. (cpatch%total_canopy_area .gt. 0._r8)) then n_density = ccohort%n/min(cpatch%area,cpatch%total_canopy_area) - n_perm2 = ccohort%n/AREA + n_perm2 = ccohort%n * AREA_INV else n_density = 0.0_r8 n_perm2 = 0.0_r8 @@ -1772,92 +1783,92 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) ! scale up cohort fluxes to their patches hio_npp_pa(io_pa) = hio_npp_pa(io_pa) + & - ccohort%npp_tstep * 1.e3_r8 * n_density / dt_tstep + ccohort%npp_tstep * g_per_kg * n_density * per_dt_tstep hio_gpp_pa(io_pa) = hio_gpp_pa(io_pa) + & - ccohort%gpp_tstep * 1.e3_r8 * n_density / dt_tstep + ccohort%gpp_tstep * g_per_kg * n_density * per_dt_tstep hio_aresp_pa(io_pa) = hio_aresp_pa(io_pa) + & - ccohort%resp_tstep * 1.e3_r8 * n_density / dt_tstep + ccohort%resp_tstep * g_per_kg * n_density * per_dt_tstep hio_growth_resp_pa(io_pa) = hio_growth_resp_pa(io_pa) + & - ccohort%resp_g * 1.e3_r8 * n_density / dt_tstep + ccohort%resp_g * g_per_kg * n_density * per_dt_tstep hio_maint_resp_pa(io_pa) = hio_maint_resp_pa(io_pa) + & - ccohort%resp_m * 1.e3_r8 * n_density / dt_tstep + ccohort%resp_m * g_per_kg * n_density * per_dt_tstep ! map ed cohort-level npp fluxes to clm column fluxes - hio_npp_si(io_si) = hio_npp_si(io_si) + ccohort%npp_tstep * n_perm2 * 1.e3_r8 /dt_tstep + hio_npp_si(io_si) = hio_npp_si(io_si) + ccohort%npp_tstep * n_perm2 * g_per_kg * per_dt_tstep ! Total AR (kgC/m2/yr) = (kgC/plant/step) / (s/step) * (plant/m2) * (s/yr) hio_ar_si_scpf(io_si,scpf) = hio_ar_si_scpf(io_si,scpf) + & - (ccohort%resp_tstep/dt_tstep) * n_perm2 * daysecs * yeardays + (ccohort%resp_tstep/dt_tstep) * n_perm2 * sec_per_day * days_per_year ! Growth AR (kgC/m2/yr) hio_ar_grow_si_scpf(io_si,scpf) = hio_ar_grow_si_scpf(io_si,scpf) + & - (ccohort%resp_g/dt_tstep) * n_perm2 * daysecs * yeardays + (ccohort%resp_g/dt_tstep) * n_perm2 * sec_per_day * days_per_year ! Maint AR (kgC/m2/yr) hio_ar_maint_si_scpf(io_si,scpf) = hio_ar_maint_si_scpf(io_si,scpf) + & - (ccohort%resp_m/dt_tstep) * n_perm2 * daysecs * yeardays + (ccohort%resp_m/dt_tstep) * n_perm2 * sec_per_day * days_per_year ! Maintenance AR partition variables are stored as rates (kgC/plant/s) ! (kgC/m2/yr) = (kgC/plant/s) * (plant/m2) * (s/yr) hio_ar_agsapm_si_scpf(io_si,scpf) = hio_ar_agsapm_si_scpf(io_si,scpf) + & - ccohort%livestem_mr * n_perm2 * daysecs * yeardays + ccohort%livestem_mr * n_perm2 * sec_per_day * days_per_year ! (kgC/m2/yr) = (kgC/plant/s) * (plant/m2) * (s/yr) hio_ar_darkm_si_scpf(io_si,scpf) = hio_ar_darkm_si_scpf(io_si,scpf) + & - ccohort%rdark * n_perm2 * daysecs * yeardays + ccohort%rdark * n_perm2 * sec_per_day * days_per_year ! (kgC/m2/yr) = (kgC/plant/s) * (plant/m2) * (s/yr) hio_ar_crootm_si_scpf(io_si,scpf) = hio_ar_crootm_si_scpf(io_si,scpf) + & - ccohort%livecroot_mr * n_perm2 * daysecs * yeardays + ccohort%livecroot_mr * n_perm2 * sec_per_day * days_per_year ! (kgC/m2/yr) = (kgC/plant/s) * (plant/m2) * (s/yr) hio_ar_frootm_si_scpf(io_si,scpf) = hio_ar_frootm_si_scpf(io_si,scpf) + & - ccohort%froot_mr * n_perm2 * daysecs * yeardays + ccohort%froot_mr * n_perm2 * sec_per_day * days_per_year ! accumulate fluxes per patch age bin hio_gpp_si_age(io_si,cpatch%age_class) = hio_gpp_si_age(io_si,cpatch%age_class) & - + ccohort%gpp_tstep * ccohort%n * 1.e3_r8 / dt_tstep + + ccohort%gpp_tstep * ccohort%n * g_per_kg * per_dt_tstep hio_npp_si_age(io_si,cpatch%age_class) = hio_npp_si_age(io_si,cpatch%age_class) & - + ccohort%npp_tstep * ccohort%n * 1.e3_r8 / dt_tstep + + ccohort%npp_tstep * ccohort%n * g_per_kg * per_dt_tstep ! accumulate fluxes on canopy- and understory- separated fluxes if (ccohort%canopy_layer .eq. 1) then hio_gpp_canopy_pa(io_pa) = hio_gpp_canopy_pa(io_pa) + & - ccohort%gpp_tstep * 1.e3_r8 * n_density / dt_tstep + ccohort%gpp_tstep * g_per_kg * n_density * per_dt_tstep hio_ar_canopy_pa(io_pa) = hio_ar_canopy_pa(io_pa) + & - ccohort%resp_tstep * 1.e3_r8 * n_density / dt_tstep + ccohort%resp_tstep * g_per_kg * n_density * per_dt_tstep ! hio_rdark_canopy_si_scls(io_si,scls) = hio_rdark_canopy_si_scls(io_si,scls) + & - ccohort%rdark * 1.e3_r8 * ccohort%n * daysecs * yeardays + ccohort%rdark * g_per_kg * ccohort%n * sec_per_day * days_per_year hio_livestem_mr_canopy_si_scls(io_si,scls) = hio_livestem_mr_canopy_si_scls(io_si,scls) + & - ccohort%livestem_mr * 1.e3_r8 * ccohort%n * daysecs * yeardays + ccohort%livestem_mr * g_per_kg * ccohort%n * sec_per_day * days_per_year hio_livecroot_mr_canopy_si_scls(io_si,scls) = hio_livecroot_mr_canopy_si_scls(io_si,scls) + & - ccohort%livecroot_mr * 1.e3_r8 * ccohort%n * daysecs * yeardays + ccohort%livecroot_mr * g_per_kg * ccohort%n * sec_per_day * days_per_year hio_froot_mr_canopy_si_scls(io_si,scls) = hio_froot_mr_canopy_si_scls(io_si,scls) + & - ccohort%froot_mr * 1.e3_r8 * ccohort%n * daysecs * yeardays + ccohort%froot_mr * g_per_kg * ccohort%n * sec_per_day * days_per_year hio_resp_g_canopy_si_scls(io_si,scls) = hio_resp_g_canopy_si_scls(io_si,scls) + & - ccohort%resp_g * 1.e3_r8 * ccohort%n * daysecs * yeardays / dt_tstep + ccohort%resp_g * g_per_kg * ccohort%n * sec_per_day * days_per_year * per_dt_tstep hio_resp_m_canopy_si_scls(io_si,scls) = hio_resp_m_canopy_si_scls(io_si,scls) + & - ccohort%resp_m * 1.e3_r8 * ccohort%n * daysecs * yeardays / dt_tstep + ccohort%resp_m * g_per_kg * ccohort%n * sec_per_day * days_per_year * per_dt_tstep else hio_gpp_understory_pa(io_pa) = hio_gpp_understory_pa(io_pa) + & - ccohort%gpp_tstep * 1.e3_r8 * n_density / dt_tstep + ccohort%gpp_tstep * g_per_kg * n_density * per_dt_tstep hio_ar_understory_pa(io_pa) = hio_ar_understory_pa(io_pa) + & - ccohort%resp_tstep * 1.e3_r8 * n_density / dt_tstep + ccohort%resp_tstep * g_per_kg * n_density * per_dt_tstep ! hio_rdark_understory_si_scls(io_si,scls) = hio_rdark_understory_si_scls(io_si,scls) + & - ccohort%rdark * 1.e3_r8 * ccohort%n * daysecs * yeardays + ccohort%rdark * g_per_kg * ccohort%n * sec_per_day * days_per_year hio_livestem_mr_understory_si_scls(io_si,scls) = hio_livestem_mr_understory_si_scls(io_si,scls) + & - ccohort%livestem_mr * 1.e3_r8 * ccohort%n * daysecs * yeardays + ccohort%livestem_mr * g_per_kg * ccohort%n * sec_per_day * days_per_year hio_livecroot_mr_understory_si_scls(io_si,scls) = hio_livecroot_mr_understory_si_scls(io_si,scls) + & - ccohort%livecroot_mr * 1.e3_r8 * ccohort%n * daysecs * yeardays + ccohort%livecroot_mr * g_per_kg * ccohort%n * sec_per_day * days_per_year hio_froot_mr_understory_si_scls(io_si,scls) = hio_froot_mr_understory_si_scls(io_si,scls) + & - ccohort%froot_mr * 1.e3_r8 * ccohort%n * daysecs * yeardays + ccohort%froot_mr * g_per_kg * ccohort%n * sec_per_day * days_per_year hio_resp_g_understory_si_scls(io_si,scls) = hio_resp_g_understory_si_scls(io_si,scls) + & - ccohort%resp_g * 1.e3_r8 * ccohort%n * daysecs * yeardays / dt_tstep + ccohort%resp_g * g_per_kg * ccohort%n * sec_per_day * days_per_year * per_dt_tstep hio_resp_m_understory_si_scls(io_si,scls) = hio_resp_m_understory_si_scls(io_si,scls) + & - ccohort%resp_m * 1.e3_r8 * ccohort%n * daysecs * yeardays / dt_tstep + ccohort%resp_m * g_per_kg * ccohort%n * sec_per_day * days_per_year * per_dt_tstep endif end associate endif @@ -1875,65 +1886,65 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) ! ! first do all the canopy x leaf x pft calculations hio_parsun_z_si_cnlfpft(io_si,cnlfpft_indx) = hio_parsun_z_si_cnlfpft(io_si,cnlfpft_indx) + & - cpatch%ed_parsun_z(ican,ipft,ileaf) * cpatch%area/AREA + cpatch%ed_parsun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV hio_parsha_z_si_cnlfpft(io_si,cnlfpft_indx) = hio_parsha_z_si_cnlfpft(io_si,cnlfpft_indx) + & - cpatch%ed_parsha_z(ican,ipft,ileaf) * cpatch%area/AREA + cpatch%ed_parsha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV ! hio_laisun_z_si_cnlfpft(io_si,cnlfpft_indx) = hio_laisun_z_si_cnlfpft(io_si,cnlfpft_indx) + & - cpatch%ed_laisun_z(ican,ipft,ileaf) * cpatch%area/AREA + cpatch%ed_laisun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV hio_laisha_z_si_cnlfpft(io_si,cnlfpft_indx) = hio_laisha_z_si_cnlfpft(io_si,cnlfpft_indx) + & - cpatch%ed_laisha_z(ican,ipft,ileaf) * cpatch%area/AREA + cpatch%ed_laisha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV ! hio_fabd_sun_si_cnlfpft(io_si,cnlfpft_indx) = hio_fabd_sun_si_cnlfpft(io_si,cnlfpft_indx) + & - cpatch%fabd_sun_z(ican,ipft,ileaf) * cpatch%area/AREA + cpatch%fabd_sun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV hio_fabd_sha_si_cnlfpft(io_si,cnlfpft_indx) = hio_fabd_sha_si_cnlfpft(io_si,cnlfpft_indx) + & - cpatch%fabd_sha_z(ican,ipft,ileaf) * cpatch%area/AREA + cpatch%fabd_sha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV hio_fabi_sun_si_cnlfpft(io_si,cnlfpft_indx) = hio_fabi_sun_si_cnlfpft(io_si,cnlfpft_indx) + & - cpatch%fabi_sun_z(ican,ipft,ileaf) * cpatch%area/AREA + cpatch%fabi_sun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV hio_fabi_sha_si_cnlfpft(io_si,cnlfpft_indx) = hio_fabi_sha_si_cnlfpft(io_si,cnlfpft_indx) + & - cpatch%fabi_sha_z(ican,ipft,ileaf) * cpatch%area/AREA + cpatch%fabi_sha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV ! ! summarize across all PFTs hio_parsun_z_si_cnlf(io_si,cnlf_indx) = hio_parsun_z_si_cnlf(io_si,cnlf_indx) + & - cpatch%ed_parsun_z(ican,ipft,ileaf) * cpatch%area/AREA + cpatch%ed_parsun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV hio_parsha_z_si_cnlf(io_si,cnlf_indx) = hio_parsha_z_si_cnlf(io_si,cnlf_indx) + & - cpatch%ed_parsha_z(ican,ipft,ileaf) * cpatch%area/AREA + cpatch%ed_parsha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV ! hio_laisun_z_si_cnlf(io_si,cnlf_indx) = hio_laisun_z_si_cnlf(io_si,cnlf_indx) + & - cpatch%ed_laisun_z(ican,ipft,ileaf) * cpatch%area/AREA + cpatch%ed_laisun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV hio_laisha_z_si_cnlf(io_si,cnlf_indx) = hio_laisha_z_si_cnlf(io_si,cnlf_indx) + & - cpatch%ed_laisha_z(ican,ipft,ileaf) * cpatch%area/AREA + cpatch%ed_laisha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV ! hio_fabd_sun_si_cnlf(io_si,cnlf_indx) = hio_fabd_sun_si_cnlf(io_si,cnlf_indx) + & - cpatch%fabd_sun_z(ican,ipft,ileaf) * cpatch%area/AREA + cpatch%fabd_sun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV hio_fabd_sha_si_cnlf(io_si,cnlf_indx) = hio_fabd_sha_si_cnlf(io_si,cnlf_indx) + & - cpatch%fabd_sha_z(ican,ipft,ileaf) * cpatch%area/AREA + cpatch%fabd_sha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV hio_fabi_sun_si_cnlf(io_si,cnlf_indx) = hio_fabi_sun_si_cnlf(io_si,cnlf_indx) + & - cpatch%fabi_sun_z(ican,ipft,ileaf) * cpatch%area/AREA + cpatch%fabi_sun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV hio_fabi_sha_si_cnlf(io_si,cnlf_indx) = hio_fabi_sha_si_cnlf(io_si,cnlf_indx) + & - cpatch%fabi_sha_z(ican,ipft,ileaf) * cpatch%area/AREA + cpatch%fabi_sha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV end do ! ! summarize just the top leaf level across all PFTs, for each canopy level hio_parsun_top_si_can(io_si,ican) = hio_parsun_top_si_can(io_si,ican) + & - cpatch%ed_parsun_z(ican,ipft,1) * cpatch%area/AREA + cpatch%ed_parsun_z(ican,ipft,1) * cpatch%area * AREA_INV hio_parsha_top_si_can(io_si,ican) = hio_parsha_top_si_can(io_si,ican) + & - cpatch%ed_parsha_z(ican,ipft,1) * cpatch%area/AREA + cpatch%ed_parsha_z(ican,ipft,1) * cpatch%area * AREA_INV ! hio_laisun_top_si_can(io_si,ican) = hio_laisun_top_si_can(io_si,ican) + & - cpatch%ed_laisun_z(ican,ipft,1) * cpatch%area/AREA + cpatch%ed_laisun_z(ican,ipft,1) * cpatch%area * AREA_INV hio_laisha_top_si_can(io_si,ican) = hio_laisha_top_si_can(io_si,ican) + & - cpatch%ed_laisha_z(ican,ipft,1) * cpatch%area/AREA + cpatch%ed_laisha_z(ican,ipft,1) * cpatch%area * AREA_INV ! hio_fabd_sun_top_si_can(io_si,ican) = hio_fabd_sun_top_si_can(io_si,ican) + & - cpatch%fabd_sun_z(ican,ipft,1) * cpatch%area/AREA + cpatch%fabd_sun_z(ican,ipft,1) * cpatch%area * AREA_INV hio_fabd_sha_top_si_can(io_si,ican) = hio_fabd_sha_top_si_can(io_si,ican) + & - cpatch%fabd_sha_z(ican,ipft,1) * cpatch%area/AREA + cpatch%fabd_sha_z(ican,ipft,1) * cpatch%area * AREA_INV hio_fabi_sun_top_si_can(io_si,ican) = hio_fabi_sun_top_si_can(io_si,ican) + & - cpatch%fabi_sun_z(ican,ipft,1) * cpatch%area/AREA + cpatch%fabi_sun_z(ican,ipft,1) * cpatch%area * AREA_INV hio_fabi_sha_top_si_can(io_si,ican) = hio_fabi_sha_top_si_can(io_si,ican) + & - cpatch%fabi_sha_z(ican,ipft,1) * cpatch%area/AREA + cpatch%fabi_sha_z(ican,ipft,1) * cpatch%area * AREA_INV ! end do end do From eab6544ca3b81bcf9494c43a537ac156bed17542 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 16 Mar 2017 16:45:41 -0700 Subject: [PATCH 376/437] Renamed dimensions for fates history output. Also renamed some fates-side dimension arrays. --- main/EDTypesMod.F90 | 91 ++++++++++++++++--------------- main/FatesHistoryInterfaceMod.F90 | 2 - main/FatesIODimensionsMod.F90 | 29 +++++----- 3 files changed, 64 insertions(+), 58 deletions(-) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index d9621b67..5bdbe5b7 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -108,23 +108,28 @@ module EDTypesMod (/"background","hydraulic ","carbon ","impact ","fire "/) + ! ------------------------------------------------------------------------------------- ! These vectors are used for history output mapping - real(r8) ,allocatable :: levsclass_ed(:) ! The lower bound on size classes for ED trees. This - ! is used really for IO into the - ! history tapes. It gets copied from - ! the parameter array sclass_ed. - integer , allocatable :: pft_levscpf_ed(:) - integer , allocatable :: scls_levscpf_ed(:) - real(r8), allocatable :: levage_ed(:) - integer , allocatable :: levpft_ed(:) - integer , allocatable :: levfuel_ed(:) - integer , allocatable :: levcwdsc_ed(:) - integer , allocatable :: levcan_ed(:) - integer , allocatable :: can_levcnlf_ed(:) - integer , allocatable :: lf_levcnlf_ed(:) - integer , allocatable :: can_levcnlfpft_ed(:) - integer , allocatable :: lf_levcnlfpft_ed(:) - integer , allocatable :: pft_levcnlfpft_ed(:) + ! CLM/ALM have limited support for multi-dimensional history output arrays. + ! FATES structure and composition is multi-dimensional, so we end up "multi-plexing" + ! multiple dimensions into one dimension. These new dimensions need definitions, + ! mapping to component dimensions, and definitions for those component dimensions as + ! well. + ! ------------------------------------------------------------------------------------- + + real(r8) ,allocatable :: fates_hdim_levsclass(:) ! plant size class lower bound dimension + integer , allocatable :: fates_hdim_pfmap_levscpf(:) ! map of pfts into size-class x pft dimension + integer , allocatable :: fates_hdim_scmap_levscpf(:) ! map of size-class into size-class x pft dimension + real(r8), allocatable :: fates_hdim_levage(:) ! patch age lower bound dimension + integer , allocatable :: fates_hdim_levpft(:) ! plant pft dimension + integer , allocatable :: fates_hdim_levfuel(:) ! fire fuel class dimension + integer , allocatable :: fates_hdim_levcwdsc(:) ! cwd class dimension + integer , allocatable :: fates_hdim_levcan(:) ! canopy-layer dimension + integer , allocatable :: fates_hdim_canmap_levcnlf(:) ! canopy-layer map into the canopy-layer x leaf-layer dimension + integer , allocatable :: fates_hdim_lfmap_levcnlf(:) ! leaf-layer map into the canopy-layer x leaf-layer dimension + integer , allocatable :: fates_hdim_canmap_levcnlfpf(:) ! canopy-layer map into the canopy-layer x pft x leaf-layer dimension + integer , allocatable :: fates_hdim_lfmap_levcnlfpf(:) ! leaf-layer map into the canopy-layer x pft x leaf-layer dimension + integer , allocatable :: fates_hdim_pftmap_levcnlfpf(:) ! pft map into the canopy-layer x pft x leaf-layer dimension !************************************ @@ -547,46 +552,46 @@ subroutine ed_hist_scpfmaps integer :: ican integer :: ileaf - allocate( levsclass_ed(1:nlevsclass_ed )) - allocate( pft_levscpf_ed(1:nlevsclass_ed*mxpft)) - allocate(scls_levscpf_ed(1:nlevsclass_ed*mxpft)) - allocate( levpft_ed(1:mxpft )) - allocate( levfuel_ed(1:NFSC )) - allocate( levcwdsc_ed(1:NCWD )) - allocate( levage_ed(1:nlevage_ed )) - - allocate(levcan_ed(nclmax)) - allocate(can_levcnlf_ed(nlevleaf*nclmax)) - allocate(lf_levcnlf_ed(nlevleaf*nclmax)) - allocate(can_levcnlfpft_ed(nlevleaf*nclmax*numpft_ed)) - allocate(lf_levcnlfpft_ed(nlevleaf*nclmax*numpft_ed)) - allocate(pft_levcnlfpft_ed(nlevleaf*nclmax*numpft_ed)) + allocate( fates_hdim_levsclass(1:nlevsclass_ed )) + allocate( fates_hdim_pfmap_levscpf(1:nlevsclass_ed*mxpft)) + allocate( fates_hdim_scmap_levscpf(1:nlevsclass_ed*mxpft)) + allocate( fates_hdim_levpft(1:mxpft )) + allocate( fates_hdim_levfuel(1:NFSC )) + allocate( fates_hdim_levcwdsc(1:NCWD )) + allocate( fates_hdim_levage(1:nlevage_ed )) + + allocate( fates_hdim_levcan(nclmax)) + allocate( fates_hdim_canmap_levcnlf(nlevleaf*nclmax)) + allocate( fates_hdim_lfmap_levcnlf(nlevleaf*nclmax)) + allocate( fates_hdim_canmap_levcnlfpf(nlevleaf*nclmax*numpft_ed)) + allocate( fates_hdim_lfmap_levcnlfpf(nlevleaf*nclmax*numpft_ed)) + allocate( fates_hdim_pftmap_levcnlfpf(nlevleaf*nclmax*numpft_ed)) ! Fill the IO array of plant size classes ! For some reason the history files did not like ! a hard allocation of sclass_ed - levsclass_ed(:) = sclass_ed(:) + fates_hdim_levsclass(:) = sclass_ed(:) - levage_ed(:) = ageclass_ed(:) + fates_hdim_levage(:) = ageclass_ed(:) ! make pft array do ipft=1,mxpft - levpft_ed(ipft) = ipft + fates_hdim_levpft(ipft) = ipft end do ! make fuel array do ifuel=1,NFSC - levfuel_ed(ifuel) = ifuel + fates_hdim_levfuel(ifuel) = ifuel end do ! make cwd array do icwd=1,NCWD - levcwdsc_ed(icwd) = icwd + fates_hdim_levcwdsc(icwd) = icwd end do ! make canopy array do ican = 1,nclmax - levcan_ed(ican) = ican + fates_hdim_levcan(ican) = ican end do ! Fill the IO arrays that match pft and size class to their combined array @@ -594,8 +599,8 @@ subroutine ed_hist_scpfmaps do ipft=1,mxpft do isc=1,nlevsclass_ed i=i+1 - pft_levscpf_ed(i) = ipft - scls_levscpf_ed(i) = isc + fates_hdim_pfmap_levscpf(i) = ipft + fates_hdim_scmap_levscpf(i) = isc end do end do @@ -603,8 +608,8 @@ subroutine ed_hist_scpfmaps do ican=1,nclmax do ileaf=1,nlevleaf i=i+1 - can_levcnlf_ed(i) = ican - lf_levcnlf_ed(i) = ileaf + fates_hdim_canmap_levcnlf(i) = ican + fates_hdim_lfmap_levcnlf(i) = ileaf end do end do @@ -613,9 +618,9 @@ subroutine ed_hist_scpfmaps do ican=1,nclmax do ileaf=1,nlevleaf i=i+1 - can_levcnlfpft_ed(i) = ican - lf_levcnlfpft_ed(i) = ileaf - pft_levcnlfpft_ed(i) = ipft + fates_hdim_canmap_levcnlfpf(i) = ican + fates_hdim_lfmap_levcnlfpf(i) = ileaf + fates_hdim_pftmap_levcnlfpf(i) = ipft end do end do end do diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index ea1808c5..93513a9a 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -1005,10 +1005,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) AREA_INV, & sclass_ed, & nlevsclass_ed, & - levage_ed, & nlevage_ed, & mxpft, & - levpft_ed, & nfsc, & ncwd, & ican_upper, & diff --git a/main/FatesIODimensionsMod.F90 b/main/FatesIODimensionsMod.F90 index c118849d..b6b4e48d 100644 --- a/main/FatesIODimensionsMod.F90 +++ b/main/FatesIODimensionsMod.F90 @@ -4,19 +4,22 @@ module FatesIODimensionsMod implicit none - character(*), parameter :: cohort = 'cohort' - character(*), parameter :: patch = 'patch' - character(*), parameter :: column = 'column' - character(*), parameter :: levgrnd = 'levgrnd' - character(*), parameter :: levscpf = 'levscpf' - character(*), parameter :: levscls = 'levscls' - character(*), parameter :: levpft = 'levpft' - character(*), parameter :: levage = 'levage' - character(*), parameter :: levfuel = 'levfuel' - character(*), parameter :: levcwdsc = 'levcwdsc' - character(*), parameter :: levcan = 'levcan' - character(*), parameter :: levcnlf = 'levcnlf' - character(*), parameter :: levcnlfpft = 'lvcnlfpf' + ! The following dimension names must be replicated in + ! CLM/ALMs histFileMod.F90 and + + character(*), parameter :: cohort = 'cohort' ! matches clm_varcon + character(*), parameter :: patch = 'patch' ! matches clm_varcon + character(*), parameter :: column = 'column' ! matches clm_varcon + character(*), parameter :: levgrnd = 'levgrnd' ! matches clm_varcon + character(*), parameter :: levscpf = 'fates_levscpf' ! matches histFileMod + character(*), parameter :: levscls = 'fates_levscls' ! matches histFileMod + character(*), parameter :: levpft = 'fates_levpft' ! matches histFileMod + character(*), parameter :: levage = 'fates_levage' ! matches histFileMod + character(*), parameter :: levfuel = 'fates_levfuel' ! matches histFileMod + character(*), parameter :: levcwdsc = 'fates_levcwdsc' ! matches histFileMod + character(*), parameter :: levcan = 'fates_levcan' ! matches histFileMod + character(*), parameter :: levcnlf = 'fates_levcnlf' ! matches histFileMod + character(*), parameter :: levcnlfpft = 'fates_levcnlfpf' ! matches histFileMod ! patch = This is a structure that records where FATES patch boundaries ! on each thread point to in the host IO array, this structure From 2c1bab62678800967c9fc4ef9ff1c4ba07f75bad Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 16 Mar 2017 19:14:42 -0700 Subject: [PATCH 377/437] Added in the size x age dimension. Moved around and added functions that help identify size, age and type classes. --- biogeochem/EDCanopyStructureMod.F90 | 18 ++++--- biogeochem/EDCohortDynamicsMod.F90 | 25 ++-------- biogeochem/EDPatchDynamicsMod.F90 | 8 ++- main/EDMainMod.F90 | 3 +- main/EDTypesMod.F90 | 76 ++++++++++++++++++++++++++++- main/FatesHistoryInterfaceMod.F90 | 76 ++++++++++++++++++++++++----- main/FatesHistoryVariableType.F90 | 10 +++- main/FatesIODimensionsMod.F90 | 6 +++ main/FatesIOVariableKindMod.F90 | 1 + 9 files changed, 172 insertions(+), 51 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 6e3f34e0..7ff3b8e0 100755 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -735,7 +735,7 @@ subroutine canopy_summarization( nsites, sites, bc_in ) use FatesInterfaceMod , only : bc_in_type use EDPatchDynamicsMod , only : set_patchno use EDPatchDYnamicsMod , only : set_root_fraction - use EDCohortDynamicsMod , only : size_and_type_class_index + use EDTypesMod , only : sizetype_class_index use EDGrowthFunctionsMod , only : tree_lai, c_area use EDEcophysConType , only : EDecophyscon use EDtypesMod , only : area @@ -791,8 +791,8 @@ subroutine canopy_summarization( nsites, sites, bc_in ) ! Update the cohort's index within the size bin classes ! Update the cohort's index within the SCPF classification system - call size_and_type_class_index(currentCohort%dbh,currentCohort%pft, & - currentCohort%size_class,currentCohort%size_by_pft_class) + call sizetype_class_index(currentCohort%dbh,currentCohort%pft, & + currentCohort%size_class,currentCohort%size_by_pft_class) currentCohort%b = currentCohort%balive+currentCohort%bdead+currentCohort%bstore @@ -810,13 +810,16 @@ subroutine canopy_summarization( nsites, sites, bc_in ) ! Check for erroneous zero values. if(currentCohort%dbh <= 0._r8 .or. currentCohort%n == 0._r8)then - write(fates_log(),*) 'ED: dbh or n is zero in canopy_summarization', currentCohort%dbh,currentCohort%n + write(fates_log(),*) 'ED: dbh or n is zero in canopy_summarization', & + currentCohort%dbh,currentCohort%n endif if(currentCohort%pft == 0.or.currentCohort%canopy_trim <= 0._r8)then - write(fates_log(),*) 'ED: PFT or trim is zero in canopy_summarization',currentCohort%pft,currentCohort%canopy_trim + write(fates_log(),*) 'ED: PFT or trim is zero in canopy_summarization', & + currentCohort%pft,currentCohort%canopy_trim endif if(currentCohort%balive <= 0._r8)then - write(fates_log(),*) 'ED: balive is zero in canopy_summarization',currentCohort%balive + write(fates_log(),*) 'ED: balive is zero in canopy_summarization', & + currentCohort%balive endif currentCohort => currentCohort%taller @@ -824,7 +827,8 @@ subroutine canopy_summarization( nsites, sites, bc_in ) enddo ! ends 'do while(associated(currentCohort)) if ( currentPatch%total_canopy_area-currentPatch%area > 0.000001_r8 ) then - write(fates_log(),*) 'ED: canopy area bigger than area',currentPatch%total_canopy_area ,currentPatch%area + write(fates_log(),*) 'ED: canopy area bigger than area', & + currentPatch%total_canopy_area ,currentPatch%area currentPatch%total_canopy_area = currentPatch%area endif diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 274202a1..74cf8c3e 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -21,6 +21,7 @@ module EDCohortDynamicsMod use EDTypesMod , only : sclass_ed,nlevsclass_ed,AREA use EDTypesMod , only : min_npm2, min_nppatch use EDTypesMod , only : min_n_safemath + use EDTypesMod , only : sizetype_class_index ! CIME globals use shr_log_mod , only : errMsg => shr_log_errMsg ! @@ -36,7 +37,6 @@ module EDCohortDynamicsMod public :: sort_cohorts public :: copy_cohort public :: count_cohorts - public :: size_and_type_class_index public :: allocate_live_biomass logical, parameter :: DEBUG = .false. ! local debug flag @@ -105,8 +105,8 @@ subroutine create_cohort(patchptr, pft, nn, hite, dbh, & new_cohort%balive = balive new_cohort%bstore = bstore - call size_and_type_class_index(new_cohort%dbh,new_cohort%pft, & - new_cohort%size_class,new_cohort%size_by_pft_class) + call sizetype_class_index(new_cohort%dbh,new_cohort%pft, & + new_cohort%size_class,new_cohort%size_by_pft_class) if ( DEBUG ) write(fates_log(),*) 'EDCohortDyn I ',bstore @@ -1196,25 +1196,6 @@ function count_cohorts( currentPatch ) result ( backcount ) end function count_cohorts - ! ===================================================================================== - - subroutine size_and_type_class_index(dbh,pft,size_class,size_by_pft_class) - - use EDTypesMod, only: sclass_ed - use EDTypesMod, only: nlevsclass_ed - - ! Arguments - real(r8),intent(in) :: dbh - integer,intent(in) :: pft - integer,intent(out) :: size_class - integer,intent(out) :: size_by_pft_class - - size_class = count(dbh-sclass_ed.ge.0.0_r8) - - size_by_pft_class = (pft-1)*nlevsclass_ed+size_class - - return - end subroutine size_and_type_class_index diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 502d4880..dff9daeb 100755 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -37,7 +37,6 @@ module EDPatchDynamicsMod public :: check_patch_area public :: set_patchno public :: set_root_fraction - private:: fuse_2_patches @@ -1197,7 +1196,7 @@ subroutine fuse_2_patches(dp, rp) ! associated with the secnd patch ! ! !USES: - use EDTypesMod, only: ageclass_ed + use EDTypesMod, only: get_age_class_index ! ! !ARGUMENTS: type (ed_patch_type) , intent(inout), pointer :: dp ! Donor Patch @@ -1217,7 +1216,7 @@ subroutine fuse_2_patches(dp, rp) !area weighted average of ages & litter rp%age = (dp%age * dp%area + rp%age * rp%area)/(dp%area + rp%area) - rp%age_class = count(rp%age-ageclass_ed.ge.0.0_r8) + rp%age_class = get_age_class_index(rp%age) do p = 1,numpft_ed rp%seeds_in(p) = (rp%seeds_in(p)*rp%area + dp%seeds_in(p)*dp%area)/(rp%area + dp%area) @@ -1586,5 +1585,4 @@ subroutine set_root_fraction( cpatch , depth_gl ) end subroutine set_root_fraction - -end module EDPatchDynamicsMod + end module EDPatchDynamicsMod diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 780787e2..aed9edc5 100755 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -22,6 +22,7 @@ module EDMainMod use EDPatchDynamicsMod , only : fuse_patches use EDPatchDynamicsMod , only : spawn_patches use EDPatchDynamicsMod , only : terminate_patches + use EDTypesMod , only : get_age_class_index use EDPhysiologyMod , only : canopy_derivs use EDPhysiologyMod , only : non_canopy_derivs use EDPhysiologyMod , only : phenology @@ -190,7 +191,7 @@ subroutine ed_integrate_state_variables(currentSite, bc_in ) endif ! check to see if the patch has moved to the next age class - currentPatch%age_class = count(currentPatch%age-ageclass_ed.ge.0.0_r8) + currentPatch%age_class = get_age_class_index(currentPatch%age) ! Find the derivatives of the growth and litter processes. call canopy_derivs(currentSite, currentPatch, bc_in) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 5bdbe5b7..c150970a 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -130,7 +130,8 @@ module EDTypesMod integer , allocatable :: fates_hdim_canmap_levcnlfpf(:) ! canopy-layer map into the canopy-layer x pft x leaf-layer dimension integer , allocatable :: fates_hdim_lfmap_levcnlfpf(:) ! leaf-layer map into the canopy-layer x pft x leaf-layer dimension integer , allocatable :: fates_hdim_pftmap_levcnlfpf(:) ! pft map into the canopy-layer x pft x leaf-layer dimension - + integer , allocatable :: fates_hdim_scmap_levscag(:) ! map of size-class into size-class x patch age dimension + integer , allocatable :: fates_hdim_agmap_levscag(:) ! map of patch-age into size-class x patch age dimension !************************************ !** COHORT type structure ** @@ -551,6 +552,7 @@ subroutine ed_hist_scpfmaps integer :: ifuel integer :: ican integer :: ileaf + integer :: iage allocate( fates_hdim_levsclass(1:nlevsclass_ed )) allocate( fates_hdim_pfmap_levscpf(1:nlevsclass_ed*mxpft)) @@ -566,6 +568,8 @@ subroutine ed_hist_scpfmaps allocate( fates_hdim_canmap_levcnlfpf(nlevleaf*nclmax*numpft_ed)) allocate( fates_hdim_lfmap_levcnlfpf(nlevleaf*nclmax*numpft_ed)) allocate( fates_hdim_pftmap_levcnlfpf(nlevleaf*nclmax*numpft_ed)) + allocate( fates_hdim_scmap_levscag(nlevsclass_ed * nlevage_ed )) + allocate( fates_hdim_agmap_levscag(nlevsclass_ed * nlevage_ed )) ! Fill the IO array of plant size classes ! For some reason the history files did not like @@ -613,6 +617,15 @@ subroutine ed_hist_scpfmaps end do end do + i=0 + do iage=1,nlevage_ed + do isc=1,nlevsclass_ed + i=i+1 + fates_hdim_scmap_levscag(i) = isc + fates_hdim_agmap_levscag(i) = iage + end do + end do + i=0 do ipft=1,numpft_ed do ican=1,nclmax @@ -627,4 +640,65 @@ subroutine ed_hist_scpfmaps end subroutine ed_hist_scpfmaps + ! ===================================================================================== + + function get_age_class_index(age) result( patch_age_class ) + + real(r8), intent(in) :: age + + integer :: patch_age_class + + patch_age_class = count(age-ageclass_ed.ge.0.0_r8) + + end function get_age_class_index + + ! ===================================================================================== + + function get_sizeage_class_index(dbh,age) result(size_by_age_class) + + ! Arguments + real(r8),intent(in) :: dbh + real(r8),intent(in) :: age + + integer :: size_class + integer :: age_class + integer :: size_by_age_class + + size_class = get_size_class_index(dbh) + + age_class = get_age_class_index(age) + + size_by_age_class = (age_class-1)*nlevage_ed + size_class + + end function get_sizeage_class_index + + ! ===================================================================================== + + subroutine sizetype_class_index(dbh,pft,size_class,size_by_pft_class) + + ! Arguments + real(r8),intent(in) :: dbh + integer,intent(in) :: pft + integer,intent(out) :: size_class + integer,intent(out) :: size_by_pft_class + + size_class = get_size_class_index(dbh) + + size_by_pft_class = (pft-1)*nlevsclass_ed+size_class + + return + end subroutine sizetype_class_index + + ! ===================================================================================== + + function get_size_class_index(dbh) result(cohort_size_class) + + real(r8), intent(in) :: dbh + + integer :: cohort_size_class + + cohort_size_class = count(dbh-sclass_ed.ge.0.0_r8) + + end function get_size_class_index + end module EDTypesMod diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 93513a9a..098ef3a7 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -76,6 +76,9 @@ module FatesHistoryInterfaceMod integer, private :: ih_canopy_biomass_pa integer, private :: ih_understory_biomass_pa + ! Indices to site by size-class by pft variables + integer, private :: ih_nplant_si_scag + ! Indices to (site) variables integer, private :: ih_nep_si integer, private :: ih_nep_timeintegrated_si @@ -265,8 +268,8 @@ module FatesHistoryInterfaceMod integer, private :: ih_fabi_sha_top_si_can ! The number of variable dim/kind types we have defined (static) - integer, parameter :: fates_history_num_dimensions = 12 - integer, parameter :: fates_history_num_dim_kinds = 14 + integer, parameter :: fates_history_num_dimensions = 13 + integer, parameter :: fates_history_num_dim_kinds = 15 @@ -301,7 +304,7 @@ module FatesHistoryInterfaceMod integer, private :: patch_index_, column_index_, levgrnd_index_, levscpf_index_ integer, private :: levscls_index_, levpft_index_, levage_index_ - integer, private :: levfuel_index_, levcwdsc_index_ + integer, private :: levfuel_index_, levcwdsc_index_, levscag_index_ integer, private :: levcan_index_, levcnlf_index_, levcnlfpft_index_ contains @@ -328,6 +331,7 @@ module FatesHistoryInterfaceMod procedure, public :: levcan_index procedure, public :: levcnlf_index procedure, public :: levcnlfpft_index + procedure, public :: levscag_index ! private work functions procedure, private :: define_history_vars @@ -348,6 +352,7 @@ module FatesHistoryInterfaceMod procedure, private :: set_levcan_index procedure, private :: set_levcnlf_index procedure, private :: set_levcnlfpft_index + procedure, private :: set_levscag_index end type fates_history_interface_type @@ -361,7 +366,7 @@ subroutine Init(this, num_threads, fates_bounds) use FatesIODimensionsMod, only : patch, column, levgrnd, levscpf use FatesIODimensionsMod, only : levscls, levpft, levage - use FatesIODimensionsMod, only : levfuel, levcwdsc + use FatesIODimensionsMod, only : levfuel, levcwdsc, levscag use FatesIODimensionsMod, only : levcan, levcnlf, levcnlfpft use FatesIODimensionsMod, only : fates_bounds_type @@ -433,6 +438,12 @@ subroutine Init(this, num_threads, fates_bounds) call this%dim_bounds(dim_count)%Init(levcnlfpft, num_threads, & fates_bounds%cnlfpft_begin, fates_bounds%cnlfpft_end) + dim_count = dim_count + 1 + call this%set_levscag_index(dim_count) + call this%dim_bounds(dim_count)%Init(levscag, num_threads, & + fates_bounds%sizeage_class_begin, fates_bounds%sizeage_class_end) + + ! FIXME(bja, 2016-10) assert(dim_count == FatesHistorydimensionmod::num_dimension_types) ! Allocate the mapping between FATES indices and the IO indices @@ -500,7 +511,11 @@ subroutine SetThreadBoundsEach(this, thread_index, thread_bounds) index = this%levcnlfpft_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & - thread_bounds%cnlfpft_begin, thread_bounds%cnlfpft_end) + thread_bounds%cnlfpft_begin, thread_bounds%cnlfpft_end) + + index = this%levscag_index() + call this%dim_bounds(index)%SetThreadBounds(thread_index, & + thread_bounds%sizeage_class_begin, thread_bounds%sizeage_class_end) end subroutine SetThreadBoundsEach @@ -510,7 +525,7 @@ subroutine assemble_history_output_types(this) use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8 use FatesIOVariableKindMod, only : site_size_r8, site_pft_r8, site_age_r8 - use FatesIOVariableKindMod, only : site_fuel_r8, site_cwdsc_r8 + use FatesIOVariableKindMod, only : site_fuel_r8, site_cwdsc_r8, site_scag_r8 use FatesIOVariableKindMod, only : site_can_r8, site_cnlf_r8, site_cnlfpft_r8 implicit none @@ -559,6 +574,9 @@ subroutine assemble_history_output_types(this) call this%set_dim_indices(site_cnlfpft_r8, 1, this%column_index()) call this%set_dim_indices(site_cnlfpft_r8, 2, this%levcnlfpft_index()) + call this%set_dim_indices(site_scag_r8, 1, this%column_index()) + call this%set_dim_indices(site_scag_r8, 2, this%levscag_index()) + end subroutine assemble_history_output_types ! =================================================================================== @@ -769,7 +787,22 @@ integer function levcnlfpft_index(this) class(fates_history_interface_type), intent(in) :: this levcnlfpft_index = this%levcnlfpft_index_ end function levcnlfpft_index + ! ====================================================================================== + subroutine set_levscag_index(this, index) + implicit none + class(fates_history_interface_type), intent(inout) :: this + integer, intent(in) :: index + this%levscag_index_ = index + end subroutine set_levscag_index + + integer function levscag_index(this) + implicit none + class(fates_history_interface_type), intent(in) :: this + levscag_index = this%levscag_index_ + end function levscag_index + ! ====================================================================================== + subroutine flush_hvars(this,nc,upfreq_in) @@ -863,7 +896,7 @@ subroutine init_dim_kinds_maps(this) use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8 use FatesIOVariableKindMod, only : site_size_r8, site_pft_r8, site_age_r8 - use FatesIOVariableKindMod, only : site_fuel_r8, site_cwdsc_r8 + use FatesIOVariableKindMod, only : site_fuel_r8, site_cwdsc_r8, site_scag_r8 use FatesIOVariableKindMod, only : site_can_r8, site_cnlf_r8, site_cnlfpft_r8 implicit none @@ -930,6 +963,10 @@ subroutine init_dim_kinds_maps(this) index = index + 1 call this%dim_kinds(index)%Init(site_cnlfpft_r8, 2) + ! site x size-class x age class + index = index + 1 + call this%dim_kinds(index)%Init(site_scag_r8, 2) + ! FIXME(bja, 2016-10) assert(index == fates_history_num_dim_kinds) end subroutine init_dim_kinds_maps @@ -1003,7 +1040,6 @@ subroutine update_history_dyn(this,nc,nsites,sites) ed_patch_type, & AREA, & AREA_INV, & - sclass_ed, & nlevsclass_ed, & nlevage_ed, & mxpft, & @@ -1012,7 +1048,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) ican_upper, & ican_ustory - use EDParamsMod , only : ED_val_ag_biomass + use EDParamsMod , only : ED_val_ag_biomass + use EDTypesMod , only : get_sizeage_class_index ! Arguments class(fates_history_interface_type) :: this @@ -1032,7 +1069,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) integer :: ft ! functional type index integer :: i_scpf,i_pft,i_scls ! iterators for scpf, pft, and scls dims integer :: i_cwd,i_fuel ! iterators for cwd and fuel dims - + integer :: iscag ! size-class x age index + real(r8) :: n_density ! individual of cohort per m2. real(r8) :: n_perm2 ! individuals per m2 for the whole column real(r8) :: patch_scaling_scalar ! ratio of canopy to patch area for counteracting patch scaling @@ -1166,7 +1204,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_cwd_ag_in_si_cwdsc => this%hvars(ih_cwd_ag_in_si_cwdsc)%r82d, & hio_cwd_bg_in_si_cwdsc => this%hvars(ih_cwd_bg_in_si_cwdsc)%r82d, & hio_cwd_ag_out_si_cwdsc => this%hvars(ih_cwd_ag_out_si_cwdsc)%r82d, & - hio_cwd_bg_out_si_cwdsc => this%hvars(ih_cwd_bg_out_si_cwdsc)%r82d) + hio_cwd_bg_out_si_cwdsc => this%hvars(ih_cwd_bg_out_si_cwdsc)%r82d, & + hio_nplant_si_scag => this%hvars(ih_nplant_si_scag)%r82d) ! --------------------------------------------------------------------------------- @@ -1346,6 +1385,12 @@ subroutine update_history_dyn(this,nc,nsites,sites) ccohort%ddbhdt*ccohort%n end if + ! update size-class x patch-age related quantities + + iscag = get_sizeage_class_index(ccohort%dbh,cpatch%age) + + hio_nplant_si_scag(io_si,iscag) = hio_nplant_si_scag(io_si,iscag) + ccohort%n + ! update SCPF/SCLS- and canopy/subcanopy- partitioned quantities if (ccohort%canopy_layer .eq. 1) then hio_bstor_canopy_si_scpf(io_si,scpf) = hio_bstor_canopy_si_scpf(io_si,scpf) + & @@ -1649,7 +1694,6 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) AREA, & AREA_INV, & nlevage_ed, & - sclass_ed, & nlevsclass_ed use EDTypesMod, only : numpft_ed, nclmax, nlevleaf ! @@ -2033,7 +2077,7 @@ subroutine define_history_vars(this, initialize_variables) use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8 use FatesIOVariableKindMod, only : site_size_r8, site_pft_r8, site_age_r8 - use FatesIOVariableKindMod, only : site_fuel_r8, site_cwdsc_r8 + use FatesIOVariableKindMod, only : site_fuel_r8, site_cwdsc_r8, site_scag_r8 use FatesIOVariableKindMod, only : site_can_r8, site_cnlf_r8, site_cnlfpft_r8 implicit none @@ -2503,6 +2547,12 @@ subroutine define_history_vars(this, initialize_variables) upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_understory_mortality_carbonflux_si ) + call this%set_history_var(vname='NPLANT_SCAG',units = 'plants/ha', & + long='number of plants per hectare in each size x age class', use_default='active', & + avgflag='A', vtype=site_scag_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_si_scag ) + + ! Carbon Flux (grid dimension x scpf) (THESE ARE DEFAULT INACTIVE!!! ! (BECAUSE THEY TAKE UP SPACE!!! ! =================================================================================== diff --git a/main/FatesHistoryVariableType.F90 b/main/FatesHistoryVariableType.F90 index cbcc25b8..eca19a31 100644 --- a/main/FatesHistoryVariableType.F90 +++ b/main/FatesHistoryVariableType.F90 @@ -46,7 +46,7 @@ subroutine Init(this, vname, units, long, use_default, & use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8 use FatesIOVariableKindMod, only : site_size_r8, site_pft_r8, site_age_r8 - use FatesIOVariableKindMod, only : site_fuel_r8, site_cwdsc_r8 + use FatesIOVariableKindMod, only : site_fuel_r8, site_cwdsc_r8, site_scag_r8 use FatesIOVariableKindMod, only : site_can_r8, site_cnlf_r8, site_cnlfpft_r8 use FatesIOVariableKindMod, only : iotype_index @@ -153,6 +153,10 @@ subroutine Init(this, vname, units, long, use_default, & allocate(this%r82d(lb1:ub1, lb2:ub2)) this%r82d(:,:) = flushval + case(site_scag_r8) + allocate(this%r82d(lb1:ub1, lb2:ub2)) + this%r82d(:,:) = flushval + case default write(fates_log(),*) 'Incompatible vtype passed to set_history_var' write(fates_log(),*) 'vtype = ',trim(vtype),' ?' @@ -219,7 +223,7 @@ subroutine Flush(this, thread, dim_bounds, dim_kinds) use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8, patch_int use FatesIOVariableKindMod, only : site_size_r8, site_pft_r8, site_age_r8 - use FatesIOVariableKindMod, only : site_fuel_r8, site_cwdsc_r8 + use FatesIOVariableKindMod, only : site_fuel_r8, site_cwdsc_r8, site_scag_r8 use FatesIOVariableKindMod, only : site_can_r8, site_cnlf_r8, site_cnlfpft_r8 implicit none @@ -262,6 +266,8 @@ subroutine Flush(this, thread, dim_bounds, dim_kinds) this%r82d(lb1:ub1, lb2:ub2) = this%flushval case(site_cnlfpft_r8) this%r82d(lb1:ub1, lb2:ub2) = this%flushval + case(site_scag_r8) + this%r82d(lb1:ub1, lb2:ub2) = this%flushval case(patch_int) this%int1d(lb1:ub1) = nint(this%flushval) case default diff --git a/main/FatesIODimensionsMod.F90 b/main/FatesIODimensionsMod.F90 index b6b4e48d..1dd5cce0 100644 --- a/main/FatesIODimensionsMod.F90 +++ b/main/FatesIODimensionsMod.F90 @@ -11,6 +11,7 @@ module FatesIODimensionsMod character(*), parameter :: patch = 'patch' ! matches clm_varcon character(*), parameter :: column = 'column' ! matches clm_varcon character(*), parameter :: levgrnd = 'levgrnd' ! matches clm_varcon + character(*), parameter :: levscag = 'fates_levscag' ! matches histFileMod character(*), parameter :: levscpf = 'fates_levscpf' ! matches histFileMod character(*), parameter :: levscls = 'fates_levscls' ! matches histFileMod character(*), parameter :: levpft = 'fates_levpft' ! matches histFileMod @@ -59,6 +60,9 @@ module FatesIODimensionsMod ! levcnlfpft = This is a structure that records the boundaries for the ! number of canopy layer x leaf layer x pft dimension + ! levscag = This is a strcture that records the boundaries for the + ! number of size-classes x patch age + type, public :: fates_bounds_type integer :: patch_begin @@ -69,6 +73,8 @@ module FatesIODimensionsMod integer :: column_end ! we call this a "site" (rgk 11-2016) integer :: ground_begin integer :: ground_end + integer :: sizeage_class_begin + integer :: sizeage_class_end integer :: sizepft_class_begin integer :: sizepft_class_end integer :: size_class_begin diff --git a/main/FatesIOVariableKindMod.F90 b/main/FatesIOVariableKindMod.F90 index 3261c35d..25e2f2bc 100644 --- a/main/FatesIOVariableKindMod.F90 +++ b/main/FatesIOVariableKindMod.F90 @@ -27,6 +27,7 @@ module FatesIOVariableKindMod character(*), parameter :: site_can_r8 = 'SI_CAN_R8' character(*), parameter :: site_cnlf_r8 = 'SI_CNLF_R8' character(*), parameter :: site_cnlfpft_r8 = 'SI_CNLFPFT_R8' + character(*), parameter :: site_scag_r8 = 'SI_SCAG_R8' ! NOTE(RGK, 2016) %active is not used yet. Was intended as a check on the HLM->FATES ! control parameter passing to ensure all active dimension types received all From 01a7a6c24824c02952ed755f27ea103e81136123 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 16 Mar 2017 19:21:48 -0700 Subject: [PATCH 378/437] Some bug fixes for the new dimension addition. Also set all multi-plexed dimensions to defautl inactive. --- main/FatesHistoryInterfaceMod.F90 | 67 ++++++++++++++++--------------- 1 file changed, 34 insertions(+), 33 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 098ef3a7..02e5ad51 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -2350,12 +2350,12 @@ subroutine define_history_vars(this, initialize_variables) ! fast fluxes by age bin call this%set_history_var(vname='NPP_BY_AGE', units='gC/m^2/s', & - long='net primary productivity by age bin', use_default='active', & + long='net primary productivity by age bin', use_default='inactive', & avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & ivar=ivar, initialize=initialize_variables, index = ih_npp_si_age ) call this%set_history_var(vname='GPP_BY_AGE', units='gC/m^2/s', & - long='gross primary productivity by age bin', use_default='active', & + long='gross primary productivity by age bin', use_default='inactive', & avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & ivar=ivar, initialize=initialize_variables, index = ih_gpp_si_age ) @@ -2371,7 +2371,7 @@ subroutine define_history_vars(this, initialize_variables) ivar=ivar, initialize=initialize_variables, index = ih_ar_canopy_pa ) call this%set_history_var(vname='GPP_UNDERSTORY', units='gC/m^2/s', & - long='gross primary production of understory plants', use_default='active', & + long='gross primary production of understory plants', use_default='inactive', & avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & ivar=ivar, initialize=initialize_variables, index = ih_gpp_understory_pa ) @@ -2380,16 +2380,17 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & ivar=ivar, initialize=initialize_variables, index = ih_ar_understory_pa ) + ! fast radiative fluxes resolved through the canopy call this%set_history_var(vname='PARSUN_Z_CNLF', units='W/m2', & long='PAR absorbed in the sun by each canopy and leaf layer', & - use_default='active', & + use_default='inactive', & avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & ivar=ivar, initialize=initialize_variables, index = ih_parsun_z_si_cnlf ) call this%set_history_var(vname='PARSHA_Z_CNLF', units='W/m2', & long='PAR absorbed in the shade by each canopy and leaf layer', & - use_default='active', & + use_default='inactive', & avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & ivar=ivar, initialize=initialize_variables, index = ih_parsha_z_si_cnlf ) @@ -2407,25 +2408,25 @@ subroutine define_history_vars(this, initialize_variables) call this%set_history_var(vname='PARSUN_Z_CAN', units='W/m2', & long='PAR absorbed in the sun by top leaf layer in each canopy layer', & - use_default='active', & + use_default='inactive', & avgflag='A', vtype=site_can_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & ivar=ivar, initialize=initialize_variables, index = ih_parsun_top_si_can ) call this%set_history_var(vname='PARSHA_Z_CAN', units='W/m2', & long='PAR absorbed in the shade by top leaf layer in each canopy layer', & - use_default='active', & + use_default='inactive', & avgflag='A', vtype=site_can_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & ivar=ivar, initialize=initialize_variables, index = ih_parsha_top_si_can ) call this%set_history_var(vname='LAISUN_Z_CNLF', units='m2/m2', & long='LAI in the sun by each canopy and leaf layer', & - use_default='active', & + use_default='inactive', & avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & ivar=ivar, initialize=initialize_variables, index = ih_laisun_z_si_cnlf ) call this%set_history_var(vname='LAISHA_Z_CNLF', units='m2/m2', & long='LAI in the shade by each canopy and leaf layer', & - use_default='active', & + use_default='inactive', & avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & ivar=ivar, initialize=initialize_variables, index = ih_laisha_z_si_cnlf ) @@ -2443,13 +2444,13 @@ subroutine define_history_vars(this, initialize_variables) call this%set_history_var(vname='LAISUN_TOP_CAN', units='m2/m2', & long='LAI in the sun by the top leaf layer of each canopy layer', & - use_default='active', & + use_default='inactive', & avgflag='A', vtype=site_can_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & ivar=ivar, initialize=initialize_variables, index = ih_laisun_top_si_can ) call this%set_history_var(vname='LAISHA_TOP_CAN', units='m2/m2', & long='LAI in the shade by the top leaf layer of each canopy layer', & - use_default='active', & + use_default='inactive', & avgflag='A', vtype=site_can_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & ivar=ivar, initialize=initialize_variables, index = ih_laisha_top_si_can ) @@ -2479,49 +2480,49 @@ subroutine define_history_vars(this, initialize_variables) call this%set_history_var(vname='FABD_SUN_CNLF', units='fraction', & long='sun fraction of direct light absorbed by each canopy and leaf layer', & - use_default='active', & + use_default='inactive', & avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & ivar=ivar, initialize=initialize_variables, index = ih_fabd_sun_si_cnlf ) call this%set_history_var(vname='FABD_SHA_CNLF', units='fraction', & long='shade fraction of direct light absorbed by each canopy and leaf layer', & - use_default='active', & + use_default='inactive', & avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & ivar=ivar, initialize=initialize_variables, index = ih_fabd_sha_si_cnlf ) call this%set_history_var(vname='FABI_SUN_CNLF', units='fraction', & long='sun fraction of indirect light absorbed by each canopy and leaf layer', & - use_default='active', & + use_default='inactive', & avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & ivar=ivar, initialize=initialize_variables, index = ih_fabi_sun_si_cnlf ) call this%set_history_var(vname='FABI_SHA_CNLF', units='fraction', & long='shade fraction of indirect light absorbed by each canopy and leaf layer', & - use_default='active', & + use_default='inactive', & avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & ivar=ivar, initialize=initialize_variables, index = ih_fabi_sha_si_cnlf ) call this%set_history_var(vname='FABD_SUN_TOPLF_BYCANLAYER', units='fraction', & long='sun fraction of direct light absorbed by the top leaf layer of each canopy layer', & - use_default='active', & + use_default='inactive', & avgflag='A', vtype=site_can_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & ivar=ivar, initialize=initialize_variables, index = ih_fabd_sun_top_si_can ) call this%set_history_var(vname='FABD_SHA_TOPLF_BYCANLAYER', units='fraction', & long='shade fraction of direct light absorbed by the top leaf layer of each canopy layer', & - use_default='active', & + use_default='inactive', & avgflag='A', vtype=site_can_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & ivar=ivar, initialize=initialize_variables, index = ih_fabd_sha_top_si_can ) call this%set_history_var(vname='FABI_SUN_TOPLF_BYCANLAYER', units='fraction', & long='sun fraction of indirect light absorbed by the top leaf layer of each canopy layer', & - use_default='active', & + use_default='inactive', & avgflag='A', vtype=site_can_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & ivar=ivar, initialize=initialize_variables, index = ih_fabi_sun_top_si_can ) call this%set_history_var(vname='FABI_SHA_TOPLF_BYCANLAYER', units='fraction', & long='shade fraction of indirect light absorbed by the top leaf layer of each canopy layer', & - use_default='active', & + use_default='inactive', & avgflag='A', vtype=site_can_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & ivar=ivar, initialize=initialize_variables, index = ih_fabi_sha_top_si_can ) @@ -2548,7 +2549,7 @@ subroutine define_history_vars(this, initialize_variables) call this%set_history_var(vname='NPLANT_SCAG',units = 'plants/ha', & - long='number of plants per hectare in each size x age class', use_default='active', & + long='number of plants per hectare in each size x age class', use_default='inactive', & avgflag='A', vtype=site_scag_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_si_scag ) @@ -2724,32 +2725,32 @@ subroutine define_history_vars(this, initialize_variables) upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_understory_si_scpf ) call this%set_history_var(vname='CWD_AG_CWDSC', units='gC/m^2', & - long='size-resolved AG CWD stocks', use_default='active', & + long='size-resolved AG CWD stocks', use_default='inactive', & avgflag='A', vtype=site_cwdsc_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_ag_si_cwdsc ) call this%set_history_var(vname='CWD_BG_CWDSC', units='gC/m^2', & - long='size-resolved BG CWD stocks', use_default='active', & + long='size-resolved BG CWD stocks', use_default='inactive', & avgflag='A', vtype=site_cwdsc_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_bg_si_cwdsc ) call this%set_history_var(vname='CWD_AG_IN_CWDSC', units='gC/m^2/y', & - long='size-resolved AG CWD input', use_default='active', & + long='size-resolved AG CWD input', use_default='inactive', & avgflag='A', vtype=site_cwdsc_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_ag_in_si_cwdsc ) call this%set_history_var(vname='CWD_BG_IN_CWDSC', units='gC/m^2/y', & - long='size-resolved BG CWD input', use_default='active', & + long='size-resolved BG CWD input', use_default='inactive', & avgflag='A', vtype=site_cwdsc_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_bg_in_si_cwdsc ) call this%set_history_var(vname='CWD_AG_OUT_CWDSC', units='gC/m^2/y', & - long='size-resolved AG CWD output', use_default='active', & + long='size-resolved AG CWD output', use_default='inactive', & avgflag='A', vtype=site_cwdsc_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_ag_out_si_cwdsc ) call this%set_history_var(vname='CWD_BG_OUT_CWDSC', units='gC/m^2/y', & - long='size-resolved BG CWD output', use_default='active', & + long='size-resolved BG CWD output', use_default='inactive', & avgflag='A', vtype=site_cwdsc_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_bg_out_si_cwdsc ) @@ -2803,37 +2804,37 @@ subroutine define_history_vars(this, initialize_variables) upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_yesterdaycanopylevel_understory_si_scls ) call this%set_history_var(vname='BA_SCLS', units = 'm2/ha', & - long='basal area by size class', use_default='active', & + long='basal area by size class', use_default='inactive', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ba_si_scls ) call this%set_history_var(vname='DEMOTION_RATE_SCLS', units = 'indiv/ha/yr', & - long='demotion rate from canopy to understory by size class', use_default='active', & + long='demotion rate from canopy to understory by size class', use_default='inactive', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_demotion_rate_si_scls ) call this%set_history_var(vname='PROMOTION_RATE_SCLS', units = 'indiv/ha/yr', & - long='promotion rate from understory to canopy by size class', use_default='active', & + long='promotion rate from understory to canopy by size class', use_default='inactive', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_promotion_rate_si_scls ) call this%set_history_var(vname='NPLANT_CANOPY_SCLS', units = 'indiv/ha', & - long='number of canopy plants by size class', use_default='active', & + long='number of canopy plants by size class', use_default='inactive', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_canopy_si_scls ) call this%set_history_var(vname='MORTALITY_CANOPY_SCLS', units = 'indiv/ha/yr', & - long='total mortality of canopy trees by size class', use_default='active', & + long='total mortality of canopy trees by size class', use_default='inactive', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_mortality_canopy_si_scls ) call this%set_history_var(vname='NPLANT_UNDERSTORY_SCLS', units = 'indiv/ha', & - long='number of understory plants by size class', use_default='active', & + long='number of understory plants by size class', use_default='inactive', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_understory_si_scls ) call this%set_history_var(vname='MORTALITY_UNDERSTORY_SCLS', units = 'indiv/ha/yr', & - long='total mortality of understory trees by size class', use_default='active', & + long='total mortality of understory trees by size class', use_default='inactive', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_mortality_understory_si_scls ) From eba56a3a6a6f31b2a706917c8cf81e74c92c89ae Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 17 Mar 2017 17:30:38 -0700 Subject: [PATCH 379/437] Added in the dleaf, zom and displar fates parameters. --- biogeochem/EDCanopyStructureMod.F90 | 9 +++++---- main/EDPftvarcon.F90 | 29 +++++++++++++++++++++++++++++ 2 files changed, 34 insertions(+), 4 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index d911c6f6..25eedcdc 100755 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1226,7 +1226,8 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) use FatesInterfaceMod , only : bc_out_type use PatchType , only : patch use ColumnType , only : col - use pftconMod , only : pftcon + use EDPftvarcon , only : EDPftvarcon_inst + ! ! !ARGUMENTS @@ -1269,9 +1270,9 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) ! previous code, before calculating more reasonable values. p = col%patchi(c) + ifp - bc_out(s)%z0m_pa(ifp) = pftcon%z0mr(patch%itype(p)) * bc_out(s)%htop_pa(ifp) - bc_out(s)%displa_pa(ifp) = pftcon%displar(patch%itype(p)) * bc_out(s)%htop_pa(ifp) - bc_out(s)%dleaf_pa(ifp) = pftcon%dleaf(patch%itype(p)) + bc_out(s)%z0m_pa(ifp) = EDPftvarcon_inst%z0mr(patch%itype(p)) * bc_out(s)%htop_pa(ifp) + bc_out(s)%displa_pa(ifp) = EDPftvarcon_inst%displar(patch%itype(p)) * bc_out(s)%htop_pa(ifp) + bc_out(s)%dleaf_pa(ifp) = EDPftvarcon_inst%dleaf(patch%itype(p)) ! bc_out(s)%z0m_pa(ifp) = pftcon%z0mr(1) * bc_out(s)%htop_pa(ifp) ! bc_out(s)%displa_pa(ifp) = pftcon%displar(1) * bc_out(s)%htop_pa(ifp) diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index b60586c8..8ead290b 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -26,6 +26,9 @@ module EDPftvarcon real(r8), allocatable :: wood_density (:) ! wood density g cm^-3 ... real(r8), allocatable :: alpha_stem (:) ! live stem turnover rate. y-1 real(r8), allocatable :: hgt_min (:) ! sapling height m + real(r8), allocatable :: dleaf (:) ! leaf characteristic dimension length (m) + real(r8), allocatable :: z0mr (:) ! ratio of roughness length of vegetation to height (-) + real(r8), allocatable :: displar (:) ! ratio of displacement height to canopy top height (-) real(r8), allocatable :: cushion (:) ! labile carbon storage target as multiple of leaf pool. real(r8), allocatable :: leaf_stor_priority (:) ! leaf turnover vs labile carbon use prioritisation. (1 = lose leaves, 0 = use store). real(r8), allocatable :: leafwatermax (:) ! degree to which respiration is limited by btran if btran = 0 @@ -339,7 +342,20 @@ subroutine Register_PFT(this, fates_params) call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) + name = 'fates_dleaf' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_z0mr' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + name = 'fates_displar' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + + end subroutine Register_PFT !----------------------------------------------------------------------- @@ -538,6 +554,19 @@ subroutine Receive_PFT(this, fates_params) call fates_params%RetreiveParameterAllocate(name=name, & data=this%grperc) + name = 'fates_dleaf' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%dleaf) + + name = 'fates_z0mr' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%z0mr) + + name = 'fates_displar' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%displar) + + end subroutine Receive_PFT !----------------------------------------------------------------------- From b1d180b34f283bdac7dd9609e15df4760fc50b67 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 17 Mar 2017 17:35:55 -0700 Subject: [PATCH 380/437] Addressed leap-year issue with the days-per-year constant. CLM/ALM have not leap day, corrected accordingly. --- main/FatesConstantsMod.F90 | 9 +++++++-- main/FatesHistoryInterfaceMod.F90 | 4 ++-- 2 files changed, 9 insertions(+), 4 deletions(-) diff --git a/main/FatesConstantsMod.F90 b/main/FatesConstantsMod.F90 index d48dee8d..e126c469 100644 --- a/main/FatesConstantsMod.F90 +++ b/main/FatesConstantsMod.F90 @@ -54,11 +54,16 @@ module FatesConstantsMod real(fates_r8), parameter :: days_per_sec = 1.0_fates_r8/86400.0_fates_r8 ! Conversion: days per year - real(fates_r8), parameter :: days_per_year = 365.25_fates_r8 + real(fates_r8), parameter :: days_per_year_noleap = 365.00_fates_r8 ! Conversion: years per day - real(fates_r8), parameter :: years_per_day = 1.0_fates_r8/365.25_fates_r8 + real(fates_r8), parameter :: years_per_day_noleap = 1.0_fates_r8/365.00_fates_r8 + ! Conversion: days per year + real(fates_r8), parameter :: days_per_year_leap = 365.25_fates_r8 + + ! Conversion: years per day + real(fates_r8), parameter :: years_per_day_leap = 1.0_fates_r8/365.25_fates_r8 ! Physical constants diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 02e5ad51..d48e6392 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -17,8 +17,8 @@ module FatesHistoryInterfaceMod use FatesConstantsMod, only : ha_per_m2 use FatesConstantsMod, only : days_per_sec use FatesConstantsMod, only : sec_per_day - use FatesConstantsMod, only : days_per_year - use FatesConstantsMod, only : years_per_day + use FatesConstantsMod, only : days_per_year => days_per_year_noleap + use FatesConstantsMod, only : years_per_day => years_per_day_noleap implicit none From 554869b8958c4010307bb24f87c1bc2ccf235409 Mon Sep 17 00:00:00 2001 From: ckoven Date: Mon, 20 Mar 2017 15:05:32 -0700 Subject: [PATCH 381/437] got rid of leap_year calendar constant and also gave the dim-name character length a proper name --- main/FatesConstantsMod.F90 | 14 ++++---------- main/FatesHistoryInterfaceMod.F90 | 4 ++-- 2 files changed, 6 insertions(+), 12 deletions(-) diff --git a/main/FatesConstantsMod.F90 b/main/FatesConstantsMod.F90 index e126c469..414bc5ff 100644 --- a/main/FatesConstantsMod.F90 +++ b/main/FatesConstantsMod.F90 @@ -53,18 +53,12 @@ module FatesConstantsMod ! Conversion: days per second real(fates_r8), parameter :: days_per_sec = 1.0_fates_r8/86400.0_fates_r8 - ! Conversion: days per year - real(fates_r8), parameter :: days_per_year_noleap = 365.00_fates_r8 + ! Conversion: days per year. assume HLM uses 365 day calendar. If we need to link to 365.25-day-calendared HLM, rewire to pass through interface + real(fates_r8), parameter :: days_per_year = 365.00_fates_r8 - ! Conversion: years per day - real(fates_r8), parameter :: years_per_day_noleap = 1.0_fates_r8/365.00_fates_r8 + ! Conversion: years per day. assume HLM uses 365 day calendar. If we need to link to 365.25-day-calendared HLM, rewire to pass through interface + real(fates_r8), parameter :: years_per_day = 1.0_fates_r8/365.00_fates_r8 - ! Conversion: days per year - real(fates_r8), parameter :: days_per_year_leap = 365.25_fates_r8 - - ! Conversion: years per day - real(fates_r8), parameter :: years_per_day_leap = 1.0_fates_r8/365.25_fates_r8 - ! Physical constants ! universal gas constant [J/K/kmol] diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index d48e6392..02e5ad51 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -17,8 +17,8 @@ module FatesHistoryInterfaceMod use FatesConstantsMod, only : ha_per_m2 use FatesConstantsMod, only : days_per_sec use FatesConstantsMod, only : sec_per_day - use FatesConstantsMod, only : days_per_year => days_per_year_noleap - use FatesConstantsMod, only : years_per_day => years_per_day_noleap + use FatesConstantsMod, only : days_per_year + use FatesConstantsMod, only : years_per_day implicit none From c390e3a26148ac4ecb613b567b56549eb35185cd Mon Sep 17 00:00:00 2001 From: ckoven Date: Fri, 24 Mar 2017 14:31:06 -0700 Subject: [PATCH 382/437] put named unit conversion factor in --- main/FatesHistoryInterfaceMod.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 6a20fffd..640d288b 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -1545,11 +1545,11 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! put litter_in flux onto site level variable so as to be able to append site-level distubance-related input flux after patch loop hio_litter_in_si(io_si) = hio_litter_in_si(io_si) + & (sum(cpatch%CWD_AG_in) +sum(cpatch%leaf_litter_in) + sum(cpatch%root_litter_in)) & - * 1.e3_r8 * cpatch%area * AREA_INV * years_per_day * days_per_sec + * g_per_kg * cpatch%area * AREA_INV * years_per_day * days_per_sec ! keep litter_out at patch level hio_litter_out_pa(io_pa) = (sum(cpatch%CWD_AG_out)+sum(cpatch%leaf_litter_out) & + sum(cpatch%root_litter_out)) & - * 1.e3_r8 * patch_scaling_scalar * years_per_day * days_per_sec + * g_per_kg * patch_scaling_scalar * years_per_day * days_per_sec hio_seeds_in_pa(io_pa) = sum(cpatch%seeds_in) * & g_per_kg * patch_scaling_scalar * years_per_day * days_per_sec From 9ddf21380c94b4cbd0779e3acf02cade9c11488f Mon Sep 17 00:00:00 2001 From: ckoven Date: Mon, 27 Mar 2017 15:41:54 -0700 Subject: [PATCH 383/437] pulled fusion params to file, staged crown exponent param for file --- biogeochem/EDCohortDynamicsMod.F90 | 4 ++-- biogeochem/EDGrowthFunctionsMod.F90 | 8 ++++++-- biogeochem/EDPatchDynamicsMod.F90 | 4 ++-- main/EDParamsMod.F90 | 9 +++++++++ main/EDPftvarcon.F90 | 9 +++++++++ main/EDTypesMod.F90 | 4 ---- 6 files changed, 28 insertions(+), 10 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index b7aafda4..52f3578e 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -13,7 +13,7 @@ module EDCohortDynamicsMod 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 + use EDParamsMod , only : ED_val_cohort_fusion_tol use EDTypesMod , only : nclmax use EDTypesMod , only : ncwd use EDTypesMod , only : maxCohortsPerPatch @@ -638,7 +638,7 @@ subroutine fuse_cohorts(patchptr) !---------------------------------------------------------------------- !set initial fusion tolerance - dynamic_fusion_tolerance = fusetol + dynamic_fusion_tolerance = ED_val_cohort_fusion_tol !This needs to be a function of the canopy layer, because otherwise, at canopy closure !the number of cohorts doubles and very dissimilar cohorts are fused together diff --git a/biogeochem/EDGrowthFunctionsMod.F90 b/biogeochem/EDGrowthFunctionsMod.F90 index 22127884..808d1616 100755 --- a/biogeochem/EDGrowthFunctionsMod.F90 +++ b/biogeochem/EDGrowthFunctionsMod.F90 @@ -229,6 +229,9 @@ real(r8) function c_area( cohort_in ) type(ed_cohort_type), intent(in) :: cohort_in real(r8) :: dbh ! Tree diameter at breat height. cm. + real(r8) :: crown_area_to_dbh_exponent + + crown_area_to_dbh_exponent = EDecophyscon%crown_area_to_dbh_exponent(cohort_in%pft) if (DEBUG_growth) then write(fates_log(),*) 'z_area 1',cohort_in%dbh,cohort_in%pft @@ -241,11 +244,12 @@ real(r8) function c_area( cohort_in ) end if dbh = min(cohort_in%dbh,EDecophyscon%max_dbh(cohort_in%pft)) + !++CDK note below a magic numebr which ought to be PI; though this will be answer-changing... if(EDPftvarcon_inst%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 + (cohort_in%patchptr%spread(cohort_in%canopy_layer)*dbh)**crown_area_to_dbh_exponent else - c_area = 3.142_r8 * cohort_in%n * (ED_val_grass_spread*dbh)**1.56_r8 + c_area = 3.142_r8 * cohort_in%n * (ED_val_grass_spread*dbh)**crown_area_to_dbh_exponent end if end function c_area diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 8aec2ca0..9c511786 100755 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -1009,7 +1009,7 @@ subroutine fuse_patches( csite ) ! Decide to fuse patches if their cohort structures are similar ! ! !USES: - use EDTypesMod , only : patchfusion_profile_tolerance + use EDParamsMod , only : ED_val_profile_tol ! ! !ARGUMENTS: type(ed_site_type), intent(inout), target :: csite @@ -1031,7 +1031,7 @@ subroutine fuse_patches( csite ) currentSite => csite - profiletol = patchfusion_profile_tolerance + profiletol = ED_val_profile_tol nopatches = 0 currentPatch => currentSite%youngest_patch diff --git a/main/EDParamsMod.F90 b/main/EDParamsMod.F90 index eda22e0b..a3e6d115 100644 --- a/main/EDParamsMod.F90 +++ b/main/EDParamsMod.F90 @@ -25,6 +25,7 @@ module EDParamsMod 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_cohort_fusion_tol real(r8),protected :: ED_val_ag_biomass character(len=param_string_length),parameter :: ED_name_grass_spread = "fates_grass_spread" @@ -37,6 +38,7 @@ module EDParamsMod character(len=param_string_length),parameter :: ED_name_nfires = "fates_nfires" character(len=param_string_length),parameter :: ED_name_understorey_death = "fates_understorey_death" character(len=param_string_length),parameter :: ED_name_profile_tol = "fates_profile_tol" + character(len=param_string_length),parameter :: ED_name_cohort_fusion_tol = "fates_cohort_fusion_tol" character(len=param_string_length),parameter :: ED_name_ag_biomass= "fates_ag_biomass" public :: FatesParamsInit @@ -64,6 +66,7 @@ subroutine FatesParamsInit() ED_val_nfires = nan ED_val_understorey_death = nan ED_val_profile_tol = nan + ED_val_cohort_fusion_tol = nan ED_val_ag_biomass = nan end subroutine FatesParamsInit @@ -120,6 +123,9 @@ subroutine FatesRegisterParams(fates_params) call fates_params%RegisterParameter(name=ED_name_profile_tol, dimension_shape=dimension_shape_1d, & dimension_names=dim_names) + call fates_params%RegisterParameter(name=ED_name_cohort_fusion_tol, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + call fates_params%RegisterParameter(name=ED_name_ag_biomass, dimension_shape=dimension_shape_1d, & dimension_names=dim_names) @@ -170,6 +176,9 @@ subroutine FatesReceiveParams(fates_params) call fates_params%RetreiveParameter(name=ED_name_profile_tol, & data=ED_val_profile_tol) + call fates_params%RetreiveParameter(name=ED_name_cohort_fusion_tol, & + data=ED_val_cohort_fusion_tol) + call fates_params%RetreiveParameter(name=ED_name_ag_biomass, & data=ED_val_ag_biomass) diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index b60586c8..4937b6e4 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -67,6 +67,7 @@ module EDPftvarcon real(r8), allocatable :: smpso(:) real(r8), allocatable :: smpsc(:) real(r8), allocatable :: grperc(:) ! NOTE(bja, 2017-01) moved from EDParamsMod, was allocated as (maxPft=79), not (0:mxpft=78)! + real(r8), allocatable :: xxx(:) real(r8), allocatable :: rhol(:, :) real(r8), allocatable :: rhos(:, :) real(r8), allocatable :: taul(:, :) @@ -339,6 +340,10 @@ subroutine Register_PFT(this, fates_params) call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) + name = 'fates_xxx' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + end subroutine Register_PFT @@ -538,6 +543,10 @@ subroutine Receive_PFT(this, fates_params) call fates_params%RetreiveParameterAllocate(name=name, & data=this%grperc) + name = 'fates_xxx' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%xxx) + end subroutine Receive_PFT !----------------------------------------------------------------------- diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 4a8b491b..b8df7fb6 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -55,11 +55,7 @@ module EDTypesMod 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.05_r8 ! min fractional difference in dbh between cohorts - ! PATCH FUSION - real(r8), parameter :: patchfusion_profile_tolerance = 0.05_r8 ! minimum fraction in difference in profiles between patches 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 From 01825acb7e6e2917c048304fbf07354b8145d3ac Mon Sep 17 00:00:00 2001 From: ckoven Date: Wed, 29 Mar 2017 13:04:04 -0700 Subject: [PATCH 384/437] threaded scalar parameters through interface calls --- biogeochem/EDCohortDynamicsMod.F90 | 2 +- biogeochem/EDGrowthFunctionsMod.F90 | 5 +- biogeochem/EDPatchDynamicsMod.F90 | 4 +- biogeochem/EDPhysiologyMod.F90 | 61 ++++----- biogeophys/FatesPlantRespPhotosynthMod.F90 | 7 +- main/EDParamsMod.F90 | 144 +++++++++++++++++++++ 6 files changed, 185 insertions(+), 38 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 9f656381..3e2a9888 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -14,7 +14,6 @@ module EDCohortDynamicsMod use EDEcophysContype , only : EDecophyscon use EDGrowthFunctionsMod , only : c_area, tree_lai use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type - use EDParamsMod , only : ED_val_cohort_fusion_tol use EDTypesMod , only : nclmax use EDTypesMod , only : ncwd use EDTypesMod , only : maxCohortsPerPatch @@ -638,6 +637,7 @@ subroutine fuse_cohorts(patchptr) ! ! !USES: use EDTypesMod , only : nlevleaf + use EDParamsMod , only : ED_val_cohort_fusion_tol ! ! !ARGUMENTS type (ed_patch_type), intent(inout), target :: patchptr diff --git a/biogeochem/EDGrowthFunctionsMod.F90 b/biogeochem/EDGrowthFunctionsMod.F90 index 3647b11d..edc4df1b 100755 --- a/biogeochem/EDGrowthFunctionsMod.F90 +++ b/biogeochem/EDGrowthFunctionsMod.F90 @@ -231,7 +231,8 @@ real(r8) function c_area( cohort_in ) real(r8) :: dbh ! Tree diameter at breat height. cm. real(r8) :: crown_area_to_dbh_exponent - crown_area_to_dbh_exponent = EDecophyscon%crown_area_to_dbh_exponent(cohort_in%pft) + ! use the same exponent as the dbh to bleaf exponent so that per-plant canopy depth remains invariant during growth + crown_area_to_dbh_exponent = EDecophyscon%dbh2bl_b(cohort_in%pft) if (DEBUG_growth) then write(fates_log(),*) 'z_area 1',cohort_in%dbh,cohort_in%pft @@ -244,7 +245,7 @@ real(r8) function c_area( cohort_in ) end if dbh = min(cohort_in%dbh,EDecophyscon%max_dbh(cohort_in%pft)) - !++CDK note below a magic numebr which ought to be PI; though this will be answer-changing... + !++CDK note below a magic number which ought to be Pi; though this will be answer-changing... if(EDPftvarcon_inst%woody(cohort_in%pft) == 1)then c_area = 3.142_r8 * cohort_in%n * & (cohort_in%patchptr%spread(cohort_in%canopy_layer)*dbh)**crown_area_to_dbh_exponent diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index b9da19e7..6e3d1a7b 100755 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -1046,7 +1046,7 @@ subroutine fuse_patches( csite ) ! Decide to fuse patches if their cohort structures are similar ! ! !USES: - use EDParamsMod , only : ED_val_profile_tol + use EDParamsMod , only : ED_val_patch_fusion_tol ! ! !ARGUMENTS: type(ed_site_type), intent(inout), target :: csite @@ -1068,7 +1068,7 @@ subroutine fuse_patches( csite ) currentSite => csite - profiletol = ED_val_profile_tol + profiletol = ED_val_patch_fusion_tol nopatches = 0 currentPatch => currentSite%youngest_patch diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index ada40d78..6da605fb 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -258,6 +258,10 @@ subroutine phenology( currentSite, bc_in ) ! ! !USES: use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm + use EDParamsMod, only : ED_val_phen_drought_threshold, ED_val_phen_doff_time + use EDParamsMod, only : ED_val_phen_a, ED_val_phen_b, ED_val_phen_c, ED_val_phen_chiltemp + use EDParamsMod, only : ED_val_phen_mindayson, ED_val_phen_ncolddayslim, ED_val_phen_coldtemp + ! ! !ARGUMENTS: @@ -293,20 +297,20 @@ subroutine phenology( currentSite, bc_in ) ! 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 = EDecophyscon%fates_ph_drought_threshold - off_time = EDecophyscon%fates_ph_doff_time + drought_threshold = ED_val_phen_drought_threshold + off_time = ED_val_phen_doff_time !Parameters: defaults from Botta et al. 2000 GCB,6 709-725 - a = EDecophyscon%fates_ph_a - b = EDecophyscon%fates_ph_b - c = EDecophyscon%fates_ph_c - coldday = EDecophyscon%fates_ph_chiltemp + a = ED_val_phen_a + b = ED_val_phen_b + c = ED_val_phen_c + coldday = ED_val_phen_chiltemp - mindayson = EDecophyscon%fates_ph_mindayson + mindayson = ED_val_phen_mindayson !Parameters, default from from SDGVM model of senesence - ncolddayslim = EDecophyscon%fates_ph_ncolddayslim - cold_t = EDecophyscon%fates_ph_coldtemp + ncolddayslim = ED_val_phen_ncolddayslim + cold_t = ED_val_phen_coldtemp t = hlm_day_of_year temp_in_C = bc_in%t_veg24_si - tfrz @@ -716,6 +720,7 @@ subroutine seed_decay( currentSite, currentPatch ) ! Flux from seed pool into leaf litter pool ! ! !USES: + use EDPftvarcon , only : EDPftvarcon_inst ! ! !ARGUMENTS type(ed_site_type), intent(inout), target :: currentSite @@ -723,14 +728,13 @@ subroutine seed_decay( currentSite, currentPatch ) ! ! !LOCAL VARIABLES: integer :: p - real(r8) :: seed_turnover !complete seed turnover rate in yr-1. !---------------------------------------------------------------------- - seed_turnover = EDecophyscon%seed_turnover ! default value from Liscke and Loffler 2006 + ! default value from Liscke and Loffler 2006 ; making this a PFT-specific parameter ! decays the seed pool according to exponential model - ! sd_mort is in yr-1 + ! seed_decay_turnover is in yr-1 do p = 1,numpft_ed - currentPatch%seed_decay(p) = currentSite%seed_bank(p) * seed_turnover + currentPatch%seed_decay(p) = currentSite%seed_bank(p) * EDPftvarcon_inst%seed_decay_turnover(p) enddo end subroutine seed_decay @@ -742,6 +746,7 @@ subroutine seed_germination( currentSite, currentPatch ) ! Flux from seed pool into sapling pool ! ! !USES: + use EDPftvarcon , only : EDPftvarcon_inst ! ! !ARGUMENTS type(ed_site_type), intent(inout), target :: currentSite @@ -750,15 +755,16 @@ subroutine seed_germination( currentSite, currentPatch ) ! !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 = EDecophyscon%germination_timescale max_germination = 1.0_r8 !this is arbitrary + ! germination_timescale is being pulled to PFT parameter; units are 1/yr + ! thus the mortality rate of seed -> recruit (in units of carbon) is seed_decay_turnover(p)/germination_timescale(p) + ! and thus the mortlaity rate (in units of individuals) is the product of that times the ratio of (hypothetical) seed mass to recruit biomass do p = 1,numpft_ed currentPatch%seed_germination(p) = min(currentSite%seed_bank(p) * & - germination_timescale,max_germination) + EDPftvarcon_inst%germination_timescale(p),max_germination) enddo end subroutine seed_germination @@ -1348,6 +1354,7 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) use FatesInterfaceMod, only : bc_in_type, bc_out_type use clm_varctl, only : use_vertsoilc use FatesGlobals, only : endrun => fates_endrun + use EDParamsMod , only : ED_val_cwd_flig, ED_val_cwd_fcel ! INTERF-TODO: remove the control parameters: exponential_rooting_profile, @@ -1402,12 +1409,6 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) real(r8) :: croot_prof(1:nsites, 1:hlm_numlevdecomp) real(r8) :: stem_prof(1:nsites, 1:hlm_numlevdecomp) - real(r8) :: cwd_fcel - real(r8) :: cwd_flig - - cwd_fcel = - cwd_flig = - delta = 0.001_r8 !no of seconds in a year. time_convert = 365.0_r8*sec_per_day @@ -1631,26 +1632,26 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) ! now disaggregate, vertically and by decomposition substrate type, the actual fluxes from CWD and litter pools ! ! do c = 1, ncwd - ! write(fates_log(),*)'cdk CWD_AG_out', c, currentpatch%CWD_AG_out(c), cwd_fcel, currentpatch%area/AREA - ! write(fates_log(),*)'cdk CWD_BG_out', c, currentpatch%CWD_BG_out(c), cwd_fcel, currentpatch%area/AREA + ! write(fates_log(),*)'cdk CWD_AG_out', c, currentpatch%CWD_AG_out(c), ED_val_cwd_fcel, currentpatch%area/AREA + ! write(fates_log(),*)'cdk CWD_BG_out', c, currentpatch%CWD_BG_out(c), ED_val_cwd_fcel, currentpatch%area/AREA ! end do ! do ft = 1,numpft_ed - ! write(fates_log(),*)'cdk leaf_litter_out', ft, currentpatch%leaf_litter_out(ft), cwd_fcel, currentpatch%area/AREA - ! write(fates_log(),*)'cdk root_litter_out', ft, currentpatch%root_litter_out(ft), cwd_fcel, currentpatch%area/AREA + ! write(fates_log(),*)'cdk leaf_litter_out', ft, currentpatch%leaf_litter_out(ft), ED_val_cwd_fcel, currentpatch%area/AREA + ! write(fates_log(),*)'cdk root_litter_out', ft, currentpatch%root_litter_out(ft), ED_val_cwd_fcel, currentpatch%area/AREA ! end do ! ! ! CWD pools fragmenting into decomposing litter pools. do ci = 1, ncwd do j = 1, hlm_numlevdecomp bc_out(s)%FATES_c_to_litr_cel_c_col(j) = bc_out(s)%FATES_c_to_litr_cel_c_col(j) + & - currentpatch%CWD_AG_out(ci) * cwd_fcel * currentpatch%area/AREA * stem_prof(s,j) + currentpatch%CWD_AG_out(ci) * ED_val_cwd_fcel * currentpatch%area/AREA * stem_prof(s,j) bc_out(s)%FATES_c_to_litr_lig_c_col(j) = bc_out(s)%FATES_c_to_litr_lig_c_col(j) + & - currentpatch%CWD_AG_out(ci) * cwd_flig * currentpatch%area/AREA * stem_prof(s,j) + currentpatch%CWD_AG_out(ci) * ED_val_cwd_flig * currentpatch%area/AREA * stem_prof(s,j) ! bc_out(s)%FATES_c_to_litr_cel_c_col(j) = bc_out(s)%FATES_c_to_litr_cel_c_col(j) + & - currentpatch%CWD_BG_out(ci) * cwd_fcel * currentpatch%area/AREA * croot_prof_perpatch(j) + currentpatch%CWD_BG_out(ci) * ED_val_cwd_fcel * currentpatch%area/AREA * croot_prof_perpatch(j) bc_out(s)%FATES_c_to_litr_lig_c_col(j) = bc_out(s)%FATES_c_to_litr_lig_c_col(j) + & - currentpatch%CWD_BG_out(ci) * cwd_flig * currentpatch%area/AREA * croot_prof_perpatch(j) + currentpatch%CWD_BG_out(ci) * ED_val_cwd_flig * currentpatch%area/AREA * croot_prof_perpatch(j) end do end do diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index 1f1ebebc..576a5133 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -82,6 +82,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm use FatesParameterDerivedMod, only : param_derived use EDPatchDynamicsMod, only: set_root_fraction + use EDParamsMod, only : ED_val_bbopt_c3, ED_val_bbopt_c4, ED_val_base_mr_20 ! ARGUMENTS: @@ -208,9 +209,9 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) frootcn => EDPftvarcon_inst%frootcn, & ! froot C:N (gc/gN) ! slope of BB relationship q10 => FatesSynchronizedParamsInst%Q10 ) - base_mr_20 = - bbbopt[1] = - bbbopt[2] = + base_mr_20 = ED_val_base_mr_20 + bbbopt[1] = ED_val_bbopt_c3 + bbbopt[2] = ED_val_bbopt_c4 do s = 1,nsites diff --git a/main/EDParamsMod.F90 b/main/EDParamsMod.F90 index a3e6d115..3e9f3bcf 100644 --- a/main/EDParamsMod.F90 +++ b/main/EDParamsMod.F90 @@ -27,6 +27,22 @@ module EDParamsMod real(r8),protected :: ED_val_profile_tol real(r8),protected :: ED_val_cohort_fusion_tol real(r8),protected :: ED_val_ag_biomass + real(r8),protected :: ED_val_cwd_fcel + real(r8),protected :: ED_val_cwd_flig + real(r8),protected :: ED_val_bbopt_c3 + real(r8),protected :: ED_val_bbopt_c4 + real(r8),protected :: ED_val_base_mr_20 + real(r8),protected :: ED_val_phen_drought_threshold + real(r8),protected :: ED_val_phen_doff_time + real(r8),protected :: ED_val_phen_a + real(r8),protected :: ED_val_phen_b + real(r8),protected :: ED_val_phen_c + real(r8),protected :: ED_val_phen_chiltemp + real(r8),protected :: ED_val_phen_mindayson + real(r8),protected :: ED_val_phen_ncolddayslim + real(r8),protected :: ED_val_phen_coldtemp + real(r8),protected :: ED_val_cohort_fusion_tol + real(r8),protected :: ED_val_patch_fusion_tol character(len=param_string_length),parameter :: ED_name_grass_spread = "fates_grass_spread" character(len=param_string_length),parameter :: ED_name_comp_excln = "fates_comp_excln" @@ -40,6 +56,22 @@ module EDParamsMod character(len=param_string_length),parameter :: ED_name_profile_tol = "fates_profile_tol" character(len=param_string_length),parameter :: ED_name_cohort_fusion_tol = "fates_cohort_fusion_tol" character(len=param_string_length),parameter :: ED_name_ag_biomass= "fates_ag_biomass" + character(len=param_string_length),parameter :: ED_name_cwd_fcel= "fates_cwd_fcel" + character(len=param_string_length),parameter :: ED_name_cwd_flig= "fates_cwd_flig" + character(len=param_string_length),parameter :: ED_name_bbopt_c3= "fates_bbopt_c3" + character(len=param_string_length),parameter :: ED_name_bbopt_c4= "fates_bbopt_c4" + character(len=param_string_length),parameter :: ED_name_base_mr_20= "fates_base_mr_20" + character(len=param_string_length),parameter :: ED_name_phen_drought_threshold= "fates_phen_drought_threshold" + character(len=param_string_length),parameter :: ED_name_phen_doff_time= "fates_phen_doff_time" + character(len=param_string_length),parameter :: ED_name_phen_a= "fates_phen_a" + character(len=param_string_length),parameter :: ED_name_phen_b= "fates_phen_b" + character(len=param_string_length),parameter :: ED_name_phen_c= "fates_phen_c" + character(len=param_string_length),parameter :: ED_name_phen_chiltemp= "fates_phen_chiltemp" + character(len=param_string_length),parameter :: ED_name_phen_mindayson= "fates_phen_mindayson" + character(len=param_string_length),parameter :: ED_name_phen_ncolddayslim= "fates_phen_ncolddayslim" + character(len=param_string_length),parameter :: ED_name_phen_coldtemp= "fates_phen_coldtemp" + character(len=param_string_length),parameter :: ED_name_cohort_fusion_tol= "fates_cohort_fusion_tol" + character(len=param_string_length),parameter :: ED_name_patch_fusion_tol= "fates_patch_fusion_tol" public :: FatesParamsInit public :: FatesRegisterParams @@ -68,6 +100,22 @@ subroutine FatesParamsInit() ED_val_profile_tol = nan ED_val_cohort_fusion_tol = nan ED_val_ag_biomass = nan + ED_val_cwd_fcel = nan + ED_val_cwd_flig = nan + ED_val_bbopt_c3 = nan + ED_val_bbopt_c4 = nan + ED_val_base_mr_20 = nan + ED_val_phen_drought_threshold = nan + ED_val_phen_doff_time = nan + ED_val_phen_a = nan + ED_val_phen_b = nan + ED_val_phen_c = nan + ED_val_phen_chiltemp = nan + ED_val_phen_mindayson = nan + ED_val_phen_ncolddayslim = nan + ED_val_phen_coldtemp = nan + ED_val_cohort_fusion_tol = nan + ED_val_patch_fusion_tol = nan end subroutine FatesParamsInit @@ -129,6 +177,54 @@ subroutine FatesRegisterParams(fates_params) call fates_params%RegisterParameter(name=ED_name_ag_biomass, dimension_shape=dimension_shape_1d, & dimension_names=dim_names) + call fates_params%RegisterParameter(name=ED_name_cwd_fcel, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=ED_name_cwd_flig, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=ED_name_bbopt_c3, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=ED_name_bbopt_c4, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=ED_name_base_mr_20, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=ED_name_phen_drought_threshold, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=ED_name_phen_doff_time, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=ED_name_phen_a, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=ED_name_phen_b, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=ED_name_phen_c, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=ED_name_phen_chiltemp, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=ED_name_phen_mindayson, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=ED_name_phen_ncolddayslim, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=ED_name_phen_coldtemp, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=ED_name_cohort_fusion_tol, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=ED_name_patch_fusion_tol, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + end subroutine FatesRegisterParams !----------------------------------------------------------------------- @@ -182,6 +278,54 @@ subroutine FatesReceiveParams(fates_params) call fates_params%RetreiveParameter(name=ED_name_ag_biomass, & data=ED_val_ag_biomass) + call fates_params%RetreiveParameter(name=ED_name_cwd_fcel, & + data=ED_val_cwd_fcel) + + call fates_params%RetreiveParameter(name=ED_name_cwd_flig, & + data=ED_val_cwd_flig) + + call fates_params%RetreiveParameter(name=ED_name_bbopt_c3, & + data=ED_val_bbopt_c3) + + call fates_params%RetreiveParameter(name=ED_name_bbopt_c4, & + data=ED_val_bbopt_c4) + + call fates_params%RetreiveParameter(name=ED_name_base_mr_20, & + data=ED_val_base_mr_20) + + call fates_params%RetreiveParameter(name=ED_name_phen_drought_threshold, & + data=ED_val_phen_drought_threshold) + + call fates_params%RetreiveParameter(name=ED_name_phen_doff_time, & + data=ED_val_phen_doff_time) + + call fates_params%RetreiveParameter(name=ED_name_phen_a, & + data=ED_val_phen_a) + + call fates_params%RetreiveParameter(name=ED_name_phen_b, & + data=ED_val_phen_b) + + call fates_params%RetreiveParameter(name=ED_name_phen_c, & + data=ED_val_phen_c) + + call fates_params%RetreiveParameter(name=ED_name_phen_chiltemp, & + data=ED_val_phen_chiltemp) + + call fates_params%RetreiveParameter(name=ED_name_phen_mindayson, & + data=ED_val_phen_mindayson) + + call fates_params%RetreiveParameter(name=ED_name_phen_ncolddayslim, & + data=ED_val_phen_ncolddayslim) + + call fates_params%RetreiveParameter(name=ED_name_phen_coldtemp, & + data=ED_val_phen_coldtemp) + + call fates_params%RetreiveParameter(name=ED_name_cohort_fusion_tol, & + data=ED_val_cohort_fusion_tol) + + call fates_params%RetreiveParameter(name=ED_name_patch_fusion_tol, & + data=ED_val_patch_fusion_tol) + end subroutine FatesReceiveParams end module EDParamsMod From 21bd96eec7151a259b41e47a1488ff1567a632ad Mon Sep 17 00:00:00 2001 From: ckoven Date: Wed, 29 Mar 2017 17:03:05 -0700 Subject: [PATCH 385/437] finished off these changes for now --- biogeochem/EDGrowthFunctionsMod.F90 | 88 ++++----- biogeophys/FatesPlantRespPhotosynthMod.F90 | 58 +++--- main/EDParamsMod.F90 | 18 -- main/EDPftvarcon.F90 | 216 ++++++++++++++++++++- 4 files changed, 282 insertions(+), 98 deletions(-) diff --git a/biogeochem/EDGrowthFunctionsMod.F90 b/biogeochem/EDGrowthFunctionsMod.F90 index edc4df1b..e0ed607b 100755 --- a/biogeochem/EDGrowthFunctionsMod.F90 +++ b/biogeochem/EDGrowthFunctionsMod.F90 @@ -9,7 +9,6 @@ module EDGrowthFunctionsMod use FatesConstantsMod, only : r8 => fates_r8 use FatesGlobals , only : fates_log use EDPftvarcon , only : EDPftvarcon_inst - use EDEcophysContype , only : EDecophyscon use EDTypesMod , only : ed_cohort_type, nlevleaf, dinc_ed implicit none @@ -48,8 +47,8 @@ real(r8) function Dbh( cohort_in ) 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 = EDecophyscon%dbh2h_m(cohort_in%pft) - c = EDecophyscon%dbh2h_c(cohort_in%pft) + m = EDPftvarcon_inst%dbh2h_m(cohort_in%pft) + c = EDPftvarcon_inst%dbh2h_c(cohort_in%pft) dbh = (10.0_r8**((log10(cohort_in%hite) - c)/m)) @@ -72,8 +71,8 @@ real(r8) function Hite( cohort_in ) real(r8) :: c real(r8) :: h - m = EDecophyscon%dbh2h_m(cohort_in%pft) - c = EDecophyscon%dbh2h_c(cohort_in%pft) + m = EDPftvarcon_inst%dbh2h_m(cohort_in%pft) + c = EDPftvarcon_inst%dbh2h_c(cohort_in%pft) if(cohort_in%dbh <= 0._r8)then write(fates_log(),*) 'ED: dbh less than zero problem!' @@ -83,10 +82,10 @@ real(r8) function Hite( cohort_in ) ! 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 + if(cohort_in%dbh <= EDPftvarcon_inst%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)) + h = (10.0_r8**(log10(EDPftvarcon_inst%max_dbh(cohort_in%pft))*m + c)) endif Hite = h @@ -109,19 +108,19 @@ real(r8) function Bleaf( cohort_in ) real(r8) :: dbh2bl_c real(r8) :: slascaler ! changes the target biomass according to the SLA - dbh2bl_a = EDecophyscon%dbh2bl_a(cohort_in%pft) - dbh2bl_b = EDecophyscon%dbh2bl_b(cohort_in%pft) - dbh2bl_c = EDecophyscon%dbh2bl_c(cohort_in%pft) - slascaler = EDecophyscon%dbh2bl_slascaler(cohort_in%pft)/pftcon%slatop(cohort_in%pft) ! 0.03_r8/pftcon%slatop(cohort_in%pft) + dbh2bl_a = EDPftvarcon_inst%dbh2bl_a(cohort_in%pft) + dbh2bl_b = EDPftvarcon_inst%dbh2bl_b(cohort_in%pft) + dbh2bl_c = EDPftvarcon_inst%dbh2bl_c(cohort_in%pft) + slascaler = EDPftvarcon_inst%dbh2bl_slascaler(cohort_in%pft)/EDPftvarcon_inst%slatop(cohort_in%pft) if(cohort_in%dbh < 0._r8.or.cohort_in%pft == 0.or.cohort_in%dbh > 1000.0_r8)then write(fates_log(),*) 'problems in bleaf',cohort_in%dbh,cohort_in%pft endif - if(cohort_in%dbh <= EDecophyscon%max_dbh(cohort_in%pft))then - bleaf = dbh2bl_a * (cohort_in%dbh**dbh2bl_b) * EDecophyscon%wood_density(cohort_in%pft)**dbh2bl_c + if(cohort_in%dbh <= EDPftvarcon_inst%max_dbh(cohort_in%pft))then + bleaf = dbh2bl_a * (cohort_in%dbh**dbh2bl_b) * EDPftvarcon_inst%wood_density(cohort_in%pft)**dbh2bl_c else - bleaf = dbh2bl_a * (EDecophyscon%max_dbh(cohort_in%pft)**dbh2bl_b) * EDecophyscon%wood_density(cohort_in%pft)**dbh2bl_c + bleaf = dbh2bl_a * (EDPftvarcon_inst%max_dbh(cohort_in%pft)**dbh2bl_b) * EDPftvarcon_inst%wood_density(cohort_in%pft)**dbh2bl_c endif bleaf = bleaf * slascaler @@ -191,7 +190,7 @@ real(r8) function tree_sai( cohort_in ) real(r8) :: bdead_per_unitarea ! KgC of leaf per m2 area of ground. real(r8) :: sai_scaler - sai_scaler = EDecophyscon%sai_scaler(cohort_in%pft) + sai_scaler = EDPftvarcon_inst%sai_scaler(cohort_in%pft) if( cohort_in%bdead < 0._r8 .or. cohort_in%pft == 0 ) then write(fates_log(),*) 'problem in treesai',cohort_in%bdead,cohort_in%pft @@ -232,11 +231,11 @@ real(r8) function c_area( cohort_in ) real(r8) :: crown_area_to_dbh_exponent ! use the same exponent as the dbh to bleaf exponent so that per-plant canopy depth remains invariant during growth - crown_area_to_dbh_exponent = EDecophyscon%dbh2bl_b(cohort_in%pft) + crown_area_to_dbh_exponent = EDPftvarcon_inst%dbh2bl_b(cohort_in%pft) if (DEBUG_growth) then write(fates_log(),*) 'z_area 1',cohort_in%dbh,cohort_in%pft - write(fates_log(),*) 'z_area 2',EDecophyscon%max_dbh + write(fates_log(),*) 'z_area 2',EDPftvarcon_inst%max_dbh write(fates_log(),*) 'z_area 3',EDPftvarcon_inst%woody write(fates_log(),*) 'z_area 4',cohort_in%n write(fates_log(),*) 'z_area 5',cohort_in%patchptr%spread @@ -244,8 +243,7 @@ real(r8) function c_area( cohort_in ) write(fates_log(),*) 'z_area 7',ED_val_grass_spread end if - dbh = min(cohort_in%dbh,EDecophyscon%max_dbh(cohort_in%pft)) - !++CDK note below a magic number which ought to be Pi; though this will be answer-changing... + dbh = min(cohort_in%dbh,EDPftvarcon_inst%max_dbh(cohort_in%pft)) if(EDPftvarcon_inst%woody(cohort_in%pft) == 1)then c_area = 3.142_r8 * cohort_in%n * & (cohort_in%patchptr%spread(cohort_in%canopy_layer)*dbh)**crown_area_to_dbh_exponent @@ -272,13 +270,13 @@ real(r8) function Bdead( cohort_in ) real(r8) :: dbh2bd_c real(r8) :: dbh2bd_d - dbh2bd_a = EDecophyscon%dbh2bd_a(cohort_in%pft) - dbh2bd_b = EDecophyscon%dbh2bd_b(cohort_in%pft) - dbh2bd_c = EDecophyscon%dbh2bd_c(cohort_in%pft) - dbh2bd_d = EDecophyscon%dbh2bd_d(cohort_in%pft) + dbh2bd_a = EDPftvarcon_inst%dbh2bd_a(cohort_in%pft) + dbh2bd_b = EDPftvarcon_inst%dbh2bd_b(cohort_in%pft) + dbh2bd_c = EDPftvarcon_inst%dbh2bd_c(cohort_in%pft) + dbh2bd_d = EDPftvarcon_inst%dbh2bd_d(cohort_in%pft) bdead = dbh2bd_a*(cohort_in%hite**dbh2bd_b)*(cohort_in%dbh**dbh2bd_c)* & - (EDecophyscon%wood_density(cohort_in%pft)** dbh2bd_d) + (EDPftvarcon_inst%wood_density(cohort_in%pft)** dbh2bd_d) end function Bdead @@ -299,13 +297,13 @@ real(r8) function dHdBd( cohort_in ) real(r8) :: dbh2bd_c real(r8) :: dbh2bd_d - dbh2bd_a = EDecophyscon%dbh2bd_a(cohort_in%pft) - dbh2bd_b = EDecophyscon%dbh2bd_b(cohort_in%pft) - dbh2bd_c = EDecophyscon%dbh2bd_c(cohort_in%pft) - dbh2bd_d = EDecophyscon%dbh2bd_d(cohort_in%pft) + dbh2bd_a = EDPftvarcon_inst%dbh2bd_a(cohort_in%pft) + dbh2bd_b = EDPftvarcon_inst%dbh2bd_b(cohort_in%pft) + dbh2bd_c = EDPftvarcon_inst%dbh2bd_c(cohort_in%pft) + dbh2bd_d = EDPftvarcon_inst%dbh2bd_d(cohort_in%pft) dbddh = dbh2bd_a*dbh2bd_b*(cohort_in%hite**(dbh2bd_b-1.0_r8))*(cohort_in%dbh**dbh2bd_c)* & - (EDecophyscon%wood_density(cohort_in%pft)**dbh2bd_d) + (EDPftvarcon_inst%wood_density(cohort_in%pft)**dbh2bd_d) dHdBd = 1.0_r8/dbddh !m/KgC return @@ -332,22 +330,22 @@ real(r8) function dDbhdBd( cohort_in ) real(r8) :: dbh2bd_c real(r8) :: dbh2bd_d - m = EDecophyscon%dbh2h_m(cohort_in%pft) - c = EDecophyscon%dbh2h_c(cohort_in%pft) + m = EDPftvarcon_inst%dbh2h_m(cohort_in%pft) + c = EDPftvarcon_inst%dbh2h_c(cohort_in%pft) - dbh2bd_a = EDecophyscon%dbh2bd_a(cohort_in%pft) - dbh2bd_b = EDecophyscon%dbh2bd_b(cohort_in%pft) - dbh2bd_c = EDecophyscon%dbh2bd_c(cohort_in%pft) - dbh2bd_d = EDecophyscon%dbh2bd_d(cohort_in%pft) + dbh2bd_a = EDPftvarcon_inst%dbh2bd_a(cohort_in%pft) + dbh2bd_b = EDPftvarcon_inst%dbh2bd_b(cohort_in%pft) + dbh2bd_c = EDPftvarcon_inst%dbh2bd_c(cohort_in%pft) + dbh2bd_d = EDPftvarcon_inst%dbh2bd_d(cohort_in%pft) dBD_dDBH = dbh2bd_c*dbh2bd_a*(cohort_in%hite**dbh2bd_b)*(cohort_in%dbh**(dbh2bd_c-1.0_r8))* & - (EDecophyscon%wood_density(cohort_in%pft)**dbh2bd_d) + (EDPftvarcon_inst%wood_density(cohort_in%pft)**dbh2bd_d) - if(cohort_in%dbh < EDecophyscon%max_dbh(cohort_in%pft))then + if(cohort_in%dbh < EDPftvarcon_inst%max_dbh(cohort_in%pft))then dH_dDBH = (10.0_r8**c)*m*(cohort_in%dbh**(m-1.0_r8)) dBD_dDBH = dBD_dDBH + dbh2bd_b*dbh2bd_a*(cohort_in%hite**(dbh2bd_b - 1.0_r8))* & - (cohort_in%dbh**dbh2bd_c)*(EDecophyscon%wood_density(cohort_in%pft)**dbh2bd_d)*dH_dDBH + (cohort_in%dbh**dbh2bd_c)*(EDPftvarcon_inst%wood_density(cohort_in%pft)**dbh2bd_d)*dH_dDBH endif dDbhdBd = 1.0_r8/dBD_dDBH @@ -371,13 +369,13 @@ real(r8) function dDbhdBl( cohort_in ) real(r8) :: dbh2bl_b real(r8) :: dbh2bl_c - dbh2bl_a = EDecophyscon%dbh2bl_a(cohort_in%pft) - dbh2bl_b = EDecophyscon%dbh2bl_b(cohort_in%pft) - dbh2bl_c = EDecophyscon%dbh2bl_c(cohort_in%pft) - dblddbh = dbh2bl_b*dbh2bl_a*(cohort_in%dbh**dbh2bl_b)*(EDecophyscon%wood_density(cohort_in%pft)**dbh2bl_c) + dbh2bl_a = EDPftvarcon_inst%dbh2bl_a(cohort_in%pft) + dbh2bl_b = EDPftvarcon_inst%dbh2bl_b(cohort_in%pft) + dbh2bl_c = EDPftvarcon_inst%dbh2bl_c(cohort_in%pft) + dblddbh = dbh2bl_b*dbh2bl_a*(cohort_in%dbh**dbh2bl_b)*(EDPftvarcon_inst%wood_density(cohort_in%pft)**dbh2bl_c) dblddbh = dblddbh*cohort_in%canopy_trim - if( cohort_in%dbh EDecophyscon%c3psn , & - slatop => EDecophyscon%slatop , & ! specific leaf area at top of canopy, + c3psn => EDPftvarcon_inst%c3psn , & + slatop => EDPftvarcon_inst%slatop , & ! specific leaf area at top of canopy, ! projected area basis [m^2/gC] - flnr => EDecophyscon%flnr , & ! fraction of leaf N in the Rubisco + flnr => EDPftvarcon_inst%flnr , & ! fraction of leaf N in the Rubisco ! enzyme (gN Rubisco / gN leaf) woody => EDPftvarcon_inst%woody , & ! Is vegetation woody or not? fnitr => EDPftvarcon_inst%fnitr , & ! foliage nitrogen limitation factor (-) @@ -210,8 +209,8 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) q10 => FatesSynchronizedParamsInst%Q10 ) base_mr_20 = ED_val_base_mr_20 - bbbopt[1] = ED_val_bbopt_c3 - bbbopt[2] = ED_val_bbopt_c4 + bbbopt(1) = ED_val_bbopt_c3 + bbbopt(2) = ED_val_bbopt_c4 do s = 1,nsites @@ -500,11 +499,11 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! ------------------------------------------------------------------ leaf_frac = 1.0_r8/(currentCohort%canopy_trim + & - EDecophyscon%sapwood_ratio(currentCohort%pft) * & - currentCohort%hite + EDecophyscon%froot_leaf(currentCohort%pft)) + EDPftvarcon_inst%sapwood_ratio(currentCohort%pft) * & + currentCohort%hite + EDPftvarcon_inst%froot_leaf(currentCohort%pft)) - currentCohort%bsw = EDecophyscon%sapwood_ratio(currentCohort%pft) * & + currentCohort%bsw = EDPftvarcon_inst%sapwood_ratio(currentCohort%pft) * & currentCohort%hite * & (currentCohort%balive + currentCohort%laimemory)*leaf_frac @@ -587,7 +586,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! no drought response right now.. something like: ! resp_m = resp_m * (1.0_r8 - currentPatch%btran_ft(currentCohort%pft) * & - ! EDecophyscon%resp_drought_response(ft)) + ! EDPftvarcon_inst%resp_drought_response(ft)) currentCohort%resp_m = currentCohort%resp_m + currentCohort%rdark @@ -600,7 +599,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) if ( DEBUG ) write(fates_log(),*) 'EDPhoto 912 ', currentCohort%resp_tstep if ( DEBUG ) write(fates_log(),*) 'EDPhoto 913 ', currentCohort%resp_m - currentCohort%resp_g = EDecophyscon%grperc(ft) * & + currentCohort%resp_g = EDPftvarcon_inst%grperc(ft) * & (max(0._r8,currentCohort%gpp_tstep - & currentCohort%resp_m)) currentCohort%resp_tstep = currentCohort%resp_m + & @@ -688,8 +687,7 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in ! Other arguments or variables may be indicative of scales broader than the LSL. ! ------------------------------------------------------------------------------------ - use EDEcophysContype , only : EDecophyscon - use EDPftvarcon , only : EDecophyscon + use EDPftvarcon , only : EDPftvarcon_inst ! Arguments ! ------------------------------------------------------------------------------------ @@ -783,9 +781,9 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in ! empirical curvature parameter for ap photosynthesis co-limitation real(r8),parameter :: theta_ip = 0.95_r8 - associate( bb_slope => EDecophyscon%BB_slope ) ! slope of BB relationship + associate( bb_slope => EDPftvarcon_inst%BB_slope ) ! slope of BB relationship - if (nint(EDecophyscon%c3psn(ft)) == 1) then! photosynthetic pathway: 0. = c4, 1. = c3 + if (nint(EDPftvarcon_inst%c3psn(ft)) == 1) then! photosynthetic pathway: 0. = c4, 1. = c3 pp_type = 1 init_co2_intra_c = init_a2l_co2_c3 * can_co2_ppress else @@ -1477,7 +1475,7 @@ subroutine LeafLayerMaintenanceRespiration(lmr25top_ft, & lmr) use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm - use EDPftvarcon , only : EDecophyscon + use EDPftvarcon , only : EDPftvarcon_inst ! Arguments real(r8), intent(in) :: lmr25top_ft ! canopy top leaf maint resp rate at 25C @@ -1544,7 +1542,7 @@ subroutine LeafLayerBiophysicalRates( parsun_lsl, & ! co2_rcurve_islope: initial slope of CO2 response curve (C4 plants) ! --------------------------------------------------------------------------------- - use EDPftvarcon , only : EDecophyscon + use EDPftvarcon , only : EDPftvarcon_inst use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm ! Arguments @@ -1598,21 +1596,21 @@ subroutine LeafLayerBiophysicalRates( parsun_lsl, & real(r8) :: jmaxc ! scaling factor for high temperature inhibition (25 C = 1.0) real(r8) :: tpuc ! scaling factor for high temperature inhibition (25 C = 1.0) - vcmaxha = EDecophyscon%vcmaxha(FT) - jmaxha = EDecophyscon%jmaxha(FT) - tpuha = EDecophyscon%tpuha(FT) + vcmaxha = EDPftvarcon_inst%vcmaxha(FT) + jmaxha = EDPftvarcon_inst%jmaxha(FT) + tpuha = EDPftvarcon_inst%tpuha(FT) - vcmaxhd = EDecophyscon%vcmaxhd(FT) - jmaxhd = EDecophyscon%jmaxhd(FT) - tpuhd = EDecophyscon%tpuhd(FT) + vcmaxhd = EDPftvarcon_inst%vcmaxhd(FT) + jmaxhd = EDPftvarcon_inst%jmaxhd(FT) + tpuhd = EDPftvarcon_inst%tpuhd(FT) - vcmaxse = EDecophyscon%vcmaxse(FT) - jmaxse = EDecophyscon%jmaxse(FT) - tpuse = EDecophyscon%tpuse(FT) + vcmaxse = EDPftvarcon_inst%vcmaxse(FT) + jmaxse = EDPftvarcon_inst%jmaxse(FT) + tpuse = EDPftvarcon_inst%tpuse(FT) - vcmaxc = fth25(vcmaxhd, vcmaxse) - jmaxc = fth25(jmaxhd, jmaxse) - tpuc = fth25(tpuhd, tpuse) + vcmaxc = fth25_f(vcmaxhd, vcmaxse) + jmaxc = fth25_f(jmaxhd, jmaxse) + tpuc = fth25_f(tpuhd, tpuse) if ( parsun_lsl <= 0._r8) then ! night time vcmax = 0._r8 @@ -1630,7 +1628,7 @@ subroutine LeafLayerBiophysicalRates( parsun_lsl, & jmax = jmax25 * ft1_f(veg_tempk, jmaxha) * fth_f(veg_tempk, jmaxhd, jmaxse, jmaxc) tpu = tpu25 * ft1_f(veg_tempk, tpuha) * fth_f(veg_tempk, tpuhd, tpuse, tpuc) - if (nint(EDecophyscon%c3psn(ft)) /= 1) then + if (nint(EDPftvarcon_inst%c3psn(ft)) /= 1) then vcmax = vcmax25 * 2._r8**((veg_tempk-(tfrz+25._r8))/10._r8) vcmax = vcmax / (1._r8 + exp( 0.2_r8*((tfrz+15._r8)-veg_tempk ) )) vcmax = vcmax / (1._r8 + exp( 0.3_r8*(veg_tempk-(tfrz+40._r8)) )) diff --git a/main/EDParamsMod.F90 b/main/EDParamsMod.F90 index 3e9f3bcf..eea9784b 100644 --- a/main/EDParamsMod.F90 +++ b/main/EDParamsMod.F90 @@ -24,8 +24,6 @@ module EDParamsMod 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_cohort_fusion_tol real(r8),protected :: ED_val_ag_biomass real(r8),protected :: ED_val_cwd_fcel real(r8),protected :: ED_val_cwd_flig @@ -53,8 +51,6 @@ module EDParamsMod character(len=param_string_length),parameter :: ED_name_init_litter = "fates_init_litter" character(len=param_string_length),parameter :: ED_name_nfires = "fates_nfires" character(len=param_string_length),parameter :: ED_name_understorey_death = "fates_understorey_death" - character(len=param_string_length),parameter :: ED_name_profile_tol = "fates_profile_tol" - character(len=param_string_length),parameter :: ED_name_cohort_fusion_tol = "fates_cohort_fusion_tol" character(len=param_string_length),parameter :: ED_name_ag_biomass= "fates_ag_biomass" character(len=param_string_length),parameter :: ED_name_cwd_fcel= "fates_cwd_fcel" character(len=param_string_length),parameter :: ED_name_cwd_flig= "fates_cwd_flig" @@ -97,8 +93,6 @@ subroutine FatesParamsInit() ED_val_init_litter = nan ED_val_nfires = nan ED_val_understorey_death = nan - ED_val_profile_tol = nan - ED_val_cohort_fusion_tol = nan ED_val_ag_biomass = nan ED_val_cwd_fcel = nan ED_val_cwd_flig = nan @@ -168,12 +162,6 @@ subroutine FatesRegisterParams(fates_params) call fates_params%RegisterParameter(name=ED_name_understorey_death, dimension_shape=dimension_shape_1d, & dimension_names=dim_names) - call fates_params%RegisterParameter(name=ED_name_profile_tol, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names) - - call fates_params%RegisterParameter(name=ED_name_cohort_fusion_tol, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names) - call fates_params%RegisterParameter(name=ED_name_ag_biomass, dimension_shape=dimension_shape_1d, & dimension_names=dim_names) @@ -269,12 +257,6 @@ subroutine FatesReceiveParams(fates_params) call fates_params%RetreiveParameter(name=ED_name_understorey_death, & data=ED_val_understorey_death) - call fates_params%RetreiveParameter(name=ED_name_profile_tol, & - data=ED_val_profile_tol) - - call fates_params%RetreiveParameter(name=ED_name_cohort_fusion_tol, & - data=ED_val_cohort_fusion_tol) - call fates_params%RetreiveParameter(name=ED_name_ag_biomass, & data=ED_val_ag_biomass) diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index 4937b6e4..58ddd8cd 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -42,7 +42,6 @@ module EDPftvarcon real(r8), allocatable :: clone_alloc (:) ! fraction of carbon balance allocated to clonal reproduction. real(r8), allocatable :: seed_alloc (:) ! fraction of carbon balance allocated to seeds. real(r8), allocatable :: sapwood_ratio (:) ! amount of sapwood per unit leaf carbon and m of height. gC/gC/m - real(r8), allocatable :: dbh2h_m (:) ! allocation parameter m from dbh to height real(r8), allocatable :: woody(:) real(r8), allocatable :: stress_decid(:) real(r8), allocatable :: season_decid(:) @@ -67,7 +66,30 @@ module EDPftvarcon real(r8), allocatable :: smpso(:) real(r8), allocatable :: smpsc(:) real(r8), allocatable :: grperc(:) ! NOTE(bja, 2017-01) moved from EDParamsMod, was allocated as (maxPft=79), not (0:mxpft=78)! - real(r8), allocatable :: xxx(:) + real(r8), allocatable :: dbh2h_m(:) + real(r8), allocatable :: dbh2h_c(:) + real(r8), allocatable :: dbh2bl_a(:) + real(r8), allocatable :: dbh2bl_b(:) + real(r8), allocatable :: dbh2bl_c(:) + real(r8), allocatable :: dbh2bl_slascaler(:) + real(r8), allocatable :: sai_scaler(:) + real(r8), allocatable :: dbh2bd_a(:) + real(r8), allocatable :: dbh2bd_b(:) + real(r8), allocatable :: dbh2bd_c(:) + real(r8), allocatable :: dbh2bd_d(:) + real(r8), allocatable :: bmort(:) + real(r8), allocatable :: hf_sm_threshold(:) + real(r8), allocatable :: vcmaxha(:) + real(r8), allocatable :: jmaxha(:) + real(r8), allocatable :: tpuha(:) + real(r8), allocatable :: vcmaxhd(:) + real(r8), allocatable :: jmaxhd(:) + real(r8), allocatable :: tpuhd(:) + real(r8), allocatable :: vcmaxse(:) + real(r8), allocatable :: jmaxse(:) + real(r8), allocatable :: tpuse(:) + real(r8), allocatable :: germination_timescale(:) + real(r8), allocatable :: seed_decay_turnover(:) real(r8), allocatable :: rhol(:, :) real(r8), allocatable :: rhos(:, :) real(r8), allocatable :: taul(:, :) @@ -340,7 +362,99 @@ subroutine Register_PFT(this, fates_params) call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'fates_xxx' + name = 'fates_dbh2h_m' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_dbh2h_c' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_dbh2bl_a' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_dbh2bl_b' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_dbh2bl_c' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_dbh2bl_slascaler' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_sai_scaler' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_dbh2bd_a' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_dbh2bd_b' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_dbh2bd_c' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_dbh2bd_d' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_bmort' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_hf_sm_threshold' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_vcmaxha' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_jmaxha' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_tpuha' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_vcmaxhd' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_jmaxhd' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_tpuhd' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_vcmaxse' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_jmaxse' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_tpuse' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_germination_timescale' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_seed_decay_turnover' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) @@ -543,9 +657,101 @@ subroutine Receive_PFT(this, fates_params) call fates_params%RetreiveParameterAllocate(name=name, & data=this%grperc) - name = 'fates_xxx' + name = 'fates_dbh2h_m' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%dbh2h_m) + + name = 'fates_dbh2h_c' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%dbh2h_c) + + name = 'fates_dbh2bl_a' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%dbh2bl_a) + + name = 'fates_dbh2bl_b' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%dbh2bl_b) + + name = 'fates_dbh2bl_c' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%dbh2bl_c) + + name = 'fates_dbh2bl_slascaler' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%dbh2bl_slascaler) + + name = 'fates_sai_scaler' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%sai_scaler) + + name = 'fates_dbh2bd_a' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%dbh2bd_a) + + name = 'fates_dbh2bd_b' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%dbh2bd_b) + + name = 'fates_dbh2bd_c' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%dbh2bd_c) + + name = 'fates_dbh2bd_d' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%dbh2bd_d) + + name = 'fates_bmort' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%bmort) + + name = 'fates_hf_sm_threshold' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%hf_sm_threshold) + + name = 'fates_vcmaxha' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%vcmaxha) + + name = 'fates_jmaxha' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%jmaxha) + + name = 'fates_tpuha' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%tpuha) + + name = 'fates_vcmaxhd' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%vcmaxhd) + + name = 'fates_jmaxhd' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%jmaxhd) + + name = 'fates_tpuhd' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%tpuhd) + + name = 'fates_vcmaxse' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%vcmaxse) + + name = 'fates_jmaxse' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%jmaxse) + + name = 'fates_tpuse' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%tpuse) + + name = 'fates_germination_timescale' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%germination_timescale) + + name = 'fates_seed_decay_turnover' call fates_params%RetreiveParameterAllocate(name=name, & - data=this%xxx) + data=this%seed_decay_turnover) end subroutine Receive_PFT From fee2fd9dcd18d750d5c3c98a3b462074bda8aecb Mon Sep 17 00:00:00 2001 From: ckoven Date: Thu, 30 Mar 2017 10:08:53 -0700 Subject: [PATCH 386/437] added parameter to allow possible difference between bleaf and crown area exponents --- biogeochem/EDGrowthFunctionsMod.F90 | 6 ++++-- main/EDPftvarcon.F90 | 9 +++++++++ 2 files changed, 13 insertions(+), 2 deletions(-) diff --git a/biogeochem/EDGrowthFunctionsMod.F90 b/biogeochem/EDGrowthFunctionsMod.F90 index e0ed607b..196c4ffd 100755 --- a/biogeochem/EDGrowthFunctionsMod.F90 +++ b/biogeochem/EDGrowthFunctionsMod.F90 @@ -230,8 +230,10 @@ real(r8) function c_area( cohort_in ) real(r8) :: dbh ! Tree diameter at breat height. cm. real(r8) :: crown_area_to_dbh_exponent - ! use the same exponent as the dbh to bleaf exponent so that per-plant canopy depth remains invariant during growth - crown_area_to_dbh_exponent = EDPftvarcon_inst%dbh2bl_b(cohort_in%pft) + ! default is to use the same exponent as the dbh to bleaf exponent so that per-plant canopy depth remains invariant during growth, + ! but allowed to vary via the dbh2bl_dbh2carea_expnt_diff term (which has default value of zero) + crown_area_to_dbh_exponent = EDPftvarcon_inst%dbh2bl_b(cohort_in%pft) + & + EDPftvarcon_inst%dbh2bl_dbh2carea_expnt_diff(cohort_in%pft) if (DEBUG_growth) then write(fates_log(),*) 'z_area 1',cohort_in%dbh,cohort_in%pft diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index 58ddd8cd..521a85cd 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -70,6 +70,7 @@ module EDPftvarcon real(r8), allocatable :: dbh2h_c(:) real(r8), allocatable :: dbh2bl_a(:) real(r8), allocatable :: dbh2bl_b(:) + real(r8), allocatable :: dbh2bl_dbh2carea_expnt_diff(:) real(r8), allocatable :: dbh2bl_c(:) real(r8), allocatable :: dbh2bl_slascaler(:) real(r8), allocatable :: sai_scaler(:) @@ -378,6 +379,10 @@ subroutine Register_PFT(this, fates_params) call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) + name = 'fates_dbh2bl_dbh2carea_expnt_diff' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + name = 'fates_dbh2bl_c' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) @@ -673,6 +678,10 @@ subroutine Receive_PFT(this, fates_params) call fates_params%RetreiveParameterAllocate(name=name, & data=this%dbh2bl_b) + name = 'fates_dbh2bl_dbh2carea_expnt_diff' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%dbh2bl_dbh2carea_expnt_diff) + name = 'fates_dbh2bl_c' call fates_params%RetreiveParameterAllocate(name=name, & data=this%dbh2bl_c) From 42bc086efe8bd51ac1ef1c3e6abf7277b5a6944e Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 30 Mar 2017 18:17:25 -0700 Subject: [PATCH 387/437] Reduced a line-length to prevent compiler freak-out. --- biogeochem/EDGrowthFunctionsMod.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/biogeochem/EDGrowthFunctionsMod.F90 b/biogeochem/EDGrowthFunctionsMod.F90 index 196c4ffd..f0c081c8 100755 --- a/biogeochem/EDGrowthFunctionsMod.F90 +++ b/biogeochem/EDGrowthFunctionsMod.F90 @@ -120,7 +120,8 @@ real(r8) function Bleaf( cohort_in ) if(cohort_in%dbh <= EDPftvarcon_inst%max_dbh(cohort_in%pft))then bleaf = dbh2bl_a * (cohort_in%dbh**dbh2bl_b) * EDPftvarcon_inst%wood_density(cohort_in%pft)**dbh2bl_c else - bleaf = dbh2bl_a * (EDPftvarcon_inst%max_dbh(cohort_in%pft)**dbh2bl_b) * EDPftvarcon_inst%wood_density(cohort_in%pft)**dbh2bl_c + bleaf = dbh2bl_a * (EDPftvarcon_inst%max_dbh(cohort_in%pft)**dbh2bl_b) * & + EDPftvarcon_inst%wood_density(cohort_in%pft)**dbh2bl_c endif bleaf = bleaf * slascaler From ac907f1cd7255534a21ab4ba7ba25a01a7262d24 Mon Sep 17 00:00:00 2001 From: ckoven Date: Fri, 31 Mar 2017 11:35:41 -0700 Subject: [PATCH 388/437] cleaned up some parameter passing and also metadata on associated param file --- biogeochem/EDPhysiologyMod.F90 | 35 ++++++---------------- biogeophys/FatesPlantRespPhotosynthMod.F90 | 9 ++---- 2 files changed, 12 insertions(+), 32 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index b583efeb..f85bc676 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -274,7 +274,6 @@ subroutine phenology( currentSite, bc_in ) 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 integer :: refdate @@ -286,32 +285,15 @@ subroutine phenology( currentSite, bc_in ) integer :: sec ! seconds of the day 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 integer :: ncdstart ! beginning of counting period for chilling degree days. integer :: gddstart ! 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 ! 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 = ED_val_phen_drought_threshold - off_time = ED_val_phen_doff_time !Parameters: defaults from Botta et al. 2000 GCB,6 709-725 - a = ED_val_phen_a - b = ED_val_phen_b - c = ED_val_phen_c - coldday = ED_val_phen_chiltemp - - mindayson = ED_val_phen_mindayson - !Parameters, default from from SDGVM model of senesence - ncolddayslim = ED_val_phen_ncolddayslim - cold_t = ED_val_phen_coldtemp t = hlm_day_of_year temp_in_C = bc_in%t_veg24_si - tfrz @@ -333,11 +315,12 @@ subroutine phenology( currentSite, bc_in ) endif !Accumulate growing/chilling days after start of counting period - if (temp_in_C < coldday)then + if (temp_in_C < ED_val_phen_chiltemp)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. + !GDD accumulation function, which also depends on chilling days. + gdd_threshold = ED_val_phen_a + ED_val_phen_b*exp(ED_val_phen_c*currentSite%ncd) !Accumulate temperature of last 10 days. currentSite%last_n_days(2:senes) = currentSite%last_n_days(1:senes-1) @@ -345,7 +328,7 @@ subroutine phenology( currentSite, bc_in ) !count number of days for leaves off ncolddays = 0 do i = 1,senes - if (currentSite%last_n_days(i) < cold_t)then + if (currentSite%last_n_days(i) < ED_val_phen_coldtemp)then ncolddays = ncolddays + 1 endif enddo @@ -389,8 +372,8 @@ subroutine phenology( currentSite, bc_in ) !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 (ncolddays > ED_val_phen_ncolddayslim)then + if (timesinceleafon > ED_val_phen_mindayson)then if (currentSite%status == 2)then currentSite%status = 1 !alter status of site to 'leaves on' currentSite%leafoffdate = hlm_model_day !record leaf off date @@ -470,9 +453,9 @@ subroutine phenology( currentSite, bc_in ) currentSite%dleafondate < 15))then ! are we in the window? ! TODO: CHANGE THIS MATH, MOVE THE DENOMENATOR OUTSIDE OF THE SUM (rgk 01-2017) if (sum(currentSite%water_memory(1:numWaterMem)/dble(numWaterMem)) & - >= drought_threshold.and.currentSite%dstatus == 1.and.t >= 10)then + >= ED_val_phen_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 + if (timesincedleafoff > ED_val_phen_doff_time)then currentSite%dstatus = 2 !alter status of site to 'leaves on' currentSite%dleafondate = t !record leaf on date endif @@ -496,7 +479,7 @@ subroutine phenology( currentSite, bc_in ) !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 (sum(currentSite%water_memory(1:10)/10._r8) <= ED_val_phen_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 diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index 55eace1d..726a18f3 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -183,8 +183,6 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! (gC/gN/s) ! ------------------------------------------------------------------------ - real(r8) :: base_mr_20 - ! ----------------------------------------------------------------------------------- ! Photosynthesis and stomatal conductance parameters, from: ! Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 @@ -208,7 +206,6 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) frootcn => EDPftvarcon_inst%frootcn, & ! froot C:N (gc/gN) ! slope of BB relationship q10 => FatesSynchronizedParamsInst%Q10 ) - base_mr_20 = ED_val_base_mr_20 bbbopt(1) = ED_val_bbopt_c3 bbbopt(2) = ED_val_bbopt_c4 @@ -535,7 +532,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) if (woody(ft) == 1) then tcwood = q10**((bc_in(s)%t_veg_pa(ifp)-tfrz - 20.0_r8)/10.0_r8) ! kgC/s = kgN * kgC/kgN/s - currentCohort%livestem_mr = live_stem_n * base_mr_20 * tcwood + currentCohort%livestem_mr = live_stem_n * ED_val_base_mr_20 * tcwood else currentCohort%livestem_mr = 0._r8 end if @@ -547,7 +544,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) do j = 1,hlm_numlevsoil tcsoi = q10**((bc_in(s)%t_soisno_gl(j)-tfrz - 20.0_r8)/10.0_r8) currentCohort%froot_mr = currentCohort%froot_mr + & - froot_n * base_mr_20 * tcsoi * currentPatch%rootfr_ft(ft,j) + froot_n * ED_val_base_mr_20 * tcsoi * currentPatch%rootfr_ft(ft,j) enddo ! Coarse Root MR (kgC/plant/s) (below ground sapwood) @@ -558,7 +555,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! Soil temperature used to adjust base rate of MR tcsoi = q10**((bc_in(s)%t_soisno_gl(j)-tfrz - 20.0_r8)/10.0_r8) currentCohort%livecroot_mr = currentCohort%livecroot_mr + & - live_croot_n * base_mr_20 * tcsoi * & + live_croot_n * ED_val_base_mr_20 * tcsoi * & currentPatch%rootfr_ft(ft,j) enddo else From 03a5447be13ec9ac34992f29da4d0524b3388ddb Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 31 Mar 2017 17:50:57 -0700 Subject: [PATCH 389/437] Added and interface to FATES plant hydraulics. Added stubs for hydraulics. --- biogeochem/EDCanopyStructureMod.F90 | 13 +- biogeochem/EDCohortDynamicsMod.F90 | 34 +- biogeochem/EDPatchDynamicsMod.F90 | 33 +- biogeochem/EDPhysiologyMod.F90 | 351 ++++++++--------- biogeophys/EDBtranMod.F90 | 43 ++- biogeophys/FatesPlantHydraulicsMod.F90 | 346 +++++++++++++++++ biogeophys/FatesPlantRespPhotosynthMod.F90 | 19 +- main/EDEcophysConType.F90 | 208 +++++++++- main/EDInitMod.F90 | 26 +- main/EDMainMod.F90 | 186 +++++++-- main/EDTypesMod.F90 | 31 +- main/FatesConstantsMod.F90 | 6 + main/FatesHistoryInterfaceMod.F90 | 428 ++++++++++++++++++++- main/FatesHydraulicsMemMod.F90 | 218 +++++++++++ main/FatesInterfaceMod.F90 | 206 +++++++--- main/FatesRestartInterfaceMod.F90 | 7 +- 16 files changed, 1830 insertions(+), 325 deletions(-) create mode 100644 biogeophys/FatesPlantHydraulicsMod.F90 create mode 100644 main/FatesHydraulicsMemMod.F90 diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 7ff3b8e0..f735d1e5 100755 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -41,7 +41,7 @@ module EDCanopyStructureMod contains ! ============================================================================ - subroutine canopy_structure( currentSite ) + subroutine canopy_structure( currentSite , bc_in ) ! ! !DESCRIPTION: ! create cohort instance @@ -84,9 +84,12 @@ subroutine canopy_structure( currentSite ) use EDParamsMod, only : ED_val_comp_excln, ED_val_ag_biomass use SFParamsMod, only : SF_val_cwd_frac use EDtypesMod , only : ncwd, min_patch_area + use FatesInterfaceMod, only : bc_in_type ! ! !ARGUMENTS type(ed_site_type) , intent(inout), target :: currentSite + type(bc_in_type), intent(in) :: bc_in + ! ! !LOCAL VARIABLES: type(ed_patch_type) , pointer :: currentPatch @@ -382,7 +385,7 @@ subroutine canopy_structure( currentSite ) enddo !is there still excess area in any layer? - call fuse_cohorts(currentPatch) + call fuse_cohorts(currentPatch, bc_in) call terminate_cohorts(currentSite, currentPatch) ! ----------- Check cohort area ------------------------------! @@ -602,7 +605,7 @@ subroutine canopy_structure( currentSite ) endif enddo !is there still not enough canopy area in any layer? - call fuse_cohorts(currentPatch) + call fuse_cohorts(currentPatch, bc_in) call terminate_cohorts(currentSite, currentPatch) if(promswitch == 1)then @@ -734,7 +737,7 @@ subroutine canopy_summarization( nsites, sites, bc_in ) use FatesInterfaceMod , only : bc_in_type use EDPatchDynamicsMod , only : set_patchno - use EDPatchDYnamicsMod , only : set_root_fraction + use EDPatchDynamicsMod , only : set_root_fraction use EDTypesMod , only : sizetype_class_index use EDGrowthFunctionsMod , only : tree_lai, c_area use EDEcophysConType , only : EDecophyscon @@ -774,7 +777,7 @@ subroutine canopy_summarization( nsites, sites, bc_in ) do while(associated(currentPatch)) - call set_root_fraction(currentPatch,bc_in(s)%depth_gl) + call set_root_fraction(currentPatch,bc_in(s)%zi_sisl) !zero cohort-summed variables. currentPatch%total_canopy_area = 0.0_r8 diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 74cf8c3e..92811786 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -7,6 +7,7 @@ module EDCohortDynamicsMod use FatesGlobals , only : endrun => fates_endrun use FatesGlobals , only : fates_log use FatesInterfaceMod , only : hlm_freq_day + use FatesInterfaceMod , only : bc_in_type use FatesConstantsMod , only : r8 => fates_r8 use FatesConstantsMod , only : fates_unset_int use FatesInterfaceMod , only : hlm_days_per_year @@ -21,7 +22,15 @@ module EDCohortDynamicsMod use EDTypesMod , only : sclass_ed,nlevsclass_ed,AREA use EDTypesMod , only : min_npm2, min_nppatch use EDTypesMod , only : min_n_safemath - use EDTypesMod , only : sizetype_class_index + use EDTypesMod , only : use_fates_plant_hydro + use FatesPlantHydraulicsMod, only : FuseCohortHydraulics + use FatesPlantHydraulicsMod, only : CopyCohortHydraulics + use FatesPlantHydraulicsMod, only : updateSizeDepTreeHydProps + use FatesPlantHydraulicsMod, only : initTreeHydStates + use FatesPlantHydraulicsMod, only : InitHydrCohort + use FatesPlantHydraulicsMod, only : DeallocateHydrCohort + use EDTypesMod , only : sizetype_class_index + ! CIME globals use shr_log_mod , only : errMsg => shr_log_errMsg ! @@ -51,7 +60,7 @@ module EDCohortDynamicsMod !-------------------------------------------------------------------------------------! subroutine create_cohort(patchptr, pft, nn, hite, dbh, & - balive, bdead, bstore, laimemory, status, ctrim, clayer) + balive, bdead, bstore, laimemory, status, ctrim, clayer, bc_in) ! ! !DESCRIPTION: ! create new cohort @@ -71,6 +80,7 @@ subroutine create_cohort(patchptr, pft, nn, hite, dbh, & 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? :- + type(bc_in_type), intent(in) :: bc_in ! External boundary conditions ! ! !LOCAL VARIABLES: type(ed_cohort_type), pointer :: new_cohort ! Pointer to New Cohort structure. @@ -164,6 +174,12 @@ subroutine create_cohort(patchptr, pft, nn, hite, dbh, & ! growth, disturbance and mortality. new_cohort%isnew = .true. + if( use_fates_plant_hydro ) then + call InitHydrCohort(new_cohort) + call updateSizeDepTreeHydProps(new_cohort, bc_in) + call initTreeHydStates(new_cohort, bc_in) + endif + call insert_cohort(new_cohort, patchptr%tallest, patchptr%shortest, tnull, snull, & storebigcohort, storesmallcohort) @@ -614,7 +630,7 @@ subroutine terminate_cohorts( currentSite, patchptr ) + currentCohort%n*(currentCohort%bdead+currentCohort%bsw) * & SF_val_CWD_frac(c) * (1.0_r8 - ED_val_ag_biomass) * hlm_days_per_year / AREA enddo - + currentSite%leaf_litter_diagnostic_input_carbonflux(currentCohort%pft) = & currentSite%leaf_litter_diagnostic_input_carbonflux(currentCohort%pft) + & currentCohort%n * (currentCohort%bl) * hlm_days_per_year / AREA @@ -622,6 +638,8 @@ subroutine terminate_cohorts( currentSite, patchptr ) currentSite%root_litter_diagnostic_input_carbonflux(currentCohort%pft) + & currentCohort%n * (currentCohort%br+currentCohort%bstore) * hlm_days_per_year / AREA + if (use_fates_plant_hydro) call DeallocateHydrCohort(currentCohort) + deallocate(currentCohort) endif endif @@ -631,7 +649,7 @@ subroutine terminate_cohorts( currentSite, patchptr ) end subroutine terminate_cohorts !-------------------------------------------------------------------------------------! - subroutine fuse_cohorts(patchptr) + subroutine fuse_cohorts(patchptr, bc_in) ! ! !DESCRIPTION: ! Join similar cohorts to reduce total number @@ -641,6 +659,7 @@ subroutine fuse_cohorts(patchptr) ! ! !ARGUMENTS type (ed_patch_type), intent(inout), target :: patchptr + type (bc_in_type), intent(in) :: bc_in ! ! !LOCAL VARIABLES: type (ed_patch_type) , pointer :: currentPatch @@ -802,6 +821,8 @@ subroutine fuse_cohorts(patchptr) endif enddo + if(use_fates_plant_hydro) call FuseCohortHydraulics(currentCohort,nextc,bc_in,newn) + currentCohort%n = newn !remove fused cohort from the list nextc%taller%shorter => nextnextc @@ -812,6 +833,7 @@ subroutine fuse_cohorts(patchptr) endif if (associated(nextc)) then + if(use_fates_plant_hydro) call DeallocateHydrCohort(nextc) deallocate(nextc) endif @@ -1152,6 +1174,10 @@ subroutine copy_cohort( currentCohort,copyc ) n%crownfire_mort = o%crownfire_mort n%cambial_mort = o%cambial_mort + ! Plant Hydraulics + + if( use_fates_plant_hydro ) call CopyCohortHydraulics(n,o) + !Pointers n%taller => NULL() ! pointer to next tallest cohort n%shorter => NULL() ! pointer to next shorter cohort diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 820e7d8f..145a4e0c 100755 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -13,12 +13,16 @@ module EDPatchDynamicsMod use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type use EDTypesMod , only : min_patch_area use EDTypesMod , only : nclmax + use EDTypesMod , only : use_fates_plant_hydro use FatesInterfaceMod , only : hlm_numlevgrnd use FatesInterfaceMod , only : hlm_numlevsoil use FatesInterfaceMod , only : hlm_numSWb + use FatesInterfaceMod , only : bc_in_type use FatesInterfaceMod , only : hlm_days_per_year use FatesGlobals , only : endrun => fates_endrun use FatesConstantsMod , only : r8 => fates_r8 + use FatesPlantHydraulicsMod, only : InitHydrCohort + use FatesPlantHydraulicsMod, only : DeallocateHydrCohort ! CIME globals use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) @@ -162,7 +166,7 @@ subroutine disturbance_rates( site_in) end subroutine disturbance_rates ! ============================================================================ - subroutine spawn_patches( currentSite ) + subroutine spawn_patches( currentSite, bc_in) ! ! !DESCRIPTION: ! In this subroutine, the following happens @@ -181,9 +185,11 @@ subroutine spawn_patches( currentSite ) 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 + type (bc_in_type), intent(in) :: bc_in ! ! !LOCAL VARIABLES: type (ed_patch_type) , pointer :: new_patch @@ -263,6 +269,7 @@ subroutine spawn_patches( currentSite ) do while(associated(currentCohort)) allocate(nc) + if(use_fates_plant_hydro) call InitHydrCohort(nc) call zero_cohort(nc) ! nc is the new cohort that goes in the disturbed patch (new_patch)... currentCohort @@ -379,6 +386,7 @@ subroutine spawn_patches( currentSite ) new_patch%tallest => storebigcohort new_patch%shortest => storesmallcohort else + if(use_fates_plant_hydro) call DeallocateHydrCohort(nc) deallocate(nc) !get rid of the new memory. endif @@ -394,7 +402,8 @@ subroutine spawn_patches( currentSite ) 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 fuse_cohorts(currentPatch, bc_in) call terminate_cohorts(currentSite, currentPatch) call sort_cohorts(currentPatch) @@ -411,7 +420,7 @@ subroutine spawn_patches( currentSite ) currentPatch%younger => new_patch currentSite%youngest_patch => new_patch - call fuse_cohorts(new_patch) + call fuse_cohorts(new_patch, bc_in) call terminate_cohorts(currentSite, new_patch) call sort_cohorts(new_patch) @@ -1040,7 +1049,7 @@ subroutine zero_patch(cp_p) end subroutine zero_patch ! ============================================================================ - subroutine fuse_patches( csite ) + subroutine fuse_patches( csite, bc_in ) ! ! !DESCRIPTION: ! Decide to fuse patches if their cohort structures are similar @@ -1050,6 +1059,7 @@ subroutine fuse_patches( csite ) ! ! !ARGUMENTS: type(ed_site_type), intent(inout), target :: csite + type(bc_in_type), intent(in) :: bc_in ! ! !LOCAL VARIABLES: type(ed_site_type) , pointer :: currentSite @@ -1142,7 +1152,7 @@ subroutine fuse_patches( csite ) if(fuse_flag == 1)then tmpptr => currentPatch%older call fuse_2_patches(currentPatch, tpp) - call fuse_cohorts(tpp) + call fuse_cohorts(tpp, bc_in) call sort_cohorts(tpp) currentPatch => tmpptr else @@ -1433,6 +1443,7 @@ subroutine dealloc_patch(cpatch) do while(associated(ccohort)) ncohort => ccohort%taller + if(use_fates_plant_hydro) call DeallocateHydrCohort(ccohort) deallocate(ccohort) ccohort => ncohort @@ -1553,7 +1564,7 @@ end function countPatches ! ==================================================================================== - subroutine set_root_fraction( cpatch , depth_gl ) + subroutine set_root_fraction( cpatch , zi ) ! ! !DESCRIPTION: ! Calculates the fractions of the root biomass in each layer for each pft. @@ -1563,7 +1574,7 @@ subroutine set_root_fraction( cpatch , depth_gl ) ! ! !ARGUMENTS type(ed_patch_type),intent(inout), target :: cpatch - real(r8),intent(in) :: depth_gl(0:hlm_numlevgrnd) + real(r8),intent(in) :: zi(0:hlm_numlevsoil) ! ! !LOCAL VARIABLES: integer :: lev,p,c,ft @@ -1576,10 +1587,10 @@ subroutine set_root_fraction( cpatch , depth_gl ) do lev = 1, hlm_numlevsoil-1 cpatch%rootfr_ft(ft,lev) = .5_r8*( & - exp(-EDPftvarcon_inst%roota_par(ft) * depth_gl(lev-1)) & - + exp(-EDPftvarcon_inst%rootb_par(ft) * depth_gl(lev-1)) & - - exp(-EDPftvarcon_inst%roota_par(ft) * depth_gl(lev)) & - - exp(-EDPftvarcon_inst%rootb_par(ft) * depth_gl(lev))) + exp(-EDPftvarcon_inst%roota_par(ft) * zi(lev-1)) & + + exp(-EDPftvarcon_inst%rootb_par(ft) * zi(lev-1)) & + - exp(-EDPftvarcon_inst%roota_par(ft) * zi(lev)) & + - exp(-EDPftvarcon_inst%rootb_par(ft) * zi(lev))) end do end do diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 7a7de349..71b324ce 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -17,7 +17,7 @@ module EDPhysiologyMod use EDEcophysContype , only : EDecophyscon use FatesInterfaceMod, only : bc_in_type use EDCohortDynamicsMod , only : allocate_live_biomass, zero_cohort - use EDCohortDynamicsMod , only : create_cohort, fuse_cohorts, sort_cohorts + use EDCohortDynamicsMod , only : create_cohort, sort_cohorts use EDTypesMod , only : numWaterMem use EDTypesMod , only : dl_sf, dinc_ed @@ -430,11 +430,11 @@ subroutine phenology( currentSite, bc_in ) ! distinction actually matter??).... !Accumulate surface water memory of last 10 days. - + do i = 1,numWaterMem-1 !shift memory along one currentSite%water_memory(numWaterMem+1-i) = currentSite%water_memory(numWaterMem-i) enddo - currentSite%water_memory(1) = bc_in%h2osoi_vol_si !waterstate_inst%h2osoi_vol_col(coli,1) + currentSite%water_memory(1) = bc_in%h2o_liqvol_gl(1) !waterstate_inst%h2osoi_vol_col(coli,1) !In drought phenology, we often need to force the leaves to stay on or off as moisture fluctuates... timesincedleafoff = 0 @@ -854,7 +854,8 @@ subroutine Growth_Derivatives( currentSite, currentCohort, bc_in) currentCohort%md = currentCohort%root_md + currentCohort%leaf_md endif - if (EDPftvarcon_inst%stress_decid(currentCohort%pft) /= 1.and.EDPftvarcon_inst%season_decid(currentCohort%pft) /= 1.and. & + if (EDPftvarcon_inst%stress_decid(currentCohort%pft) /= 1 & + .and.EDPftvarcon_inst%season_decid(currentCohort%pft) /= 1.and. & EDPftvarcon_inst%evergreen(currentCohort%pft) /= 1)then write(fates_log(),*) 'problem with phenology definitions',currentCohort%pft, & EDPftvarcon_inst%stress_decid(currentCohort%pft), & @@ -895,7 +896,7 @@ subroutine Growth_Derivatives( currentSite, currentCohort, bc_in) 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 + currentCohort%storage_flux = currentCohort%carbon_balance * f_store currentCohort%npp_store = currentCohort%carbon_balance * f_store if ( DEBUG ) write(fates_log(),*) 'EDphys B ',f_store @@ -1021,7 +1022,7 @@ subroutine Growth_Derivatives( currentSite, currentCohort, bc_in) end subroutine Growth_Derivatives ! ============================================================================ - subroutine recruitment( t, currentSite, currentPatch ) + subroutine recruitment( t, currentSite, currentPatch, bc_in ) ! ! !DESCRIPTION: ! spawn new cohorts of juveniles of each PFT @@ -1033,6 +1034,7 @@ subroutine recruitment( t, currentSite, currentPatch ) integer, intent(in) :: t type(ed_site_type), intent(inout), target :: currentSite type(ed_patch_type), intent(inout), pointer :: currentPatch + type(bc_in_type), intent(in) :: bc_in ! ! !LOCAL VARIABLES: integer :: ft @@ -1083,10 +1085,12 @@ subroutine recruitment( t, currentSite, currentPatch ) if ( DEBUG ) write(fates_log(),*) 'EDPhysiologyMod.F90 call create_cohort ' 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) + temp_cohort%laimemory, cohortstatus, temp_cohort%canopy_trim, currentPatch%NCL_p, & + bc_in) ! keep track of how many individuals were recruited for passing to history currentSite%recruitment_rate(ft) = currentSite%recruitment_rate(ft) + temp_cohort%n + endif enddo !pft loop @@ -1342,7 +1346,6 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) use SoilBiogeochemVerticalProfileMod, only: surfprof_exp use EDPftvarcon, only : EDPftvarcon_inst use FatesConstantsMod, only : sec_per_day - use clm_varcon, only : zisoi, dzsoi_decomp, zsoi use EDParamsMod, only : ED_val_ag_biomass use FatesInterfaceMod, only : bc_in_type, bc_out_type use clm_varctl, only : use_vertsoilc @@ -1350,7 +1353,7 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) ! INTERF-TODO: remove the control parameters: exponential_rooting_profile, - ! pftspecific_rootingprofile, rootprof_exp, surfprof_exp, zisoi, dzsoi_decomp, zsoi + ! pftspecific_rootingprofile, rootprof_exp, surfprof_exp ! implicit none ! @@ -1415,169 +1418,171 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) mass_convert = 1000._r8 - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! first calculate vertical profiles - ! define two types of profiles: - ! (1) a surface profile, for leaves and stem inputs, which is the same for each - ! pft but differs from one site to the next to avoid inputting any C into permafrost or bedrock - ! (2) a fine root profile, which is indexed by both site and pft, differs for - ! each pft and also from one site to the next to avoid inputting any C into permafrost or bedrock - ! (3) a coarse root profile, which is the root-biomass=weighted average of the fine root profiles - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - if (use_vertsoilc) then - - ! define a single shallow surface profile for surface additions (leaves, stems, and N deposition) - surface_prof(:) = 0._r8 - do j = 1, hlm_numlevdecomp - surface_prof(j) = exp(-surfprof_exp * zsoi(j)) / dzsoi_decomp(j) - end do - - ! initialize profiles to zero - leaf_prof(1:nsites, :) = 0._r8 - froot_prof(1:nsites, 1:numpft_ed, :) = 0._r8 - croot_prof(1:nsites, :) = 0._r8 - stem_prof(1:nsites, :) = 0._r8 - - cinput_rootfr(1:numpft_ed, :) = 0._r8 - - ! calculate pft-specific rooting profiles in the absence of permafrost or bedrock limitations - if ( exponential_rooting_profile ) then - if ( .not. pftspecific_rootingprofile ) then - ! define rooting profile from exponential parameters - do ft = 1, numpft_ed - do j = 1, hlm_numlevdecomp - cinput_rootfr(ft,j) = exp(-rootprof_exp * zsoi(j)) / dzsoi_decomp(j) - end do - end do - else - ! use beta distribution parameter from Jackson et al., 1996 - do ft = 1, numpft_ed - do j = 1, hlm_numlevdecomp - cinput_rootfr(ft,j) = & - ( EDPftvarcon_inst%rootprof_beta(ft, rooting_profile_varindex_water) ** (zisoi(j-1)*100._r8) - & - EDPftvarcon_inst%rootprof_beta(ft, rooting_profile_varindex_water) ** (zisoi(j)*100._r8) ) & - / dzsoi_decomp(j) - end do - end do - endif - else - do ft = 1,numpft_ed - do j = 1, hlm_numlevdecomp - ! use standard CLM root fraction profiles; - cinput_rootfr(ft,j) = ( .5_r8*( & - exp(-EDPftvarcon_inst%roota_par(ft) * zisoi(j-1)) & - + exp(-EDPftvarcon_inst%rootb_par(ft) * zisoi(j-1)) & - - exp(-EDPftvarcon_inst%roota_par(ft) * zisoi(j)) & - - exp(-EDPftvarcon_inst%rootb_par(ft) * zisoi(j)))) / dzsoi_decomp(j) - end do - end do - endif - ! - - do s = 1,nsites - ! - ! now add permafrost constraint: integrate rootfr over active layer of soil site, - ! truncate below permafrost or bedrock table where present, and rescale so that integral = 1 - do ft = 1,numpft_ed - rootfr_tot(ft) = 0._r8 - end do - surface_prof_tot = 0._r8 - ! - do j = 1, min(max(bc_in(s)%max_rooting_depth_index_col, 1), hlm_numlevdecomp) - surface_prof_tot = surface_prof_tot + surface_prof(j) * dzsoi_decomp(j) - end do - do ft = 1,numpft_ed - do j = 1, min(max(bc_in(s)%max_rooting_depth_index_col, 1), hlm_numlevdecomp) - rootfr_tot(ft) = rootfr_tot(ft) + cinput_rootfr(ft,j) * dzsoi_decomp(j) - end do - end do - ! - ! rescale the fine root profile - do ft = 1,numpft_ed - if ( (bc_in(s)%max_rooting_depth_index_col > 0) .and. (rootfr_tot(ft) > 0._r8) ) then - ! where there is not permafrost extending to the surface, integrate the profiles over the active layer - ! this is equivalent to integrating over all soil layers outside of permafrost regions - do j = 1, min(max(bc_in(s)%max_rooting_depth_index_col, 1), hlm_numlevdecomp) - froot_prof(s,ft,j) = cinput_rootfr(ft,j) / rootfr_tot(ft) - end do - else - ! if fully frozen, or no roots, put everything in the top layer - froot_prof(s,ft,1) = 1._r8/dzsoi_decomp(1) - endif - end do - ! - ! rescale the shallow profiles - if ( (bc_in(s)%max_rooting_depth_index_col > 0) .and. (surface_prof_tot > 0._r8) ) then - ! where there is not permafrost extending to the surface, integrate the profiles over the active layer - ! this is equivalent to integrating over all soil layers outside of permafrost regions - do j = 1, min(max(bc_in(s)%max_rooting_depth_index_col, 1), hlm_numlevdecomp) - ! set all surface processes to shallower profile - leaf_prof(s,j) = surface_prof(j)/ surface_prof_tot - stem_prof(s,j) = surface_prof(j)/ surface_prof_tot - end do - else - ! if fully frozen, or no roots, put everything in the top layer - leaf_prof(s,1) = 1._r8/dzsoi_decomp(1) - stem_prof(s,1) = 1._r8/dzsoi_decomp(1) - do j = 2, hlm_numlevdecomp - leaf_prof(s,j) = 0._r8 - stem_prof(s,j) = 0._r8 - end do - endif - end do - - else - - ! for one layer decomposition model, set profiles to unity - leaf_prof(1:nsites, :) = 1._r8 - froot_prof(1:nsites, 1:numpft_ed, :) = 1._r8 - stem_prof(1:nsites, :) = 1._r8 - - end if - - ! sanity check to ensure they integrate to 1 - do s = 1, nsites - ! check the leaf and stem profiles - leaf_prof_sum = 0._r8 - stem_prof_sum = 0._r8 - do j = 1, hlm_numlevdecomp - leaf_prof_sum = leaf_prof_sum + leaf_prof(s,j) * dzsoi_decomp(j) - stem_prof_sum = stem_prof_sum + stem_prof(s,j) * dzsoi_decomp(j) - end do - if ( ( abs(stem_prof_sum - 1._r8) > delta ) .or. ( abs(leaf_prof_sum - 1._r8) > delta ) ) then - write(fates_log(), *) 'profile sums: ', leaf_prof_sum, stem_prof_sum - write(fates_log(), *) 'surface_prof: ', surface_prof - write(fates_log(), *) 'surface_prof_tot: ', surface_prof_tot - write(fates_log(), *) 'leaf_prof: ', leaf_prof(s,:) - write(fates_log(), *) 'stem_prof: ', stem_prof(s,:) - write(fates_log(), *) 'max_rooting_depth_index_col: ', bc_in(s)%max_rooting_depth_index_col - write(fates_log(), *) 'dzsoi_decomp: ', dzsoi_decomp - call endrun(msg=errMsg(sourcefile, __LINE__)) - endif - ! now check each fine root profile - do ft = 1,numpft_ed - froot_prof_sum = 0._r8 - do j = 1, hlm_numlevdecomp - froot_prof_sum = froot_prof_sum + froot_prof(s,ft,j) * dzsoi_decomp(j) - end do - if ( ( abs(froot_prof_sum - 1._r8) > delta ) ) then - write(fates_log(), *) 'profile sums: ', froot_prof_sum - call endrun(msg=errMsg(sourcefile, __LINE__)) - endif - end do - end do - - ! zero the site-level C input variables - do s = 1, nsites - do j = 1, hlm_numlevdecomp - bc_out(s)%FATES_c_to_litr_lab_c_col(j) = 0._r8 - bc_out(s)%FATES_c_to_litr_cel_c_col(j) = 0._r8 - bc_out(s)%FATES_c_to_litr_lig_c_col(j) = 0._r8 - croot_prof(s,j) = 0._r8 - end do - end do - + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! first calculate vertical profiles + ! define two types of profiles: + ! (1) a surface profile, for leaves and stem inputs, which is the same for each + ! pft but differs from one site to the next to avoid inputting any C into permafrost or bedrock + ! (2) a fine root profile, which is indexed by both site and pft, differs for + ! each pft and also from one site to the next to avoid inputting any C into permafrost or bedrock + ! (3) a coarse root profile, which is the root-biomass=weighted average of the fine root profiles + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + if (use_vertsoilc) then + + do s = 1,nsites + ! define a single shallow surface profile for surface additions (leaves, stems, and N deposition) + surface_prof(:) = 0._r8 + do j = 1, hlm_numlevdecomp + surface_prof(j) = exp(-surfprof_exp * bc_in(s)%zi_sisl(j)) / bc_in(s)%dz_decomp_sisl(j) + end do + + ! initialize profiles to zero + leaf_prof(1:nsites, :) = 0._r8 + froot_prof(1:nsites, 1:numpft_ed, :) = 0._r8 + croot_prof(1:nsites, :) = 0._r8 + stem_prof(1:nsites, :) = 0._r8 + + cinput_rootfr(1:numpft_ed, :) = 0._r8 + + ! calculate pft-specific rooting profiles in the absence of permafrost or bedrock limitations + if ( exponential_rooting_profile ) then + if ( .not. pftspecific_rootingprofile ) then + ! define rooting profile from exponential parameters + do ft = 1, numpft_ed + do j = 1, hlm_numlevdecomp + cinput_rootfr(ft,j) = exp(-rootprof_exp * bc_in(s)%z_sisl(j)) / bc_in(s)%dz_decomp_sisl(j) + end do + end do + else + ! use beta distribution parameter from Jackson et al., 1996 + do ft = 1, numpft_ed + do j = 1, hlm_numlevdecomp + cinput_rootfr(ft,j) = & + ( EDPftvarcon_inst%rootprof_beta(ft, rooting_profile_varindex_water) ** & + (bc_in(s)%zi_sisl(j-1)*100._r8) - & + EDPftvarcon_inst%rootprof_beta(ft, rooting_profile_varindex_water) ** & + (bc_in(s)%zi_sisl(j)*100._r8) ) & + / bc_in(s)%dz_decomp_sisl(j) + end do + end do + endif + else + do ft = 1,numpft_ed + do j = 1, hlm_numlevdecomp + ! use standard CLM root fraction profiles; + cinput_rootfr(ft,j) = ( .5_r8*( & + exp(-EDPftvarcon_inst%roota_par(ft) * bc_in(s)%zi_sisl(j-1)) & + + exp(-EDPftvarcon_inst%rootb_par(ft) * bc_in(s)%zi_sisl(j-1)) & + - exp(-EDPftvarcon_inst%roota_par(ft) * bc_in(s)%zi_sisl(j)) & + - exp(-EDPftvarcon_inst%rootb_par(ft) * bc_in(s)%zi_sisl(j)))) & + / bc_in(s)%dz_decomp_sisl(j) + end do + end do + endif + + ! + ! now add permafrost constraint: integrate rootfr over active layer of soil site, + ! truncate below permafrost or bedrock table where present, and rescale so that integral = 1 + do ft = 1,numpft_ed + rootfr_tot(ft) = 0._r8 + end do + surface_prof_tot = 0._r8 + ! + do j = 1, min(max(bc_in(s)%max_rooting_depth_index_col, 1), hlm_numlevdecomp) + surface_prof_tot = surface_prof_tot + surface_prof(j) * bc_in(s)%dz_decomp_sisl(j) + end do + do ft = 1,numpft_ed + do j = 1, min(max(bc_in(s)%max_rooting_depth_index_col, 1), hlm_numlevdecomp) + rootfr_tot(ft) = rootfr_tot(ft) + cinput_rootfr(ft,j) * bc_in(s)%dz_decomp_sisl(j) + end do + end do + ! + ! rescale the fine root profile + do ft = 1,numpft_ed + if ( (bc_in(s)%max_rooting_depth_index_col > 0) .and. (rootfr_tot(ft) > 0._r8) ) then + ! where there is not permafrost extending to the surface, integrate the profiles over the active layer + ! this is equivalent to integrating over all soil layers outside of permafrost regions + do j = 1, min(max(bc_in(s)%max_rooting_depth_index_col, 1), hlm_numlevdecomp) + froot_prof(s,ft,j) = cinput_rootfr(ft,j) / rootfr_tot(ft) + end do + else + ! if fully frozen, or no roots, put everything in the top layer + froot_prof(s,ft,1) = 1._r8/bc_in(s)%dz_decomp_sisl(1) + endif + end do + ! + ! rescale the shallow profiles + if ( (bc_in(s)%max_rooting_depth_index_col > 0) .and. (surface_prof_tot > 0._r8) ) then + ! where there is not permafrost extending to the surface, integrate the profiles over the active layer + ! this is equivalent to integrating over all soil layers outside of permafrost regions + do j = 1, min(max(bc_in(s)%max_rooting_depth_index_col, 1), hlm_numlevdecomp) + ! set all surface processes to shallower profile + leaf_prof(s,j) = surface_prof(j)/ surface_prof_tot + stem_prof(s,j) = surface_prof(j)/ surface_prof_tot + end do + else + ! if fully frozen, or no roots, put everything in the top layer + leaf_prof(s,1) = 1._r8/bc_in(s)%dz_decomp_sisl(1) + stem_prof(s,1) = 1._r8/bc_in(s)%dz_decomp_sisl(1) + do j = 2, hlm_numlevdecomp + leaf_prof(s,j) = 0._r8 + stem_prof(s,j) = 0._r8 + end do + endif + end do + + else + + ! for one layer decomposition model, set profiles to unity + leaf_prof(1:nsites, :) = 1._r8 + froot_prof(1:nsites, 1:numpft_ed, :) = 1._r8 + stem_prof(1:nsites, :) = 1._r8 + + end if + + ! sanity check to ensure they integrate to 1 + do s = 1, nsites + ! check the leaf and stem profiles + leaf_prof_sum = 0._r8 + stem_prof_sum = 0._r8 + do j = 1, hlm_numlevdecomp + leaf_prof_sum = leaf_prof_sum + leaf_prof(s,j) * bc_in(s)%dz_decomp_sisl(j) + stem_prof_sum = stem_prof_sum + stem_prof(s,j) * bc_in(s)%dz_decomp_sisl(j) + end do + if ( ( abs(stem_prof_sum - 1._r8) > delta ) .or. ( abs(leaf_prof_sum - 1._r8) > delta ) ) then + write(fates_log(), *) 'profile sums: ', leaf_prof_sum, stem_prof_sum + write(fates_log(), *) 'surface_prof: ', surface_prof + write(fates_log(), *) 'surface_prof_tot: ', surface_prof_tot + write(fates_log(), *) 'leaf_prof: ', leaf_prof(s,:) + write(fates_log(), *) 'stem_prof: ', stem_prof(s,:) + write(fates_log(), *) 'max_rooting_depth_index_col: ', bc_in(s)%max_rooting_depth_index_col + write(fates_log(), *) 'bc_in(s)%dz_decomp_sisl: ', bc_in(s)%dz_decomp_sisl + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + ! now check each fine root profile + do ft = 1,numpft_ed + froot_prof_sum = 0._r8 + do j = 1, hlm_numlevdecomp + froot_prof_sum = froot_prof_sum + froot_prof(s,ft,j) * bc_in(s)%dz_decomp_sisl(j) + end do + if ( ( abs(froot_prof_sum - 1._r8) > delta ) ) then + write(fates_log(), *) 'profile sums: ', froot_prof_sum + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + end do + end do + + ! zero the site-level C input variables + do s = 1, nsites + do j = 1, hlm_numlevdecomp + bc_out(s)%FATES_c_to_litr_lab_c_col(j) = 0._r8 + bc_out(s)%FATES_c_to_litr_cel_c_col(j) = 0._r8 + bc_out(s)%FATES_c_to_litr_lig_c_col(j) = 0._r8 + croot_prof(s,j) = 0._r8 + end do + end do + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! now disaggregate the inputs vertically, using the vertical profiles !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -1618,7 +1623,7 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) end do end do else ! no biomass - croot_prof_perpatch(1) = 1./dzsoi_decomp(1) + croot_prof_perpatch(1) = 1./bc_in(s)%dz_decomp_sisl(1) end if ! diff --git a/biogeophys/EDBtranMod.F90 b/biogeophys/EDBtranMod.F90 index 5e868eb0..229008b6 100644 --- a/biogeophys/EDBtranMod.F90 +++ b/biogeophys/EDBtranMod.F90 @@ -15,6 +15,7 @@ module EDBtranMod use shr_kind_mod , only : r8 => shr_kind_r8 use FatesInterfaceMod , only : bc_in_type, & bc_out_type + use EDTypesMod , only : use_fates_plant_hydro use FatesGlobals , only : fates_log ! @@ -76,6 +77,9 @@ end subroutine get_active_suction_layers ! ===================================================================================== subroutine btran_ed( nsites, sites, bc_in, bc_out) + + use FatesPlantHydraulicsMod, only : BTranForHLMDiagnosticsFromCohortHydr + ! --------------------------------------------------------------------------------- ! Calculate the transpiration wetness function (BTRAN) and the root uptake @@ -107,7 +111,8 @@ subroutine btran_ed( nsites, sites, bc_in, bc_out) real(r8) :: rresis ! suction limitation to transpiration independent ! of root density real(r8) :: pftgs(numpft_ed) ! pft weighted stomatal conductance s/m - real(r8) :: temprootr + real(r8) :: temprootr + real(r8) :: balive_patch !------------------------------------------------------------------------------ associate( & @@ -192,21 +197,26 @@ subroutine btran_ed( nsites, sites, bc_in, bc_out) end if enddo enddo + + ! Calculate the BTRAN that is passed back to the HLM + ! used only for diagnostics. If plant hydraulics is turned off + ! we are using the patchxpft level btran calculation + + if(.not.use_fates_plant_hydro) then + !weight patch level output BTRAN for the + bc_out(s)%btran_pa(ifp) = 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) + bc_out(s)%btran_pa(ifp) = bc_out(s)%btran_pa(ifp) + cpatch%btran_ft(ft) * pftgs(ft)/sum(pftgs) + else + bc_out(s)%btran_pa(ifp) = bc_out(s)%btran_pa(ifp) + cpatch%btran_ft(ft) * 1./numpft_ed + end if + enddo + end if - !weight patch level output BTRAN for the - bc_out(s)%btran_pa(ifp) = 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) - bc_out(s)%btran_pa(ifp) = bc_out(s)%btran_pa(ifp) + cpatch%btran_ft(ft) * pftgs(ft)/sum(pftgs) - else - bc_out(s)%btran_pa(ifp) = bc_out(s)%btran_pa(ifp) + cpatch%btran_ft(ft) * 1./numpft_ed - end if - enddo - - ! While the in-pft root profiles summed to unity, averaging them weighted - ! by conductance, or not, will break sum to unity. Thus, re-normalize. temprootr = sum(bc_out(s)%rootr_pagl(ifp,1:hlm_numlevgrnd)) + if(abs(1.0_r8-temprootr) > 1.0e-10_r8 .and. temprootr > 1.0e-10_r8)then write(fates_log(),*) 'error with rootr in canopy fluxes',temprootr,sum(pftgs) do j = 1,hlm_numlevgrnd @@ -217,8 +227,11 @@ subroutine btran_ed( nsites, sites, bc_in, bc_out) cpatch => cpatch%younger end do - end do + + if(use_fates_plant_hydro) then + call BTranForHLMDiagnosticsFromCohortHydr(nsites,sites,bc_out) + end if end associate diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 new file mode 100644 index 00000000..456088dc --- /dev/null +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -0,0 +1,346 @@ +module FatesPlantHydraulicsMod + + + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!99 + ! (TODO: THE ROW WIDTH ON THIS MODULE ARE TOO LARGE. NAG COMPILERS + ! WILL FREAK IF LINES ARE TOO LONG. BEFORE SUBMITTING THIS TO + ! MASTER WE NEED TO GO THROUGH AND GET THESE LINES BELOW + ! 100 spaces (for readability), or 130 (for NAG) + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!99 + + use FatesGlobals, only : endrun => fates_endrun + use FatesGlobals, only : fates_log + + use FatesConstantsMod, only : r8 => fates_r8 + use FatesConstantsMod, only : fates_huge + use FatesConstantsMod, only : denh2o => dens_fresh_liquid_water + use FatesConstantsMod, only : grav => grav_earth + + use EDTypesMod, only : use_fates_plant_hydro + use EDTypesMod , only : ed_site_type + use EDTypesMod , only : ed_patch_type + use EDTypesMod , only : ed_cohort_type + + use FatesInterfaceMod , only : bc_in_type + use FatesInterfaceMod , only : bc_out_type + use FatesInterfaceMod , only : hlm_numlevsoil + + use EDEcophysconType, only : EDecophyscon + + use FatesHydraulicsMemMod, only: ed_site_hydr_type + use FatesHydraulicsMemMod, only: ed_patch_hydr_type + use FatesHydraulicsMemMod, only: ed_cohort_hydr_type + use FatesHydraulicsMemMod, only: npool_leaf + use FatesHydraulicsMemMod, only: npool_tot + use FatesHydraulicsMemMod, only: npool_stem + use FatesHydraulicsMemMod, only: numLWPmem + use FatesHydraulicsMemMod, only: npool_troot + use FatesHydraulicsMemMod, only: npool_aroot + use FatesHydraulicsMemMod, only: n_porous_media + use FatesHydraulicsMemMod, only: nshell + use FatesHydraulicsMemMod, only: npool_ag + use FatesHydraulicsMemMod, only: npool_bg + use FatesHydraulicsMemMod, only: porous_media + use FatesHydraulicsMemMod, only: nlevsoi_hyd + + ! CIME Globals + use shr_log_mod , only : errMsg => shr_log_errMsg + use shr_infnan_mod , only : isnan => shr_infnan_isnan + + + implicit none + + private + integer, parameter :: van_genuchten = 1 + integer, parameter :: campbell = 2 + integer :: iswc = campbell + + ! 1=leaf, 2=stem, 3=troot, 4=aroot + ! Several of these may be better transferred to the parameter file in due time (RGK) + + integer, public :: use_ed_planthydraulics = 1 ! 0 => use vanilla btran + ! 1 => use BC hydraulics; + ! 2 => use CX hydraulics + logical, public :: do_dqtopdth_leaf = .false. ! should a nonzero dqtopdth_leaf + ! term be applied to the plant + ! hydraulics numerical solution? + logical, public :: do_dyn_xylemrefill = .true. ! should the dynamics of xylem refilling + ! (i.e., non-instantaneous) be considered + ! within plant hydraulics? + logical, public :: do_kbound_upstream = .false. ! should the hydraulic conductance at the + ! boundary between nodes be taken to be a + ! function of the upstream loss of + ! conductivity (flc)? + logical, public :: do_growthrecruiteffects = .true. ! should size- or root length-dependent + ! hydraulic properties and states be + ! updated every day when trees grow or + ! when recruitment happens? + logical, public :: do_static_ed = .true. ! should growth, mortality, and patch + ! dynamics be turned off? + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + ! + ! !PUBLIC MEMBER FUNCTIONS: + public :: hydraulics_drive + public :: InitHydrSites + public :: HydrSiteColdStart + public :: BTranForHLMDiagnosticsFromCohortHydr + public :: InitHydrCohort + public :: DeallocateHydrCohort + public :: UpdateH2OVeg + public :: CopyCohortHydraulics + public :: FuseCohortHydraulics + public :: updateSizeDepTreeHydProps + public :: updateSizeDepTreeHydStates + public :: initTreeHydStates + public :: updateSizeDepRhizHydProps + + !------------------------------------------------------------------------------ + ! 01/18/16: Created by Brad Christoffersen + ! 02/xx/17: Refactoring by Ryan Knox and Brad Christoffersen + !------------------------------------------------------------------------------ + +contains + + !------------------------------------------------------------------------------ + subroutine hydraulics_drive( nsites, sites, bc_in,bc_out,dtime ) + + ! ARGUMENTS: + ! ----------------------------------------------------------------------------------- + integer,intent(in) :: nsites + type(ed_site_type),intent(inout),target :: sites(nsites) + type(bc_in_type),intent(in) :: bc_in(nsites) + type(bc_out_type),intent(inout) :: bc_out(nsites) + real(r8),intent(in) :: dtime + + write(fates_log(),*) 'FATES Plant Hydraulics is still under development, ending run.' + call endrun(msg=errMsg(sourcefile, __LINE__)) + + end subroutine Hydraulics_Drive + + ! ===================================================================================== + + subroutine initTreeHydStates(cc_p, bc_in) + ! + ! !DESCRIPTION: + ! + ! !USES: + use EDEcophysConType , only : EDecophyscon + + ! !ARGUMENTS: + type(ed_cohort_type), intent(inout), target :: cc_p ! current cohort pointer + type(bc_in_type) , intent(in) :: bc_in + + write(fates_log(),*) 'FATES Plant Hydraulics is still under development, ending run.' + call endrun(msg=errMsg(sourcefile, __LINE__)) + + end subroutine initTreeHydStates + + ! ===================================================================================== + + subroutine updateSizeDepTreeHydProps(cc_p,bc_in) + ! + ! !DESCRIPTION: Updates absorbing root length (total and its vertical distribution) + ! as well as the consequential change in the size of the 'representative' rhizosphere + ! shell radii, volumes + ! + ! !USES: + use FatesConstantsMod , only : pi_const + use EDEcophysConType , only : EDecophyscon + use shr_sys_mod , only : shr_sys_abort + ! + ! !ARGUMENTS: + type(ed_cohort_type) , intent(inout), target :: cc_p ! current cohort pointer + type(bc_in_type) , intent(in) :: bc_in ! Boundary Conditions + + write(fates_log(),*) 'FATES Plant Hydraulics is still under development, ending run.' + call endrun(msg=errMsg(sourcefile, __LINE__)) + + end subroutine updateSizeDepTreeHydProps + + ! ===================================================================================== + + subroutine updateSizeDepTreeHydStates(cc_p) + ! + ! !DESCRIPTION: + ! + ! !USES: + ! !ARGUMENTS: + type(ed_cohort_type) , intent(inout), target :: cc_p ! current cohort pointer + ! + write(fates_log(),*) 'FATES Plant Hydraulics is still under development, ending run.' + call endrun(msg=errMsg(sourcefile, __LINE__)) + + end subroutine updateSizeDepTreeHydStates + + ! ===================================================================================== + + subroutine CopyCohortHydraulics(newCohort, oldCohort) + + ! Arguments + type(ed_cohort_type), intent(inout), target :: newCohort + type(ed_cohort_type), intent(inout), target :: oldCohort + + write(fates_log(),*) 'FATES Plant Hydraulics is still under development, ending run.' + call endrun(msg=errMsg(sourcefile, __LINE__)) + + end subroutine CopyCohortHydraulics + + ! ===================================================================================== + + subroutine FuseCohortHydraulics(currentCohort, nextCohort, bc_in, newn) + + + type(ed_cohort_type), intent(inout), target :: currentCohort ! current cohort + type(ed_cohort_type), intent(inout), target :: nextCohort ! next (donor) cohort + type(bc_in_type), intent(in) :: bc_in + real(r8), intent(in) :: newn + + write(fates_log(),*) 'FATES Plant Hydraulics is still under development, ending run.' + call endrun(msg=errMsg(sourcefile, __LINE__)) + + end subroutine FuseCohortHydraulics + + + + ! ===================================================================================== + ! Initialization Routines + ! ===================================================================================== + + subroutine InitHydrCohort(currentCohort) + + ! Arguments + type(ed_cohort_type), target :: currentCohort + type(ed_cohort_hydr_type), pointer :: ccohort_hydr + write(fates_log(),*) 'FATES Plant Hydraulics is still under development, ending run.' + call endrun(msg=errMsg(sourcefile, __LINE__)) + + end subroutine InitHydrCohort + + ! ===================================================================================== + + subroutine DeallocateHydrCohort(currentCohort) + + ! Arguments + type(ed_cohort_type), target :: currentCohort + type(ed_cohort_hydr_type), pointer :: ccohort_hydr + + write(fates_log(),*) 'FATES Plant Hydraulics is still under development, ending run.' + call endrun(msg=errMsg(sourcefile, __LINE__)) + + end subroutine DeallocateHydrCohort + + + ! ===================================================================================== + + subroutine InitHydrSites(sites) + + ! Arguments + type(ed_site_type),intent(inout),target :: sites(:) + + ! Locals + integer :: nsites + integer :: s + type(ed_site_hydr_type),pointer :: csite_hydr + + write(fates_log(),*) 'FATES Plant Hydraulics is still under development, ending run.' + call endrun(msg=errMsg(sourcefile, __LINE__)) + + end subroutine InitHydrSites + + ! =================================================================================== + + subroutine HydrSiteColdStart(sites, bc_in) + + + ! Arguments + type(ed_site_type),intent(inout),target :: sites(:) + type(bc_in_type),intent(inout) :: bc_in(:) + + write(fates_log(),*) 'FATES Plant Hydraulics is still under development, ending run.' + call endrun(msg=errMsg(sourcefile, __LINE__)) + + end subroutine HydrSiteColdStart + + ! ===================================================================================== + + subroutine UpdateH2OVeg(nsites,sites,bc_out) + + ! ---------------------------------------------------------------------------------- + ! This subroutine is called following dynamics. After growth has been updated + ! there needs to be a re-assesment of the how much liquid water is bound in the + ! plants. This value is necessary for water balancing in the HLM. + ! ---------------------------------------------------------------------------------- + + use EDTypesMod, only : AREA + + ! Arguments + integer, intent(in) :: nsites + type(ed_site_type), intent(inout), target :: sites(nsites) + type(bc_out_type), intent(inout) :: bc_out(nsites) + + write(fates_log(),*) 'FATES Plant Hydraulics is still under development, ending run.' + call endrun(msg=errMsg(sourcefile, __LINE__)) + + end subroutine UpdateH2OVeg + + ! ===================================================================================== + + subroutine updateSizeDepRhizHydProps(currentSite, bc_in ) + ! + ! !DESCRIPTION: Updates size of 'representative' rhizosphere -- node radii, volumes. + ! As fine root biomass (and thus absorbing root length) increases, this characteristic + ! rhizosphere shrinks even though the total volume of soil tapped by fine roots remains + ! the same. + ! + ! !USES: + use FatesConstantsMod , only : pi_const + use EDTypesMod , only : AREA + + ! !ARGUMENTS: + type(ed_site_type) , intent(inout), target :: currentSite + type(bc_in_type) , intent(in) :: bc_in + + write(fates_log(),*) 'FATES Plant Hydraulics is still under development, ending run.' + call endrun(msg=errMsg(sourcefile, __LINE__)) + + end subroutine updateSizeDepRhizHydProps + + ! ================================================================================= + + subroutine updateSizeDepRhizHydStates(currentSite, bc_in) + ! + ! !DESCRIPTION: Updates size of 'representative' rhizosphere -- node radii, volumes. + ! As fine root biomass (and thus absorbing root length) increases, this characteristic + ! rhizosphere shrinks even though the total volume of soil tapped by fine roots remains + ! the same. + ! + ! !USES: + ! + ! !ARGUMENTS: + type(ed_site_type), intent(inout), target :: currentSite + type(bc_in_type), intent(in) :: bc_in + ! + write(fates_log(),*) 'FATES Plant Hydraulics is still under development, ending run.' + call endrun(msg=errMsg(sourcefile, __LINE__)) + +end subroutine updateSizeDepRhizHydStates + + ! ==================================================================================== + + subroutine BTranForHLMDiagnosticsFromCohortHydr(nsites,sites,bc_out) + + ! Arguments + integer,intent(in) :: nsites + type(ed_site_type),intent(inout),target :: sites(nsites) + type(bc_out_type),intent(inout) :: bc_out(nsites) + + write(fates_log(),*) 'FATES Plant Hydraulics is still under development, ending run.' + call endrun(msg=errMsg(sourcefile, __LINE__)) + + + end subroutine BTranForHLMDiagnosticsFromCohortHydr + + +end module FatesPlantHydraulicsMod diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index affdf592..77de846b 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -293,7 +293,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) end do !ft - call set_root_fraction(currentPatch,bc_in(s)%depth_gl) + call set_root_fraction(currentPatch,bc_in(s)%zi_sisl) ! ------------------------------------------------------------------------ ! Part VI: Loop over all leaf layers. @@ -352,14 +352,15 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) if ( .not.rate_mask_z(iv,ft,cl) .or. use_fates_plant_hydro ) then if (use_fates_plant_hydro) then - write(fates_log(),*) 'use_fates_plant_hydro in EDTypes' - write(fates_log(),*) 'has been set to true. You have inadvertently' - write(fates_log(),*) 'turned on a future feature that is not in the' - write(fates_log(),*) 'FATES codeset yet. Please set this to' - write(fates_log(),*) 'false and re-compile.' - call endrun(msg=errMsg(sourcefile, __LINE__)) - !! !! bbb = max (bbbopt(ps)*currentCohort%btran(iv), 1._r8) - !! !! btran = currentCohort%btran(iv) +! write(fates_log(),*) 'use_fates_plant_hydro in EDTypes' +! write(fates_log(),*) 'has been set to true. You have inadvertently' +! write(fates_log(),*) 'turned on a future feature that is not in the' +! write(fates_log(),*) 'FATES codeset yet. Please set this to' +! write(fates_log(),*) 'false and re-compile.' +! call endrun(msg=errMsg(sourcefile, __LINE__)) + + bbb = max (bbbopt(nint(c3psn(ft)))*currentCohort%co_hydr%btran(1), 1._r8) + btran_eff = currentCohort%co_hydr%btran(1) else bbb = max (bbbopt(nint(c3psn(ft)))*currentPatch%btran_ft(ft), 1._r8) btran_eff = currentPatch%btran_ft(ft) diff --git a/main/EDEcophysConType.F90 b/main/EDEcophysConType.F90 index e305510f..eca9a4e5 100644 --- a/main/EDEcophysConType.F90 +++ b/main/EDEcophysConType.F90 @@ -7,6 +7,17 @@ module EDEcophysConType ! !USES: use shr_kind_mod , only : r8 => shr_kind_r8 use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + + use FatesHydraulicsMemMod , only : n_porous_media + use FatesHydraulicsMemMod , only : porous_media + use FatesHydraulicsMemMod , only : npool_tot + use FatesHydraulicsMemMod , only : npool_leaf + use FatesHydraulicsMemMod , only : npool_stem + use FatesHydraulicsMemMod , only : npool_aroot + use FatesHydraulicsMemMod , only : npool_troot + + use EDTypesMod, only : use_fates_plant_hydro + ! implicit none save @@ -38,11 +49,73 @@ module EDEcophysConType 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 + + + + ! pft parameters for plant hydraulics (PFT) + real(r8), pointer :: wd (:) ! wood density (distinct from wood_density for testing) [g m-3] + real(r8), pointer :: lma (:) ! leaf mass per area [g m-2] + ! ~ 90 for tropical angiosperms, cf Patino et al. 2012 + ! (existing param 'slatop' is biased high) + real(r8), pointer :: n (:) ! leaf nitrogen [mg g-1] + real(r8), pointer :: p (:) ! leaf phosphorus [mg g-1] + real(r8), pointer :: ldmc (:) ! leaf dry matter content [g g-1] + real(r8), pointer :: lmv (:) ! leaf mass per volume [g m-3] + real(r8), pointer :: psi0 (:) ! sapwood water potential at saturation [MPa] + real(r8), pointer :: psicap (:) ! sapwood water potential at rwcft [MPa] + ! BOC...rhoc, rint_petiole, rint_jansenchoat, ccontent and (maybe) + ! rs2 and rfrac_stem should really be global constants, not pft parameters + real(r8), pointer :: rhoc (:) ! dry matter (or cell wall) density of wood [g cm-3] Siau 1984 + real(r8), pointer :: rint_petiole (:) ! radius of xylem conduits in petioles [um] + real(r8), pointer :: rint_jansenchoat (:) ! average radius of xylem conduits where ks mmts were made [um] + ! taken from choat & jansen XFT database for tropical angiosperms only + real(r8), pointer :: Amaxh (:) ! light-saturated photosynthesis rate [umol m-2 s-1] + real(r8), pointer :: rs2 (:) ! mean absorbing fine root radius [m] ~ 0.001 m? + real(r8), pointer :: srl (:) ! specific root length [m kg-1] + ! ~ 15000 for tropical angiosperms, cf Metcalfe et al. 2008 Plant Soil Fig. 2b; + ! rootdens = 500 kg m-3 is biased high by an order of magnitude + ! (cf Comas et al. 2002 Oecologia); SPA rootdens implies a SRL of only 637 m kg-1. + real(r8), pointer :: ccontent (:) ! carbon content (fraction of dry mass) [-] + ! ~ 0.47 for tropical angiosperms, cf Thomas & Martin (2012) Forests + real(r8), pointer :: latosa (:) ! leaf to sapwood area ratio [m2 m-2] + ! ~ 8000 for tropical angiosperms, cf Patino et al. 2012 + real(r8), pointer :: rfrac_stem (:) ! fraction of total tree resistance (under well-watered conditions) + ! from troot to canopy (i.e., aboveground) [-] ~ 0.625 for tropical angiosperms, + ! cf BC re-analysis of Fisher et al. 2006 + real(r8), pointer :: rootshoot (:) ! root:shoot ratio (belowground-to-aboveground biomass) [-] + ! ~ 0.20 for tropical forests (see Houghton et al. 2001 Table 3, + ! Cairns et al. 1997 Table 2, Jackson et al. 1996 Table 3) + real(r8), pointer :: avuln_gs (:) ! stomata PLC: vulnerability curve shape parameter [-] + real(r8), pointer :: p50_gs (:) ! stomata PLC: water potential at 50% loss of conductivity [Pa] + + ! pft parameters for plant hydraulics (PFT x tissue type (leaf, stem, troot, aroot)) + real(r8), pointer :: kmax_node (:,:) ! xylem PLC: maximum xylem hydraulic conductivity [kg m-1 s-1 Pa-1] + real(r8), pointer :: avuln_node (:,:) ! xylem PLC: vulnerability curve shape parameter [-] + real(r8), pointer :: p50_node (:,:) ! xylem PLC: water potential at 50% loss of conductivity [Pa] + real(r8), pointer :: thetas_node (:,:) ! P-V curve: saturated volumetric water content for node [m3 m-3] + real(r8), pointer :: epsil_node (:,:) ! P-V curve: bulk elastic modulus [MPa] + real(r8), pointer :: pinot_node (:,:) ! P-V curve: osmotic potential at full turgor [MPa] + real(r8), pointer :: pitlp_node (:,:) ! P-V curve: osmotic potential at turgor loss [MPa] + real(r8), pointer :: resid_node (:,:) ! P-V curve: residual fraction [-] + real(r8), pointer :: rwctlp_node (:,:) ! P-V curve: total relative water content at turgor loss [g or m3 H2O / g or m3 H2O, sat] + real(r8), pointer :: fcap_node (:,:) ! P-V curve: fraction of (1-resid_node) that is capillary in source [-] + real(r8), pointer :: rwcft_node (:,:) ! P-V curve: total RWC @ which elastic drainage begins [-] + real(r8), pointer :: rwccap_node (:,:) ! P-V curve: total RWC @ which capillary reserves exhausted + real(r8), pointer :: slp_node (:,:) ! P-V curve: slope of capillary region of curve (sapwood only) + real(r8), pointer :: intercept_node (:,:) ! P-V curve: intercept of capillary region of curve (sapwood only) + real(r8), pointer :: corrInt_node (:,:) ! P-V curve: correction for nonzero psi0 + + + end type EDecophyscon_type type(EDecophyscon_type), public :: EDecophyscon ! ED ecophysiological constants structure !------------------------------------------------------------------------ + + + + contains !------------------------------------------------------------------------ @@ -56,7 +129,7 @@ subroutine EDecophysconInit(EDpftvarcon_inst, numpft) integer , intent(in) :: numpft ! ! !LOCAL VARIABLES: - integer :: m, ib + integer :: m, ib, n, k !------------------------------------------------------------------------ allocate( EDecophyscon%max_dbh (0:numpft)); EDecophyscon%max_dbh (:) = nan @@ -105,6 +178,139 @@ subroutine EDecophysconInit(EDpftvarcon_inst, numpft) EDecophyscon%sapwood_ratio(m) = EDPftvarcon_inst%sapwood_ratio(m) end do + + if (use_fates_plant_hydro) then + allocate( EDecophyscon%wd (0:numpft) ); EDecophyscon%wd (:) = nan + allocate( EDecophyscon%lma (0:numpft) ); EDecophyscon%lma (:) = nan + allocate( EDecophyscon%n (0:numpft) ); EDecophyscon%n (:) = nan + allocate( EDecophyscon%p (0:numpft) ); EDecophyscon%p (:) = nan + allocate( EDecophyscon%ldmc (0:numpft) ); EDecophyscon%ldmc (:) = nan + allocate( EDecophyscon%lmv (0:numpft) ); EDecophyscon%lmv (:) = nan + allocate( EDecophyscon%psi0 (0:numpft) ); EDecophyscon%psi0 (:) = nan + allocate( EDecophyscon%psicap (0:numpft) ); EDecophyscon%psicap (:) = nan + allocate( EDecophyscon%rhoc (0:numpft) ); EDecophyscon%rhoc (:) = nan + allocate( EDecophyscon%rint_petiole (0:numpft) ); EDecophyscon%rint_petiole (:) = nan + allocate( EDecophyscon%rint_jansenchoat (0:numpft) ); EDecophyscon%rint_jansenchoat (:) = nan + allocate( EDecophyscon%Amaxh (0:numpft) ); EDecophyscon%Amaxh (:) = nan + allocate( EDecophyscon%rs2 (0:numpft) ); EDecophyscon%rs2 (:) = nan + allocate( EDecophyscon%srl (0:numpft) ); EDecophyscon%srl (:) = nan + allocate( EDecophyscon%ccontent (0:numpft) ); EDecophyscon%ccontent (:) = nan + allocate( EDecophyscon%latosa (0:numpft) ); EDecophyscon%latosa (:) = nan + allocate( EDecophyscon%rfrac_stem (0:numpft) ); EDecophyscon%rfrac_stem (:) = nan + allocate( EDecophyscon%rootshoot (0:numpft) ); EDecophyscon%rootshoot (:) = nan + allocate( EDecophyscon%avuln_gs (0:numpft) ); EDecophyscon%avuln_gs (:) = nan + allocate( EDecophyscon%p50_gs (0:numpft) ); EDecophyscon%p50_gs (:) = nan + + allocate( EDecophyscon%kmax_node (0:numpft,1:n_porous_media) ); EDecophyscon%kmax_node (:,:) = nan + allocate( EDecophyscon%avuln_node (0:numpft,1:n_porous_media) ); EDecophyscon%avuln_node (:,:) = nan + allocate( EDecophyscon%p50_node (0:numpft,1:n_porous_media) ); EDecophyscon%p50_node (:,:) = nan + allocate( EDecophyscon%thetas_node (0:numpft,1:n_porous_media) ); EDecophyscon%thetas_node (:,:) = nan + allocate( EDecophyscon%epsil_node (0:numpft,1:n_porous_media) ); EDecophyscon%epsil_node (:,:) = nan + allocate( EDecophyscon%pinot_node (0:numpft,1:n_porous_media) ); EDecophyscon%pinot_node (:,:) = nan + allocate( EDecophyscon%pitlp_node (0:numpft,1:n_porous_media) ); EDecophyscon%pitlp_node (:,:) = nan + allocate( EDecophyscon%resid_node (0:numpft,1:n_porous_media) ); EDecophyscon%resid_node (:,:) = nan + allocate( EDecophyscon%rwctlp_node (0:numpft,1:n_porous_media) ); EDecophyscon%rwctlp_node (:,:) = nan + allocate( EDecophyscon%fcap_node (0:numpft,1:n_porous_media) ); EDecophyscon%fcap_node (:,:) = nan + allocate( EDecophyscon%rwcft_node (0:numpft,1:n_porous_media) ); EDecophyscon%rwcft_node (:,:) = nan + allocate( EDecophyscon%rwccap_node (0:numpft,1:n_porous_media) ); EDecophyscon%rwccap_node (:,:) = nan + allocate( EDecophyscon%slp_node (0:numpft,1:n_porous_media) ); EDecophyscon%slp_node (:,:) = nan + allocate( EDecophyscon%intercept_node (0:numpft,1:n_porous_media) ); EDecophyscon%intercept_node (:,:) = nan + allocate( EDecophyscon%corrInt_node (0:numpft,1:n_porous_media) ); EDecophyscon%corrInt_node (:,:) = nan + + do m = 0,numpft + + !BOC...new hydraulics constants + EDecophyscon%wd(m) = 0.73_r8 ! EDPftvarcon_inst%wd(m) + EDecophyscon%lma(m) = 96.06_r8 ! EDPftvarcon_inst%lma(m) + EDecophyscon%n(m) = 20.87_r8 ! EDPftvarcon_inst%n(m) + EDecophyscon%p(m) = 0.59_r8 ! EDPftvarcon_inst%p(m) + EDecophyscon%ldmc(m) = -0.207_r8*log(10**4._r8/EDecophyscon%lma(m))+1.431_r8 ! EDPftvarcon_inst%ldmc(m) + EDecophyscon%lmv(m) = (-2.3231_r8*(10**4._r8/EDecophyscon%lma(m))+781.899_r8)/1000._r8 ! EDPftvarcon_inst%lmv(m) + EDecophyscon%psi0(m) = -0.08_r8 ! EDPftvarcon_inst%psi0(m) + EDecophyscon%psicap(m) = -0.39_r8 ! EDPftvarcon_inst%psicap(m) + EDecophyscon%rhoc(m) = 1.54_r8 ! EDPftvarcon_inst%rhoc(m) + EDecophyscon%rint_petiole(m) = 10._r8 ! EDPftvarcon_inst%rint_petiole(m) + EDecophyscon%rint_jansenchoat(m) = 22._r8 ! EDPftvarcon_inst%rint_jansenchoat(m) + EDecophyscon%Amaxh(m) = 11.53_r8 ! EDPftvarcon_inst%Amaxh(m) + EDecophyscon%rs2(m) = 0.001_r8 ! EDPftvarcon_inst%rs2(m) + EDecophyscon%srl(m) = 15000._r8 ! EDPftvarcon_inst%srl(m) + EDecophyscon%ccontent(m) = 0.47_r8 ! EDPftvarcon_inst%ccontent(m) + EDecophyscon%rfrac_stem(m) = 0.625_r8 ! EDPftvarcon_inst%rfrac_stem(m) + EDecophyscon%rootshoot(m) = 0.20_r8 ! EDPftvarcon_inst%rootshoot(m) + n = 2 + EDecophyscon%kmax_node(m,n) = 3.00_r8 ! TESTING: intermediate + EDecophyscon%p50_node(m,n) = -1.00_r8 ! TESTING: hi + EDecophyscon%avuln_node(m,n) = 4.40_r8 ! TESTING: lo + EDecophyscon%thetas_node(m,n) = 1._r8 - EDecophyscon%wd(m)/EDecophyscon%rhoc(m) ! 0.530_r8 + EDecophyscon%epsil_node(m,n) = 22.41_r8 + EDecophyscon%pinot_node(m,n) = -2.146_r8 + EDecophyscon%pitlp_node(m,n) = -2.373_r8 + EDecophyscon%resid_node(m,n) = 0.479_r8 + EDecophyscon%rwctlp_node(m,n) = 0.912_r8 + EDecophyscon%fcap_node(m,n) = 0.080_r8 + EDecophyscon%rwcft_node(m,n) = 0.958_r8 + EDecophyscon%rwccap_node(m,n) = 0.947_r8 + EDecophyscon%slp_node(m,n) = & + (EDecophyscon%psi0(m) - EDecophyscon%psicap(m))/(1._r8 - EDecophyscon%rwccap_node(m,n)) ! 5.795_r8 + EDecophyscon%intercept_node(m,n) = -EDecophyscon%slp_node(m,n) + EDecophyscon%psi0(m) !-5.875_r8 + EDecophyscon%corrInt_node(m,n) = -EDecophyscon%intercept_node(m,n)/EDecophyscon%slp_node(m,n) ! 1.014_r8 + n = 1 + EDecophyscon%kmax_node(m,n) = & + EDecophyscon%kmax_node(m,2)*((EDecophyscon%rint_petiole(m)/EDecophyscon%rint_jansenchoat(m))**2._r8) !0.480_r8 + EDecophyscon%avuln_node(m,n) = EDecophyscon%avuln_node(m,2) + EDecophyscon%p50_node(m,n) = EDecophyscon%p50_node(m,2) + EDecophyscon%thetas_node(m,n) = EDecophyscon%lmv(m)*(1.0_r8/EDecophyscon%ldmc(m)-1.0_r8) + EDecophyscon%epsil_node(m,n) = 22.56_r8 + EDecophyscon%pinot_node(m,n) = -1.943_r8 + EDecophyscon%pitlp_node(m,n) = -1.789_r8 + EDecophyscon%resid_node(m,n) = 0.413_r8 + EDecophyscon%rwctlp_node(m,n) = 0.953_r8 + EDecophyscon%fcap_node(m,n) = 0._r8 + EDecophyscon%rwcft_node(m,n) = 1._r8 + EDecophyscon%rwccap_node(m,n) = 1._r8 + EDecophyscon%slp_node(m,n) = 0._r8 + EDecophyscon%intercept_node(m,n) = 0._r8 + EDecophyscon%corrInt_node(m,n) = 1._r8 + do n = 3,n_porous_media + EDecophyscon%kmax_node(m,n) = EDecophyscon%kmax_node(m,2) + EDecophyscon%avuln_node(m,n) = EDecophyscon%avuln_node(m,2) + EDecophyscon%p50_node(m,n) = EDecophyscon%p50_node(m,2) + EDecophyscon%thetas_node(m,n) = EDecophyscon%thetas_node(m,2) + EDecophyscon%epsil_node(m,n) = EDecophyscon%epsil_node(m,2) + EDecophyscon%pinot_node(m,n) = EDecophyscon%pinot_node(m,2) + EDecophyscon%pitlp_node(m,n) = EDecophyscon%pitlp_node(m,2) + EDecophyscon%resid_node(m,n) = EDecophyscon%resid_node(m,2) + EDecophyscon%rwctlp_node(m,n) = EDecophyscon%rwctlp_node(m,2) + EDecophyscon%fcap_node(m,n) = EDecophyscon%fcap_node(m,2) + EDecophyscon%rwcft_node(m,n) = EDecophyscon%rwcft_node(m,2) + EDecophyscon%rwccap_node(m,n) = EDecophyscon%rwccap_node(m,2) + EDecophyscon%slp_node(m,n) = EDecophyscon%slp_node(m,2) + EDecophyscon%intercept_node(m,n) = EDecophyscon%intercept_node(m,2) + EDecophyscon%corrInt_node(m,n) = EDecophyscon%corrInt_node(m,2) + end do + EDecophyscon%latosa(m) = 10000._r8*exp(-0.69_r8)*(EDecophyscon%kmax_node(m,2)**0.41_r8) ! EDPftvarcon_inst%latosa(m) + EDecophyscon%p50_gs(m) = -6.0_r8 ! testing: lo + EDecophyscon%avuln_gs(m) = 60.15_r8*(-EDecophyscon%p50_gs(m))**(-1.25_r8) ! Christoffersen et al. (2016) + + do k = 1,npool_tot + if(k <= npool_leaf) then + porous_media(k) = 1 + else if(k <= (npool_leaf+npool_stem)) then + porous_media(k) = 2 + else if(k <= (npool_leaf+npool_stem+npool_troot)) then + porous_media(k) = 3 + else if(k <= (npool_leaf+npool_stem+npool_troot+npool_aroot)) then + porous_media(k) = 4 + else + porous_media(k) = 5 + end if + enddo + + end do + + + end if + end subroutine EDecophysconInit end module EDEcophysConType diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index d5c5c296..9a63d488 100755 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -19,6 +19,8 @@ module EDInitMod use EDTypesMod , only : ncwd use EDTypesMod , only : nuMWaterMem use EDTypesMod , only : numpft_ed + use FatesInterfaceMod , only : bc_in_type + use EDTypesMod , only : use_fates_plant_hydro implicit none private @@ -181,17 +183,19 @@ subroutine set_site_properties( nsites, sites) end subroutine set_site_properties ! ============================================================================ - subroutine init_patches( nsites, sites) + subroutine init_patches( nsites, sites, bc_in) ! ! !DESCRIPTION: !initialize patches on new ground ! ! !USES: - use EDParamsMod , only : ED_val_maxspread + use EDParamsMod , only : ED_val_maxspread + use FatesPlantHydraulicsMod, only : updateSizeDepRhizHydProps ! ! !ARGUMENTS integer, intent(in) :: nsites type(ed_site_type) , intent(inout), target :: sites(nsites) + type(bc_in_type), intent(in) :: bc_in(nsites) ! ! !LOCAL VARIABLES: integer :: s @@ -228,15 +232,22 @@ subroutine init_patches( nsites, sites) call create_patch(sites(s), newp, age, AREA, & spread_local, cwd_ag_local, cwd_bg_local, leaf_litter_local, & root_litter_local) + + call init_cohorts(newp, bc_in(s)) - call init_cohorts(newp) + ! This sets the rhizosphere shells based on the plant initialization + ! The initialization of the plant-relevant hydraulics variables + ! were set from a call inside of the init_cohorts()->create_cohort() subroutine + if (use_fates_plant_hydro) then + call updateSizeDepRhizHydProps(sites(s), bc_in(s)) + end if enddo end subroutine init_patches ! ============================================================================ - subroutine init_cohorts( patch_in ) + subroutine init_cohorts( patch_in, bc_in) ! ! !DESCRIPTION: ! initialize new cohorts on bare ground @@ -245,6 +256,7 @@ subroutine init_cohorts( patch_in ) ! ! !ARGUMENTS type(ed_patch_type), intent(inout), pointer :: patch_in + type(bc_in_type), intent(in) :: bc_in ! ! !LOCAL VARIABLES: type(ed_cohort_type),pointer :: temp_cohort @@ -264,6 +276,8 @@ subroutine init_cohorts( patch_in ) temp_cohort%pft = pft temp_cohort%n = EDecophyscon%initd(pft) * patch_in%area temp_cohort%hite = EDecophyscon%hgt_min(pft) + !temp_cohort%n = 0.5_r8 * 0.0028_r8 * patch_in%area ! BOC for fixed size runs EDecophyscon%initd(pft) * patch_in%area + !temp_cohort%hite = 28.65_r8 ! BOC translates to DBH of 50cm. 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) @@ -300,7 +314,7 @@ subroutine init_cohorts( patch_in ) 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) + temp_cohort%laimemory, cstatus, temp_cohort%canopy_trim, 1, bc_in) deallocate(temp_cohort) ! get rid of temporary cohort @@ -308,7 +322,7 @@ subroutine init_cohorts( patch_in ) enddo !numpft - call fuse_cohorts(patch_in) + call fuse_cohorts(patch_in,bc_in) call sort_cohorts(patch_in) end subroutine init_cohorts diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index aed9edc5..93d95d48 100755 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -36,7 +36,18 @@ module EDMainMod use EDtypesMod , only : ed_cohort_type use FatesInterfaceMod , only : bc_in_type use FatesInterfaceMod , only : hlm_masterproc - + use FatesPlantHydraulicsMod, only : do_growthrecruiteffects + use FatesPlantHydraulicsMod, only : updateSizeDepTreeHydProps + use FatesPlantHydraulicsMod, only : updateSizeDepTreeHydStates + use FatesPlantHydraulicsMod, only : initTreeHydStates + use FatesPlantHydraulicsMod, only : updateSizeDepRhizHydProps +! use FatesPlantHydraulicsMod, only : updateSizeDepRhizHydStates + use EDTypesMod , only : use_fates_plant_hydro + use EDTypesMod , only : do_ed_phenology +! use EDTypesMod , only : do_ed_growth +! use EDTypesMod , only : do_ed_recruitment +! use EDTypesMod , only : do_ed_mort_dist + use EDTypesMod , only : do_ed_dynamics implicit none private @@ -50,6 +61,7 @@ module EDMainMod private :: ed_integrate_state_variables private :: ed_total_balance_check + private :: bypass_dynamics logical :: DEBUG = .false. ! @@ -84,47 +96,68 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) call ed_total_balance_check(currentSite, 0) - call phenology(currentSite, bc_in ) + if (do_ed_phenology) then + call phenology(currentSite, bc_in ) + end if + + if (do_ed_dynamics) then + call fire_model(currentSite, bc_in) - call fire_model(currentSite, bc_in) + ! Calculate disturbance and mortality based on previous timestep vegetation. + call disturbance_rates(currentSite) + end if - ! Calculate disturbance and mortality based on previous timestep vegetation. - call disturbance_rates(currentSite) + if (do_ed_dynamics) then + ! Integrate state variables from annual rates to daily timestep + call ed_integrate_state_variables(currentSite, bc_in ) - ! Integrate state variables from annual rates to daily timestep - call ed_integrate_state_variables(currentSite, bc_in ) + else + ! ed_intergrate_state_variables is where the new cohort flag + ! is set. This flag designates wether a cohort has + ! experienced a day, and therefore has been populated with non-nonsense + ! values. If we aren't entering that sequence, we need to set the flag + ! Make sure cohorts are marked as non-recruits + + call bypass_dynamics(currentSite) + + end if !****************************************************************************** ! 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, currentSite, currentPatch) - - currentPatch => currentPatch%younger - enddo + if(do_ed_dynamics) then + currentPatch => currentSite%oldest_patch + do while (associated(currentPatch)) + + ! adds small cohort of each PFT + call recruitment(0, currentSite, currentPatch, bc_in) + + currentPatch => currentPatch%younger + enddo + end if + call ed_total_balance_check(currentSite,1) - currentPatch => currentSite%oldest_patch - do while (associated(currentPatch)) - - ! puts cohorts in right order - call sort_cohorts(currentPatch) - - ! fuses similar cohorts - call fuse_cohorts(currentPatch) - - ! kills cohorts that are too small - call terminate_cohorts(currentSite, currentPatch) - - - currentPatch => currentPatch%younger - enddo - + if( do_ed_dynamics ) then + currentPatch => currentSite%oldest_patch + do while (associated(currentPatch)) + + ! puts cohorts in right order + call sort_cohorts(currentPatch) + + ! fuses similar cohorts + call fuse_cohorts(currentPatch, bc_in ) + + ! kills cohorts that are too small + call terminate_cohorts(currentSite, currentPatch) + + + currentPatch => currentPatch%younger + enddo + end if + call ed_total_balance_check(currentSite,2) !********************************************************************************* @@ -132,17 +165,36 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) !********************************************************************************* ! make new patches from disturbed land - call spawn_patches(currentSite) + if ( do_ed_dynamics ) then + call spawn_patches(currentSite, bc_in) + end if call ed_total_balance_check(currentSite,3) ! fuse on the spawned patches. - call fuse_patches(currentSite) - + if ( do_ed_dynamics ) then + call fuse_patches(currentSite, bc_in ) + + ! If using BC FATES hydraulics, update the rhizosphere geometry + ! based on the new cohort-patch structure + ! 'rhizosphere geometry' (column-level root biomass + rootfr --> root length + ! density --> node radii and volumes) + if(use_fates_plant_hydro .and. do_growthrecruiteffects) then + call updateSizeDepRhizHydProps(currentSite, bc_in) + ! call updateSizeDepRhizHydStates(currentSite, bc_in) + ! if(nshell > 1) then (THIS BEING CHECKED INSIDE OF the update) + ! call updateSizeDepRhizHydStates(currentSite, c, soilstate_inst, & + ! waterstate_inst) + ! end if + end if + end if + call ed_total_balance_check(currentSite,4) ! kill patches that are too small - call terminate_patches(currentSite) + if ( do_ed_dynamics ) then + call terminate_patches(currentSite) + end if call ed_total_balance_check(currentSite,5) @@ -232,6 +284,14 @@ subroutine ed_integrate_state_variables(currentSite, bc_in ) currentCohort%resp_acc = 0.0_r8 call allocate_live_biomass(currentCohort,1) + + ! BOC...update tree 'hydraulic geometry' + ! (size --> heights of elements --> hydraulic path lengths --> + ! maximum node-to-node conductances) + if(use_fates_plant_hydro .and. do_growthrecruiteffects) then + call updateSizeDepTreeHydProps(currentCohort, bc_in) + call updateSizeDepTreeHydStates(currentCohort) + end if currentCohort => currentCohort%taller @@ -335,7 +395,7 @@ subroutine ed_update_site( currentSite, bc_in ) call ed_total_balance_check(currentSite,6) - call canopy_structure(currentSite) + call canopy_structure(currentSite, bc_in) call ed_total_balance_check(currentSite,7) @@ -454,5 +514,59 @@ subroutine ed_total_balance_check (currentSite, call_index ) currentSite%old_stock = total_stock end subroutine ed_total_balance_check + + ! ===================================================================================== + + subroutine bypass_dynamics(currentSite) + + ! ---------------------------------------------------------------------------------- + ! If dynamics are bypassed, various fluxes, rates and flags need to be set + ! to trivial values. + ! WARNING: Turning off things like dynamics is experimental. The setting of + ! variables to trivial values may not be complete, use at your own risk. + ! ---------------------------------------------------------------------------------- + + ! Arguments + type(ed_site_type) , intent(inout), target :: currentSite + + ! Locals + type(ed_patch_type), pointer :: currentPatch + type(ed_cohort_type), pointer :: currentCohort + + currentPatch => currentSite%youngest_patch + do while(associated(currentPatch)) + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + + currentCohort%isnew=.false. + + currentCohort%npp_acc_hold = currentCohort%npp_acc * dble(hlm_days_per_year) + currentCohort%gpp_acc_hold = currentCohort%gpp_acc * dble(hlm_days_per_year) + currentCohort%resp_acc_hold = currentCohort%resp_acc * dble(hlm_days_per_year) + + currentCohort%npp_acc = 0.0_r8 + currentCohort%gpp_acc = 0.0_r8 + currentCohort%resp_acc = 0.0_r8 + + currentCohort%npp_leaf = 0.0_r8 + currentCohort%npp_froot = 0.0_r8 + currentCohort%npp_bsw = 0.0_r8 + currentCohort%npp_bdead = 0.0_r8 + currentCohort%npp_bseed = 0.0_r8 + currentCohort%npp_store = 0.0_r8 + + currentCohort%bmort = 0.0_r8 + currentCohort%hmort = 0.0_r8 + currentCohort%cmort = 0.0_r8 + currentCohort%imort = 0.0_r8 + currentCohort%fmort = 0.0_r8 + + currentCohort => currentCohort%taller + enddo + currentPatch => currentPatch%older + enddo + + end subroutine bypass_dynamics + end module EDMainMod diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index c69e3bbe..d84cc6b6 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -2,7 +2,11 @@ module EDTypesMod use FatesConstantsMod , only : r8 => fates_r8 use clm_varpar , only : mxpft + use shr_infnan_mod, only : nan => shr_infnan_nan, assignment(=) + use FatesHydraulicsMemMod, only : ed_cohort_hydr_type + use FatesHydraulicsMemMod, only : ed_patch_hydr_type + use FatesHydraulicsMemMod, only : ed_site_hydr_type implicit none save @@ -21,7 +25,7 @@ module EDTypesMod integer, parameter :: numpft_ed = 2 ! number of PFTs used in ED. - ! TODO: we use this cp_maxSWb only because we have a static array (size=2) of + ! TODO: we use this cp_maxSWb only because we have a static array q(size=2) of ! land-ice abledo for vis and nir. This should be a parameter, which would ! get us on track to start using multi-spectral or hyper-spectral (RGK 02-2017) integer, parameter :: maxSWb = 2 ! maximum number of broad-bands in the @@ -33,8 +37,16 @@ module EDTypesMod ! Module switches (this will be read in one day) ! This variable only exists now to serve as a place holder !!!!!!!!!! THIS SHOULD NOT BE SET TO TRUE !!!!!!!!!!!!!!!!! - logical, parameter :: use_fates_plant_hydro = .false. + logical,parameter :: use_fates_plant_hydro = .false. + + ! Switches that turn on/off ED dynamics process (names are self explanatory) + ! TO-DO: THESE SHOULD BE PARAMETERS IN THE FILE OR NAMELIST - ADDING THESE + ! WAS OUTSIDE THE SCOPE OF THE VERY LARGE CHANGESET WHERE THESE WERE FIRST + ! INTRODUCED (RGK 03-2017) + logical, parameter :: do_ed_phenology = .true. + logical, parameter :: do_ed_dynamics = .true. + ! MODEL PARAMETERS real(r8), parameter :: AREA = 10000.0_r8 ! Notional area of simulated forest m2 @@ -216,6 +228,7 @@ module EDTypesMod real(r8) :: npp_leaf ! NPP into leaves (includes replacement of turnover): KgC/indiv/year real(r8) :: npp_froot ! NPP into fine roots (includes replacement of turnover): KgC/indiv/year + real(r8) :: npp_bsw ! NPP into sapwood: KgC/indiv/year real(r8) :: npp_bdead ! NPP into deadwood (structure): KgC/indiv/year real(r8) :: npp_bseed ! NPP into seeds: KgC/indiv/year @@ -275,6 +288,10 @@ module EDTypesMod 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:- + ! Hydraulics + type(ed_cohort_hydr_type), pointer :: co_hydr ! All cohort hydraulics data, see FatesHydraulicsMemMod.F90 + + end type ed_cohort_type !************************************ @@ -431,6 +448,9 @@ module EDTypesMod real(r8) :: tfc_ros ! total fuel consumed - no trunks. KgC/m2/day real(r8) :: burnt_frac_litter(nfsc) ! fraction of each litter pool burned:- + ! PLANT HYDRAULICS + type(ed_patch_hydr_type) , pointer :: pa_hydr ! All patch hydraulics data, see FatesHydraulicsMemMod.F90 + contains end type ed_patch_type @@ -517,7 +537,11 @@ module EDTypesMod real(r8) :: cwd_ag_burned(ncwd) real(r8) :: leaf_litter_burned(numpft_ed) + ! PLANT HYDRAULICS + type(ed_site_hydr_type), pointer :: si_hydr + ! TERMINATION, RECRUITMENT, DEMOTION, and DISTURBANCE + real(r8) :: terminated_nindivs(1:nlevsclass_ed,1:mxpft,2) ! number of individuals that were in cohorts which were terminated this timestep, on size x pft x canopy array. real(r8) :: termination_carbonflux(2) ! carbon flux from live to dead pools associated with termination mortality, per canopy level real(r8) :: recruitment_rate(1:mxpft) ! number of individuals that were recruited into new cohorts @@ -538,7 +562,8 @@ module EDTypesMod contains - !-------------------------------------------------------------------------------------! + + !-------------------------------------------------------------------------------------! subroutine ed_hist_scpfmaps ! This subroutine allocates and populates the variables ! that define the mapping of variables in history files in the "scpf" format diff --git a/main/FatesConstantsMod.F90 b/main/FatesConstantsMod.F90 index 414bc5ff..764318c5 100644 --- a/main/FatesConstantsMod.F90 +++ b/main/FatesConstantsMod.F90 @@ -70,6 +70,12 @@ module FatesConstantsMod ! freezing point of water at triple point (K) real(fates_r8), parameter :: t_water_freeze_k_triple = 273.16_fates_r8 + ! Density of fresh liquid water (kg/m3) + real(fates_r8), parameter :: dens_fresh_liquid_water = 1.0E3_fates_r8 + + ! Gravity constant on earth [m/s] + real(fates_r8), parameter :: grav_earth = 9.8_fates_r8 + ! For numerical inquiry real(fates_r8), parameter :: fates_huge = huge(g_per_kg) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 640d288b..d016d2d5 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -4,6 +4,7 @@ module FatesHistoryInterfaceMod use FatesConstantsMod, only : r8 => fates_r8 use FatesConstantsMod, only : fates_avg_flag_length, fates_short_string_length, fates_long_string_length use FatesGlobals , only : fates_log + use FatesGlobals, only : endrun => fates_endrun use FatesIODimensionsMod, only : fates_io_dimension_type use FatesIOVariableKindMod, only : fates_io_variable_kind_type @@ -13,6 +14,9 @@ module FatesHistoryInterfaceMod ! FIXME(bja, 2016-10) need to remove CLM dependancy use EDPftvarcon , only : EDPftvarcon_inst + ! CIME Globals + use shr_log_mod , only : errMsg => shr_log_errMsg + use shr_infnan_mod , only : isnan => shr_infnan_isnan use FatesConstantsMod, only : g_per_kg use FatesConstantsMod, only : ha_per_m2 use FatesConstantsMod, only : days_per_sec @@ -226,6 +230,35 @@ module FatesHistoryInterfaceMod integer, private :: ih_ncl_si_age integer, private :: ih_npatches_si_age + ! Indices to hydraulics variables + + integer, private :: ih_errh2o_scpf + integer, private :: ih_tran_scpf + integer, private :: ih_rootuptake_scpf + integer, private :: ih_rootuptake01_scpf + integer, private :: ih_rootuptake02_scpf + integer, private :: ih_rootuptake03_scpf + integer, private :: ih_rootuptake04_scpf + integer, private :: ih_rootuptake05_scpf + integer, private :: ih_rootuptake06_scpf + integer, private :: ih_rootuptake07_scpf + integer, private :: ih_rootuptake08_scpf + integer, private :: ih_rootuptake09_scpf + integer, private :: ih_rootuptake10_scpf + integer, private :: ih_sapflow_scpf + integer, private :: ih_iterh1_scpf + integer, private :: ih_iterh2_scpf + integer, private :: ih_supsub_scpf + integer, private :: ih_ath_scpf + integer, private :: ih_tth_scpf + integer, private :: ih_sth_scpf + integer, private :: ih_lth_scpf + integer, private :: ih_awp_scpf + integer, private :: ih_twp_scpf + integer, private :: ih_swp_scpf + integer, private :: ih_lwp_scpf + integer, private :: ih_btran_scpf + ! indices to (site x fuel class) variables integer, private :: ih_litter_moisture_si_fuel @@ -316,6 +349,7 @@ module FatesHistoryInterfaceMod procedure, public :: update_history_dyn procedure, public :: update_history_prod procedure, public :: update_history_cbal + procedure, public :: update_history_hydraulics ! 'get' methods used by external callers to access private read only data procedure, public :: num_history_vars @@ -356,7 +390,8 @@ module FatesHistoryInterfaceMod end type fates_history_interface_type - + character(len=*), parameter, private :: sourcefile = & + __FILE__ contains @@ -1042,6 +1077,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) AREA_INV, & nlevsclass_ed, & nlevage_ed, & + do_ed_dynamics, & mxpft, & nfsc, & ncwd, & @@ -1214,6 +1250,10 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! --------------------------------------------------------------------------------- call this%flush_hvars(nc,upfreq_in=1) + + ! If we don't have dynamics turned on, we just abort these diagnostics + if (.not.do_ed_dynamics) return + ! --------------------------------------------------------------------------------- ! Loop through the FATES scale hierarchy and fill the history IO arrays ! --------------------------------------------------------------------------------- @@ -1347,7 +1387,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) if( abs(ccohort%npp_acc_hold-(ccohort%npp_leaf+ccohort%npp_froot+ & ccohort%npp_bsw+ccohort%npp_bdead+ & - ccohort%npp_bseed+ccohort%npp_store))>1.e-9) then + ccohort%npp_bseed+ccohort%npp_store))>1.e-9) then write(fates_log(),*) 'NPP Partitions are not balancing' write(fates_log(),*) 'Fractional Error: ', & abs(ccohort%npp_acc_hold-(ccohort%npp_leaf+ccohort%npp_froot+ & @@ -2005,6 +2045,252 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) end subroutine update_history_prod + ! ===================================================================================== + + subroutine update_history_hydraulics(this,nc,nsites,sites,dt_tstep) + + ! --------------------------------------------------------------------------------- + ! This is the call to update the history IO arrays that are expected to only change + ! after rapid timescale productivity calculations (gpp and respiration). + ! --------------------------------------------------------------------------------- + + use EDtypesMod , only : ed_site_type, & + ed_cohort_type, & + ed_patch_type, & + AREA, & + nlevage_ed, & + sclass_ed, & + nlevsclass_ed + + use FatesHydraulicsMemMod, only : ed_cohort_hydr_type + use EDTypesMod , only : use_fates_plant_hydro + use FatesHydraulicsMemMod, only : nlevsoi_hyd + use EDTypesMod , only : nlevsclass_ed + use EDTypesMod , only : do_ed_dynamics + use clm_varpar , only : mxpft + + ! Arguments + class(fates_history_interface_type) :: this + integer , intent(in) :: nc ! clump index + integer , intent(in) :: nsites + type(ed_site_type) , intent(inout), target :: sites(nsites) + real(r8) , intent(in) :: dt_tstep + + ! Locals + integer :: s ! The local site index + integer :: io_si ! The site index of the IO array + integer :: ipa ! The local "I"ndex of "PA"tches + integer :: io_pa ! The patch index of the IO array + integer :: io_pa1 ! The first patch index in the IO array for each site + integer :: ft ! functional type index + integer :: scpf + real(r8) :: n_density ! individual of cohort per m2. + real(r8) :: n_perm2 ! individuals per m2 for the whole column + real(r8), parameter :: tiny = 1.e-5_r8 ! some small number + real(r8) :: ncohort_scpf(nlevsclass_ed*mxpft) ! Bins to count up cohorts counts used in weighting + ! should be "hio_nplant_si_scpf" + real(r8) :: number_fraction + real(r8) :: number_fraction_rate + integer :: ipa2 ! patch incrementer + integer :: iscpf ! index of the scpf group + + type(fates_history_variable_type),pointer :: hvar + type(ed_patch_type),pointer :: cpatch + type(ed_cohort_type),pointer :: ccohort + type(ed_cohort_hydr_type), pointer :: ccohort_hydr + + real(r8), parameter :: daysecs = 86400.0_r8 ! What modeler doesn't recognize 86400? + real(r8), parameter :: yeardays = 365.0_r8 ! Should this be 365.25? + + if(.not.use_fates_plant_hydro) return + + associate( hio_errh2o_scpf => this%hvars(ih_errh2o_scpf)%r82d, & + hio_tran_scpf => this%hvars(ih_tran_scpf)%r82d, & + hio_rootuptake_scpf => this%hvars(ih_rootuptake_scpf)%r82d, & + hio_rootuptake01_scpf => this%hvars(ih_rootuptake01_scpf)%r82d, & + hio_rootuptake02_scpf => this%hvars(ih_rootuptake02_scpf)%r82d, & + hio_rootuptake03_scpf => this%hvars(ih_rootuptake03_scpf)%r82d, & + hio_rootuptake04_scpf => this%hvars(ih_rootuptake04_scpf)%r82d, & + hio_rootuptake05_scpf => this%hvars(ih_rootuptake05_scpf)%r82d, & + hio_rootuptake06_scpf => this%hvars(ih_rootuptake06_scpf)%r82d, & + hio_rootuptake07_scpf => this%hvars(ih_rootuptake07_scpf)%r82d, & + hio_rootuptake08_scpf => this%hvars(ih_rootuptake08_scpf)%r82d, & + hio_rootuptake09_scpf => this%hvars(ih_rootuptake09_scpf)%r82d, & + hio_rootuptake10_scpf => this%hvars(ih_rootuptake10_scpf)%r82d, & + hio_sapflow_scpf => this%hvars(ih_sapflow_scpf)%r82d, & + hio_iterh1_scpf => this%hvars(ih_iterh1_scpf)%r82d, & + hio_iterh2_scpf => this%hvars(ih_iterh2_scpf)%r82d, & + hio_ath_scpf => this%hvars(ih_ath_scpf)%r82d, & + hio_tth_scpf => this%hvars(ih_tth_scpf)%r82d, & + hio_sth_scpf => this%hvars(ih_sth_scpf)%r82d, & + hio_lth_scpf => this%hvars(ih_lth_scpf)%r82d, & + hio_awp_scpf => this%hvars(ih_awp_scpf)%r82d, & + hio_twp_scpf => this%hvars(ih_twp_scpf)%r82d, & + hio_swp_scpf => this%hvars(ih_swp_scpf)%r82d, & + hio_lwp_scpf => this%hvars(ih_lwp_scpf)%r82d, & + hio_btran_scpf => this%hvars(ih_btran_scpf)%r82d, & + hio_nplant_si_scpf => this%hvars(ih_nplant_si_scpf)%r82d ) + + ! Flush the relevant history variables + call this%flush_hvars(nc,upfreq_in=4) + + do s = 1,nsites + + io_si = this%iovar_map(nc)%site_index(s) + io_pa1 = this%iovar_map(nc)%patch1_index(s) + + ncohort_scpf(:) = 0.0_r8 ! Counter for normalizing weighting + ! factors for cohort mean propoerties + ! This is actually used as a check + ! on hio_nplant_si_scpf + + cpatch => sites(s)%oldest_patch + do while(associated(cpatch)) + ccohort => cpatch%shortest + do while(associated(ccohort)) + if ( .not. ccohort%isnew ) then + ! Calculate index for the scpf class + iscpf = ccohort%size_by_pft_class + ncohort_scpf(iscpf) = ncohort_scpf(iscpf) + ccohort%n + end if + ccohort => ccohort%taller + enddo ! cohort loop + cpatch => cpatch%younger + end do !patch loop + + + ipa = 0 + cpatch => sites(s)%oldest_patch + do while(associated(cpatch)) + + io_pa = io_pa1 + ipa + + ccohort => cpatch%shortest + do while(associated(ccohort)) + + ccohort_hydr => ccohort%co_hydr + + ! TODO: we need a standardized logical function on this (used lots, RGK) + if ((cpatch%area .gt. 0._r8) .and. (cpatch%total_canopy_area .gt. 0._r8)) then + n_density = ccohort%n/min(cpatch%area,cpatch%total_canopy_area) + n_perm2 = ccohort%n/AREA + else + n_density = 0.0_r8 + n_perm2 = 0.0_r8 + endif + + if ( .not. ccohort%isnew ) then + + ! Calculate index for the scpf class + iscpf = ccohort%size_by_pft_class + + ! scale up cohort fluxes to their sites + number_fraction_rate = (ccohort%n / ncohort_scpf(iscpf))/dt_tstep + + ! scale cohorts to mean quantity + number_fraction = (ccohort%n / ncohort_scpf(iscpf)) + + hio_errh2o_scpf(io_si,iscpf) = hio_errh2o_scpf(io_si,iscpf) + & + ccohort_hydr%errh2o * number_fraction_rate ! [kg/indiv/s] + + hio_tran_scpf(io_si,iscpf) = hio_tran_scpf(io_si,iscpf) + & + (ccohort_hydr%qtop_dt + ccohort_hydr%dqtopdth_dthdt) * number_fraction_rate ! [kg/indiv/s] + + hio_rootuptake_scpf(io_si,iscpf) = hio_rootuptake_scpf(io_si,iscpf) + & + ccohort_hydr%rootuptake * number_fraction_rate ! [kg/indiv/s] + + if(nlevsoi_hyd == 10) then + hio_rootuptake01_scpf(io_si,iscpf) = hio_rootuptake01_scpf(io_si,iscpf) + & + ccohort_hydr%rootuptake01 * number_fraction_rate ! [kg/indiv/s] + + hio_rootuptake02_scpf(io_si,iscpf) = hio_rootuptake02_scpf(io_si,iscpf) + & + ccohort_hydr%rootuptake02 * number_fraction_rate ! [kg/indiv/s] + + hio_rootuptake03_scpf(io_si,iscpf) = hio_rootuptake03_scpf(io_si,iscpf) + & + ccohort_hydr%rootuptake03 * number_fraction_rate ! [kg/indiv/s] + + hio_rootuptake04_scpf(io_si,iscpf) = hio_rootuptake04_scpf(io_si,iscpf) + & + ccohort_hydr%rootuptake04 * number_fraction_rate ! [kg/indiv/s] + + hio_rootuptake05_scpf(io_si,iscpf) = hio_rootuptake05_scpf(io_si,iscpf) + & + ccohort_hydr%rootuptake05 * number_fraction_rate ! [kg/indiv/s] + + hio_rootuptake06_scpf(io_si,iscpf) = hio_rootuptake06_scpf(io_si,iscpf) + & + ccohort_hydr%rootuptake06 * number_fraction_rate ! [kg/indiv/s] + + hio_rootuptake07_scpf(io_si,iscpf) = hio_rootuptake07_scpf(io_si,iscpf) + & + ccohort_hydr%rootuptake07 * number_fraction_rate ! [kg/indiv/s] + + hio_rootuptake08_scpf(io_si,iscpf) = hio_rootuptake08_scpf(io_si,iscpf) + & + ccohort_hydr%rootuptake08 * number_fraction_rate ! [kg/indiv/s] + + hio_rootuptake09_scpf(io_si,iscpf) = hio_rootuptake09_scpf(io_si,iscpf) + & + ccohort_hydr%rootuptake09 * number_fraction_rate ! [kg/indiv/s] + + hio_rootuptake10_scpf(io_si,iscpf) = hio_rootuptake10_scpf(io_si,iscpf) + & + ccohort_hydr%rootuptake10 * number_fraction_rate ! [kg/indiv/s] + + end if + + hio_sapflow_scpf(io_si,iscpf) = hio_sapflow_scpf(io_si,iscpf) + & + ccohort_hydr%sapflow * number_fraction_rate ! [kg/indiv/s] + + hio_iterh1_scpf(io_si,iscpf) = hio_iterh1_scpf(io_si,iscpf) + & + ccohort_hydr%iterh1 * number_fraction ! [-] + + hio_iterh2_scpf(io_si,iscpf) = hio_iterh2_scpf(io_si,iscpf) + & + ccohort_hydr%iterh2 * number_fraction ! [-] + + hio_ath_scpf(io_si,iscpf) = hio_ath_scpf(io_si,iscpf) + & + ccohort_hydr%th_aroot(1) * number_fraction ! [m3 m-3] + + hio_tth_scpf(io_si,iscpf) = hio_tth_scpf(io_si,iscpf) + & + ccohort_hydr%th_bg(1) * number_fraction ! [m3 m-3] + + hio_sth_scpf(io_si,iscpf) = hio_sth_scpf(io_si,iscpf) + & + ccohort_hydr%th_ag(2) * number_fraction ! [m3 m-3] + + hio_lth_scpf(io_si,iscpf) = hio_lth_scpf(io_si,iscpf) + & + ccohort_hydr%th_ag(1) * number_fraction ! [m3 m-3] + + hio_awp_scpf(io_si,iscpf) = hio_awp_scpf(io_si,iscpf) + & + ccohort_hydr%psi_aroot(1) * number_fraction ! [MPa] + + hio_twp_scpf(io_si,iscpf) = hio_twp_scpf(io_si,iscpf) + & + ccohort_hydr%psi_bg(1) * number_fraction ! [MPa] + + hio_swp_scpf(io_si,iscpf) = hio_swp_scpf(io_si,iscpf) + & + ccohort_hydr%psi_ag(2) * number_fraction ! [MPa] + + hio_lwp_scpf(io_si,iscpf) = hio_lwp_scpf(io_si,iscpf) + & + ccohort_hydr%psi_ag(1) * number_fraction ! [MPa] + + hio_btran_scpf(io_si,iscpf) = hio_btran_scpf(io_si,iscpf) + & + ccohort_hydr%btran(1) * number_fraction ! [-] + + endif + + ccohort => ccohort%taller + enddo ! cohort loop + ipa = ipa + 1 + cpatch => cpatch%younger + end do !patch loop + + if(do_ed_dynamics) then + do scpf=1,nlevsclass_ed*mxpft + if( abs(hio_nplant_si_scpf(io_si, scpf)-ncohort_scpf(scpf)) > 1.0E-8_r8 ) then + write(fates_log(),*) 'nplant check on hio_nplant_si_scpf fails during hydraulics history updates' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end do + end if + + enddo ! site loop + + end associate + + end subroutine update_history_hydraulics + ! ==================================================================================== integer function num_history_vars(this) @@ -2070,8 +2356,10 @@ subroutine define_history_vars(this, initialize_variables) use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8 use FatesIOVariableKindMod, only : site_size_r8, site_pft_r8, site_age_r8 + use EDTypesMod , only : use_fates_plant_hydro use FatesIOVariableKindMod, only : site_fuel_r8, site_cwdsc_r8, site_scag_r8 use FatesIOVariableKindMod, only : site_can_r8, site_cnlf_r8, site_cnlfpft_r8 + implicit none class(fates_history_interface_type), intent(inout) :: this @@ -3084,6 +3372,142 @@ subroutine define_history_vars(this, initialize_variables) upfreq=3, ivar=ivar, initialize=initialize_variables, index = ih_cwd_stock_si ) + ! PLANT HYDRAULICS + + if(use_fates_plant_hydro) then + + call this%set_history_var(vname='FATES_ERRH2O_SCPF', units='kg/indiv/s', & + long='mean individual water balance error', use_default='active', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_errh2o_scpf ) + + call this%set_history_var(vname='FATES_TRAN_SCPF', units='kg/indiv/s', & + long='mean individual transpiration rate', use_default='active', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_tran_scpf ) + + call this%set_history_var(vname='FATES_ROOTUPTAKE_SCPF', units='kg/indiv/s', & + long='mean individual root uptake rate', use_default='active', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake_scpf ) + + call this%set_history_var(vname='FATES_ROOTUPTAKE01_SCPF', units='kg/indiv/s', & + long='mean individual root uptake rate, layer 1', use_default='active', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake01_scpf ) + + call this%set_history_var(vname='FATES_ROOTUPTAKE02_SCPF', units='kg/indiv/s', & + long='mean individual root uptake rate, layer 2', use_default='active', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake02_scpf ) + + call this%set_history_var(vname='FATES_ROOTUPTAKE03_SCPF', units='kg/indiv/s', & + long='mean individual root uptake rate, layer 3', use_default='active', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake03_scpf ) + + call this%set_history_var(vname='FATES_ROOTUPTAKE04_SCPF', units='kg/indiv/s', & + long='mean individual root uptake rate, layer 4', use_default='active', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake04_scpf ) + + call this%set_history_var(vname='FATES_ROOTUPTAKE05_SCPF', units='kg/indiv/s', & + long='mean individual root uptake rate, layer 5', use_default='active', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake05_scpf ) + + call this%set_history_var(vname='FATES_ROOTUPTAKE06_SCPF', units='kg/indiv/s', & + long='mean individual root uptake rate, layer 6', use_default='active', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake06_scpf ) + + call this%set_history_var(vname='FATES_ROOTUPTAKE07_SCPF', units='kg/indiv/s', & + long='mean individual root uptake rate, layer 7', use_default='active', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake07_scpf ) + + call this%set_history_var(vname='FATES_ROOTUPTAKE08_SCPF', units='kg/indiv/s', & + long='mean individual root uptake rate, layer 8', use_default='active', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake08_scpf ) + + call this%set_history_var(vname='FATES_ROOTUPTAKE09_SCPF', units='kg/indiv/s', & + long='mean individual root uptake rate, layer 9', use_default='active', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake09_scpf ) + + call this%set_history_var(vname='FATES_ROOTUPTAKE10_SCPF', units='kg/indiv/s', & + long='mean individual root uptake rate, layer 10', use_default='active', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake10_scpf ) + + call this%set_history_var(vname='FATES_SAPFLOW_COL_SCPF', units='kg/indiv/s', & + long='individual sap flow rate', use_default='active', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_sapflow_scpf ) + + call this%set_history_var(vname='FATES_ITERH1_COL_SCPF', units='count/indiv/step', & + long='number of outer iterations required to achieve tolerable water balance error', use_default='active', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_iterh1_scpf ) + + call this%set_history_var(vname='FATES_ITERH2_COL_SCPF', units='count/indiv/step', & + long='number of inner iterations required to achieve tolerable water balance error', use_default='active', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_iterh2_scpf ) + + call this%set_history_var(vname='FATES_ATH_COL_SCPF', units='m3 m-3', & + long='absorbing root water content', use_default='active', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_ath_scpf ) + + call this%set_history_var(vname='FATES_TTH_COL_SCPF', units='m3 m-3', & + long='transporting root water content', use_default='active', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_tth_scpf ) + + call this%set_history_var(vname='FATES_STH_COL_SCPF', units='m3 m-3', & + long='stem water contenet', use_default='active', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_sth_scpf ) + + call this%set_history_var(vname='FATES_LTH_COL_SCPF', units='m3 m-3', & + long='leaf water content', use_default='active', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_lth_scpf ) + + call this%set_history_var(vname='FATES_AWP_COL_SCPF', units='MPa', & + long='absorbing root water potential', use_default='active', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_awp_scpf ) + + call this%set_history_var(vname='FATES_TWP_COL_SCPF', units='MPa', & + long='transporting root water potential', use_default='active', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_twp_scpf ) + + call this%set_history_var(vname='FATES_SWP_COL_SCPF', units='MPa', & + long='stem water potential', use_default='active', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_swp_scpf ) + + call this%set_history_var(vname='FATES_LWP_COL_SCPF', units='MPa', & + long='leaf water potential', use_default='active', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_lwp_scpf ) + + call this%set_history_var(vname='FATES_BTRAN_COL_SCPF', units='MPa', & + long='mean individual level btran', use_default='active', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_btran_scpf ) + +! call this%set_history_var(vname='FATES_LAROOT_COL_SCPF', units='kg/indiv/s', & +! long='Needs Description', use_default='active', & +! avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & +! upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_laroot_scpf) + + end if + ! Must be last thing before return this%num_history_vars_ = ivar diff --git a/main/FatesHydraulicsMemMod.F90 b/main/FatesHydraulicsMemMod.F90 new file mode 100644 index 00000000..43001b0f --- /dev/null +++ b/main/FatesHydraulicsMemMod.F90 @@ -0,0 +1,218 @@ +module FatesHydraulicsMemMod + + use FatesConstantsMod, only : r8 => fates_r8 + use shr_infnan_mod, only : nan => shr_infnan_nan, assignment(=) + + implicit none + + integer,parameter :: nlevsoi_hyd = 10 ! use_fates_plant_hydro parameter: + ! Number of soil layers for indexing + ! cohort fine root quanitities + + + integer , parameter :: n_porous_media = 4 ! number of distinct types + ! of plant porous media + ! (leaf, stem, troot, aroot) + integer , parameter :: npool_leaf = 1 ! + integer , parameter :: npool_stem = 1 ! + integer , parameter :: npool_troot = 1 ! + integer , parameter :: npool_aroot = 1 ! + integer , parameter :: nshell = 5 ! + integer , parameter :: npool_ag = npool_leaf+npool_stem ! number of aboveground plant water storage nodes + integer , parameter :: npool_bg = npool_troot ! number of belowground plant water storage nodes + integer , parameter :: npool_tot = npool_ag + 2 + nshell ! total number of water storage nodes + integer :: porous_media(npool_tot) ! vector indexing the type of + ! porous medium over an arbitrary + ! number of plant pools + integer, parameter :: numLWPmem = 4 ! number of previous timestep's leaf water + ! potential to be retained + integer, parameter :: nlevcan_hyd = 2 ! mirror of nlevcan, hard-set for simplicity + ! TODO: remove nlevcan_hyd on a rainy day + real(r8), parameter :: fine_root_radius_const = 0.001_r8 ! Mean fine root radius expected in the bulk soil + + type ed_site_hydr_type + + ! Plant Hydraulics + + real(r8),allocatable :: v_shell(:,:) ! Volume of rhizosphere compartment (m) + real(r8),allocatable :: v_shell_init(:,:) ! Previous volume of rhizosphere compartment (m) + real(r8),allocatable :: v_shell_1D(:) ! Volume of rhizosphere compartment (m) + real(r8),allocatable :: r_node_shell(:,:) ! Nodal radius of rhizosphere compartment (m) + real(r8),allocatable :: r_node_shell_init(:,:) ! Previous Nodal radius of rhizosphere compartment (m) + real(r8),allocatable :: l_aroot_layer(:) ! Total length (across cohorts) of absorbing + ! roots by soil layer (m) + real(r8),allocatable :: l_aroot_layer_init(:) ! Total length (across cohorts) of absorbing + ! roots by soil layer (m) + real(r8),allocatable :: kmax_upper_shell(:,:) ! Maximum soil hydraulic conductance node k + ! to upper (closer to atmosphere) rhiz + ! shell boundaries (kg s-1 MPa-1) + real(r8),allocatable :: kmax_bound_shell(:,:) ! Maximum soil hydraulic conductance at upper + ! (closer to atmosphere) rhiz shell + ! boundaries (kg s-1 MPa-1) + real(r8),allocatable :: kmax_lower_shell(:,:) ! Maximum soil hydraulic conductance node k + ! to lower (further from atmosphere) + ! rhiz shell boundaries (kg s-1 MPa-1) + real(r8),allocatable :: r_out_shell(:,:) ! Outer radius of rhizosphere compartment (m) + real(r8),allocatable :: r_out_shell_1D(:) ! Outer radius of rhizosphere compartment (m) (USED?) + real(r8),allocatable :: r_node_shell_1D(:) ! Nodal radius of rhizosphere compartment (m) + + real(r8),allocatable :: rs1(:) ! Mean fine root radius (m) (currently a constant) + + real(r8),allocatable :: kmax_upper_shell_1D(:) ! Maximum soil hydraulic conductance node + ! k to upper (closer to atmosphere) rhiz + ! shell boundaries (kg s-1 MPa-1) + real(r8),allocatable :: kmax_bound_shell_1D(:) ! Maximum soil hydraulic conductance at upper + ! (closer to atmosphere) rhiz shell + ! boundaries (kg s-1 MPa-1) + real(r8),allocatable :: kmax_lower_shell_1D(:) ! Maximum soil hydraulic conductance node + ! k to lower (further from atmosphere) rhiz + ! shell boundaries (kg s-1 MPa-1) + + integer,allocatable :: supsub_flag(:) ! index of the outermost rhizosphere shell + ! encountering super- or sub-saturation + real(r8),allocatable :: h2osoi_liqvol_shell(:,:) ! volumetric water in rhizosphere compartment (m3/m3) + + real(r8),allocatable :: h2osoi_liq_prev(:) ! liquid water mass for the bulk soil layer + ! defined at the end of the hydraulics sequence + ! after root water has been extracted. This should + ! be equal to the sum of the water over the rhizosphere shells + + real(r8),allocatable :: psisoi_liq_innershell(:) ! Matric potential of the inner rhizosphere shell (MPa) + + real(r8) :: l_aroot_1D ! Total (across cohorts) absorbing root + ! length across all layers + + real(r8) :: errh2o_hyd ! plant hydraulics error summed across + ! cohorts to column level (mm) + real(r8) :: dwat_veg ! change in stored water in vegetation + ! column level (kg) + real(r8) :: h2oveg ! stored water in vegetation (kg) + + ! Hold Until Van Genuchten is implemented + ! real(r8), allocatable :: alpha_VG(:) ! col inverse of air-entry pressure [MPa-1] (for van Genuchten SWC only) + ! real(r8), allocatable :: n_VG(:) ! col pore-size distribution index [-] (for van Genuchten SWC only) + ! real(r8), allocatable :: m_VG(:) ! = 1 - 1/n_VG [-] (for van Genuchten SWC only) + ! real(r8), allocatable :: l_VG(:) ! col pore tortuosity parameter [-] (for van Genuchten SWC only) + + contains + + procedure :: InitHydrSite + + end type ed_site_hydr_type + + type ed_patch_hydr_type + real(r8) :: netRad_mem(numLWPmem) ! patch-level net radiation for the previous numLWPmem timesteps [W m-2] + end type ed_patch_hydr_type + + + type ed_cohort_hydr_type + + ! BC...PLANT HYDRAULICS - "constants" that change with size. Heights are referenced to soil surface (+ = above; - = below) + real(r8) :: z_node_ag(npool_ag) ! nodal height of aboveground water storage compartments [m] + real(r8) :: z_node_bg(npool_bg) ! nodal height of belowground water storage compartments [m] + real(r8) :: z_node_aroot(nlevsoi_hyd) ! nodal height of absorbing root water storage compartments [m] + real(r8) :: z_upper_ag(npool_ag) ! upper boundary height of aboveground water storage compartments [m] + real(r8) :: z_upper_bg(npool_bg) ! upper boundary height of belowground water storage compartments [m] + real(r8) :: z_lower_ag(npool_ag) ! lower boundary height of aboveground water storage compartments [m] + real(r8) :: z_lower_bg(npool_bg) ! lower boundary height of belowground water storage compartments [m] + real(r8) :: kmax_upper(npool_ag) ! maximum hydraulic conductance from node to upper boundary [kg s-1 MPa-1] + real(r8) :: kmax_lower(npool_ag) ! maximum hydraulic conductance from node to lower boundary [kg s-1 MPa-1] + real(r8) :: kmax_upper_troot ! maximum hydraulic conductance from troot node to upper boundary [kg s-1 MPa-1] + real(r8) :: kmax_bound(npool_ag) ! maximum hydraulic conductance at lower boundary (canopy to troot) [kg s-1 MPa-1] + real(r8) :: kmax_treebg_tot ! total belowground tree kmax (troot to surface of absorbing roots) [kg s-1 MPa-1] + real(r8) :: kmax_treebg_layer(nlevsoi_hyd) ! total belowground tree kmax partitioned by soil layer [kg s-1 MPa-1] + real(r8) :: v_ag_init(npool_ag) ! previous day's volume of aboveground water storage compartments [m3] + real(r8) :: v_ag(npool_ag) ! volume of aboveground water storage compartments [m3] + real(r8) :: v_bg_init(npool_bg) ! previous day's volume of belowground water storage compartments [m3] + real(r8) :: v_bg(npool_bg) ! volume of belowground water storage compartments [m3] + real(r8) :: v_aroot_tot ! total volume of absorbing roots [m3] + real(r8) :: v_aroot_layer_init(nlevsoi_hyd) ! previous day's volume of absorbing roots by soil layer [m3] + real(r8) :: v_aroot_layer(nlevsoi_hyd) ! volume of absorbing roots by soil layer [m3] + real(r8) :: l_aroot_tot ! total length of absorbing roots [m] + real(r8) :: l_aroot_layer(nlevsoi_hyd) ! length of absorbing roots by soil layer [m] + + ! BC PLANT HYDRAULICS - state variables + real(r8) :: th_ag(npool_ag) ! water in aboveground compartments [kgh2o/indiv] + real(r8) :: th_bg(npool_bg) ! water in belowground compartments [kgh2o/indiv] + real(r8) :: th_aroot(nlevsoi_hyd) ! water in absorbing roots [kgh2o/indiv] + real(r8) :: lwp_mem(numLWPmem) ! leaf water potential over the previous numLWPmem timesteps [MPa] + real(r8) :: lwp_stable ! leaf water potential just before it became unstable [MPa] + logical :: lwp_is_unstable ! flag for instability of leaf water potential over previous timesteps + real(r8) :: psi_ag(npool_ag) ! water potential in aboveground compartments [MPa] + real(r8) :: psi_bg(npool_bg) ! water potential in belowground compartments [MPa] + real(r8) :: psi_aroot(nlevsoi_hyd) ! water potential in absorbing roots [MPa] + real(r8) :: flc_ag(npool_ag) ! fractional loss of conductivity in aboveground compartments [-] + real(r8) :: flc_bg(npool_bg) ! fractional loss of conductivity in belowground compartments [-] + real(r8) :: flc_aroot(nlevsoi_hyd) ! fractional loss of conductivity in absorbing roots [-] + real(r8) :: flc_min_ag(npool_ag) ! min attained fractional loss of conductivity in aboveground compartments (for tracking xylem refilling dynamics) [-] + real(r8) :: flc_min_bg(npool_bg) ! min attained fractional loss of conductivity in belowground compartments (for tracking xylem refilling dynamics) [-] + real(r8) :: flc_min_aroot(nlevsoi_hyd) ! min attained fractional loss of conductivity in absorbing roots (for tracking xylem refilling dynamics) [-] + real(r8) :: refill_thresh ! water potential threshold for xylem refilling to occur [MPa] + real(r8) :: refill_days ! number of days required for 50% of xylem refilling to occur [days] + real(r8) :: btran(nlevcan_hyd) ! leaf water potential limitation on gs [0-1] + real(r8) :: supsub_flag ! k index of last node to encounter supersaturation or sub-residual water content (+ supersaturation; - subsaturation) + real(r8) :: iterh1 ! number of iterations required to achieve tolerable water balance error + real(r8) :: iterh2 ! number of inner iterations + real(r8) :: errh2o ! total water balance error per unit crown area [kgh2o/m2] + + ! BC PLANT HYDRAULICS - fluxes + real(r8) :: qtop_dt ! transpiration boundary condition (+ to atm) [kg/indiv/timestep] + real(r8) :: dqtopdth_dthdt ! transpiration tendency term (+ to atm) [kg/indiv/timestep] + ! NOTE: total transpiration is given by qtop_dt + dqtopdth_dthdt + real(r8) :: sapflow ! flow at base of tree (+ upward) [kg/indiv/timestep] + real(r8) :: rootuptake ! net flow into roots (+ into roots) [kg/indiv/timestep] + real(r8) :: rootuptake01 ! net flow into roots (+ into roots), soil layer 1 [kg/indiv/timestep] + real(r8) :: rootuptake02 ! net flow into roots (+ into roots), soil layer 2 [kg/indiv/timestep] + real(r8) :: rootuptake03 ! net flow into roots (+ into roots), soil layer 3 [kg/indiv/timestep] + real(r8) :: rootuptake04 ! net flow into roots (+ into roots), soil layer 4 [kg/indiv/timestep] + real(r8) :: rootuptake05 ! net flow into roots (+ into roots), soil layer 5 [kg/indiv/timestep] + real(r8) :: rootuptake06 ! net flow into roots (+ into roots), soil layer 6 [kg/indiv/timestep] + real(r8) :: rootuptake07 ! net flow into roots (+ into roots), soil layer 7 [kg/indiv/timestep] + real(r8) :: rootuptake08 ! net flow into roots (+ into roots), soil layer 8 [kg/indiv/timestep] + real(r8) :: rootuptake09 ! net flow into roots (+ into roots), soil layer 9 [kg/indiv/timestep] + real(r8) :: rootuptake10 ! net flow into roots (+ into roots), soil layer 10 [kg/indiv/timestep] + end type ed_cohort_hydr_type + + contains + + ! =================================================================================== + + subroutine InitHydrSite(this) + + ! Arguments + class(ed_site_hydr_type),intent(inout) :: this + + allocate(this%v_shell(1:nlevsoi_hyd,1:nshell)) ; this%v_shell = nan + allocate(this%v_shell_init(1:nlevsoi_hyd,1:nshell)) ; this%v_shell_init = nan + allocate(this%v_shell_1D(1:nshell)) ; this%v_shell_1D = nan + allocate(this%r_node_shell(1:nlevsoi_hyd,1:nshell)) ; this%r_node_shell = nan + allocate(this%r_node_shell_init(1:nlevsoi_hyd,1:nshell)); this%r_node_shell_init = nan + allocate(this%r_out_shell(1:nlevsoi_hyd,1:nshell)) ; this%r_out_shell = nan + allocate(this%l_aroot_layer(1:nlevsoi_hyd)) ; this%l_aroot_layer = nan + allocate(this%l_aroot_layer_init(1:nlevsoi_hyd)) ; this%l_aroot_layer_init = nan + allocate(this%kmax_upper_shell(1:nlevsoi_hyd,1:nshell)); this%kmax_upper_shell = nan + allocate(this%kmax_bound_shell(1:nlevsoi_hyd,1:nshell)); this%kmax_bound_shell = nan + allocate(this%kmax_lower_shell(1:nlevsoi_hyd,1:nshell)); this%kmax_lower_shell = nan + allocate(this%r_out_shell_1D(1:nshell)) ; this%r_out_shell_1D = nan + allocate(this%r_node_shell_1D(1:nshell)) ; this%r_node_shell_1D = nan + allocate(this%kmax_upper_shell_1D(1:nshell)) ; this%kmax_upper_shell_1D = nan + allocate(this%kmax_bound_shell_1D(1:nshell)) ; this%kmax_bound_shell_1D = nan + allocate(this%kmax_lower_shell_1D(1:nshell)) ; this%kmax_lower_shell_1D = nan + allocate(this%supsub_flag(nlevsoi_hyd)) ; this%supsub_flag = -999 + allocate(this%h2osoi_liqvol_shell(1:nlevsoi_hyd,1:nshell)) ; this%h2osoi_liqvol_shell = nan + allocate(this%h2osoi_liq_prev(1:nlevsoi_hyd)) ; this%h2osoi_liq_prev = nan + allocate(this%psisoi_liq_innershell(1:nlevsoi_hyd)); this%psisoi_liq_innershell = nan + allocate(this%rs1(1:nlevsoi_hyd)); this%rs1(:) = fine_root_radius_const + + this%l_aroot_1D = nan + this%errh2o_hyd = nan + this%dwat_veg = nan + this%h2oveg = nan + return + end subroutine InitHydrSite + + + + + +end module FatesHydraulicsMemMod diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 3a1e2576..d350f948 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -19,7 +19,12 @@ module FatesInterfaceMod use FatesConstantsMod , only : r8 => fates_r8 use FatesGlobals , only : fates_global_verbose use FatesGlobals , only : fates_log - + use EDTypesMod , only : use_fates_plant_hydro + use FatesGlobals , only : endrun => fates_endrun + + ! CIME Globals + use shr_log_mod , only : errMsg => shr_log_errMsg + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) implicit none @@ -28,6 +33,9 @@ module FatesInterfaceMod public :: SetFatesTime public :: set_fates_global_elements + character(len=*), parameter, private :: sourcefile = & + __FILE__ + ! ------------------------------------------------------------------------------------- ! Parameters that are dictated by the Host Land Model ! THESE ARE NOT DYNAMIC. SHOULD BE SET ONCE DURING INTIALIZATION. @@ -71,6 +79,13 @@ module FatesInterfaceMod ! for knowing if the current machine should be ! printing out messages to the logs or terminals ! 1 = TRUE (is master) 0 = FALSE (is not master) + + integer, protected :: hlm_ipedof ! The HLM pedotransfer index + ! this is only used by the plant hydraulics + ! submodule to check and/or enable consistency + ! between the pedotransfer functions of the HLM + ! and how it moves and stores water in its + ! rhizosphere shells ! ------------------------------------------------------------------------------------- @@ -142,6 +157,16 @@ module FatesInterfaceMod ! The actual number of FATES' ED patches integer :: npatches + + ! Soil layer structure + real(r8),allocatable :: zi_sisl(:) ! interface level below a "z" level (m) + ! this contains a zero index for surface. + real(r8),allocatable :: dz_sisl(:) ! layer thickness (m) + real(r8),allocatable :: z_sisl(:) ! layer depth (m) (1:hlm_nlevsoil) + + ! Decomposition Layer Structure + real(r8), allocatable :: dz_decomp_sisl(:) + ! Vegetation Dynamics ! --------------------------------------------------------------------------------- @@ -155,12 +180,6 @@ module FatesInterfaceMod ! Patch 24 hour vegetation temperature [K] real(r8),allocatable :: t_veg24_pa(:) - ! NOTE: h2osoi_vol_si is used to update surface water memory - ! CLM/ALM may be using "waterstate%h2osoi_vol_col" on the first index (coli,1) - ! to inform this. I think this should be re-evaluated (RGK 01/2017) - ! Site volumetric soil water (0<=h2osoi_vol<=watsat) [m3/m3] - real(r8) :: h2osoi_vol_si - ! Fire Model ! Average precipitation over the last 24 hours [mm/s] @@ -182,26 +201,7 @@ module FatesInterfaceMod ! Downwelling diffuse (I-ndirect) radiation (patch,radiation-band) [W/m2] real(r8), allocatable :: solai_parb(:,:) - ! Hydrology variables for BTRAN - ! --------------------------------------------------------------------------------- - - ! Soil suction potential of layers in each site, negative, [mm] - real(r8), allocatable :: smp_gl(:) - - ! Effective porosity = porosity - vol_ic, of layers in each site [-] - real(r8), allocatable :: eff_porosity_gl(:) - - ! volumetric soil water at saturation (porosity) - real(r8), allocatable :: watsat_gl(:) - - ! Temperature of ground layers [K] - real(r8), allocatable :: tempk_gl(:) - ! Liquid volume in ground layer - real(r8), allocatable :: h2o_liqvol_gl(:) - - ! Site level filter for uptake response functions - logical :: filter_btran ! Photosynthesis variables ! --------------------------------------------------------------------------------- @@ -278,10 +278,43 @@ module FatesInterfaceMod real(r8) :: snow_depth_si ! Depth of snow in snowy areas of site (m) real(r8) :: frac_sno_eff_si ! Fraction of ground covered by snow (0-1) - ! Ground Layer Structure - real(r8),allocatable :: depth_gl(:) ! Depth in vertical direction of ground layers - ! Interface level below a "z" level (m) (1:cp_nlevgrnd) + ! Hydrology variables for BTRAN + ! --------------------------------------------------------------------------------- + + ! Soil suction potential of layers in each site, negative, [mm] + real(r8), allocatable :: smp_gl(:) + + ! Effective porosity = porosity - vol_ic, of layers in each site [-] + real(r8), allocatable :: eff_porosity_gl(:) + + ! volumetric soil water at saturation (porosity) + real(r8), allocatable :: watsat_gl(:) + + ! Temperature of ground layers [K] + real(r8), allocatable :: tempk_gl(:) + ! Liquid volume in ground layer (m3/m3) + real(r8), allocatable :: h2o_liqvol_gl(:) + + ! Site level filter for uptake response functions + logical :: filter_btran + + ! Plant-Hydro + ! --------------------------------------------------------------------------------- + + + real(r8),allocatable :: qflx_transp_pa(:) ! Transpiration flux as dictated by the HLM's + ! canopy solver. [mm H2O/s] [+ into root] + real(r8),allocatable :: swrad_net_pa(:) ! Net absorbed shortwave radiation (W/m2) + real(r8),allocatable :: lwrad_net_pa(:) ! Net absorbed longwave radiation (W/m2) + real(r8),allocatable :: watsat_sisl(:) ! volumetric soil water at saturation (porosity) + real(r8),allocatable :: watres_sisl(:) ! volumetric residual soil water + real(r8),allocatable :: sucsat_sisl(:) ! minimum soil suction (mm) (hlm_nlevsoil) + real(r8),allocatable :: bsw_sisl(:) ! Clapp and Hornberger "b" (hlm_nlevsoil) + real(r8),allocatable :: hksat_sisl(:) ! hydraulic conductivity at saturation (mm H2O /s) + real(r8),allocatable :: h2o_liq_sisl(:) ! Liquid water mass in each layer (kg/m2) + real(r8) :: smpmin_si ! restriction for min of soil potential (mm) + end type bc_in_type @@ -358,6 +391,8 @@ module FatesInterfaceMod !total lignin litter coming from ED. gC/m3/s real(r8), allocatable :: FATES_c_to_litr_lig_c_col(:) + + ! Canopy Structure real(r8), allocatable :: elai_pa(:) ! exposed leaf area index @@ -377,7 +412,18 @@ module FatesInterfaceMod ! vegetation in the patch is exposed. ! [0,1] + ! FATES Hydraulics + + real(r8) :: plant_stored_h2o_si ! stored water in vegetation (kg/m2 H2O) + ! Assuming density of 1Mg/m3 ~= mm/m2 H2O + ! This must be set and transfered prior to clm_drv() + ! following the calls to ed_update_site() + ! ed_update_site() is called during both the restart + ! and coldstart process + real(r8),allocatable :: qflx_soil2root_sisl(:) ! Water flux from soil into root by site and soil layer + ! [mm H2O/s] [+ into root] + end type bc_out_type @@ -465,7 +511,12 @@ subroutine allocate_bcin(bc_in) type(bc_in_type), intent(inout) :: bc_in ! Allocate input boundaries - + allocate(bc_in%zi_sisl(0:hlm_numlevsoil)) + allocate(bc_in%dz_sisl(hlm_numlevsoil)) + allocate(bc_in%z_sisl(hlm_numlevsoil)) + + allocate(bc_in%dz_decomp_sisl(hlm_numlevdecomp_full)) + ! Vegetation Dynamics allocate(bc_in%t_veg24_pa(maxPatchesPerSite)) @@ -502,11 +553,19 @@ subroutine allocate_bcin(bc_in) allocate(bc_in%albgr_dir_rb(hlm_numSWb)) allocate(bc_in%albgr_dif_rb(hlm_numSWb)) - ! Carbon Balance Checking - ! (snow-depth and snow fraction are site level and not vectors) - - ! Ground layer structure - allocate(bc_in%depth_gl(0:hlm_numlevgrnd)) + ! Plant-Hydro BC's + if (use_fates_plant_hydro) then + + allocate(bc_in%qflx_transp_pa(maxPatchesPerSite)) + allocate(bc_in%swrad_net_pa(maxPatchesPerSite)) + allocate(bc_in%lwrad_net_pa(maxPatchesPerSite)) + allocate(bc_in%watsat_sisl(hlm_numlevsoil)) + allocate(bc_in%watres_sisl(hlm_numlevsoil)) + allocate(bc_in%sucsat_sisl(hlm_numlevsoil)) + allocate(bc_in%bsw_sisl(hlm_numlevsoil)) + allocate(bc_in%hksat_sisl(hlm_numlevsoil)) + allocate(bc_in%h2o_liq_sisl(hlm_numlevsoil)); bc_in%h2o_liq_sisl = nan + end if return end subroutine allocate_bcin @@ -560,6 +619,10 @@ subroutine allocate_bcout(bc_out) allocate(bc_out%canopy_fraction_pa(maxPatchesPerSite)) allocate(bc_out%frac_veg_nosno_alb_pa(maxPatchesPerSite)) + ! Plant-Hydro BC's + if (use_fates_plant_hydro) then + allocate(bc_out%qflx_soil2root_sisl(hlm_numlevsoil)) + end if return end subroutine allocate_bcout @@ -573,10 +636,13 @@ subroutine zero_bcs(this,s) integer, intent(in) :: s ! Input boundaries - + this%bc_in(s)%zi_sisl(:) = 0.0_r8 + this%bc_in(s)%dz_sisl(:) = 0.0_r8 + this%bc_in(s)%z_sisl(:) = 0.0_r8 + this%bc_in(s)%dz_decomp_sisl = 0.0_r8 + this%bc_in(s)%t_veg24_si = 0.0_r8 this%bc_in(s)%t_veg24_pa(:) = 0.0_r8 - this%bc_in(s)%h2osoi_vol_si = 0.0_r8 this%bc_in(s)%precip24_pa(:) = 0.0_r8 this%bc_in(s)%relhumid24_pa(:) = 0.0_r8 this%bc_in(s)%wind24_pa(:) = 0.0_r8 @@ -598,8 +664,20 @@ subroutine zero_bcs(this,s) this%bc_in(s)%tot_litc = 0.0_r8 this%bc_in(s)%snow_depth_si = 0.0_r8 this%bc_in(s)%frac_sno_eff_si = 0.0_r8 - this%bc_in(s)%depth_gl(:) = 0.0_r8 - + + if (use_fates_plant_hydro) then + + this%bc_in(s)%qflx_transp_pa(:) = 0.0_r8 + this%bc_in(s)%swrad_net_pa(:) = 0.0_r8 + this%bc_in(s)%lwrad_net_pa(:) = 0.0_r8 + this%bc_in(s)%watsat_sisl(:) = 0.0_r8 + this%bc_in(s)%watres_sisl(:) = 0.0_r8 + this%bc_in(s)%sucsat_sisl(:) = 0.0_r8 + this%bc_in(s)%bsw_sisl(:) = 0.0_r8 + this%bc_in(s)%hksat_sisl(:) = 0.0_r8 + end if + + ! Output boundaries this%bc_out(s)%active_suction_gl(:) = .false. this%bc_out(s)%fsun_pa(:) = 0.0_r8 @@ -631,9 +709,14 @@ subroutine zero_bcs(this,s) this%bc_out(s)%hbot_pa(:) = 0.0_r8 this%bc_out(s)%canopy_fraction_pa(:) = 0.0_r8 this%bc_out(s)%frac_veg_nosno_alb_pa(:) = 0.0_r8 - + + if (use_fates_plant_hydro) then + this%bc_out(s)%plant_stored_h2o_si = 0.0_r8 + this%bc_out(s)%qflx_soil2root_sisl(:) = 0.0_r8 + end if + return - end subroutine zero_bcs + end subroutine zero_bcs ! =================================================================================== @@ -750,6 +833,7 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) hlm_name = 'unset' hlm_hio_ignore_val = unset_double hlm_masterproc = unset_int + hlm_ipedof = unset_int case('check_allset') @@ -757,16 +841,14 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) if (fates_global_verbose()) then write(fates_log(), *) 'FATES dimension/parameter unset: num_sw_rad_bbands' end if - ! INTERF-TODO: FATES NEEDS INTERNAL end_run - ! end_run('MESSAGE') + call endrun(msg=errMsg(sourcefile, __LINE__)) end if if(hlm_masterproc .eq. unset_int) then if (fates_global_verbose()) then write(fates_log(), *) 'FATES parameter unset: hlm_masterproc' end if - ! INTERF-TODO: FATES NEEDS INTERNAL end_run - ! end_run('MESSAGE') + call endrun(msg=errMsg(sourcefile, __LINE__)) end if if(hlm_numSWb > maxSWb) then @@ -779,57 +861,59 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) write(fates_log(), *) 'please increase maxSWb in EDTypes to match' write(fates_log(), *) 'or exceed this value' end if - ! end_run('MESSAGE') + call endrun(msg=errMsg(sourcefile, __LINE__)) end if if(hlm_numlevgrnd .eq. unset_int) then if (fates_global_verbose()) then write(fates_log(), *) 'FATES dimension/parameter unset: numlevground' end if - ! INTERF-TODO: FATES NEEDS INTERNAL end_run - ! end_run('MESSAGE') + call endrun(msg=errMsg(sourcefile, __LINE__)) end if if(hlm_numlevsoil .eq. unset_int) then if (fates_global_verbose()) then write(fates_log(), *) 'FATES dimension/parameter unset: numlevground' end if - ! INTERF-TODO: FATES NEEDS INTERNAL end_run - ! end_run('MESSAGE') + call endrun(msg=errMsg(sourcefile, __LINE__)) end if if(hlm_numlevdecomp_full .eq. unset_int) then if (fates_global_verbose()) then write(fates_log(), *) 'FATES dimension/parameter unset: numlevdecomp_full' end if - ! INTERF-TODO: FATES NEEDS INTERNAL end_run - ! end_run('MESSAGE') + call endrun(msg=errMsg(sourcefile, __LINE__)) end if if(hlm_numlevdecomp .eq. unset_int) then if (fates_global_verbose()) then write(fates_log(), *) 'FATES dimension/parameter unset: numlevdecomp' end if - ! INTERF-TODO: FATES NEEDS INTERNAL end_run - ! end_run('MESSAGE') + call endrun(msg=errMsg(sourcefile, __LINE__)) end if if(trim(hlm_name) .eq. 'unset') then if (fates_global_verbose()) then write(fates_log(),*) 'FATES dimension/parameter unset: hlm_name' end if - ! INTERF-TODO: FATES NEEDS INTERNAL end_run - ! end_run('MESSAGE') + call endrun(msg=errMsg(sourcefile, __LINE__)) end if if( abs(hlm_hio_ignore_val-unset_double)<1e-10 ) then if (fates_global_verbose()) then write(fates_log(),*) 'FATES dimension/parameter unset: hio_ignore' end if - ! INTERF-TODO: FATES NEEDS INTERNAL end_run - ! end_run('MESSAGE') + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if(hlm_ipedof .eq. unset_int) then + if (fates_global_verbose()) then + write(fates_log(), *) 'index for the HLMs pedotransfer function unset: hlm_ipedof' + end if + call endrun(msg=errMsg(sourcefile, __LINE__)) end if + if (fates_global_verbose()) then write(fates_log(), *) 'Checked. All control parameters sent to FATES.' end if @@ -876,6 +960,12 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) write(fates_log(),*) 'Transfering num_levdecomp = ',ival,' to FATES' end if + case('soilwater_ipedof') + hlm_ipedof = ival + if (fates_global_verbose()) then + write(fates_log(),*) 'Transfering hlm_ipedof = ',ival,' to FATES' + end if + case default if (fates_global_verbose()) then write(fates_log(), *) 'tag not recognized:',trim(tag) diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index cb26ac4b..6f8cc680 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -10,6 +10,7 @@ module FatesRestartInterfaceMod use FatesIODimensionsMod, only : fates_io_dimension_type use FatesIOVariableKindMod, only : fates_io_variable_kind_type use FatesRestartVariableMod, only : fates_restart_variable_type + use FatesInterfaceMod, only : bc_in_type ! CIME GLOBALS use shr_log_mod , only : errMsg => shr_log_errMsg @@ -1292,7 +1293,7 @@ end subroutine set_restart_vectors ! ==================================================================================== - subroutine create_patchcohort_structure(this, nc, nsites, sites ) + subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) ! ---------------------------------------------------------------------------------- ! This subroutine takes a peak at the restart file to determine how to allocate @@ -1322,6 +1323,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites ) integer , intent(in) :: nc integer , intent(in) :: nsites type(ed_site_type) , intent(inout), target :: sites(nsites) + type(bc_in_type) , intent(in) :: bc_in(nsites) ! local variables @@ -1441,7 +1443,8 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites ) 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) + temp_cohort%laimemory, cohortstatus, temp_cohort%canopy_trim, newp%NCL_p, & + bc_in(s)) deallocate(temp_cohort) From e01da617784895b328a6c8f85ca3ba760ade258a Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 3 Apr 2017 13:07:31 -0700 Subject: [PATCH 390/437] Fixed an error in the zeroing of some arrays during flux_into_litter_pools. I had how the looping was structured to accomodate variable depth geometries at the site scale, but by accident I put the zeroing of the site-level arrays leaf_prof, froot_prof and stem_prof inside the loop. Badness fixed, I hope. --- biogeochem/EDPhysiologyMod.F90 | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 71b324ce..772ef601 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1429,6 +1429,11 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! if (use_vertsoilc) then + + ! initialize profiles to zero + leaf_prof(1:nsites, :) = 0._r8 + froot_prof(1:nsites, 1:numpft_ed, :) = 0._r8 + stem_prof(1:nsites, :) = 0._r8 do s = 1,nsites ! define a single shallow surface profile for surface additions (leaves, stems, and N deposition) @@ -1437,12 +1442,6 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) surface_prof(j) = exp(-surfprof_exp * bc_in(s)%zi_sisl(j)) / bc_in(s)%dz_decomp_sisl(j) end do - ! initialize profiles to zero - leaf_prof(1:nsites, :) = 0._r8 - froot_prof(1:nsites, 1:numpft_ed, :) = 0._r8 - croot_prof(1:nsites, :) = 0._r8 - stem_prof(1:nsites, :) = 0._r8 - cinput_rootfr(1:numpft_ed, :) = 0._r8 ! calculate pft-specific rooting profiles in the absence of permafrost or bedrock limitations From 728d5eed54ddca75dd8934730c3463828b4098d7 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 3 Apr 2017 13:48:31 -0700 Subject: [PATCH 391/437] Cleaned up some of the code that was hard-setting ecophyscon hydraulics parameters. I did not want to invest too much time in this part of the code, as it may become obsolete as we move to one unified parameter structure. Added in some warning language also for do_ed_dynamics and do_ed_phenology flags. --- biogeophys/FatesPlantHydraulicsMod.F90 | 17 +++++ main/EDEcophysConType.F90 | 96 ++------------------------ main/EDTypesMod.F90 | 4 ++ 3 files changed, 26 insertions(+), 91 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 456088dc..bd85036c 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -95,6 +95,7 @@ module FatesPlantHydraulicsMod public :: updateSizeDepTreeHydStates public :: initTreeHydStates public :: updateSizeDepRhizHydProps + public :: SetHydraulicsTestingParams !------------------------------------------------------------------------------ ! 01/18/16: Created by Brad Christoffersen @@ -343,4 +344,20 @@ subroutine BTranForHLMDiagnosticsFromCohortHydr(nsites,sites,bc_out) end subroutine BTranForHLMDiagnosticsFromCohortHydr + ! ==================================================================================== + + + subroutine SetHydraulicsTestingParams(EDEcophyscon) + + use EDEcophysconType, only : EDecophyscon_type + + ! Arguments + type(EDecophyscon_type), intent(inout) :: EDEcophyscon + + write(fates_log(),*) 'FATES Plant Hydraulics is still under development, ending run.' + call endrun(msg=errMsg(sourcefile, __LINE__)) + + + end subroutine SetHydraulicsTestingParams + end module FatesPlantHydraulicsMod diff --git a/main/EDEcophysConType.F90 b/main/EDEcophysConType.F90 index eca9a4e5..c9b29e30 100644 --- a/main/EDEcophysConType.F90 +++ b/main/EDEcophysConType.F90 @@ -217,97 +217,11 @@ subroutine EDecophysconInit(EDpftvarcon_inst, numpft) allocate( EDecophyscon%intercept_node (0:numpft,1:n_porous_media) ); EDecophyscon%intercept_node (:,:) = nan allocate( EDecophyscon%corrInt_node (0:numpft,1:n_porous_media) ); EDecophyscon%corrInt_node (:,:) = nan - do m = 0,numpft - - !BOC...new hydraulics constants - EDecophyscon%wd(m) = 0.73_r8 ! EDPftvarcon_inst%wd(m) - EDecophyscon%lma(m) = 96.06_r8 ! EDPftvarcon_inst%lma(m) - EDecophyscon%n(m) = 20.87_r8 ! EDPftvarcon_inst%n(m) - EDecophyscon%p(m) = 0.59_r8 ! EDPftvarcon_inst%p(m) - EDecophyscon%ldmc(m) = -0.207_r8*log(10**4._r8/EDecophyscon%lma(m))+1.431_r8 ! EDPftvarcon_inst%ldmc(m) - EDecophyscon%lmv(m) = (-2.3231_r8*(10**4._r8/EDecophyscon%lma(m))+781.899_r8)/1000._r8 ! EDPftvarcon_inst%lmv(m) - EDecophyscon%psi0(m) = -0.08_r8 ! EDPftvarcon_inst%psi0(m) - EDecophyscon%psicap(m) = -0.39_r8 ! EDPftvarcon_inst%psicap(m) - EDecophyscon%rhoc(m) = 1.54_r8 ! EDPftvarcon_inst%rhoc(m) - EDecophyscon%rint_petiole(m) = 10._r8 ! EDPftvarcon_inst%rint_petiole(m) - EDecophyscon%rint_jansenchoat(m) = 22._r8 ! EDPftvarcon_inst%rint_jansenchoat(m) - EDecophyscon%Amaxh(m) = 11.53_r8 ! EDPftvarcon_inst%Amaxh(m) - EDecophyscon%rs2(m) = 0.001_r8 ! EDPftvarcon_inst%rs2(m) - EDecophyscon%srl(m) = 15000._r8 ! EDPftvarcon_inst%srl(m) - EDecophyscon%ccontent(m) = 0.47_r8 ! EDPftvarcon_inst%ccontent(m) - EDecophyscon%rfrac_stem(m) = 0.625_r8 ! EDPftvarcon_inst%rfrac_stem(m) - EDecophyscon%rootshoot(m) = 0.20_r8 ! EDPftvarcon_inst%rootshoot(m) - n = 2 - EDecophyscon%kmax_node(m,n) = 3.00_r8 ! TESTING: intermediate - EDecophyscon%p50_node(m,n) = -1.00_r8 ! TESTING: hi - EDecophyscon%avuln_node(m,n) = 4.40_r8 ! TESTING: lo - EDecophyscon%thetas_node(m,n) = 1._r8 - EDecophyscon%wd(m)/EDecophyscon%rhoc(m) ! 0.530_r8 - EDecophyscon%epsil_node(m,n) = 22.41_r8 - EDecophyscon%pinot_node(m,n) = -2.146_r8 - EDecophyscon%pitlp_node(m,n) = -2.373_r8 - EDecophyscon%resid_node(m,n) = 0.479_r8 - EDecophyscon%rwctlp_node(m,n) = 0.912_r8 - EDecophyscon%fcap_node(m,n) = 0.080_r8 - EDecophyscon%rwcft_node(m,n) = 0.958_r8 - EDecophyscon%rwccap_node(m,n) = 0.947_r8 - EDecophyscon%slp_node(m,n) = & - (EDecophyscon%psi0(m) - EDecophyscon%psicap(m))/(1._r8 - EDecophyscon%rwccap_node(m,n)) ! 5.795_r8 - EDecophyscon%intercept_node(m,n) = -EDecophyscon%slp_node(m,n) + EDecophyscon%psi0(m) !-5.875_r8 - EDecophyscon%corrInt_node(m,n) = -EDecophyscon%intercept_node(m,n)/EDecophyscon%slp_node(m,n) ! 1.014_r8 - n = 1 - EDecophyscon%kmax_node(m,n) = & - EDecophyscon%kmax_node(m,2)*((EDecophyscon%rint_petiole(m)/EDecophyscon%rint_jansenchoat(m))**2._r8) !0.480_r8 - EDecophyscon%avuln_node(m,n) = EDecophyscon%avuln_node(m,2) - EDecophyscon%p50_node(m,n) = EDecophyscon%p50_node(m,2) - EDecophyscon%thetas_node(m,n) = EDecophyscon%lmv(m)*(1.0_r8/EDecophyscon%ldmc(m)-1.0_r8) - EDecophyscon%epsil_node(m,n) = 22.56_r8 - EDecophyscon%pinot_node(m,n) = -1.943_r8 - EDecophyscon%pitlp_node(m,n) = -1.789_r8 - EDecophyscon%resid_node(m,n) = 0.413_r8 - EDecophyscon%rwctlp_node(m,n) = 0.953_r8 - EDecophyscon%fcap_node(m,n) = 0._r8 - EDecophyscon%rwcft_node(m,n) = 1._r8 - EDecophyscon%rwccap_node(m,n) = 1._r8 - EDecophyscon%slp_node(m,n) = 0._r8 - EDecophyscon%intercept_node(m,n) = 0._r8 - EDecophyscon%corrInt_node(m,n) = 1._r8 - do n = 3,n_porous_media - EDecophyscon%kmax_node(m,n) = EDecophyscon%kmax_node(m,2) - EDecophyscon%avuln_node(m,n) = EDecophyscon%avuln_node(m,2) - EDecophyscon%p50_node(m,n) = EDecophyscon%p50_node(m,2) - EDecophyscon%thetas_node(m,n) = EDecophyscon%thetas_node(m,2) - EDecophyscon%epsil_node(m,n) = EDecophyscon%epsil_node(m,2) - EDecophyscon%pinot_node(m,n) = EDecophyscon%pinot_node(m,2) - EDecophyscon%pitlp_node(m,n) = EDecophyscon%pitlp_node(m,2) - EDecophyscon%resid_node(m,n) = EDecophyscon%resid_node(m,2) - EDecophyscon%rwctlp_node(m,n) = EDecophyscon%rwctlp_node(m,2) - EDecophyscon%fcap_node(m,n) = EDecophyscon%fcap_node(m,2) - EDecophyscon%rwcft_node(m,n) = EDecophyscon%rwcft_node(m,2) - EDecophyscon%rwccap_node(m,n) = EDecophyscon%rwccap_node(m,2) - EDecophyscon%slp_node(m,n) = EDecophyscon%slp_node(m,2) - EDecophyscon%intercept_node(m,n) = EDecophyscon%intercept_node(m,2) - EDecophyscon%corrInt_node(m,n) = EDecophyscon%corrInt_node(m,2) - end do - EDecophyscon%latosa(m) = 10000._r8*exp(-0.69_r8)*(EDecophyscon%kmax_node(m,2)**0.41_r8) ! EDPftvarcon_inst%latosa(m) - EDecophyscon%p50_gs(m) = -6.0_r8 ! testing: lo - EDecophyscon%avuln_gs(m) = 60.15_r8*(-EDecophyscon%p50_gs(m))**(-1.25_r8) ! Christoffersen et al. (2016) - - do k = 1,npool_tot - if(k <= npool_leaf) then - porous_media(k) = 1 - else if(k <= (npool_leaf+npool_stem)) then - porous_media(k) = 2 - else if(k <= (npool_leaf+npool_stem+npool_troot)) then - porous_media(k) = 3 - else if(k <= (npool_leaf+npool_stem+npool_troot+npool_aroot)) then - porous_media(k) = 4 - else - porous_media(k) = 5 - end if - enddo - - end do - + ! ------------------------------------------------------------------------------------------------ + ! Until the hydraulics parameter are added to the parameter file, they need a location to be set. + ! This happens here until further notice. + ! ------------------------------------------------------------------------------------------------ + call SetHydraulicsTestingParams(EDecophyscon) end if diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index d84cc6b6..87177f18 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -41,6 +41,10 @@ module EDTypesMod ! Switches that turn on/off ED dynamics process (names are self explanatory) + ! IMPORTANT NOTE!!! THESE SWITCHES ARE EXPERIMENTAL. + ! THEY SHOULD CORRECTLY TURN OFF OR ON THE PROCESS, BUT.. THERE ARE VARIOUS + ! ASPECTS REGARDING DIAGNOSING RATES AND HOW THEY ARE REPORTED WHEN THESE + ! PROCESSES ARE OFF THAT NEED TO BE DISCUSSED AND CONSIDERED. ! TO-DO: THESE SHOULD BE PARAMETERS IN THE FILE OR NAMELIST - ADDING THESE ! WAS OUTSIDE THE SCOPE OF THE VERY LARGE CHANGESET WHERE THESE WERE FIRST ! INTRODUCED (RGK 03-2017) From 5afb2c4c09242e73afe76cb65fa3b8a71990be1c Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 3 Apr 2017 16:19:27 -0700 Subject: [PATCH 392/437] Fixed some circular dependencies related to the edecophyscon for hydraulics parameters was bypassed. --- biogeophys/FatesPlantHydraulicsMod.F90 | 14 +------------- main/EDEcophysConType.F90 | 18 ++++++++++++++++++ main/FatesHydraulicsMemMod.F90 | 4 ---- 3 files changed, 19 insertions(+), 17 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index bd85036c..688117f2 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -95,7 +95,6 @@ module FatesPlantHydraulicsMod public :: updateSizeDepTreeHydStates public :: initTreeHydStates public :: updateSizeDepRhizHydProps - public :: SetHydraulicsTestingParams !------------------------------------------------------------------------------ ! 01/18/16: Created by Brad Christoffersen @@ -347,17 +346,6 @@ end subroutine BTranForHLMDiagnosticsFromCohortHydr ! ==================================================================================== - subroutine SetHydraulicsTestingParams(EDEcophyscon) - - use EDEcophysconType, only : EDecophyscon_type - - ! Arguments - type(EDecophyscon_type), intent(inout) :: EDEcophyscon - - write(fates_log(),*) 'FATES Plant Hydraulics is still under development, ending run.' - call endrun(msg=errMsg(sourcefile, __LINE__)) - - - end subroutine SetHydraulicsTestingParams + end module FatesPlantHydraulicsMod diff --git a/main/EDEcophysConType.F90 b/main/EDEcophysConType.F90 index c9b29e30..974b7b96 100644 --- a/main/EDEcophysConType.F90 +++ b/main/EDEcophysConType.F90 @@ -7,6 +7,9 @@ module EDEcophysConType ! !USES: use shr_kind_mod , only : r8 => shr_kind_r8 use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + use shr_log_mod , only : errMsg => shr_log_errMsg + use FatesGlobals, only : endrun => fates_endrun + use FatesGlobals, only : fates_log use FatesHydraulicsMemMod , only : n_porous_media use FatesHydraulicsMemMod , only : porous_media @@ -22,6 +25,10 @@ module EDEcophysConType implicit none save private + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + ! ! !PUBLIC MEMBER FUNCTIONS: public :: EDecophysconInit @@ -227,4 +234,15 @@ subroutine EDecophysconInit(EDpftvarcon_inst, numpft) end subroutine EDecophysconInit + subroutine SetHydraulicsTestingParams(EDEcophyscon) + + ! Arguments + type(EDecophyscon_type), intent(inout) :: EDEcophyscon + + write(fates_log(),*) 'FATES Plant Hydraulics is still under development, ending run.' + call endrun(msg=errMsg(sourcefile, __LINE__)) + + + end subroutine SetHydraulicsTestingParams + end module EDEcophysConType diff --git a/main/FatesHydraulicsMemMod.F90 b/main/FatesHydraulicsMemMod.F90 index 43001b0f..71f921a7 100644 --- a/main/FatesHydraulicsMemMod.F90 +++ b/main/FatesHydraulicsMemMod.F90 @@ -211,8 +211,4 @@ subroutine InitHydrSite(this) return end subroutine InitHydrSite - - - - end module FatesHydraulicsMemMod From 289da109d7fd4d1ef6b5cf6e16ca77bdca2c8cb8 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 4 Apr 2017 18:11:30 -0700 Subject: [PATCH 393/437] Bug fix, had inadvertently used zi_sisl instead of z_sisl while updating EDPhysiologyMod. --- biogeochem/EDPhysiologyMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 772ef601..bb605741 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1439,7 +1439,7 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) ! define a single shallow surface profile for surface additions (leaves, stems, and N deposition) surface_prof(:) = 0._r8 do j = 1, hlm_numlevdecomp - surface_prof(j) = exp(-surfprof_exp * bc_in(s)%zi_sisl(j)) / bc_in(s)%dz_decomp_sisl(j) + surface_prof(j) = exp(-surfprof_exp * bc_in(s)%z_sisl(j)) / bc_in(s)%dz_decomp_sisl(j) end do cinput_rootfr(1:numpft_ed, :) = 0._r8 From 2f64fe0f7102be3bbaab03662c6e569181e89a21 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 5 Apr 2017 15:46:41 -0700 Subject: [PATCH 394/437] Fixed bug where in non-hydraulics mode we were passing the total_plant_stored_h2o_col to the HLM, where a) it is not necessary and b) it was not being initialized to zero either. Removed some unnecessary declarations of the vert_trans_sink local in SoilWaterMovement and added some diagnostics output to the error reporting in BalanceCheckMod. --- main/FatesInterfaceMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index d350f948..e3a47a47 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -711,9 +711,9 @@ subroutine zero_bcs(this,s) this%bc_out(s)%frac_veg_nosno_alb_pa(:) = 0.0_r8 if (use_fates_plant_hydro) then - this%bc_out(s)%plant_stored_h2o_si = 0.0_r8 this%bc_out(s)%qflx_soil2root_sisl(:) = 0.0_r8 end if + this%bc_out(s)%plant_stored_h2o_si = 0.0_r8 return end subroutine zero_bcs From e75ce1ed60e826f1db2d9940447a6cb08b09dc70 Mon Sep 17 00:00:00 2001 From: ckoven Date: Thu, 6 Apr 2017 15:42:34 -0700 Subject: [PATCH 395/437] bugfix for restarting --- main/FatesRestartInterfaceMod.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index cb26ac4b..88cb6c75 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -1423,7 +1423,8 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites ) if ((mod(fto, 2) == 0 )) then ft=1 endif - + temp_cohort%pft = ft + cohortstatus = newp%siteptr%status if(EDPftvarcon_inst%stress_decid(ft) == 1)then !drought decidous, override status. From 9124c2ffefd1d0b2356c83cc4a35fe15bbdf081a Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 12 Apr 2017 16:23:01 -0700 Subject: [PATCH 396/437] Added control parameter boundary conditions for use_vertsoilc and use_ed_spitfire --- biogeochem/EDPhysiologyMod.F90 | 5 +- fire/SFMainMod.F90 | 136 ++++++++++++++++----------------- main/EDInitMod.F90 | 3 +- main/EDMainMod.F90 | 3 +- main/FatesConstantsMod.F90 | 8 ++ main/FatesInterfaceMod.F90 | 37 +++++++++ 6 files changed, 119 insertions(+), 73 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index a6a2f6b0..fefcc4cb 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1339,7 +1339,8 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) use FatesConstantsMod, only : sec_per_day use EDParamsMod, only : ED_val_ag_biomass use FatesInterfaceMod, only : bc_in_type, bc_out_type - use clm_varctl, only : use_vertsoilc + use FatesInterfaceMod, only : hlm_use_vertsoilc + use FatesConstantsMod, only : itrue use FatesGlobals, only : endrun => fates_endrun use EDParamsMod , only : ED_val_cwd_flig, ED_val_cwd_fcel @@ -1414,7 +1415,7 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) ! (3) a coarse root profile, which is the root-biomass=weighted average of the fine root profiles !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - if (use_vertsoilc) then + if (hlm_use_vertsoilc == itrue) then ! initialize profiles to zero leaf_prof(1:nsites, :) = 0._r8 diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index 013b663d..687fdc7e 100755 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -6,14 +6,14 @@ module SFMainMod ! ============================================================================ use FatesConstantsMod , only : r8 => fates_r8 - + use FatesConstantsMod , only : itrue, ifalse use FatesInterfaceMod , only : hlm_masterproc ! 1= master process, 0=not master process use EDTypesMod , only : numWaterMem use FatesGlobals , only : fates_log use FatesInterfaceMod , only : bc_in_type use pftconMod , only : pftcon - use EDPftvarcon , only : EDPftvarcon_inst + use EDPftvarcon , only : EDPftvarcon_inst use EDEcophysconType , only : EDecophyscon use EDtypesMod , only : ed_site_type @@ -57,7 +57,7 @@ module SFMainMod ! ============================================================================ subroutine fire_model( currentSite, bc_in) - use clm_varctl, only : use_ed_spitfire + use FatesInterfaceMod, only : hlm_use_spitfire type(ed_site_type) , intent(inout), target :: currentSite type(bc_in_type) , intent(in) :: bc_in @@ -75,10 +75,10 @@ subroutine fire_model( currentSite, bc_in) enddo if(write_SF==1)then - write(fates_log(),*) 'use_ed_spitfire',use_ed_spitfire + write(fates_log(),*) 'use_spitfire',hlm_use_spitfire endif - if(use_ed_spitfire)then + if( hlm_use_spitfire == itrue )then call fire_danger_index(currentSite, bc_in) call wind_effect(currentSite, bc_in) call charecteristics_of_fuel(currentSite) @@ -186,16 +186,16 @@ subroutine charecteristics_of_fuel ( currentSite ) currentPatch%sum_fuel = 0.0_r8 currentPatch%fuel_frac = 0.0_r8 - if(write_sf == 1)then - if ( hlm_masterproc == 1 ) write(fates_log(),*) ' leaf_litter1 ',currentPatch%leaf_litter - if ( hlm_masterproc == 1 ) write(fates_log(),*) ' leaf_litter2 ',sum(currentPatch%CWD_AG) - if ( hlm_masterproc == 1 ) write(fates_log(),*) ' leaf_litter3 ',currentPatch%livegrass - if ( hlm_masterproc == 1 ) write(fates_log(),*) ' sum fuel', currentPatch%sum_fuel + if(write_sf == itrue)then + if ( hlm_masterproc == itrue ) write(fates_log(),*) ' leaf_litter1 ',currentPatch%leaf_litter + if ( hlm_masterproc == itrue ) write(fates_log(),*) ' leaf_litter2 ',sum(currentPatch%CWD_AG) + if ( hlm_masterproc == itrue ) write(fates_log(),*) ' leaf_litter3 ',currentPatch%livegrass + if ( hlm_masterproc == itrue ) write(fates_log(),*) ' 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 ( hlm_masterproc == 1 ) write(fates_log(),*) 'sum fuel', currentPatch%sum_fuel,currentPatch%area + if(write_SF == itrue)then + if ( hlm_masterproc == itrue ) write(fates_log(),*) 'sum fuel', currentPatch%sum_fuel,currentPatch%area endif ! =============================================== ! Average moisture, bulk density, surface area-volume and moisture extinction of fuel @@ -206,10 +206,10 @@ subroutine charecteristics_of_fuel ( currentSite ) currentPatch%fuel_frac(dl_sf) = sum(currentPatch%leaf_litter)/ currentPatch%sum_fuel currentPatch%fuel_frac(dl_sf+1:tr_sf) = currentPatch%CWD_AG / currentPatch%sum_fuel - if(write_sf == 1)then - if ( hlm_masterproc == 1 ) write(fates_log(),*) 'ff1 ',currentPatch%fuel_frac - if ( hlm_masterproc == 1 ) write(fates_log(),*) 'ff2 ',currentPatch%fuel_frac - if ( hlm_masterproc == 1 ) write(fates_log(),*) 'ff2a ',lg_sf,currentPatch%livegrass,currentPatch%sum_fuel + if(write_sf == itrue)then + if ( hlm_masterproc == itrue ) write(fates_log(),*) 'ff1 ',currentPatch%fuel_frac + if ( hlm_masterproc == itrue ) write(fates_log(),*) 'ff2 ',currentPatch%fuel_frac + if ( hlm_masterproc == itrue ) write(fates_log(),*) 'ff2a ',lg_sf,currentPatch%livegrass,currentPatch%sum_fuel endif currentPatch%fuel_frac(lg_sf) = currentPatch%livegrass / currentPatch%sum_fuel @@ -219,11 +219,11 @@ subroutine charecteristics_of_fuel ( currentSite ) ! Equation 6 in Thonicke et al. 2010. fuel_moisture(dl_sf+1:tr_sf) = exp(-1.0_r8 * SF_val_alpha_FMC(dl_sf+1:tr_sf) * currentSite%acc_NI) - if(write_SF == 1)then - if ( hlm_masterproc == 1 ) write(fates_log(),*) 'ff3 ',currentPatch%fuel_frac - if ( hlm_masterproc == 1 ) write(fates_log(),*) 'fm ',fuel_moisture - if ( hlm_masterproc == 1 ) write(fates_log(),*) 'csa ',currentSite%acc_NI - if ( hlm_masterproc == 1 ) write(fates_log(),*) 'sfv ',SF_val_alpha_FMC + if(write_SF == itrue)then + if ( hlm_masterproc == itrue ) write(fates_log(),*) 'ff3 ',currentPatch%fuel_frac + if ( hlm_masterproc == itrue ) write(fates_log(),*) 'fm ',fuel_moisture + if ( hlm_masterproc == itrue ) write(fates_log(),*) 'csa ',currentSite%acc_NI + if ( hlm_masterproc == itrue ) write(fates_log(),*) 'sfv ',SF_val_alpha_FMC endif ! FIX(RF,032414): needs refactoring. ! average water content !is this the correct metric? @@ -237,8 +237,8 @@ subroutine charecteristics_of_fuel ( currentSite ) currentPatch%fuel_sav = sum(currentPatch%fuel_frac(dl_sf:lb_sf) * SF_val_SAV(dl_sf:lb_sf)) currentPatch%fuel_mef = sum(currentPatch%fuel_frac(dl_sf:lb_sf) * MEF(dl_sf:lb_sf)) currentPatch%fuel_eff_moist = sum(currentPatch%fuel_frac(dl_sf:lb_sf) * fuel_moisture(dl_sf:lb_sf)) - if(write_sf == 1)then - if ( hlm_masterproc == 1 ) write(fates_log(),*) 'ff4 ',currentPatch%fuel_eff_moist + if(write_sf == itrue)then + if ( hlm_masterproc == itrue ) write(fates_log(),*) '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) @@ -263,16 +263,16 @@ subroutine charecteristics_of_fuel ( currentSite ) else - if(write_SF == 1)then + if(write_SF == itrue)then - if ( hlm_masterproc == 1 ) write(fates_log(),*) 'no litter fuel at all',currentPatch%patchno, & + if ( hlm_masterproc == itrue ) write(fates_log(),*) '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:nfsc))/(nfsc) ! make average sav to avoid crashing code. - if ( hlm_masterproc == 1 ) write(fates_log(),*) 'problem with spitfire fuel averaging' + if ( hlm_masterproc == itrue ) write(fates_log(),*) 'problem with spitfire fuel averaging' ! FIX(SPM,032414) refactor...should not have 0 fuel unless everything is burnt ! off. @@ -286,9 +286,9 @@ subroutine charecteristics_of_fuel ( currentSite ) endif ! check values. ! FIX(SPM,032414) refactor... - if(write_SF == 1.and.currentPatch%fuel_sav <= 0.0_r8.or.currentPatch%fuel_bulkd <= & + if(write_SF == itrue.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 ( hlm_masterproc == 1 ) write(fates_log(),*) 'problem with spitfire fuel averaging' + if ( hlm_masterproc == itrue ) write(fates_log(),*) 'problem with spitfire fuel averaging' endif currentPatch => currentPatch%younger @@ -326,8 +326,8 @@ subroutine wind_effect ( currentSite, bc_in) iofp = currentSite%oldest_patch%patchno wind = bc_in%wind24_pa(iofp) * sec_per_min ! Convert to m/min for SPITFIRE units. - if(write_SF == 1)then - if ( hlm_masterproc == 1 ) write(fates_log(),*) 'wind24', wind + if(write_SF == itrue)then + if ( hlm_masterproc == itrue ) write(fates_log(),*) 'wind24', wind endif ! --- influence of wind speed, corrected for surface roughness---- ! --- averaged over the whole grid cell to prevent extreme divergence @@ -342,7 +342,7 @@ subroutine wind_effect ( currentSite, bc_in) do while(associated(currentCohort)) write(fates_log(),*) 'SF currentCohort%c_area ',currentCohort%c_area - if(EDPftvarcon_inst%woody(currentCohort%pft) == 1)then + if(EDPftvarcon_inst%woody(currentCohort%pft) == itrue)then currentPatch%total_tree_area = currentPatch%total_tree_area + currentCohort%c_area else total_grass_area = total_grass_area + currentCohort%c_area @@ -365,8 +365,8 @@ subroutine wind_effect ( currentSite, bc_in) !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 ( hlm_masterproc == 1 ) write(fates_log(),*) 'grass, trees, bare',grass_fraction, tree_fraction, bare_fraction + if(write_sf == itrue)then + if ( hlm_masterproc == itrue ) write(fates_log(),*) 'grass, trees, bare',grass_fraction, tree_fraction, bare_fraction endif currentPatch=>currentSite%oldest_patch; @@ -420,8 +420,8 @@ subroutine rate_of_spread ( currentSite ) ! ----start spreading--- - if ( hlm_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - currentPatch%fuel_bulkd ',currentPatch%fuel_bulkd - if ( hlm_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - SF_val_part_dens ',SF_val_part_dens + if ( hlm_masterproc == itrue .and.DEBUG) write(fates_log(),*) 'SF - currentPatch%fuel_bulkd ',currentPatch%fuel_bulkd + if ( hlm_masterproc == itrue .and.DEBUG) write(fates_log(),*) 'SF - SF_val_part_dens ',SF_val_part_dens ! beta = packing ratio (unitless) ! fraction of fuel array volume occupied by fuel or compactness of fuel bed @@ -432,12 +432,12 @@ subroutine rate_of_spread ( currentSite ) ! packing ratio (unitless) beta_op = 0.200395_r8 *(currentPatch%fuel_sav**(-0.8189_r8)) - if ( hlm_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - beta ',beta - if ( hlm_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - beta_op ',beta_op + if ( hlm_masterproc == itrue .and.DEBUG) write(fates_log(),*) 'SF - beta ',beta + if ( hlm_masterproc == itrue .and.DEBUG) write(fates_log(),*) 'SF - beta_op ',beta_op bet = beta/beta_op !unitless - if(write_sf == 1)then - if ( hlm_masterproc == 1 ) write(fates_log(),*) 'esf ',currentPatch%fuel_eff_moist + if(write_sf == itrue)then + if ( hlm_masterproc == itrue ) write(fates_log(),*) 'esf ',currentPatch%fuel_eff_moist endif ! ---heat of pre-ignition--- @@ -457,11 +457,11 @@ subroutine rate_of_spread ( currentSite ) e = 0.715_r8 * (exp(-0.01094_r8 * currentPatch%fuel_sav)) if (DEBUG) then - if ( hlm_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - c ',c - if ( hlm_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - currentPatch%effect_wspeed ',currentPatch%effect_wspeed - if ( hlm_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - b ',b - if ( hlm_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - bet ',bet - if ( hlm_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - e ',e + if ( hlm_masterproc == itrue .and.DEBUG) write(fates_log(),*) 'SF - c ',c + if ( hlm_masterproc == itrue .and.DEBUG) write(fates_log(),*) 'SF - currentPatch%effect_wspeed ',currentPatch%effect_wspeed + if ( hlm_masterproc == itrue .and.DEBUG) write(fates_log(),*) 'SF - b ',b + if ( hlm_masterproc == itrue .and.DEBUG) write(fates_log(),*) 'SF - bet ',bet + if ( hlm_masterproc == itrue .and.DEBUG) write(fates_log(),*) 'SF - e ',e endif ! Equation A5 in Thonicke et al. 2010 @@ -498,7 +498,7 @@ subroutine rate_of_spread ( currentSite ) (3.52_r8*(mw_weight**3.0_r8)))) ! FIX(SPM, 040114) ask RF if this should be an endrun - ! if(write_SF == 1)then + ! if(write_SF == itrue)then ! write(fates_log(),*) 'moist_damp' ,moist_damp,mw_weight,currentPatch%fuel_eff_moist,currentPatch%fuel_mef ! endif @@ -618,7 +618,7 @@ subroutine fire_intensity ( currentSite ) !currentPatch%ROS_front forward ROS (m/min) !currentPatch%TFC_ROS total fuel consumed by flaming front (kgC/m2) - use clm_varctl, only : use_ed_spitfire + use FatesInterfaceMod, only : hlm_use_spitfire use SFParamsMod, only : SF_val_fdi_alpha,SF_val_fuel_energy, & SF_val_max_durat, SF_val_durat_slope @@ -636,8 +636,8 @@ subroutine fire_intensity ( currentSite ) 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( hlm_masterproc == 1 ) write(fates_log(),*) 'fire_intensity',currentPatch%fi,W,currentPatch%ROS_front + if(write_sf == itrue)then + if( hlm_masterproc == itrue ) write(fates_log(),*) '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 @@ -648,8 +648,8 @@ subroutine fire_intensity ( currentSite ) ! Equation 14 in Thonicke et al. 2010 ! fire duration in minutes 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 ( hlm_masterproc == 1 ) write(fates_log(),*) 'fire duration minutes',currentPatch%fd + if(write_SF == itrue)then + if ( hlm_masterproc == itrue ) write(fates_log(),*) '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 @@ -659,7 +659,7 @@ subroutine fire_intensity ( currentSite ) 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_spitfire)then + if( hlm_use_spitfire == ifalse )then currentPatch%fire = 0 !fudge to turn fire off endif @@ -697,7 +697,7 @@ subroutine area_burnt ( currentSite ) currentPatch%frac_burnt = 0.0_r8 lb = 0.0_r8; db = 0.0_r8; df = 0.0_r8 - if (currentPatch%fire == 1) then + if (currentPatch%fire == itrue) 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. @@ -742,19 +742,19 @@ subroutine area_burnt ( currentSite ) patch_area_in_m2 = gridarea*currentPatch%area/area if (currentPatch%AB > patch_area_in_m2 ) then !all of patch burnt. - if ( hlm_masterproc == 1 ) write(fates_log(),*) 'burnt all of patch',currentPatch%patchno, & + if ( hlm_masterproc == itrue ) write(fates_log(),*) 'burnt all of patch',currentPatch%patchno, & currentPatch%area/area,currentPatch%ab,patch_area_in_m2 - if ( hlm_masterproc == 1 ) write(fates_log(),*) 'ros',currentPatch%ROS_front,currentPatch%FD, & + if ( hlm_masterproc == itrue ) write(fates_log(),*) 'ros',currentPatch%ROS_front,currentPatch%FD, & currentPatch%NF,currentPatch%FI,size_of_fire - if ( hlm_masterproc == 1 ) write(fates_log(),*) 'litter', & + if ( hlm_masterproc == itrue ) write(fates_log(),*) 'litter', & currentPatch%sum_fuel,currentPatch%CWD_AG,currentPatch%leaf_litter ! turn km2 into m2. work out total area burnt. currentPatch%AB = patch_area_in_m2 endif currentPatch%frac_burnt = currentPatch%AB / patch_area_in_m2 - if(write_SF == 1)then - if ( hlm_masterproc == 1 ) write(fates_log(),*) 'frac_burnt',currentPatch%frac_burnt + if(write_SF == itrue)then + if ( hlm_masterproc == itrue ) write(fates_log(),*) 'frac_burnt',currentPatch%frac_burnt endif endif endif! fire @@ -788,10 +788,10 @@ subroutine crown_scorching ( currentSite ) tree_ag_biomass = 0.0_r8 f_ag_bmass = 0.0_r8 - if (currentPatch%fire == 1) then + if (currentPatch%fire == itrue) then currentCohort => currentPatch%tallest; do while(associated(currentCohort)) - if (EDPftvarcon_inst%woody(currentCohort%pft) == 1) then !trees only + if (EDPftvarcon_inst%woody(currentCohort%pft) == itrue) then !trees only tree_ag_biomass = tree_ag_biomass+(currentCohort%bl+ED_val_ag_biomass* & (currentCohort%bsw + currentCohort%bdead))*currentCohort%n endif !trees only @@ -806,12 +806,12 @@ subroutine crown_scorching ( currentSite ) currentPatch%SH = 0.0_r8 currentCohort => currentPatch%tallest; do while(associated(currentCohort)) - if (EDPftvarcon_inst%woody(currentCohort%pft) == 1.and.(tree_ag_biomass > 0.0_r8)) then !trees only + if (EDPftvarcon_inst%woody(currentCohort%pft) == itrue.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 ( hlm_masterproc == 1 ) write(fates_log(),*) 'currentPatch%SH',currentPatch%SH,f_ag_bmass + if(write_SF == itrue)then + if ( hlm_masterproc == itrue ) write(fates_log(),*) '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) @@ -840,13 +840,13 @@ subroutine crown_damage ( currentSite ) currentPatch => currentSite%oldest_patch do while(associated(currentPatch)) - if (currentPatch%fire == 1) then + if (currentPatch%fire == itrue) then currentCohort=>currentPatch%tallest do while(associated(currentCohort)) currentCohort%cfa = 0.0_r8 - if (EDPftvarcon_inst%woody(currentCohort%pft) == 1) then !trees only + if (EDPftvarcon_inst%woody(currentCohort%pft) == itrue) 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 @@ -904,10 +904,10 @@ subroutine cambial_damage_kill ( currentSite ) do while(associated(currentPatch)) - if (currentPatch%fire == 1) then + if (currentPatch%fire == itrue) then currentCohort => currentPatch%tallest; do while(associated(currentCohort)) - if (EDPftvarcon_inst%woody(currentCohort%pft) == 1) then !trees only + if (EDPftvarcon_inst%woody(currentCohort%pft) == itrue) 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. @@ -954,12 +954,12 @@ subroutine post_fire_mortality ( currentSite ) do while(associated(currentPatch)) - if (currentPatch%fire == 1) then + if (currentPatch%fire == itrue) then currentCohort => currentPatch%tallest do while(associated(currentCohort)) currentCohort%fire_mort = 0.0_r8 currentCohort%crownfire_mort = 0.0_r8 - if (EDPftvarcon_inst%woody(currentCohort%pft) == 1) then + if (EDPftvarcon_inst%woody(currentCohort%pft) == itrue) 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. diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 9a63d488..0c2b4374 100755 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -8,9 +8,8 @@ module EDInitMod use FatesGlobals , only : endrun => fates_endrun use EDTypesMod , only : nclmax use FatesGlobals , only : fates_log - use clm_varctl , only : use_ed_spitfire use clm_time_manager , only : is_restart - use EDPftvarcon , only : EDPftvarcon_inst + use EDPftvarcon , only : EDPftvarcon_inst use EDEcophysConType , only : EDecophyscon use EDGrowthFunctionsMod , only : bdead, bleaf, dbh use EDCohortDynamicsMod , only : create_cohort, fuse_cohorts, sort_cohorts diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 93d95d48..a44de0b5 100755 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -36,6 +36,7 @@ module EDMainMod use EDtypesMod , only : ed_cohort_type use FatesInterfaceMod , only : bc_in_type use FatesInterfaceMod , only : hlm_masterproc + use FatesConstantsMod , only : itrue use FatesPlantHydraulicsMod, only : do_growthrecruiteffects use FatesPlantHydraulicsMod, only : updateSizeDepTreeHydProps use FatesPlantHydraulicsMod, only : updateSizeDepTreeHydStates @@ -84,7 +85,7 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) type(ed_patch_type), pointer :: currentPatch !----------------------------------------------------------------------- - if ( hlm_masterproc==1 ) write(fates_log(),'(A,I4,A,I2.2,A,I2.2)') 'FATES Dynamics: ',& + if ( hlm_masterproc==itrue ) write(fates_log(),'(A,I4,A,I2.2,A,I2.2)') 'FATES Dynamics: ',& hlm_current_year,'-',hlm_current_month,'-',hlm_current_day !************************************************************************** diff --git a/main/FatesConstantsMod.F90 b/main/FatesConstantsMod.F90 index 764318c5..6170d6d6 100644 --- a/main/FatesConstantsMod.F90 +++ b/main/FatesConstantsMod.F90 @@ -16,6 +16,14 @@ module FatesConstantsMod ! Unset and various other 'special' values integer, parameter :: fates_unset_int = -9999 + + + ! Integer equivalent of true (in case some compilers dont auto convert) + integer, parameter :: itrue = 1 + + ! Integer equivalent of false (in case come compilers dont auto convert) + integer, parameter :: ifalse = 0 + ! Unit conversion constants: diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 2ba3f76a..ca477cc4 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -86,7 +86,16 @@ module FatesInterfaceMod ! between the pedotransfer functions of the HLM ! and how it moves and stores water in its ! rhizosphere shells + + integer, protected :: hlm_use_vertsoilc ! This flag signals whether or not the + ! host model is using vertically discretized + ! soil carbon + ! 1 = TRUE, 0 = FALSE + ! SOON TO BE DEPRECATED, WILL BE READ IN VIA + ! FATES NL OR PARAM FILE. + integer, protected :: hlm_use_spitfire ! This flag signals whether or not to use SPITFIRE + ! 1 = TRUE, 0 = FALSE ! ------------------------------------------------------------------------------------- ! Parameters that are dictated by FATES and known to be required knowledge @@ -838,6 +847,7 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) if (fates_global_verbose()) then write(fates_log(), *) 'Flushing FATES control parameters prior to transfer from host' end if + hlm_numSwb = unset_int hlm_numlevgrnd = unset_int hlm_numlevsoil = unset_int @@ -847,6 +857,8 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) hlm_hio_ignore_val = unset_double hlm_masterproc = unset_int hlm_ipedof = unset_int + hlm_use_vertsoilc = unset_int + hlm_use_spitfire = unset_int case('check_allset') @@ -926,6 +938,19 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) call endrun(msg=errMsg(sourcefile, __LINE__)) end if + if(hlm_use_vertsoilc .eq. unset_int) then + if (fates_global_verbose()) then + write(fates_log(), *) 'switch for the HLMs soil carbon discretization unset: hlm_use_vertsoilc' + end if + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if(hlm_use_spitfire .eq. unset_int) then + if (fates_global_verbose()) then + write(fates_log(), *) 'switch for SPITFIRE unset: hlm_use_spitfire' + end if + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if if (fates_global_verbose()) then write(fates_log(), *) 'Checked. All control parameters sent to FATES.' @@ -979,6 +1004,18 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) write(fates_log(),*) 'Transfering hlm_ipedof = ',ival,' to FATES' end if + case('use_vertsoilc') + hlm_use_vertsoilc = ival + if (fates_global_verbose()) then + write(fates_log(),*) 'Transfering hlm_use_vertsoilc= ',ival,' to FATES' + end if + + case('use_spitfire') + hlm_use_spitfire = ival + if (fates_global_verbose()) then + write(fates_log(),*) 'Transfering hlm_use_spitfire= ',ival,' to FATES' + end if + case default if (fates_global_verbose()) then write(fates_log(), *) 'tag not recognized:',trim(tag) From 895375e006a83aafdceeba6c4d49f088b0a35f1a Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 12 Apr 2017 16:53:24 -0700 Subject: [PATCH 397/437] Removed hlm global mxpft from FATES. --- biogeophys/FatesPlantRespPhotosynthMod.F90 | 13 ++++---- main/EDPftvarcon.F90 | 2 +- main/EDTypesMod.F90 | 19 +++++------ main/FatesHistoryInterfaceMod.F90 | 38 +++++++++++----------- 4 files changed, 35 insertions(+), 37 deletions(-) diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index d7a897d7..06ae3d4f 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -61,8 +61,6 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! !USES: - use clm_varpar , only : mxpft ! THIS WILL BE DEPRECATED WHEN PARAMETER - ! READS ARE REFACTORED (RGK 10-13-2016) use EDPftvarcon , only : EDPftvarcon_inst use EDParamsMod , only : ED_val_ag_biomass @@ -70,6 +68,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) use EDTypesMod , only : ed_patch_type use EDTypesMod , only : ed_cohort_type use EDTypesMod , only : ed_site_type + use EDTypesMod , only : maxpft use FatesInterfaceMod , only : hlm_numlevsoil use FatesInterfaceMod , only : bc_in_type use FatesInterfaceMod , only : bc_out_type @@ -115,17 +114,17 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! ----------------------------------------------------------------------------------- ! leaf maintenance (dark) respiration (umol CO2/m**2/s) Double check this - real(r8) :: lmr_z(nlevleaf,mxpft,nclmax) + real(r8) :: lmr_z(nlevleaf,maxpft,nclmax) ! stomatal resistance s/m - real(r8) :: rs_z(nlevleaf,mxpft,nclmax) + real(r8) :: rs_z(nlevleaf,maxpft,nclmax) ! net leaf photosynthesis averaged over sun and shade leaves. (umol CO2/m**2/s) - real(r8) :: anet_av_z(nlevleaf,mxpft,nclmax) + real(r8) :: anet_av_z(nlevleaf,maxpft,nclmax) ! Mask used to determine which leaf-layer biophysical rates have been ! used already - logical :: rate_mask_z(nlevleaf,mxpft,nclmax) + logical :: rate_mask_z(nlevleaf,maxpft,nclmax) real(r8) :: vcmax_z ! leaf layer maximum rate of carboxylation ! (umol co2/m**2/s) @@ -141,7 +140,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) real(r8) :: co2_cpoint ! CO2 compensation point (Pa) real(r8) :: btran_eff ! effective transpiration wetness factor (0 to 1) real(r8) :: bbb ! Ball-Berry minimum leaf conductance (umol H2O/m**2/s) - real(r8) :: kn(mxpft) ! leaf nitrogen decay coefficient + real(r8) :: kn(maxpft) ! leaf nitrogen decay coefficient real(r8) :: cf ! s m**2/umol -> s/m real(r8) :: gb_mol ! leaf boundary layer conductance (umol H2O/m**2/s) real(r8) :: ceair ! vapor pressure of air, constrained (Pa) diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index 1a03963b..a02d2b21 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -6,7 +6,7 @@ module EDPftvarcon ! read and initialize vegetation (PFT) constants. ! ! !USES: - use clm_varpar , only : mxpft, numrad, ivis, inir, nvariants + use clm_varpar , only : numrad, ivis, inir, nvariants use shr_kind_mod, only : r8 => shr_kind_r8 use FatesGlobals, only : fates_log diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 997d4850..e270ebca 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -1,7 +1,6 @@ module EDTypesMod use FatesConstantsMod , only : r8 => fates_r8 - use clm_varpar , only : mxpft use shr_infnan_mod, only : nan => shr_infnan_nan, assignment(=) use FatesHydraulicsMemMod, only : ed_cohort_hydr_type @@ -542,9 +541,9 @@ module EDTypesMod ! TERMINATION, RECRUITMENT, DEMOTION, and DISTURBANCE - real(r8) :: terminated_nindivs(1:nlevsclass_ed,1:mxpft,2) ! number of individuals that were in cohorts which were terminated this timestep, on size x pft x canopy array. + real(r8) :: terminated_nindivs(1:nlevsclass_ed,1:maxpft,2) ! number of individuals that were in cohorts which were terminated this timestep, on size x pft x canopy array. real(r8) :: termination_carbonflux(2) ! carbon flux from live to dead pools associated with termination mortality, per canopy level - real(r8) :: recruitment_rate(1:mxpft) ! number of individuals that were recruited into new cohorts + real(r8) :: recruitment_rate(1:maxpft) ! number of individuals that were recruited into new cohorts real(r8) :: demotion_rate(1:nlevsclass_ed) ! rate of individuals demoted from canopy to understory per FATES timestep real(r8) :: demotion_carbonflux ! biomass of demoted individuals from canopy to understory [kgC/ha/day] real(r8) :: promotion_rate(1:nlevsclass_ed) ! rate of individuals promoted from understory to canopy per FATES timestep @@ -553,8 +552,8 @@ module EDTypesMod ! some diagnostic-only (i.e. not resolved by ODE solver) flux of carbon to CWD and litter pools from termination and canopy mortality real(r8) :: CWD_AG_diagnostic_input_carbonflux(1:ncwd) ! diagnostic flux to AG CWD [kg C / m2 / yr] real(r8) :: CWD_BG_diagnostic_input_carbonflux(1:ncwd) ! diagnostic flux to BG CWD [kg C / m2 / yr] - real(r8) :: leaf_litter_diagnostic_input_carbonflux(1:mxpft) ! diagnostic flux to AG litter [kg C / m2 / yr] - real(r8) :: root_litter_diagnostic_input_carbonflux(1:mxpft) ! diagnostic flux to BG litter [kg C / m2 / yr] + real(r8) :: leaf_litter_diagnostic_input_carbonflux(1:maxpft) ! diagnostic flux to AG litter [kg C / m2 / yr] + real(r8) :: root_litter_diagnostic_input_carbonflux(1:maxpft) ! diagnostic flux to BG litter [kg C / m2 / yr] end type ed_site_type @@ -580,9 +579,9 @@ subroutine ed_hist_scpfmaps integer :: iage allocate( fates_hdim_levsclass(1:nlevsclass_ed )) - allocate( fates_hdim_pfmap_levscpf(1:nlevsclass_ed*mxpft)) - allocate( fates_hdim_scmap_levscpf(1:nlevsclass_ed*mxpft)) - allocate( fates_hdim_levpft(1:mxpft )) + allocate( fates_hdim_pfmap_levscpf(1:nlevsclass_ed*maxpft)) + allocate( fates_hdim_scmap_levscpf(1:nlevsclass_ed*maxpft)) + allocate( fates_hdim_levpft(1:maxpft )) allocate( fates_hdim_levfuel(1:NFSC )) allocate( fates_hdim_levcwdsc(1:NCWD )) allocate( fates_hdim_levage(1:nlevage_ed )) @@ -604,7 +603,7 @@ subroutine ed_hist_scpfmaps fates_hdim_levage(:) = ageclass_ed(:) ! make pft array - do ipft=1,mxpft + do ipft=1,maxpft fates_hdim_levpft(ipft) = ipft end do @@ -625,7 +624,7 @@ subroutine ed_hist_scpfmaps ! Fill the IO arrays that match pft and size class to their combined array i=0 - do ipft=1,mxpft + do ipft=1,maxpft do isc=1,nlevsclass_ed i=i+1 fates_hdim_pfmap_levscpf(i) = ipft diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index d016d2d5..4d0a6a04 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -1070,19 +1070,19 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! after Ecosystem Dynamics have been processed. ! --------------------------------------------------------------------------------- - use EDtypesMod , only : ed_site_type, & - ed_cohort_type, & - ed_patch_type, & - AREA, & - AREA_INV, & - nlevsclass_ed, & - nlevage_ed, & - do_ed_dynamics, & - mxpft, & - nfsc, & - ncwd, & - ican_upper, & - ican_ustory + use EDtypesMod , only : ed_site_type + use EDtypesMod , only : ed_cohort_type + use EDtypesMod , only : ed_patch_type + use EDtypesMod , only : AREA + use EDtypesMod , only : AREA_INV + use EDtypesMod , only : nlevsclass_ed + use EDtypesMod , only : nlevage_ed + use EDtypesMod , only : do_ed_dynamics + use EDtypesMod , only : nfsc + use EDtypesMod , only : ncwd + use EDtypesMod , only : ican_upper + use EDtypesMod , only : ican_ustory + use EDTypesMod , only : maxpft use EDParamsMod , only : ED_val_ag_biomass use EDTypesMod , only : get_sizeage_class_index @@ -1633,7 +1633,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! pass the cohort termination mortality as a flux to the history, and then reset the termination mortality buffer ! note there are various ways of reporting the total mortality, so pass to these as well - do i_pft = 1, mxpft + do i_pft = 1, maxpft do i_scls = 1,nlevsclass_ed i_scpf = (i_pft-1)*nlevsclass_ed + i_scls hio_m6_si_scpf(io_si,i_scpf) = (sites(s)%terminated_nindivs(i_scls,i_pft,1) + & @@ -1651,13 +1651,13 @@ subroutine update_history_dyn(this,nc,nsites,sites) sites(s)%terminated_nindivs(:,:,:) = 0._r8 ! pass the recruitment rate as a flux to the history, and then reset the recruitment buffer - do i_pft = 1, mxpft + do i_pft = 1, maxpft hio_recruitment_si_pft(io_si,i_pft) = sites(s)%recruitment_rate(i_pft) * days_per_year end do sites(s)%recruitment_rate(:) = 0._r8 ! summarize all of the mortality fluxes by PFT - do i_pft = 1, mxpft + do i_pft = 1, maxpft do i_scls = 1,nlevsclass_ed i_scpf = (i_pft-1)*nlevsclass_ed + i_scls hio_mortality_si_pft(io_si,i_pft) = hio_mortality_si_pft(io_si,i_pft) + & @@ -2067,7 +2067,7 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,dt_tstep) use FatesHydraulicsMemMod, only : nlevsoi_hyd use EDTypesMod , only : nlevsclass_ed use EDTypesMod , only : do_ed_dynamics - use clm_varpar , only : mxpft + use EDTypesMod , only : maxpft ! Arguments class(fates_history_interface_type) :: this @@ -2087,7 +2087,7 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,dt_tstep) real(r8) :: n_density ! individual of cohort per m2. real(r8) :: n_perm2 ! individuals per m2 for the whole column real(r8), parameter :: tiny = 1.e-5_r8 ! some small number - real(r8) :: ncohort_scpf(nlevsclass_ed*mxpft) ! Bins to count up cohorts counts used in weighting + real(r8) :: ncohort_scpf(nlevsclass_ed*maxpft) ! Bins to count up cohorts counts used in weighting ! should be "hio_nplant_si_scpf" real(r8) :: number_fraction real(r8) :: number_fraction_rate @@ -2277,7 +2277,7 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,dt_tstep) end do !patch loop if(do_ed_dynamics) then - do scpf=1,nlevsclass_ed*mxpft + do scpf=1,nlevsclass_ed*maxpft if( abs(hio_nplant_si_scpf(io_si, scpf)-ncohort_scpf(scpf)) > 1.0E-8_r8 ) then write(fates_log(),*) 'nplant check on hio_nplant_si_scpf fails during hydraulics history updates' call endrun(msg=errMsg(sourcefile, __LINE__)) From 69281270e6345e0c158d5b99e29e98e82aea982e Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 12 Apr 2017 17:25:15 -0700 Subject: [PATCH 398/437] Migrated ivis, numrad and inir to fates globals. --- main/EDPftvarcon.F90 | 8 +++++--- main/EDTypesMod.F90 | 11 ++++++++++ main/FatesInterfaceMod.F90 | 41 +++++++++++++++++++++++++++++++++++++- 3 files changed, 56 insertions(+), 4 deletions(-) diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index a02d2b21..1a81ccf2 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -6,7 +6,7 @@ module EDPftvarcon ! read and initialize vegetation (PFT) constants. ! ! !USES: - use clm_varpar , only : numrad, ivis, inir, nvariants + use EDTypesMod , only : maxSWb, ivis, inir use shr_kind_mod, only : r8 => shr_kind_r8 use FatesGlobals, only : fates_log @@ -18,7 +18,7 @@ module EDPftvarcon integer, parameter, public :: lower_bound_pft = 0 integer, parameter, public :: lower_bound_general = 1 - + !ED specific variables. type, public :: EDPftvarcon_type real(r8), allocatable :: max_dbh (:) ! maximum dbh at which height growth ceases... @@ -890,7 +890,9 @@ subroutine Receive_PFT_numrad(this, fates_params) lower_bound_1 = lower_bound_pft upper_bound_1 = lower_bound_pft + dimension_sizes(1) - 1 lower_bound_2 = lower_bound_general - upper_bound_2 = numrad + upper_bound_2 = maxSWb ! When we have radiation parameters read in as a vector + ! We will compare the vector dimension size that we + ! read-in to the parameterized size that fates expects allocate(dummy_data(lower_bound_1:upper_bound_1)) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index e270ebca..6d6557ca 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -33,6 +33,17 @@ module EDTypesMod ! if cp_numSWb is larger than this value ! simply bump this number up as needed + integer, parameter :: ivis = 1 ! This is the array index for short-wave + ! radiation in the visible spectrum, as expected + ! in boundary condition files and parameter + ! files. This will be compared with + ! the HLM's expectation in FatesInterfaceMod + integer, parameter :: inir = 2 ! This is the array index for short-wave + ! radiation in the near-infrared spectrum, as expected + ! in boundary condition files and parameter + ! files. This will be compared with + ! the HLM's expectation in FatesInterfaceMod + ! Module switches (this will be read in one day) ! This variable only exists now to serve as a place holder !!!!!!!!!! THIS SHOULD NOT BE SET TO TRUE !!!!!!!!!!!!!!!!! diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index ca477cc4..547ac4d2 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -13,6 +13,8 @@ module FatesInterfaceMod use EDTypesMod , only : maxPatchesPerSite use EDTypesMod , only : maxCohortsPerPatch use EDTypesMod , only : maxSWb + use EDTypesMod , only : ivis + use EDTypesMod , only : inir use EDTypesMod , only : nclmax use EDTypesMod , only : nlevleaf use EDTypesMod , only : numpft_ed @@ -46,6 +48,13 @@ module FatesInterfaceMod ! specturm to track ! (typically 2 as a default, VIS/NIR, in ED variants <2016) + integer, protected :: hlm_ivis ! The HLMs assumption of the array index associated with the + ! visible portion of the spectrum in short-wave radiation arrays + + integer, protected :: hlm_inir ! The HLMs assumption of the array index associated with the + ! NIR portion of the spectrum in short-wave radiation arrays + + integer, protected :: hlm_numlevgrnd ! Number of ground layers integer, protected :: hlm_numlevsoil ! Number of soil layers @@ -848,7 +857,9 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) write(fates_log(), *) 'Flushing FATES control parameters prior to transfer from host' end if - hlm_numSwb = unset_int + hlm_numSWb = unset_int + hlm_inir = unset_int + hlm_ivis = unset_int hlm_numlevgrnd = unset_int hlm_numlevsoil = unset_int hlm_numlevdecomp_full = unset_int @@ -889,6 +900,22 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) call endrun(msg=errMsg(sourcefile, __LINE__)) end if + if(hlm_ivis .ne. ivis) then + if (fates_global_verbose()) then + write(fates_log(), *) 'FATES assumption about the index of visible shortwave' + write(fates_log(), *) 'radiation is different from the HLM' + end if + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if(hlm_inir .ne. inir) then + if (fates_global_verbose()) then + write(fates_log(), *) 'FATES assumption about the index of NIR shortwave' + write(fates_log(), *) 'radiation is different from the HLM' + end if + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + if(hlm_numlevgrnd .eq. unset_int) then if (fates_global_verbose()) then write(fates_log(), *) 'FATES dimension/parameter unset: numlevground' @@ -974,6 +1001,18 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) write(fates_log(),*) 'Transfering num_sw_bbands = ',ival,' to FATES' end if + case('vis_sw_index') + hlm_ivis = ival + if (fates_global_verbose()) then + write(fates_log(),*) 'Transfering index associated with visible SW rad = ',ival,' to FATES' + end if + + case('nir_sw_index') + hlm_inir = ival + if (fates_global_verbose()) then + write(fates_log(),*) 'Transfering index associated with NIR SW rad = ',ival,' to FATES' + end if + case('num_lev_ground') hlm_numlevgrnd = ival if (fates_global_verbose()) then From e11824973dc83aaf09b02ab32f7bac33c998085c Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 12 Apr 2017 17:55:07 -0700 Subject: [PATCH 399/437] Added a boundary condition control parameter for is_restart(). Removed bounds from a patch counter. --- biogeochem/EDPatchDynamicsMod.F90 | 4 +-- biogeochem/EDSharedParamsMod.F90 | 57 ------------------------------- fire/SFMainMod.F90 | 1 - main/EDInitMod.F90 | 7 ++-- main/FatesInterfaceMod.F90 | 17 +++++++++ 5 files changed, 22 insertions(+), 64 deletions(-) delete mode 100644 biogeochem/EDSharedParamsMod.F90 diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index f3a0f3c7..428ac6ca 100755 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -1530,17 +1530,15 @@ subroutine patch_pft_size_profile(cp_pnt) end subroutine patch_pft_size_profile ! ===================================================================================== - function countPatches( bounds, nsites, sites ) result ( totNumPatches ) + function countPatches( nsites, sites ) result ( totNumPatches ) ! ! !DESCRIPTION: ! Loop over all Patches to count how many there are ! ! !USES: - use decompMod , only : bounds_type use EDTypesMod , only : ed_site_type ! ! !ARGUMENTS: - type(bounds_type) , intent(in) :: bounds integer, intent(in) :: nsites type(ed_site_type) , intent(inout), target :: sites(nsites) ! diff --git a/biogeochem/EDSharedParamsMod.F90 b/biogeochem/EDSharedParamsMod.F90 deleted file mode 100644 index d6d7d7cb..00000000 --- a/biogeochem/EDSharedParamsMod.F90 +++ /dev/null @@ -1,57 +0,0 @@ -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 - - character(len=*), parameter, private :: sourcefile = & - __FILE__ - - !----------------------------------------------------------------------- - -contains - - !----------------------------------------------------------------------- - subroutine EDParamsReadShared(ncid) - ! - use ncdio_pio , only : file_desc_t,ncd_io - use FatesGlobals, only : endrun => fates_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(sourcefile, __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(sourcefile, __LINE__)) - EDParamsShareInst%froz_q10=tempr - - end subroutine EDParamsReadShared - -end module EDSharedParamsMod diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index 687fdc7e..53fa7f84 100755 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -12,7 +12,6 @@ module SFMainMod use FatesGlobals , only : fates_log use FatesInterfaceMod , only : bc_in_type - use pftconMod , only : pftcon use EDPftvarcon , only : EDPftvarcon_inst use EDEcophysconType , only : EDecophyscon diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 0c2b4374..f7ada2f3 100755 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -5,10 +5,11 @@ module EDInitMod ! ============================================================================ use FatesConstantsMod , only : r8 => fates_r8 + use FatesConstantsMod , only : ifalse use FatesGlobals , only : endrun => fates_endrun use EDTypesMod , only : nclmax use FatesGlobals , only : fates_log - use clm_time_manager , only : is_restart + use FatesInterfaceMod , only : hlm_is_restart use EDPftvarcon , only : EDPftvarcon_inst use EDEcophysConType , only : EDecophyscon use EDGrowthFunctionsMod , only : bdead, bleaf, dbh @@ -127,7 +128,7 @@ subroutine set_site_properties( nsites, sites) integer :: dleafon !---------------------------------------------------------------------- - if ( .not. is_restart() ) then + if ( hlm_is_restart == ifalse ) then !initial guess numbers for site condition. NCD = 0.0_r8 GDD = 30.0_r8 @@ -163,7 +164,7 @@ subroutine set_site_properties( nsites, sites) sites(s)%dleafondate = dleafon sites(s)%ED_GDD_site = GDD - if ( .not. is_restart() ) then + if ( hlm_is_restart == ifalse ) then sites(s)%water_memory(1:numWaterMem) = watermem end if diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 547ac4d2..669a73b3 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -69,6 +69,9 @@ module FatesInterfaceMod ! biogeochemistry; can be either 1 or the total ! number of soil layers + integer, protected :: hlm_is_restart ! Is the HLM signalling that this is a restart + ! type simulation? + ! 1=TRUE, 0=FALSE character(len=16), protected :: hlm_name ! This character string passed by the HLM ! is used during the processing of IO data, @@ -860,6 +863,7 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) hlm_numSWb = unset_int hlm_inir = unset_int hlm_ivis = unset_int + hlm_is_restart = unset_int hlm_numlevgrnd = unset_int hlm_numlevsoil = unset_int hlm_numlevdecomp_full = unset_int @@ -916,6 +920,13 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) call endrun(msg=errMsg(sourcefile, __LINE__)) end if + if(hlm_is_restart .eq. unset_int) then + if (fates_global_verbose()) then + write(fates_log(), *) 'FATES parameter unset: hlm_is_restart' + end if + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + if(hlm_numlevgrnd .eq. unset_int) then if (fates_global_verbose()) then write(fates_log(), *) 'FATES dimension/parameter unset: numlevground' @@ -1013,6 +1024,12 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) write(fates_log(),*) 'Transfering index associated with NIR SW rad = ',ival,' to FATES' end if + case('is_restart') + hlm_is_restart = ival + if (fates_global_verbose()) then + write(fates_log(),*) 'Transfering flag signaling restart / not-restart = ',ival,' to FATES' + end if + case('num_lev_ground') hlm_numlevgrnd = ival if (fates_global_verbose()) then From a33b8471daa6e264aaf7b1a9caa1bd5f3a420127 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 12 Apr 2017 22:36:15 -0700 Subject: [PATCH 400/437] Fixed some line truncation errors. Converted the dleaf, z0m, and displar boundary condition calculation to avoid HLM globals. The conversion needs a science evaluation in the long-run. --- biogeochem/EDCanopyStructureMod.F90 | 34 +++++++++++++++++--------- fire/SFMainMod.F90 | 38 +++++++++++++++++------------ 2 files changed, 44 insertions(+), 28 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 50bbfb15..35905f1e 100755 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1272,8 +1272,6 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) use EDTypesMod , only : ed_patch_type, ed_cohort_type, & ed_site_type, AREA use FatesInterfaceMod , only : bc_out_type - use PatchType , only : patch - use ColumnType , only : col use EDPftvarcon , only : EDPftvarcon_inst @@ -1285,10 +1283,13 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) type(bc_out_type), intent(inout) :: bc_out(nsites) ! Locals + type (ed_cohort_type) , pointer :: currentCohort integer :: s, ifp, c, p type (ed_patch_type) , pointer :: currentPatch real(r8) :: bare_frac_area real(r8) :: total_patch_area + real(r8) :: weight ! Weighting for cohort variables in patch + do s = 1,nsites @@ -1314,17 +1315,26 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) bc_out(s)%hbot_pa(ifp) = max(0._r8, min(0.2_r8, bc_out(s)%htop_pa(ifp)- 1.0_r8)) - ! Temporary: Recreate the roughness, leaf width and displacment height of the - ! previous code, before calculating more reasonable values. - p = col%patchi(c) + ifp - - bc_out(s)%z0m_pa(ifp) = EDPftvarcon_inst%z0mr(patch%itype(p)) * bc_out(s)%htop_pa(ifp) - bc_out(s)%displa_pa(ifp) = EDPftvarcon_inst%displar(patch%itype(p)) * bc_out(s)%htop_pa(ifp) - bc_out(s)%dleaf_pa(ifp) = EDPftvarcon_inst%dleaf(patch%itype(p)) + ! Use leaf area weighting for all cohorts in the patch to define the characteristic + ! leaf width used by the HLM + ! ---------------------------------------------------------------------------- + bc_out(s)%dleaf_pa(ifp) = 0.0_r8 + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + weight = min(1.0_r8,currentCohort%lai/currentPatch%lai) + bc_out(s)%dleaf_pa(ifp) = bc_out(s)%dleaf_pa(ifp) + & + EDPftvarcon_inst%dleaf(currentCohort%pft)*weight + currentCohort => currentCohort%taller + enddo -! bc_out(s)%z0m_pa(ifp) = pftcon%z0mr(1) * bc_out(s)%htop_pa(ifp) -! bc_out(s)%displa_pa(ifp) = pftcon%displar(1) * bc_out(s)%htop_pa(ifp) -! bc_out(s)%dleaf_pa(ifp) = pftcon%dleaf(1) + ! Roughness length and displacement height are not PFT properties, they are + ! properties of the canopy assemblage. Defining this needs an appropriate model. + ! Right now z0 and d are pft level parameters. For the time being we will just + ! use the 1st index until a suitable model is defined. (RGK 04-2017) + ! ----------------------------------------------------------------------------- + bc_out(s)%z0m_pa(ifp) = EDPftvarcon_inst%z0mr(1) * bc_out(s)%htop_pa(ifp) + bc_out(s)%displa_pa(ifp) = EDPftvarcon_inst%displar(1) * bc_out(s)%htop_pa(ifp) + ! 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. diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index 53fa7f84..66f113a1 100755 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -208,7 +208,8 @@ subroutine charecteristics_of_fuel ( currentSite ) if(write_sf == itrue)then if ( hlm_masterproc == itrue ) write(fates_log(),*) 'ff1 ',currentPatch%fuel_frac if ( hlm_masterproc == itrue ) write(fates_log(),*) 'ff2 ',currentPatch%fuel_frac - if ( hlm_masterproc == itrue ) write(fates_log(),*) 'ff2a ',lg_sf,currentPatch%livegrass,currentPatch%sum_fuel + if ( hlm_masterproc == itrue ) write(fates_log(),*) 'ff2a ', & + lg_sf,currentPatch%livegrass,currentPatch%sum_fuel endif currentPatch%fuel_frac(lg_sf) = currentPatch%livegrass / currentPatch%sum_fuel @@ -341,7 +342,7 @@ subroutine wind_effect ( currentSite, bc_in) do while(associated(currentCohort)) write(fates_log(),*) 'SF currentCohort%c_area ',currentCohort%c_area - if(EDPftvarcon_inst%woody(currentCohort%pft) == itrue)then + if(EDPftvarcon_inst%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 @@ -365,7 +366,8 @@ subroutine wind_effect ( currentSite, bc_in) grass_fraction = min(grass_fraction,1.0_r8-tree_fraction) bare_fraction = 1.0 - tree_fraction - grass_fraction if(write_sf == itrue)then - if ( hlm_masterproc == itrue ) write(fates_log(),*) 'grass, trees, bare',grass_fraction, tree_fraction, bare_fraction + if ( hlm_masterproc == itrue ) write(fates_log(),*) 'grass, trees, bare', & + grass_fraction, tree_fraction, bare_fraction endif currentPatch=>currentSite%oldest_patch; @@ -419,8 +421,10 @@ subroutine rate_of_spread ( currentSite ) ! ----start spreading--- - if ( hlm_masterproc == itrue .and.DEBUG) write(fates_log(),*) 'SF - currentPatch%fuel_bulkd ',currentPatch%fuel_bulkd - if ( hlm_masterproc == itrue .and.DEBUG) write(fates_log(),*) 'SF - SF_val_part_dens ',SF_val_part_dens + if ( hlm_masterproc == itrue .and.DEBUG) write(fates_log(),*) & + 'SF - currentPatch%fuel_bulkd ',currentPatch%fuel_bulkd + if ( hlm_masterproc == itrue .and.DEBUG) write(fates_log(),*) & + 'SF - SF_val_part_dens ',SF_val_part_dens ! beta = packing ratio (unitless) ! fraction of fuel array volume occupied by fuel or compactness of fuel bed @@ -457,7 +461,8 @@ subroutine rate_of_spread ( currentSite ) if (DEBUG) then if ( hlm_masterproc == itrue .and.DEBUG) write(fates_log(),*) 'SF - c ',c - if ( hlm_masterproc == itrue .and.DEBUG) write(fates_log(),*) 'SF - currentPatch%effect_wspeed ',currentPatch%effect_wspeed + if ( hlm_masterproc == itrue .and.DEBUG) write(fates_log(),*) & + 'SF - currentPatch%effect_wspeed ',currentPatch%effect_wspeed if ( hlm_masterproc == itrue .and.DEBUG) write(fates_log(),*) 'SF - b ',b if ( hlm_masterproc == itrue .and.DEBUG) write(fates_log(),*) 'SF - bet ',bet if ( hlm_masterproc == itrue .and.DEBUG) write(fates_log(),*) 'SF - e ',e @@ -696,7 +701,7 @@ subroutine area_burnt ( currentSite ) currentPatch%frac_burnt = 0.0_r8 lb = 0.0_r8; db = 0.0_r8; df = 0.0_r8 - if (currentPatch%fire == itrue) then + 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. @@ -787,10 +792,10 @@ subroutine crown_scorching ( currentSite ) tree_ag_biomass = 0.0_r8 f_ag_bmass = 0.0_r8 - if (currentPatch%fire == itrue) then + if (currentPatch%fire == 1) then currentCohort => currentPatch%tallest; do while(associated(currentCohort)) - if (EDPftvarcon_inst%woody(currentCohort%pft) == itrue) then !trees only + if (EDPftvarcon_inst%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 @@ -805,7 +810,8 @@ subroutine crown_scorching ( currentSite ) currentPatch%SH = 0.0_r8 currentCohort => currentPatch%tallest; do while(associated(currentCohort)) - if (EDPftvarcon_inst%woody(currentCohort%pft) == itrue.and.(tree_ag_biomass > 0.0_r8)) then !trees only + if (EDPftvarcon_inst%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 @@ -839,13 +845,13 @@ subroutine crown_damage ( currentSite ) currentPatch => currentSite%oldest_patch do while(associated(currentPatch)) - if (currentPatch%fire == itrue) then + if (currentPatch%fire == 1) then currentCohort=>currentPatch%tallest do while(associated(currentCohort)) currentCohort%cfa = 0.0_r8 - if (EDPftvarcon_inst%woody(currentCohort%pft) == itrue) then !trees only + if (EDPftvarcon_inst%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 @@ -903,10 +909,10 @@ subroutine cambial_damage_kill ( currentSite ) do while(associated(currentPatch)) - if (currentPatch%fire == itrue) then + if (currentPatch%fire == 1) then currentCohort => currentPatch%tallest; do while(associated(currentCohort)) - if (EDPftvarcon_inst%woody(currentCohort%pft) == itrue) then !trees only + if (EDPftvarcon_inst%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. @@ -953,12 +959,12 @@ subroutine post_fire_mortality ( currentSite ) do while(associated(currentPatch)) - if (currentPatch%fire == itrue) then + 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 (EDPftvarcon_inst%woody(currentCohort%pft) == itrue) then + if (EDPftvarcon_inst%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. From 60e95312ee3990331e9a3fa9aea6e601ac58b4c2 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 13 Apr 2017 00:34:28 -0700 Subject: [PATCH 401/437] Simplified dleaf boundary condition calculation to preserve numerical consistency on ERS tests. --- biogeochem/EDCanopyStructureMod.F90 | 21 ++++++++++++--------- 1 file changed, 12 insertions(+), 9 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 35905f1e..e4453a62 100755 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1318,15 +1318,17 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) ! Use leaf area weighting for all cohorts in the patch to define the characteristic ! leaf width used by the HLM ! ---------------------------------------------------------------------------- - bc_out(s)%dleaf_pa(ifp) = 0.0_r8 - currentCohort => currentPatch%shortest - do while(associated(currentCohort)) - weight = min(1.0_r8,currentCohort%lai/currentPatch%lai) - bc_out(s)%dleaf_pa(ifp) = bc_out(s)%dleaf_pa(ifp) + & - EDPftvarcon_inst%dleaf(currentCohort%pft)*weight - currentCohort => currentCohort%taller - enddo - +! bc_out(s)%dleaf_pa(ifp) = 0.0_r8 +! if(currentPatch%lai>1.0e-9_r8) then +! currentCohort => currentPatch%shortest +! do while(associated(currentCohort)) +! weight = min(1.0_r8,currentCohort%lai/currentPatch%lai) +! bc_out(s)%dleaf_pa(ifp) = bc_out(s)%dleaf_pa(ifp) + & +! EDPftvarcon_inst%dleaf(currentCohort%pft)*weight +! currentCohort => currentCohort%taller +! enddo +! end if + ! Roughness length and displacement height are not PFT properties, they are ! properties of the canopy assemblage. Defining this needs an appropriate model. ! Right now z0 and d are pft level parameters. For the time being we will just @@ -1334,6 +1336,7 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) ! ----------------------------------------------------------------------------- bc_out(s)%z0m_pa(ifp) = EDPftvarcon_inst%z0mr(1) * bc_out(s)%htop_pa(ifp) bc_out(s)%displa_pa(ifp) = EDPftvarcon_inst%displar(1) * bc_out(s)%htop_pa(ifp) + bc_out(s)%dleaf_pa(ifp) = EDPftvarcon_inst%dleaf(1) ! We are assuming here that grass is all located underneath tree canopies. From d44ff9a508fb1cf661fa03769632714e82b1b0c3 Mon Sep 17 00:00:00 2001 From: JKShuman Date: Tue, 18 Apr 2017 12:58:10 -0600 Subject: [PATCH 402/437] Spitfire updates to params and fuel moisture calc Development to correct equations to literature and code clarity. 1.Litter moisture of trunk corrected from zero to calculated value of fuel_moisture/MEF. Confirmed ROS and intensity calcualtions do not use trunk, but calculated trunk litter moisture needed for fuel_consumption routine 2.Remove 0.45 multipliers on fuel_bulkd. Needs to be in kgBiomass/m2. No need to convert to carbon and convert back to biomass. 3.fuel_moisture corrected to (dg_sf:lb_sf) for fuel classes 1,2,3,4 per Thonicke et al 2010. 4.Add twig parameter tw_sf=2 (fuel class 2) and update instances of (dl_sf+1) to new twig parameter (tw_sf) where appropraite Fixes: User interface changes?: No Code review: JKShuman Test suite: SMS_D_Ld5.f10_f10.ICLM45ED.yellowstone_intel.clm-edTest Test baseline:ed-clm-8f2c36e Test namelist changes:no Test answer changes: bit for bit Test summary: PASS Test suite: ERS_D_Ld5.f10_f10.ICLM45ED.yellowstone_intel.clm-edFire Test baseline:ed-clm-8f2c36e Test namelist changes:no Test answer changes: bit for bit Test summary: PASS for functionality, FAIL: not bit for bit with ed-clm-8f2c36e as expected --- fire/SFMainMod.F90 | 35 ++++++++++++++++++----------------- main/EDTypesMod.F90 | 3 ++- 2 files changed, 20 insertions(+), 18 deletions(-) diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index 013b663d..2bb4d11c 100755 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -13,7 +13,7 @@ module SFMainMod use FatesInterfaceMod , only : bc_in_type use pftconMod , only : pftcon - use EDPftvarcon , only : EDPftvarcon_inst + use EDPftvarcon , only : EDPftvarcon_inst use EDEcophysconType , only : EDecophyscon use EDtypesMod , only : ed_site_type @@ -22,6 +22,7 @@ module SFMainMod use EDtypesMod , only : AREA use EDtypesMod , only : DL_SF use EDtypesMod , only : FIRE_THRESHOLD + use EDTypesMod , only : TW_SF use EDtypesMod , only : LB_SF use EDtypesMod , only : LG_SF use EDtypesMod , only : NCWD @@ -175,7 +176,7 @@ subroutine charecteristics_of_fuel ( currentSite ) ! 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 - ! dl_sf = 1, lb_sf, = 4, tr_sf = 5, lg_sf = 6, + ! dl_sf = 1, tw_sf = 2, lb_sf = 4, tr_sf = 5, lg_sf = 6, ! zero fire arrays. currentPatch%fuel_eff_moist = 0.0_r8 @@ -204,7 +205,7 @@ subroutine charecteristics_of_fuel ( currentSite ) if (currentPatch%sum_fuel > 0.0) then ! Fraction of fuel in litter classes currentPatch%fuel_frac(dl_sf) = sum(currentPatch%leaf_litter)/ currentPatch%sum_fuel - currentPatch%fuel_frac(dl_sf+1:tr_sf) = currentPatch%CWD_AG / currentPatch%sum_fuel + currentPatch%fuel_frac(tw_sf:tr_sf) = currentPatch%CWD_AG / currentPatch%sum_fuel if(write_sf == 1)then if ( hlm_masterproc == 1 ) write(fates_log(),*) 'ff1 ',currentPatch%fuel_frac @@ -216,8 +217,10 @@ subroutine charecteristics_of_fuel ( currentSite ) MEF(1:nfsc) = 0.524_r8 - 0.066_r8 * log10(SF_val_SAV(1:nfsc)) !--- weighted average of relative moisture content--- - ! Equation 6 in Thonicke et al. 2010. - fuel_moisture(dl_sf+1:tr_sf) = exp(-1.0_r8 * SF_val_alpha_FMC(dl_sf+1:tr_sf) * currentSite%acc_NI) + ! Equation 6 in Thonicke et al. 2010. across leaves,twig, small branch, and large branch + ! dead leaves and twigs included in 1hr pool per Thonicke (2010) + ! Calculate fuel moisture for trunks to hold value for fuel consumption + fuel_moisture(dl_sf:tr_sf) = exp(-1.0_r8 * SF_val_alpha_FMC(dl_sf:tr_sf) * currentSite%acc_NI) if(write_SF == 1)then if ( hlm_masterproc == 1 ) write(fates_log(),*) 'ff3 ',currentPatch%fuel_frac @@ -229,7 +232,7 @@ subroutine charecteristics_of_fuel ( currentSite ) ! average water content !is this the correct metric? timeav_swc = sum(currentSite%water_memory(1:numWaterMem)) / dble(numWaterMem) ! Equation B2 in Thonicke et al. 2010 - ! live grass moisture content + ! live grass moisture content depends on upper soil layer fuel_moisture(lg_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) @@ -246,19 +249,17 @@ subroutine charecteristics_of_fuel ( currentSite ) 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) + ! Correct averaging for the fact that we are not using the trunks pool for fire ROS and intensity (5) + ! Consumption of fuel in trunk pool does not influence fire ROS or intensity (Pyne 1996) 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. - 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(dl_sf:lb_sf) = fuel_moisture(dl_sf:lb_sf)/MEF(dl_sf:lb_sf) - currentPatch%litter_moisture(tr_sf) = 0.0_r8 + currentPatch%litter_moisture(tr_sf) = fuel_moisture(tr_sf)/MEF(tr_sf) currentPatch%litter_moisture(lg_sf) = fuel_moisture(lg_sf)/MEF(lg_sf) else @@ -426,7 +427,7 @@ subroutine rate_of_spread ( currentSite ) ! beta = packing ratio (unitless) ! fraction of fuel array volume occupied by fuel or compactness of fuel bed - beta = (currentPatch%fuel_bulkd / 0.45_r8) / SF_val_part_dens + beta = currentPatch%fuel_bulkd / SF_val_part_dens ! Equation A6 in Thonicke et al. 2010 ! packing ratio (unitless) @@ -508,11 +509,11 @@ subroutine rate_of_spread ( currentSite ) ! write(fates_log(),*) '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 + if (((currentPatch%fuel_bulkd) <= 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. ! forward ROS in m/min - currentPatch%ROS_front = (ir*xi*(1.0_r8+phi_wind)) / (currentPatch%fuel_bulkd/0.45_r8*eps*q_ig) + currentPatch%ROS_front = (ir*xi*(1.0_r8+phi_wind)) / (currentPatch%fuel_bulkd*eps*q_ig) ! write(fates_log(),*) 'ROS',currentPatch%ROS_front,phi_wind,currentPatch%effect_wspeed ! write(fates_log(),*) 'ros calcs',currentPatch%fuel_bulkd,ir,xi,eps,q_ig endif @@ -581,9 +582,9 @@ subroutine ground_fuel_consumption ( currentSite ) currentPatch%burnt_frac_litter = currentPatch%burnt_frac_litter * (1.0_r8-SF_val_miner_total) !---Calculate amount of fuel burnt.--- - FC_ground(dl_sf) = currentPatch%burnt_frac_litter(dl_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 + FC_ground(dl_sf) = currentPatch%burnt_frac_litter(dl_sf) * sum(currentPatch%leaf_litter) + FC_ground(tw_sf:tr_sf) = currentPatch%burnt_frac_litter(tw_sf: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 diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index c69e3bbe..d7179f40 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -54,8 +54,9 @@ module EDTypesMod integer , parameter :: NFSC = NCWD+2 ! number fuel size classes (really this is a mix of cwd size classes, leaf litter, and grass types) integer, parameter :: lg_sf = 6 ! array index of live grass pool for spitfire integer, parameter :: dl_sf = 1 ! array index of dead leaf pool for spitfire (dead grass and dead leaves) + integer, parameter :: tw_sf = 2 ! array index of twig 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 + integer, parameter :: lb_sf = 4 ! array index of large branch pool for spitfire real(r8), parameter :: fire_threshold = 35.0_r8 ! threshold for fires that spread or go out. KWm-2 ! COHORT FUSION From 5da1040f2eef152f2cb4c11e4ee6115da5011a9c Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 27 Apr 2017 13:04:26 -0700 Subject: [PATCH 403/437] Create README.md --- README.md | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) create mode 100644 README.md diff --git a/README.md b/README.md new file mode 100644 index 00000000..f95e973e --- /dev/null +++ b/README.md @@ -0,0 +1,22 @@ +# NGEE-T fates repository +------------------------------ + +This is the developer repository of the Next Generation Ecosystem Experiment Tropics’ (NGEE-T) model: the Functionally Assembled Terrestrial Ecosystem Simulator (FATES). + +For more information on the FATES model, see our wiki: https://github.com/NGEET/fates/wiki + + +## Important: +------------------------------ + +**Most users should not need to directly clone this repository. FATES needs to be run through a host model, and all supported host-models are in charge of cloning and loading the fates software.** + +FATES has support to be run via the Accelerated Climate Model for Energy (ACME) and the Community Earth System Model (CESM). + +https://climatemodeling.science.energy.gov/projects/accelerated-climate-modeling-energy + +http://www.cesm.ucar.edu/ + +The NGEE-T project maintains a mirror of CLM. That software system will automatically pull in the FATES software, and is where most users should go to clone the code: + +https://github.com/NGEET/fates-clm From 354767cf1337f7c4cecbc45c94eff0883be64f1e Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 3 May 2017 11:55:04 -0700 Subject: [PATCH 404/437] Migrated surfprof_exp to a local in flux_into_litter_pools --- biogeochem/EDPhysiologyMod.F90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index fefcc4cb..6191609c 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1334,7 +1334,6 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) use EDTypesMod, only : numpft_ed use FatesInterfaceMod, only : hlm_numlevdecomp_full use FatesInterfaceMod, only : hlm_numlevdecomp - use SoilBiogeochemVerticalProfileMod, only: surfprof_exp use EDPftvarcon, only : EDPftvarcon_inst use FatesConstantsMod, only : sec_per_day use EDParamsMod, only : ED_val_ag_biomass @@ -1345,11 +1344,8 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) use EDParamsMod , only : ED_val_cwd_flig, ED_val_cwd_fcel - ! INTERF-TODO: remove the control parameters: exponential_rooting_profile, - ! pftspecific_rootingprofile, rootprof_exp, surfprof_exp - ! implicit none - ! + ! !ARGUMENTS integer , intent(in) :: nsites type(ed_site_type) , intent(inout), target :: sites(nsites) @@ -1383,6 +1379,10 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) real(r8), parameter :: rootprof_exp = 3. ! how steep profile is ! for root C inputs (1/ e-folding depth) (1/m) + ! NOTE(rgk, 201705) this parameter was brought over from SoilBiogeochemVerticalProfile + ! how steep profile is for surface components (1/ e_folding depth) (1/m) + real(r8), parameter :: surfprof_exp = 10. + ! NOTE(bja, 201608) as of clm4_5_10_r187 rootprof_beta is now a ! two dimensional array with the second dimension being water,1, ! or carbon,2,. These are currently hard coded, but may be From dbb35a1c5914948a8db3b9cfaf31c5df1765ea29 Mon Sep 17 00:00:00 2001 From: JKShuman Date: Wed, 17 May 2017 14:20:58 -0600 Subject: [PATCH 405/437] SF Wind Max for ROS Max wind speed added per Lasslop et al 2014 used to reduce ROS for high wind speeds. High Wind speed determined by data.After this high wind speed an alternate equation for effective wind speed is used for calculation of ROS. Debug statment added to track the conditional. User interface changes?: no code review: JKShuman Test suite: Full test suite for Ed and short for CLM 45, yellowstone, intel test namelist changes: none test answer changes: bit for bit with non-fire, (ed-clm-89081b8) fates-clm 9ee8751 test summary: bit for bit for non-fire answer changing for fire, as expected --- fire/SFMainMod.F90 | 94 +++++++++++++++++++++++++++------------------- 1 file changed, 55 insertions(+), 39 deletions(-) diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index b9b39037..680b16e6 100755 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -1,4 +1,4 @@ -module SFMainMod + module SFMainMod ! ============================================================================ ! All subroutines realted to the SPITFIRE fire routine. @@ -315,12 +315,13 @@ subroutine wind_effect ( currentSite, bc_in) type(ed_patch_type) , pointer :: currentPatch type(ed_cohort_type), pointer :: currentCohort - real(r8) :: wind ! daily wind in m/min - 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 - integer :: iofp ! index of oldest fates patch + real(r8) :: wind ! daily wind in m/min + 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 + integer :: iofp ! index of oldest fates patch + ! note - this is a patch level temperature, which probably won't have much inpact, ! unless we decide to ever calculated the NI for each patch. @@ -355,10 +356,10 @@ subroutine wind_effect ( currentSite, bc_in) grass_fraction = grass_fraction + min(currentPatch%area,total_grass_area)/AREA if(DEBUG)then - !write(fates_log(),*) 'SF currentPatch%area ',currentPatch%area - !write(fates_log(),*) 'SF currentPatch%total_area ',currentPatch%total_tree_area - !write(fates_log(),*) 'SF total_grass_area ',tree_fraction,grass_fraction - !write(fates_log(),*) 'SF AREA ',AREA + write(fates_log(),*) 'SF currentPatch%area ',currentPatch%area + write(fates_log(),*) 'SF currentPatch%total_area ',currentPatch%total_tree_area + write(fates_log(),*) 'SF total_grass_area ',tree_fraction,grass_fraction + write(fates_log(),*) 'SF AREA ',AREA endif currentPatch => currentPatch%younger @@ -392,32 +393,37 @@ subroutine rate_of_spread ( currentSite ) use SFParamsMod, only : SF_val_miner_total, SF_val_part_dens, & SF_val_miner_damp, SF_val_fuel_energy + use FatesInterfaceMod, only : hlm_current_day, hlm_current_month 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,beta_op !weighted average of packing ratio (unitless) real(r8) ir !reaction intensity (kJ/m2/min) real(r8) xi,eps,phi_wind !all are unitless real(r8) q_ig !heat of pre-ignition (kJ/kg) - real(r8) reaction_v_opt,reaction_v_max !reaction velocity (per min) + real(r8) reaction_v_opt,reaction_v_max !reaction velocity (per min)!optimum and maximum real(r8) moist_damp,mw_weight !moisture dampening coefficient and ratio fuel moisture to extinction - real(r8) bet !ratio of beta/beta_op - real(r8) a,b,c,e !function of fuel sav + real(r8) beta_ratio !ratio of beta/beta_op + real(r8) a_beta !dummy variable for product of a* beta_ratio for react_v_opt equation + real(r8) a,b,c,e !function of fuel sav + real(r8),parameter::wind_max = 45.718_r8 !max wind speed (m/min)=150 ft/min per Lasslop etal 2014 + real(r8) wind_elev_fire !wind speed (m/min) at elevevation relevant for fire + + logical,parameter :: debug_windspeed = .false. !for debugging 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 + beta_ratio = 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; reaction_v_max = 0.0_r8; reaction_v_opt = 0.0_r8; mw_weight = 0.0_r8 - moist_damp = 0.0_r8; ir = 0.0_r8; dummy = 0.0_r8; + moist_damp = 0.0_r8; ir = 0.0_r8; a_beta = 0.0_r8; currentPatch%ROS_front = 0.0_r8 + ! remove mineral content from net fuel load per Thonicke 2010 for ir calculation currentPatch%sum_fuel = currentPatch%sum_fuel * (1.0_r8 - SF_val_miner_total) !net of minerals @@ -430,16 +436,15 @@ subroutine rate_of_spread ( currentSite ) ! beta = packing ratio (unitless) ! fraction of fuel array volume occupied by fuel or compactness of fuel bed - beta = currentPatch%fuel_bulkd / SF_val_part_dens ! Equation A6 in Thonicke et al. 2010 ! packing ratio (unitless) beta_op = 0.200395_r8 *(currentPatch%fuel_sav**(-0.8189_r8)) - if ( hlm_masterproc == itrue .and.DEBUG) write(fates_log(),*) 'SF - beta ',beta - if ( hlm_masterproc == itrue .and.DEBUG) write(fates_log(),*) 'SF - beta_op ',beta_op - bet = beta/beta_op !unitless + if ( hlm_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - beta ',beta + if ( hlm_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - beta_op ',beta_op + beta_ratio = beta/beta_op !unitless if(write_sf == itrue)then if ( hlm_masterproc == itrue ) write(fates_log(),*) 'esf ',currentPatch%fuel_eff_moist @@ -462,37 +467,48 @@ subroutine rate_of_spread ( currentSite ) e = 0.715_r8 * (exp(-0.01094_r8 * currentPatch%fuel_sav)) if (DEBUG) then - if ( hlm_masterproc == itrue .and.DEBUG) write(fates_log(),*) 'SF - c ',c - if ( hlm_masterproc == itrue .and.DEBUG) write(fates_log(),*) & - 'SF - currentPatch%effect_wspeed ',currentPatch%effect_wspeed - if ( hlm_masterproc == itrue .and.DEBUG) write(fates_log(),*) 'SF - b ',b - if ( hlm_masterproc == itrue .and.DEBUG) write(fates_log(),*) 'SF - bet ',bet - if ( hlm_masterproc == itrue .and.DEBUG) write(fates_log(),*) 'SF - e ',e + if ( hlm_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - c ',c + if ( hlm_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - currentPatch%effect_wspeed ',currentPatch%effect_wspeed + if ( hlm_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - b ',b + if ( hlm_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - beta_ratio ',beta_ratio + if ( hlm_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - e ',e endif ! Equation A5 in Thonicke et al. 2010 - ! convert effect_wspeed from m/min to ft/min for Rothermel ROS eqn ! phi_wind (unitless) - phi_wind = c * ((3.281_r8*currentPatch%effect_wspeed)**b)*(bet**(-e)) + ! convert wind_elev_fire from m/min to ft/min for Rothermel ROS eqn + ! wind max per Lasslop et al 2014 to lenearly reduce ROS for high wind speeds + !OLD! phi_wind = c * ((3.281_r8*currentPatch%effect_wspeed)**b)*(beta_ratio**(-e)) + if (currentPatch%effect_wspeed .le. wind_max) then + wind_elev_fire = currentPatch%effect_wspeed + phi_wind = c * ((3.281_r8*wind_elev_fire)**b)*(beta_ratio**(-e)) + if (debug_windspeed) write(fates_log(),*) 'SF wind LESS max ', currentPatch%effect_wspeed + if (debug_windspeed) write(fates_log(),*) 'month and day', hlm_current_month, hlm_current_day + else + ! max conditional 225 ft/min from Lasslop 2014 converted to 68.577 m/min + wind_elev_fire = max(0.0_r8,(68.577-0.5*currentPatch%effect_wspeed)) + phi_wind = c * ((3.281_r8*wind_elev_fire)**b)*(beta_ratio**(-e)) + if (debug_windspeed) write(fates_log(),*) 'SF wind GREATER max ', currentPatch%effect_wspeed + if (debug_windspeed) write(fates_log(),*) 'month and day', hlm_current_month, hlm_current_day + endif ! ---propagating flux---- - ! Equation A2 in Thonicke et al. - ! xi (unitless) - + ! Equation A2 in Thonicke et al.2010 + ! xi (unitless) 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)) + a_beta = exp(a*(1-beta_ratio)) !dummy variable for reaction_v_opt equation + ! Equation in table A1 Thonicke et al. 2010. ! reaction_v_max and reaction_v_opt = reaction velocity in units of per min - - ! Equation 36 in Rothermal 1972 12 + ! reaction_v_max = Equation 36 in Rothermal 1972 and Fig 12 reaction_v_max = 1.0_r8 / (0.0591_r8 + 2.926_r8* (currentPatch%fuel_sav**(-1.5_r8))) - ! Equation 38 in Rothermal 1972 and Fig 11 - reaction_v_opt = reaction_v_max*(bet**a)*dummy + ! reaction_v_opt = Equation 38 in Rothermal 1972 and Fig 11 + reaction_v_opt = reaction_v_max*(beta_ratio**a)*a_beta ! mw_weight = relative fuel moisture/fuel moisture of extinction ! average values for litter pools (dead leaves, twigs, small and large branches) plus grass @@ -509,7 +525,7 @@ subroutine rate_of_spread ( currentSite ) ! endif ! ir = reaction intenisty in kJ/m2/min - ! currentPatch%sum_fuel needs to be converted from kgC/m2 to kgBiomass/m2 for ir calculation + ! currentPatch%sum_fuel converted from kgC/m2 to kgBiomass/m2 for ir calculation ir = reaction_v_opt*(currentPatch%sum_fuel/0.45_r8)*SF_val_fuel_energy*moist_damp*SF_val_miner_damp ! write(fates_log(),*) 'ir',gamma_aptr,moist_damp,SF_val_fuel_energy,SF_val_miner_damp From ceee36e88a0a63033da5b9d0117d311a72a049bd Mon Sep 17 00:00:00 2001 From: JKShuman Date: Thu, 18 May 2017 15:18:36 -0600 Subject: [PATCH 406/437] Update debug in Spitfire Update instances of "hlm_masterproc == 1" to hlm_masterproc == itrue" Fixes: none User interface changes? No Code review: jkshuman testing: none --- fire/SFMainMod.F90 | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index 680b16e6..796f671b 100755 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -442,8 +442,8 @@ subroutine rate_of_spread ( currentSite ) ! packing ratio (unitless) beta_op = 0.200395_r8 *(currentPatch%fuel_sav**(-0.8189_r8)) - if ( hlm_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - beta ',beta - if ( hlm_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - beta_op ',beta_op + if ( hlm_masterproc == itrue .and.DEBUG) write(fates_log(),*) 'SF - beta ',beta + if ( hlm_masterproc == itrue .and.DEBUG) write(fates_log(),*) 'SF - beta_op ',beta_op beta_ratio = beta/beta_op !unitless if(write_sf == itrue)then @@ -467,11 +467,11 @@ subroutine rate_of_spread ( currentSite ) e = 0.715_r8 * (exp(-0.01094_r8 * currentPatch%fuel_sav)) if (DEBUG) then - if ( hlm_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - c ',c - if ( hlm_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - currentPatch%effect_wspeed ',currentPatch%effect_wspeed - if ( hlm_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - b ',b - if ( hlm_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - beta_ratio ',beta_ratio - if ( hlm_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - e ',e + if ( hlm_masterproc == itrue .and.DEBUG) write(fates_log(),*) 'SF - c ',c + if ( hlm_masterproc == itrue .and.DEBUG) write(fates_log(),*) 'SF - currentPatch%effect_wspeed ',currentPatch%effect_wspeed + if ( hlm_masterproc == itrue .and.DEBUG) write(fates_log(),*) 'SF - b ',b + if ( hlm_masterproc == itrue .and.DEBUG) write(fates_log(),*) 'SF - beta_ratio ',beta_ratio + if ( hlm_masterproc == itrue .and.DEBUG) write(fates_log(),*) 'SF - e ',e endif ! Equation A5 in Thonicke et al. 2010 From 3b7f067f333d3dde7a51dcd74fc34a8ae6dabdb3 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 17 May 2017 20:25:31 -0400 Subject: [PATCH 407/437] Bug fixes. Fix to infinite fusion loop by allowing new recruites to fuse with each other. Added the ability of the c_area function to suppress large or small canopy layer indexes, as the function is called during the logic which promotes and demotes canopy layers, and is expected to have layers that are outside the expected range. Added cohort size and size-type indices to the copy cohort routine. Removed white-space changes from EDCanopystructure Split termination to allow the safe-math portion to be calculated prior to fusion. Removed the max(1,X) on canopy layer indices inside crown area calculations. Turning off cnaopy mortality carbonflux as a default as well. Turning off cnaopy mortality carbonflux as a default. --- biogeochem/EDCanopyStructureMod.F90 | 16 +- biogeochem/EDCohortDynamicsMod.F90 | 552 ++++++++++++++++------------ biogeochem/EDGrowthFunctionsMod.F90 | 17 +- biogeochem/EDPatchDynamicsMod.F90 | 16 +- biogeochem/EDPhysiologyMod.F90 | 1 - main/EDMainMod.F90 | 13 +- main/EDTypesMod.F90 | 4 +- main/FatesHistoryInterfaceMod.F90 | 4 +- 8 files changed, 362 insertions(+), 261 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index e4453a62..d042fa78 100755 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -383,10 +383,15 @@ subroutine canopy_structure( currentSite , bc_in ) enddo currentPatch%ncl_p = min(z,nclmax) - enddo !is there still excess area in any layer? + enddo !is there still excess area in any layer? + + ! Remove cohorts that are incredibly sparse + call terminate_cohorts(currentSite, currentPatch, 1) call fuse_cohorts(currentPatch, bc_in) - call terminate_cohorts(currentSite, currentPatch) + + ! Remove cohorts for various other reasons + call terminate_cohorts(currentSite, currentPatch, 2) ! ----------- Check cohort area ------------------------------! do i = 1,z @@ -605,8 +610,13 @@ subroutine canopy_structure( currentSite , bc_in ) endif enddo !is there still not enough canopy area in any layer? + ! remove cohorts that are extremely sparse + call terminate_cohorts(currentSite, currentPatch, 1) + call fuse_cohorts(currentPatch, bc_in) - call terminate_cohorts(currentSite, currentPatch) + + ! remove cohorts for various other reasons + call terminate_cohorts(currentSite, currentPatch, 2) if(promswitch == 1)then !write(fates_log(),*) 'going into cohort check' diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 0c6aaca1..feade648 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -117,7 +117,6 @@ subroutine create_cohort(patchptr, pft, nn, hite, dbh, & call sizetype_class_index(new_cohort%dbh,new_cohort%pft, & new_cohort%size_class,new_cohort%size_by_pft_class) - if ( DEBUG ) write(fates_log(),*) 'EDCohortDyn I ',bstore ! This routine may be called during restarts, and at this point in the call sequence ! the actual cohort data is unknown, as this is really only used for allocation @@ -476,7 +475,7 @@ subroutine zero_cohort(cc_p) currentcohort%resp_acc_hold = 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%year_net_uptake(:) = 999._r8 ! 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 @@ -500,7 +499,7 @@ subroutine zero_cohort(cc_p) end subroutine zero_cohort !-------------------------------------------------------------------------------------! - subroutine terminate_cohorts( currentSite, patchptr ) + subroutine terminate_cohorts( currentSite, patchptr, level ) ! ! !DESCRIPTION: ! terminates cohorts when they get too small @@ -512,6 +511,16 @@ subroutine terminate_cohorts( currentSite, patchptr ) ! !ARGUMENTS type (ed_site_type) , intent(inout), target :: currentSite type (ed_patch_type), intent(inout), target :: patchptr + integer , intent(in) :: level + + ! Important point regarding termination levels. Termination is typically + ! called after fusion. We do this so that we can re-capture the biomass that would + ! otherwise be lost from termination. The biomass of a fused plant remains in the + ! live pool. However, some plant number densities can be so low that they + ! can cause numerical instabilities. Thus, we call terminate_cohorts at level=1 + ! before fusion to get rid of these cohorts that are so incredibly sparse, and then + ! terminate the remainder at level 2 for various other reasons. + ! ! !LOCAL VARIABLES: type (ed_patch_type) , pointer :: currentPatch @@ -529,16 +538,16 @@ subroutine terminate_cohorts( currentSite, patchptr ) nextc => currentCohort%shorter terminate = 0 - ! Check if number density is so low is breaks math - if (currentcohort%n < min_n_safemath) then + ! Check if number density is so low is breaks math (level 1) + if (currentcohort%n < min_n_safemath .and. level == 1) then terminate = 1 if ( DEBUG ) then write(fates_log(),*) 'terminating cohorts 0',currentCohort%n/currentPatch%area,currentCohort%dbh endif endif - ! The rest of these are only allowed if we are not dealing with a recruit - if (.not.currentCohort%isnew) then + ! The rest of these are only allowed if we are not dealing with a recruit (level 2) + if (.not.currentCohort%isnew .and. level == 2) then ! Not enough n or dbh if (currentCohort%n/currentPatch%area <= min_npm2 .or. & ! @@ -577,10 +586,10 @@ subroutine terminate_cohorts( currentSite, patchptr ) currentCohort%bstore, currentCohort%n endif - endif - endif + endif + endif ! if (.not.currentCohort%isnew .and. level == 2) then - if (terminate == 1) then + if (terminate == 1) then ! preserve a record of the to-be-terminated cohort for mortality accounting if (currentCohort%canopy_layer .eq. 1) then levcan = 1 @@ -649,244 +658,297 @@ end subroutine terminate_cohorts !-------------------------------------------------------------------------------------! subroutine fuse_cohorts(patchptr, bc_in) - ! - ! !DESCRIPTION: - ! Join similar cohorts to reduce total number - ! - ! !USES: - use EDTypesMod , only : nlevleaf - use EDParamsMod , only : ED_val_cohort_fusion_tol - ! - ! !ARGUMENTS - type (ed_patch_type), intent(inout), target :: patchptr - type (bc_in_type), intent(in) :: bc_in - ! - ! !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 = ED_val_cohort_fusion_tol - - !This needs to be a function of the canopy layer, because otherwise, at canopy closure - !the number of cohorts doubles and very dissimilar cohorts are fused together - !because c_area and biomass are non-linear with dbh, this causes several mass inconsistancies - !in theory, all of this routine therefore causes minor losses of C and area, but these are below - !detection limit normally. - iterate = 1 - fusion_took_place = 0 - currentPatch => patchptr - maxcohorts = maxCohortsPerPatch - - !---------------------------------------------------------------------! - ! Keep doing this until nocohorts <= maxcohorts ! - !---------------------------------------------------------------------! - if (associated(currentPatch%shortest)) then - do while(iterate == 1) - - currentCohort => currentPatch%tallest - - ! The following logic continues the loop while the current cohort is not the shortest cohort - ! if they point to the same target (ie equivalence), then the loop ends. - ! This loop is different than the simple "continue while associated" loop in that - ! it omits the last cohort (because it has already been compared by that point) - - do while ( .not.associated(currentCohort,currentPatch%shortest) ) - - nextc => currentPatch%tallest - - do while (associated(nextc)) - nextnextc => nextc%shorter - diff = abs((currentCohort%dbh - nextc%dbh)/(0.5*(currentCohort%dbh + nextc%dbh))) - - !Criteria used to divide up the height continuum into different cohorts. - - if (diff < dynamic_fusion_tolerance) then - - ! Don't fuse a cohort with itself! - if (.not.associated(currentCohort,nextc) ) then - - if (currentCohort%pft == nextc%pft) then - - ! check cohorts in same c. layer. before fusing - - if (currentCohort%canopy_layer == nextc%canopy_layer) then - - ! Note: because newly recruited cohorts that have not experienced - ! a day yet will have un-known flux quantities or change rates - ! we don't want them fusing with non-new cohorts. We allow them - ! to fuse with other new cohorts to keep the total number of cohorts - ! down. - - if( .not.(currentCohort%isnew) .and. .not.(nextc%isnew) ) then - - newn = currentCohort%n + nextc%n - fusion_took_place = 1 - - - currentCohort%balive = (currentCohort%n*currentCohort%balive + nextc%n*nextc%balive)/newn - currentCohort%bdead = (currentCohort%n*currentCohort%bdead + nextc%n*nextc%bdead)/newn - - if ( DEBUG ) write(fates_log(),*) 'EDcohortDyn I ',currentCohort%bstore - - currentCohort%bstore = (currentCohort%n*currentCohort%bstore + nextc%n*nextc%bstore)/newn - - if ( DEBUG ) write(fates_log(),*) 'EDcohortDyn II ',currentCohort%bstore - - 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 - - if ( DEBUG ) write(fates_log(),*) 'EDcohortDyn 569 ',currentCohort%br - if ( DEBUG ) write(fates_log(),*) 'EDcohortDyn 570 ',currentCohort%n - if ( DEBUG ) write(fates_log(),*) 'EDcohortDyn 571 ',nextc%br - if ( DEBUG ) write(fates_log(),*) 'EDcohortDyn 572 ',nextc%n - - 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 - - if ( DEBUG ) write(fates_log(),*) 'EDcohortDyn III ',currentCohort%npp_acc - if ( DEBUG ) write(fates_log(),*) 'EDcohortDyn IV ',currentCohort%resp_acc - - 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 - - if ( DEBUG ) write(fates_log(),*) 'EDcohortDyn V ',currentCohort%npp_acc - if ( DEBUG ) write(fates_log(),*) 'EDcohortDyn VI ',currentCohort%resp_acc - - currentCohort%resp_acc_hold = & - (currentCohort%n*currentCohort%resp_acc_hold + & - nextc%n*nextc%resp_acc_hold)/newn - currentCohort%npp_acc_hold = & - (currentCohort%n*currentCohort%npp_acc_hold + & - nextc%n*nextc%npp_acc_hold)/newn - currentCohort%gpp_acc_hold = & - (currentCohort%n*currentCohort%gpp_acc_hold + & - nextc%n*nextc%gpp_acc_hold)/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 - - ! mortality diagnostics - currentCohort%cmort = (currentCohort%n*currentCohort%cmort + nextc%n*nextc%cmort)/newn - currentCohort%hmort = (currentCohort%n*currentCohort%hmort + nextc%n*nextc%hmort)/newn - currentCohort%bmort = (currentCohort%n*currentCohort%bmort + nextc%n*nextc%bmort)/newn - currentCohort%imort = (currentCohort%n*currentCohort%imort + nextc%n*nextc%imort)/newn - currentCohort%fmort = (currentCohort%n*currentCohort%fmort + nextc%n*nextc%fmort)/newn - - ! npp diagnostics - currentCohort%npp_leaf = (currentCohort%n*currentCohort%npp_leaf + nextc%n*nextc%npp_leaf)/newn - currentCohort%npp_froot = (currentCohort%n*currentCohort%npp_froot + nextc%n*nextc%npp_froot)/newn - currentCohort%npp_bsw = (currentCohort%n*currentCohort%npp_bsw + nextc%n*nextc%npp_bsw)/newn - currentCohort%npp_bdead = (currentCohort%n*currentCohort%npp_bdead + nextc%n*nextc%npp_bdead)/newn - currentCohort%npp_bseed = (currentCohort%n*currentCohort%npp_bseed + nextc%n*nextc%npp_bseed)/newn - currentCohort%npp_store = (currentCohort%n*currentCohort%npp_store + nextc%n*nextc%npp_store)/newn - - ! recent canopy history - currentCohort%canopy_layer_yesterday = (currentCohort%n*currentCohort%canopy_layer_yesterday + & - nextc%n*nextc%canopy_layer_yesterday)/newn - - do i=1, nlevleaf - 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 - - if(use_fates_plant_hydro) call FuseCohortHydraulics(currentCohort,nextc,bc_in,newn) - - 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 - if(use_fates_plant_hydro) call DeallocateHydrCohort(nextc) - deallocate(nextc) - endif - - endif ! Not a recruit - - 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 - !---------------------------------------------------------------------! - ! Making profile tolerance larger means that more fusion will happen ! - !---------------------------------------------------------------------! - dynamic_fusion_tolerance = dynamic_fusion_tolerance * 1.1_r8 - - write(fates_log(),*) 'maxcohorts exceeded',dynamic_fusion_tolerance + ! + ! !DESCRIPTION: + ! Join similar cohorts to reduce total number + ! + ! !USES: + use EDTypesMod , only : nlevleaf + use EDParamsMod , only : ED_val_cohort_fusion_tol + use shr_infnan_mod, only : nan => shr_infnan_nan, assignment(=) + ! + ! !ARGUMENTS + type (ed_patch_type), intent(inout), target :: patchptr + type (bc_in_type), intent(in) :: bc_in + ! + ! !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 + + logical, parameter :: FUSE_DEBUG = .false. ! This debug is over-verbose + ! and gets its own flag + + !---------------------------------------------------------------------- + + !set initial fusion tolerance + dynamic_fusion_tolerance = ED_val_cohort_fusion_tol + + !This needs to be a function of the canopy layer, because otherwise, at canopy closure + !the number of cohorts doubles and very dissimilar cohorts are fused together + !because c_area and biomass are non-linear with dbh, this causes several mass inconsistancies + !in theory, all of this routine therefore causes minor losses of C and area, but these are below + !detection limit normally. + iterate = 1 + fusion_took_place = 0 + currentPatch => patchptr + maxcohorts = maxCohortsPerPatch + + !---------------------------------------------------------------------! + ! Keep doing this until nocohorts <= maxcohorts ! + !---------------------------------------------------------------------! + + if (associated(currentPatch%shortest)) then + do while(iterate == 1) + + currentCohort => currentPatch%tallest + + ! The following logic continues the loop while the current cohort is not the shortest cohort + ! if they point to the same target (ie equivalence), then the loop ends. + ! This loop is different than the simple "continue while associated" loop in that + ! it omits the last cohort (because it has already been compared by that point) + + do while ( .not.associated(currentCohort,currentPatch%shortest) ) + + nextc => currentPatch%tallest + + do while (associated(nextc)) + nextnextc => nextc%shorter + diff = abs((currentCohort%dbh - nextc%dbh)/(0.5*(currentCohort%dbh + nextc%dbh))) + + !Criteria used to divide up the height continuum into different cohorts. + + if (diff < dynamic_fusion_tolerance) then + + ! Don't fuse a cohort with itself! + if (.not.associated(currentCohort,nextc) ) then + + if (currentCohort%pft == nextc%pft) then + + ! check cohorts in same c. layer. before fusing + + if (currentCohort%canopy_layer == nextc%canopy_layer) then + + ! Note: because newly recruited cohorts that have not experienced + ! a day yet will have un-known flux quantities or change rates + ! we don't want them fusing with non-new cohorts. We allow them + ! to fuse with other new cohorts to keep the total number of cohorts + ! down. + + if( currentCohort%isnew.eqv.nextc%isnew ) then + + newn = currentCohort%n + nextc%n + fusion_took_place = 1 + + if ( FUSE_DEBUG .and. currentCohort%isnew ) then + write(fates_log(),*) 'Fusing Two Cohorts' + write(fates_log(),*) 'newn: ',newn + write(fates_log(),*) 'Cohort I, Cohort II' + write(fates_log(),*) 'n:',currentCohort%n,nextc%n + write(fates_log(),*) 'isnew:',currentCohort%isnew,nextc%isnew + write(fates_log(),*) 'balive:',currentCohort%balive,nextc%balive + write(fates_log(),*) 'bdead:',currentCohort%bdead,nextc%bdead + write(fates_log(),*) 'bstore:',currentCohort%bstore,nextc%bstore + write(fates_log(),*) 'laimemory:',currentCohort%laimemory,nextc%laimemory + write(fates_log(),*) 'b:',currentCohort%b,nextc%b + write(fates_log(),*) 'bsw:',currentCohort%bsw,nextc%bsw + write(fates_log(),*) 'bl:',currentCohort%bl ,nextc%bl + write(fates_log(),*) 'br:',currentCohort%br,nextc%br + write(fates_log(),*) 'hite:',currentCohort%hite,nextc%hite + write(fates_log(),*) 'dbh:',currentCohort%dbh,nextc%dbh + write(fates_log(),*) 'pft:',currentCohort%pft,nextc%pft + write(fates_log(),*) 'canopy_trim:',currentCohort%canopy_trim,nextc%canopy_trim + write(fates_log(),*) 'canopy_layer_yesterday:', & + currentCohort%canopy_layer_yesterday,nextc%canopy_layer_yesterday + do i=1, nlevleaf + write(fates_log(),*) 'leaf level: ',i,'year_net_uptake', & + currentCohort%year_net_uptake(i),nextc%year_net_uptake(i) + end do + end if + + 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%laimemory = (currentCohort%n*currentCohort%laimemory & + + nextc%n*nextc%laimemory)/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%canopy_trim = (currentCohort%n*currentCohort%canopy_trim & + + nextc%n*nextc%canopy_trim)/newn + + call sizetype_class_index(currentCohort%dbh,currentCohort%pft, & + currentCohort%size_class,currentCohort%size_by_pft_class) + + if(use_fates_plant_hydro) call FuseCohortHydraulics(currentCohort,nextc,bc_in,newn) + + ! recent canopy history + currentCohort%canopy_layer_yesterday = (currentCohort%n*currentCohort%canopy_layer_yesterday + & + nextc%n*nextc%canopy_layer_yesterday)/newn + + ! Flux and biophysics variables have not been calculated for recruits we just default to + ! their initization values, which should be the same for eahc + + if ( .not.currentCohort%isnew) then + + currentCohort%md = (currentCohort%n*currentCohort%md + & + nextc%n*nextc%md)/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%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%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_acc_hold = & + (currentCohort%n*currentCohort%resp_acc_hold + & + nextc%n*nextc%resp_acc_hold)/newn + currentCohort%npp_acc_hold = & + (currentCohort%n*currentCohort%npp_acc_hold + & + nextc%n*nextc%npp_acc_hold)/newn + currentCohort%gpp_acc_hold = & + (currentCohort%n*currentCohort%gpp_acc_hold + & + nextc%n*nextc%gpp_acc_hold)/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 + + ! mortality diagnostics + currentCohort%cmort = (currentCohort%n*currentCohort%cmort + nextc%n*nextc%cmort)/newn + currentCohort%hmort = (currentCohort%n*currentCohort%hmort + nextc%n*nextc%hmort)/newn + currentCohort%bmort = (currentCohort%n*currentCohort%bmort + nextc%n*nextc%bmort)/newn + currentCohort%imort = (currentCohort%n*currentCohort%imort + nextc%n*nextc%imort)/newn + currentCohort%fmort = (currentCohort%n*currentCohort%fmort + nextc%n*nextc%fmort)/newn + + ! npp diagnostics + currentCohort%npp_leaf = (currentCohort%n*currentCohort%npp_leaf + nextc%n*nextc%npp_leaf)/newn + currentCohort%npp_froot = (currentCohort%n*currentCohort%npp_froot + nextc%n*nextc%npp_froot)/newn + currentCohort%npp_bsw = (currentCohort%n*currentCohort%npp_bsw + nextc%n*nextc%npp_bsw)/newn + currentCohort%npp_bdead = (currentCohort%n*currentCohort%npp_bdead + nextc%n*nextc%npp_bdead)/newn + currentCohort%npp_bseed = (currentCohort%n*currentCohort%npp_bseed + nextc%n*nextc%npp_bseed)/newn + currentCohort%npp_store = (currentCohort%n*currentCohort%npp_store + nextc%n*nextc%npp_store)/newn + + do i=1, nlevleaf + 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 + + end if !(currentCohort%isnew) + + 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 + if(use_fates_plant_hydro) call DeallocateHydrCohort(nextc) + deallocate(nextc) + endif + + endif ! if( currentCohort%isnew.eqv.nextc%isnew ) then + + 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 + !---------------------------------------------------------------------! + ! Making profile tolerance larger means that more fusion will happen ! + !---------------------------------------------------------------------! + dynamic_fusion_tolerance = dynamic_fusion_tolerance * 1.1_r8 + + write(fates_log(),*) 'maxcohorts exceeded',dynamic_fusion_tolerance + + else + iterate = 0 + endif - else - iterate = 0 - endif + if ( dynamic_fusion_tolerance .gt. 100._r8) then + ! something has gone terribly wrong and we need to report what + write(fates_log(),*) 'exceeded reasonable expectation of cohort fusion.' + currentCohort => currentPatch%tallest + nocohorts = 0 + do while(associated(currentCohort)) + write(fates_log(),*) 'cohort ', nocohorts, currentCohort%dbh, currentCohort%canopy_layer, currentCohort%n + nocohorts = nocohorts + 1 + currentCohort => currentCohort%shorter + enddo + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif - enddo !do while nocohorts>maxcohorts + enddo !do while nocohorts>maxcohorts - endif ! patch. + endif ! patch. - if (fusion_took_place == 1) then ! if fusion(s) occured sort cohorts - call sort_cohorts(currentPatch) - endif + if (fusion_took_place == 1) then ! if fusion(s) occured sort cohorts + call sort_cohorts(currentPatch) + endif end subroutine fuse_cohorts @@ -1099,6 +1161,8 @@ subroutine copy_cohort( currentCohort,copyc ) n%status_coh = o%status_coh n%excl_weight = o%excl_weight n%prom_weight = o%prom_weight + n%size_class = o%size_class + n%size_by_pft_class = o%size_by_pft_class ! CARBON FLUXES n%gpp_acc_hold = o%gpp_acc_hold diff --git a/biogeochem/EDGrowthFunctionsMod.F90 b/biogeochem/EDGrowthFunctionsMod.F90 index f0c081c8..e0abb086 100755 --- a/biogeochem/EDGrowthFunctionsMod.F90 +++ b/biogeochem/EDGrowthFunctionsMod.F90 @@ -225,11 +225,13 @@ real(r8) function c_area( cohort_in ) ! ============================================================================ use EDParamsMod , only : ED_val_grass_spread + use EDTypesMod , only : nclmax type(ed_cohort_type), intent(in) :: cohort_in real(r8) :: dbh ! Tree diameter at breat height. cm. real(r8) :: crown_area_to_dbh_exponent + integer :: can_layer_index ! default is to use the same exponent as the dbh to bleaf exponent so that per-plant canopy depth remains invariant during growth, ! but allowed to vary via the dbh2bl_dbh2carea_expnt_diff term (which has default value of zero) @@ -247,9 +249,22 @@ real(r8) function c_area( cohort_in ) end if dbh = min(cohort_in%dbh,EDPftvarcon_inst%max_dbh(cohort_in%pft)) + + ! ---------------------------------------------------------------------------------- + ! The function c_area is called during the process of canopy position demotion + ! and promotion. As such, some cohorts are temporarily elevated to canopy positions + ! that are outside the number of alloted canopy spaces. Ie, a two story canopy + ! may have a third-story plant, if only for a moment. However, these plants + ! still need to generate a crown area to complete the promotion, demotion process. + ! So we allow layer index exceedence here and force it down to max. + ! (rgk/cdk 05/2017) + ! ---------------------------------------------------------------------------------- + + can_layer_index = min(cohort_in%canopy_layer,nclmax) + if(EDPftvarcon_inst%woody(cohort_in%pft) == 1)then c_area = 3.142_r8 * cohort_in%n * & - (cohort_in%patchptr%spread(cohort_in%canopy_layer)*dbh)**crown_area_to_dbh_exponent + (cohort_in%patchptr%spread(can_layer_index)*dbh)**crown_area_to_dbh_exponent else c_area = 3.142_r8 * cohort_in%n * (ED_val_grass_spread*dbh)**crown_area_to_dbh_exponent end if diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 428ac6ca..3bfa11f8 100755 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -401,10 +401,13 @@ subroutine spawn_patches( currentSite, bc_in) !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. - + ! sort out the cohorts, since some of them may be so small as to need removing. + ! the first call to terminate cohorts removes sparse number densities, + ! the second call removes for all other reasons (sparse culling must happen + ! before fusion) + call terminate_cohorts(currentSite, currentPatch, 1) call fuse_cohorts(currentPatch, bc_in) - call terminate_cohorts(currentSite, currentPatch) + call terminate_cohorts(currentSite, currentPatch, 2) call sort_cohorts(currentPatch) currentPatch => currentPatch%younger @@ -420,8 +423,13 @@ subroutine spawn_patches( currentSite, bc_in) currentPatch%younger => new_patch currentSite%youngest_patch => new_patch + ! sort out the cohorts, since some of them may be so small as to need removing. + ! the first call to terminate cohorts removes sparse number densities, + ! the second call removes for all other reasons (sparse culling must happen + ! before fusion) + call terminate_cohorts(currentSite, new_patch, 1) call fuse_cohorts(new_patch, bc_in) - call terminate_cohorts(currentSite, new_patch) + call terminate_cohorts(currentSite, new_patch, 2) call sort_cohorts(new_patch) endif !end new_patch area diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 6191609c..e6229de8 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -874,7 +874,6 @@ subroutine Growth_Derivatives( currentSite, currentCohort, bc_in) currentCohort%npp_froot = max(0.0_r8,min(currentCohort%npp_acc_hold*currentCohort%root_md/currentCohort%md, & currentCohort%root_md*EDecophyscon%leaf_stor_priority(currentCohort%pft))) - if (Bleaf(currentCohort) > 0._r8)then if ( DEBUG ) write(fates_log(),*) 'EDphys A ',currentCohort%carbon_balance diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index a44de0b5..4ab507ef 100755 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -147,12 +147,15 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) ! puts cohorts in right order call sort_cohorts(currentPatch) - + + ! kills cohorts that are too few + call terminate_cohorts(currentSite, currentPatch, 1) + ! fuses similar cohorts call fuse_cohorts(currentPatch, bc_in ) - ! kills cohorts that are too small - call terminate_cohorts(currentSite, currentPatch) + ! kills cohorts for various other reasons + call terminate_cohorts(currentSite, currentPatch, 2) currentPatch => currentPatch%younger @@ -403,7 +406,9 @@ subroutine ed_update_site( currentSite, bc_in ) currentPatch => currentSite%oldest_patch do while(associated(currentPatch)) - call terminate_cohorts(currentSite, currentPatch) + ! Is termination really needed here? canopy_structure just called it several times! (rgk) + call terminate_cohorts(currentSite, currentPatch, 1) + call terminate_cohorts(currentSite, currentPatch, 2) ! FIX(SPM,040314) why is this needed for BFB restarts? Look into this at some point cohort_number = count_cohorts(currentPatch) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 9ebefb8a..386bce8b 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -97,8 +97,8 @@ module EDTypesMod real(r8), parameter :: min_patch_area = 0.001_r8 ! smallest allowable patch area before termination real(r8), parameter :: min_nppatch = 1.0E-11_r8 ! minimum number of cohorts per patch (min_npm2*min_patch_area) real(r8), parameter :: min_n_safemath = 1.0E-15_r8 ! in some cases, we want to immediately remove super small - ! number densities of cohorts to prevent FPEs, this is usually - ! just relevant in the first day after recruitment + ! number densities of cohorts to prevent FPEs + character*4 yearchar ! special mode to cause PFTs to create seed mass of all currently-existing PFTs diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 4d0a6a04..ff26b42b 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -2818,12 +2818,12 @@ subroutine define_history_vars(this, initialize_variables) upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_promotion_carbonflux_si ) call this%set_history_var(vname='MORTALITY_CARBONFLUX_CANOPY', units = 'gC/m2/s', & - long='flux of biomass carbon from live to dead pools from mortality of canopy plants', use_default='active', & + long='flux of biomass carbon from live to dead pools from mortality of canopy plants', use_default='inactive', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_canopy_mortality_carbonflux_si ) call this%set_history_var(vname='MORTALITY_CARBONFLUX_UNDERSTORY', units = 'gC/m2/s', & - long='flux of biomass carbon from live to dead pools from mortality of understory plants', use_default='active', & + long='flux of biomass carbon from live to dead pools from mortality of understory plants',use_default='inactive',& avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_understory_mortality_carbonflux_si ) From 4e8c18cea4f2d6fc468eca7bbc5120ab234af37c Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Wed, 10 May 2017 09:39:50 -0700 Subject: [PATCH 408/437] added new diagnostics on canopy trim as resolved by size and canopy level, as well as total crown area on same dimensions so that it can be used as denominator in carbon budgets to normalize across size classes fixed variable names on prior fixed dimension multiplexing on SCAG (size-class x age) dimension fixed unit error on CROWN_AREA_CANOPY_SCLS and CROWN_AREA_UNDERSTORY_SCLS adding diagnostics on canopy- and leaf-layered carbon balance and structure reorganized some of the diagnostics and turned on the gpp_understory field as default bugfix on history updating for two new fields --- main/EDTypesMod.F90 | 2 +- main/FatesHistoryInterfaceMod.F90 | 95 ++++++++++++++++++++++++++++++- 2 files changed, 95 insertions(+), 2 deletions(-) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 9ebefb8a..785e6cbd 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -704,7 +704,7 @@ function get_sizeage_class_index(dbh,age) result(size_by_age_class) age_class = get_age_class_index(age) - size_by_age_class = (age_class-1)*nlevage_ed + size_class + size_by_age_class = (age_class-1)*nlevsclass_ed + size_class end function get_sizeage_class_index diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 4d0a6a04..50c48363 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -165,6 +165,10 @@ module FatesHistoryInterfaceMod integer, private :: ih_mortality_understory_si_scls integer, private :: ih_demotion_rate_si_scls integer, private :: ih_promotion_rate_si_scls + integer, private :: ih_trimming_canopy_si_scls + integer, private :: ih_trimming_understory_si_scls + integer, private :: ih_crown_area_canopy_si_scls + integer, private :: ih_crown_area_understory_si_scls ! lots of non-default diagnostics for understanding canopy versus understory carbon balances integer, private :: ih_rdark_canopy_si_scls @@ -279,6 +283,10 @@ module FatesHistoryInterfaceMod integer, private :: ih_fabd_sha_si_cnlf integer, private :: ih_fabi_sun_si_cnlf integer, private :: ih_fabi_sha_si_cnlf + integer, private :: ih_ts_net_uptake_si_cnlf + integer, private :: ih_year_net_uptake_si_cnlf + integer, private :: ih_crownarea_si_cnlf + ! indices to (site x [canopy layer x leaf layer x pft]) variables integer, private :: ih_parsun_z_si_cnlfpft @@ -299,6 +307,7 @@ module FatesHistoryInterfaceMod integer, private :: ih_fabd_sha_top_si_can integer, private :: ih_fabi_sun_top_si_can integer, private :: ih_fabi_sha_top_si_can + integer, private :: ih_crownarea_si_can ! The number of variable dim/kind types we have defined (static) integer, parameter :: fates_history_num_dimensions = 13 @@ -1086,6 +1095,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) use EDParamsMod , only : ED_val_ag_biomass use EDTypesMod , only : get_sizeage_class_index + use EDTypesMod , only : nlevleaf ! Arguments class(fates_history_interface_type) :: this @@ -1106,6 +1116,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) integer :: i_scpf,i_pft,i_scls ! iterators for scpf, pft, and scls dims integer :: i_cwd,i_fuel ! iterators for cwd and fuel dims integer :: iscag ! size-class x age index + integer :: ican, ileaf, cnlf_indx ! iterators for leaf and canopy level real(r8) :: n_density ! individual of cohort per m2. real(r8) :: n_perm2 ! individuals per m2 for the whole column @@ -1196,6 +1207,10 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_demotion_rate_si_scls => this%hvars(ih_demotion_rate_si_scls)%r82d, & hio_demotion_carbonflux_si => this%hvars(ih_demotion_carbonflux_si)%r81d, & hio_promotion_rate_si_scls => this%hvars(ih_promotion_rate_si_scls)%r82d, & + hio_trimming_canopy_si_scls => this%hvars(ih_trimming_canopy_si_scls)%r82d, & + hio_trimming_understory_si_scls => this%hvars(ih_trimming_understory_si_scls)%r82d, & + hio_crown_area_canopy_si_scls => this%hvars(ih_crown_area_canopy_si_scls)%r82d, & + hio_crown_area_understory_si_scls => this%hvars(ih_crown_area_understory_si_scls)%r82d, & hio_promotion_carbonflux_si => this%hvars(ih_promotion_carbonflux_si)%r81d, & hio_canopy_mortality_carbonflux_si => this%hvars(ih_canopy_mortality_carbonflux_si)%r81d, & hio_understory_mortality_carbonflux_si => this%hvars(ih_understory_mortality_carbonflux_si)%r81d, & @@ -1241,6 +1256,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_cwd_bg_in_si_cwdsc => this%hvars(ih_cwd_bg_in_si_cwdsc)%r82d, & hio_cwd_ag_out_si_cwdsc => this%hvars(ih_cwd_ag_out_si_cwdsc)%r82d, & hio_cwd_bg_out_si_cwdsc => this%hvars(ih_cwd_bg_out_si_cwdsc)%r82d, & + hio_crownarea_si_cnlf => this%hvars(ih_crownarea_si_cnlf)%r82d, & + hio_crownarea_si_can => this%hvars(ih_crownarea_si_can)%r82d, & hio_nplant_si_scag => this%hvars(ih_nplant_si_scag)%r82d) @@ -1442,6 +1459,10 @@ subroutine update_history_dyn(this,nc,nsites,sites) (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%imort + ccohort%fmort) * ccohort%n hio_nplant_canopy_si_scpf(io_si,scpf) = hio_nplant_canopy_si_scpf(io_si,scpf) + ccohort%n hio_nplant_canopy_si_scls(io_si,scls) = hio_nplant_canopy_si_scls(io_si,scls) + ccohort%n + hio_trimming_canopy_si_scls(io_si,scls) = hio_trimming_canopy_si_scls(io_si,scls) + & + ccohort%n * ccohort%canopy_trim + hio_crown_area_canopy_si_scls(io_si,scls) = hio_crown_area_canopy_si_scls(io_si,scls) + & + ccohort%c_area hio_gpp_canopy_si_scpf(io_si,scpf) = hio_gpp_canopy_si_scpf(io_si,scpf) + & n_perm2*ccohort%gpp_acc_hold hio_ar_canopy_si_scpf(io_si,scpf) = hio_ar_canopy_si_scpf(io_si,scpf) + & @@ -1497,6 +1518,10 @@ subroutine update_history_dyn(this,nc,nsites,sites) (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%imort + ccohort%fmort) * ccohort%n hio_nplant_understory_si_scpf(io_si,scpf) = hio_nplant_understory_si_scpf(io_si,scpf) + ccohort%n hio_nplant_understory_si_scls(io_si,scls) = hio_nplant_understory_si_scls(io_si,scls) + ccohort%n + hio_trimming_understory_si_scls(io_si,scls) = hio_trimming_understory_si_scls(io_si,scls) + & + ccohort%n * ccohort%canopy_trim + hio_crown_area_understory_si_scls(io_si,scls) = hio_crown_area_understory_si_scls(io_si,scls) + & + ccohort%c_area hio_gpp_understory_si_scpf(io_si,scpf) = hio_gpp_understory_si_scpf(io_si,scpf) + & n_perm2*ccohort%gpp_acc_hold hio_ar_understory_si_scpf(io_si,scpf) = hio_ar_understory_si_scpf(io_si,scpf) + & @@ -1548,6 +1573,17 @@ subroutine update_history_dyn(this,nc,nsites,sites) end associate end if + + ! resolve some canopy area profiles, both total and of occupied leaves + ican = ccohort%canopy_layer + ! + hio_crownarea_si_can(io_si, ican) = hio_crownarea_si_can(io_si, ican) + ccohort%c_area / AREA + ! + do ileaf=1,ccohort%nv + cnlf_indx = ileaf + (ican-1) * nlevleaf + hio_crownarea_si_cnlf(io_si, cnlf_indx) = hio_crownarea_si_cnlf(io_si, cnlf_indx) + & + ccohort%c_area / AREA + end do ccohort => ccohort%taller enddo ! cohort loop @@ -1791,6 +1827,8 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) hio_npp_si_age => this%hvars(ih_npp_si_age)%r82d, & hio_parsun_z_si_cnlf => this%hvars(ih_parsun_z_si_cnlf)%r82d, & hio_parsha_z_si_cnlf => this%hvars(ih_parsha_z_si_cnlf)%r82d, & + hio_ts_net_uptake_si_cnlf => this%hvars(ih_ts_net_uptake_si_cnlf)%r82d, & + hio_year_net_uptake_si_cnlf => this%hvars(ih_year_net_uptake_si_cnlf)%r82d, & hio_parsun_z_si_cnlfpft => this%hvars(ih_parsun_z_si_cnlfpft)%r82d, & hio_parsha_z_si_cnlfpft => this%hvars(ih_parsha_z_si_cnlfpft)%r82d, & hio_laisun_z_si_cnlf => this%hvars(ih_laisun_z_si_cnlf)%r82d, & @@ -1948,6 +1986,16 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) end associate endif + !!! resolve some canopy profile terms that are also on the cohort indices + ican = ccohort%canopy_layer + do ileaf=1,ccohort%nv + cnlf_indx = ileaf + (ican-1) * nlevleaf + hio_ts_net_uptake_si_cnlf(io_si, cnlf_indx) = hio_ts_net_uptake_si_cnlf(io_si, cnlf_indx) + & + ccohort%ts_net_uptake(ileaf) * ccohort%c_area / AREA + hio_year_net_uptake_si_cnlf(io_si, cnlf_indx) = hio_year_net_uptake_si_cnlf(io_si, cnlf_indx) + & + ccohort%year_net_uptake(ileaf) * ccohort%c_area / AREA + end do + ccohort => ccohort%taller enddo ! cohort loop @@ -2651,7 +2699,7 @@ subroutine define_history_vars(this, initialize_variables) ivar=ivar, initialize=initialize_variables, index = ih_ar_canopy_pa ) call this%set_history_var(vname='GPP_UNDERSTORY', units='gC/m^2/s', & - long='gross primary production of understory plants', use_default='inactive', & + long='gross primary production of understory plants', use_default='active', & avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & ivar=ivar, initialize=initialize_variables, index = ih_gpp_understory_pa ) @@ -2806,6 +2854,31 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_can_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & ivar=ivar, initialize=initialize_variables, index = ih_fabi_sha_top_si_can ) + !!! canopy-resolved fluxes and structure + call this%set_history_var(vname='TS_NET_UPTAKE_CNLF', units='kgC/m2/s', & + long='net carbon uptake by each canopy and leaf layer er unit ground area (i.e. divide by CROWNAREA_CNLF)', & + use_default='inactive', & + avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_ts_net_uptake_si_cnlf ) + + call this%set_history_var(vname='YEAR_NET_UPTAKE_CNLF', units='kgC/m2/y', & + long='yearly net carbon uptake by each canopy and leaf layer per unit ground area (i.e. divide by CROWNAREA_CNLF)', & + use_default='inactive', & + avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_year_net_uptake_si_cnlf ) + + call this%set_history_var(vname='CROWNAREA_CNLF', units='m2/m2', & + long='total crown area that is occupied by leaves in each canopy and leaf layer', & + use_default='inactive', & + avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_crownarea_si_cnlf ) + + call this%set_history_var(vname='CROWNAREA_CAN', units='m2/m2', & + long='total crown area in each canopy layer', & + use_default='active', & + avgflag='A', vtype=site_can_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_crownarea_si_can ) + ! slow carbon fluxes associated with mortality from or transfer betweeen canopy and understory call this%set_history_var(vname='DEMOTION_CARBONFLUX', units = 'gC/m2/s', & long='demotion-associated biomass carbon flux from canopy to understory', use_default='active', & @@ -3118,6 +3191,26 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_mortality_understory_si_scls ) + call this%set_history_var(vname='TRIMMING_CANOPY_SCLS', units = 'indiv/ha', & + long='trimming term of canopy plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_trimming_canopy_si_scls ) + + call this%set_history_var(vname='TRIMMING_UNDERSTORY_SCLS', units = 'indiv/ha', & + long='trimming term of understory plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_trimming_understory_si_scls ) + + call this%set_history_var(vname='CROWN_AREA_CANOPY_SCLS', units = 'm2/ha', & + long='total crown area of canopy plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_crown_area_canopy_si_scls ) + + call this%set_history_var(vname='CROWN_AREA_UNDERSTORY_SCLS', units = 'm2/ha', & + long='total crown area of understory plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_crown_area_understory_si_scls ) + call this%set_history_var(vname='LEAF_MD_CANOPY_SCLS', units = 'kg C / ha / yr', & long='LEAF_MD for canopy plants by size class', use_default='inactive', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & From 2ae46a6c8f896258b7b70065d6028b817d361155 Mon Sep 17 00:00:00 2001 From: ckoven Date: Wed, 24 May 2017 14:45:05 -0700 Subject: [PATCH 409/437] fixed unit error in size- and canopy-resolved AR fluxes --- main/FatesHistoryInterfaceMod.F90 | 30 ++++++++++++++++++------------ 1 file changed, 18 insertions(+), 12 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 50c48363..e1e2a116 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -1947,41 +1947,47 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) ! accumulate fluxes on canopy- and understory- separated fluxes if (ccohort%canopy_layer .eq. 1) then + ! + ! bulk fluxes are in gC / m2 / s hio_gpp_canopy_pa(io_pa) = hio_gpp_canopy_pa(io_pa) + & ccohort%gpp_tstep * g_per_kg * n_density * per_dt_tstep hio_ar_canopy_pa(io_pa) = hio_ar_canopy_pa(io_pa) + & ccohort%resp_tstep * g_per_kg * n_density * per_dt_tstep ! + ! size-resolved respiration fluxes are in kg C / ha / yr hio_rdark_canopy_si_scls(io_si,scls) = hio_rdark_canopy_si_scls(io_si,scls) + & - ccohort%rdark * g_per_kg * ccohort%n * sec_per_day * days_per_year + ccohort%rdark * ccohort%n * sec_per_day * days_per_year hio_livestem_mr_canopy_si_scls(io_si,scls) = hio_livestem_mr_canopy_si_scls(io_si,scls) + & - ccohort%livestem_mr * g_per_kg * ccohort%n * sec_per_day * days_per_year + ccohort%livestem_mr * ccohort%n * sec_per_day * days_per_year hio_livecroot_mr_canopy_si_scls(io_si,scls) = hio_livecroot_mr_canopy_si_scls(io_si,scls) + & - ccohort%livecroot_mr * g_per_kg * ccohort%n * sec_per_day * days_per_year + ccohort%livecroot_mr * ccohort%n * sec_per_day * days_per_year hio_froot_mr_canopy_si_scls(io_si,scls) = hio_froot_mr_canopy_si_scls(io_si,scls) + & - ccohort%froot_mr * g_per_kg * ccohort%n * sec_per_day * days_per_year + ccohort%froot_mr * ccohort%n * sec_per_day * days_per_year hio_resp_g_canopy_si_scls(io_si,scls) = hio_resp_g_canopy_si_scls(io_si,scls) + & - ccohort%resp_g * g_per_kg * ccohort%n * sec_per_day * days_per_year * per_dt_tstep + ccohort%resp_g * ccohort%n * sec_per_day * days_per_year * per_dt_tstep hio_resp_m_canopy_si_scls(io_si,scls) = hio_resp_m_canopy_si_scls(io_si,scls) + & - ccohort%resp_m * g_per_kg * ccohort%n * sec_per_day * days_per_year * per_dt_tstep + ccohort%resp_m * ccohort%n * sec_per_day * days_per_year * per_dt_tstep else + ! + ! bulk fluxes are in gC / m2 / s hio_gpp_understory_pa(io_pa) = hio_gpp_understory_pa(io_pa) + & ccohort%gpp_tstep * g_per_kg * n_density * per_dt_tstep hio_ar_understory_pa(io_pa) = hio_ar_understory_pa(io_pa) + & ccohort%resp_tstep * g_per_kg * n_density * per_dt_tstep ! + ! size-resolved respiration fluxes are in kg C / ha / yr hio_rdark_understory_si_scls(io_si,scls) = hio_rdark_understory_si_scls(io_si,scls) + & - ccohort%rdark * g_per_kg * ccohort%n * sec_per_day * days_per_year + ccohort%rdark * ccohort%n * sec_per_day * days_per_year hio_livestem_mr_understory_si_scls(io_si,scls) = hio_livestem_mr_understory_si_scls(io_si,scls) + & - ccohort%livestem_mr * g_per_kg * ccohort%n * sec_per_day * days_per_year + ccohort%livestem_mr * ccohort%n * sec_per_day * days_per_year hio_livecroot_mr_understory_si_scls(io_si,scls) = hio_livecroot_mr_understory_si_scls(io_si,scls) + & - ccohort%livecroot_mr * g_per_kg * ccohort%n * sec_per_day * days_per_year + ccohort%livecroot_mr * ccohort%n * sec_per_day * days_per_year hio_froot_mr_understory_si_scls(io_si,scls) = hio_froot_mr_understory_si_scls(io_si,scls) + & - ccohort%froot_mr * g_per_kg * ccohort%n * sec_per_day * days_per_year + ccohort%froot_mr * ccohort%n * sec_per_day * days_per_year hio_resp_g_understory_si_scls(io_si,scls) = hio_resp_g_understory_si_scls(io_si,scls) + & - ccohort%resp_g * g_per_kg * ccohort%n * sec_per_day * days_per_year * per_dt_tstep + ccohort%resp_g * ccohort%n * sec_per_day * days_per_year * per_dt_tstep hio_resp_m_understory_si_scls(io_si,scls) = hio_resp_m_understory_si_scls(io_si,scls) + & - ccohort%resp_m * g_per_kg * ccohort%n * sec_per_day * days_per_year * per_dt_tstep + ccohort%resp_m * ccohort%n * sec_per_day * days_per_year * per_dt_tstep endif end associate endif From 5809197ec7af3f48107bf116bc723db53f81f2d4 Mon Sep 17 00:00:00 2001 From: JKShuman Date: Wed, 24 May 2017 10:13:43 -0600 Subject: [PATCH 410/437] Update Spitfire CFA euqation Update equation of crown area affected by fire (cfa) to correctly calculate crown length Fixes: User interface changes?: No Code review:JKShuman Test suite: Full test suite Ed, short for CLM45, cheyenne, intel Test baseline: fates-clm 601eb87 Test namelist changes: none Test answer changes: bit for bit with non-fire fates-clm Test summary: bit for bit for non-fire answer changing for fire, as expected --- fire/SFMainMod.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index 796f671b..3adebfa9 100755 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -881,8 +881,8 @@ subroutine crown_damage ( currentSite ) 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* & + currentCohort%cfa = (currentPatch%SH-currentCohort%hite*(1- & + EDecophyscon%crown(currentCohort%pft)))/(currentCohort%hite* & EDecophyscon%crown(currentCohort%pft)) else From 79c762d68b6ed029945fe741feda70e2c9567978 Mon Sep 17 00:00:00 2001 From: JKShuman Date: Wed, 31 May 2017 14:23:02 -0600 Subject: [PATCH 411/437] Update ROS_back equation Update Backwards Rate of Spread (ROS_back) equation to include patch area Fixes: User interface changes?: no Code review: JKShuman Test suite: Full test suite ED, short for CLM 45, cheyenne, intel Test baseline:fates-clm-601eb87 and clm4_5_15_r233 Test namelist changes:no Test summary:bit for bit for non-fire answer changing for fire, as expected --- fire/SFMainMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index 3adebfa9..70b8b282 100755 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -780,7 +780,7 @@ subroutine area_burnt ( currentSite ) endif endif endif! fire - currentSite%frac_burnt = currentSite%frac_burnt + currentPatch%frac_burnt + currentSite%frac_burnt = currentSite%frac_burnt + currentPatch%frac_burnt * currentPatch%area/area currentPatch => currentPatch%younger From a7021770e873bd234fbad2ff06325d513bae5621 Mon Sep 17 00:00:00 2001 From: JKShuman Date: Thu, 1 Jun 2017 15:20:55 -0600 Subject: [PATCH 412/437] Update ROS_back and fire duration Correct equation for fire duration (currentPatch%FD) to add one in the numerator to SF_val_max_durat per Thonicke et al 2010. Correct equation for ROS_back equation to use wind which is not reduced by vegetation as is effect_wspeed. Per Thonicke et al. 2010. Fixes: Spitfire development User interface changes?: no Code review:JKShuman Test suite:Full test suite ED, short for CLM 45, cheyenne, intel Test baseline:fates-clm-601eb87 and clm4_5_15_r233 Test namelist changes:no Test answer changes: bit for bit non-fire Test summary: bit for bit for non-fire answer changing for fire, as expected --- fire/SFMainMod.F90 | 22 ++++++++++++---------- 1 file changed, 12 insertions(+), 10 deletions(-) diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index 70b8b282..3bbc86de 100755 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -400,15 +400,16 @@ subroutine rate_of_spread ( currentSite ) type(ed_patch_type), pointer :: currentPatch ! Rothermal fire spread model parameters. - real(r8) beta,beta_op !weighted average of packing ratio (unitless) - real(r8) ir !reaction intensity (kJ/m2/min) - real(r8) xi,eps,phi_wind !all are unitless - real(r8) q_ig !heat of pre-ignition (kJ/kg) + real(r8) beta,beta_op ! weighted average of packing ratio (unitless) + real(r8) ir ! reaction intensity (kJ/m2/min) + real(r8) xi,eps,phi_wind ! all are unitless + real(r8) q_ig ! heat of pre-ignition (kJ/kg) real(r8) reaction_v_opt,reaction_v_max !reaction velocity (per min)!optimum and maximum - real(r8) moist_damp,mw_weight !moisture dampening coefficient and ratio fuel moisture to extinction - real(r8) beta_ratio !ratio of beta/beta_op - real(r8) a_beta !dummy variable for product of a* beta_ratio for react_v_opt equation - real(r8) a,b,c,e !function of fuel sav + real(r8) moist_damp,mw_weight ! moisture dampening coefficient and ratio fuel moisture to extinction + real(r8) beta_ratio ! ratio of beta/beta_op + real(r8) a_beta ! dummy variable for product of a* beta_ratio for react_v_opt equation + real(r8) a,b,c,e ! function of fuel sav + real(r8) :: wind ! daily wind in m/mi real(r8),parameter::wind_max = 45.718_r8 !max wind speed (m/min)=150 ft/min per Lasslop etal 2014 real(r8) wind_elev_fire !wind speed (m/min) at elevevation relevant for fire @@ -540,7 +541,8 @@ subroutine rate_of_spread ( currentSite ) endif ! Equation 10 in Thonicke et al. 2010 ! backward ROS from Can FBP System (1992) in m/min - currentPatch%ROS_back = currentPatch%ROS_front*exp(-0.012_r8*currentPatch%effect_wspeed) + ! backward ROS wind not changed by vegetation + currentPatch%ROS_back = currentPatch%ROS_front*exp(-0.012_r8*wind) currentPatch => currentPatch%younger @@ -669,7 +671,7 @@ subroutine fire_intensity ( currentSite ) 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 ! fire duration in minutes - currentPatch%FD = SF_val_max_durat / (1.0_r8 + SF_val_max_durat * exp(SF_val_durat_slope*d_FDI)) + currentPatch%FD = (SF_val_max_durat+1) / (1.0_r8 + SF_val_max_durat * exp(SF_val_durat_slope*d_FDI)) if(write_SF == itrue)then if ( hlm_masterproc == itrue ) write(fates_log(),*) 'fire duration minutes',currentPatch%fd endif From b98035bef279034f9f16a2b4f3578773525d1267 Mon Sep 17 00:00:00 2001 From: JKShuman Date: Fri, 2 Jun 2017 15:36:28 -0600 Subject: [PATCH 413/437] Spitfire wind site level Update converted input wind (m/min) in Spitfire to be site level for use in wind effect routine and rate of spread routine. Fixes: User interface changes?: no Code review: JKShuman Test suite: Test baseline: Test namelist changes: Test answer changes: Test summary: code compiles. no further testing. --- fire/SFMainMod.F90 | 13 ++++++------- main/EDTypesMod.F90 | 3 ++- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index 3bbc86de..bc9198e3 100755 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -305,7 +305,8 @@ subroutine wind_effect ( currentSite, bc_in) !*****************************************************************. ! Routine called daily from within ED within a site loop. - ! Calculates the effective windspeed based on vegetation charecteristics. + ! Calculates the effective windspeed based on vegetation charecteristics. + ! currentSite%wind is daily wind converted to m/min for Spitfire units use FatesConstantsMod, only : sec_per_min @@ -315,7 +316,6 @@ subroutine wind_effect ( currentSite, bc_in) type(ed_patch_type) , pointer :: currentPatch type(ed_cohort_type), pointer :: currentCohort - real(r8) :: wind ! daily wind in m/min 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 @@ -327,10 +327,10 @@ subroutine wind_effect ( currentSite, bc_in) ! unless we decide to ever calculated the NI for each patch. iofp = currentSite%oldest_patch%patchno - wind = bc_in%wind24_pa(iofp) * sec_per_min ! Convert to m/min for SPITFIRE units. + currentSite%wind = bc_in%wind24_pa(iofp) * sec_per_min !Convert to m/min for SPITFIRE if(write_SF == itrue)then - if ( hlm_masterproc == itrue ) write(fates_log(),*) 'wind24', wind + if ( hlm_masterproc == itrue ) write(fates_log(),*) 'wind24', currentSite%wind endif ! --- influence of wind speed, corrected for surface roughness---- ! --- averaged over the whole grid cell to prevent extreme divergence @@ -378,7 +378,7 @@ subroutine wind_effect ( currentSite, bc_in) do while(associated(currentPatch)) currentPatch%total_tree_area = min(currentPatch%total_tree_area,currentPatch%area) ! effect_wspeed in units m/min - currentPatch%effect_wspeed = wind * (tree_fraction*0.4+(grass_fraction+bare_fraction)*0.6) + currentPatch%effect_wspeed = currentSite%wind * (tree_fraction*0.4+(grass_fraction+bare_fraction)*0.6) currentPatch => currentPatch%younger enddo !end patch loop @@ -409,7 +409,6 @@ subroutine rate_of_spread ( currentSite ) real(r8) beta_ratio ! ratio of beta/beta_op real(r8) a_beta ! dummy variable for product of a* beta_ratio for react_v_opt equation real(r8) a,b,c,e ! function of fuel sav - real(r8) :: wind ! daily wind in m/mi real(r8),parameter::wind_max = 45.718_r8 !max wind speed (m/min)=150 ft/min per Lasslop etal 2014 real(r8) wind_elev_fire !wind speed (m/min) at elevevation relevant for fire @@ -542,7 +541,7 @@ subroutine rate_of_spread ( currentSite ) ! Equation 10 in Thonicke et al. 2010 ! backward ROS from Can FBP System (1992) in m/min ! backward ROS wind not changed by vegetation - currentPatch%ROS_back = currentPatch%ROS_front*exp(-0.012_r8*wind) + currentPatch%ROS_back = currentPatch%ROS_front*exp(-0.012_r8*currentSite%wind) currentPatch => currentPatch%younger diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 9ebefb8a..19d0ef0a 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -540,7 +540,8 @@ module EDTypesMod real(r8) :: dseed_dt(numpft_ed) real(r8) :: seed_rain_flux(numpft_ed) ! flux of seeds from exterior KgC/m2/year (needed for C balance purposes) - ! FIRE + ! FIRE + real(r8) :: wind ! daily wind in m/min for Spitfire units 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. From f8b15047f454357a14d837b252e22e6051dec0a1 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 2 Jun 2017 15:51:14 -0700 Subject: [PATCH 414/437] bug fixes to litterflux out and in, mostly related to the patch fusion and creation process. --- biogeochem/EDPatchDynamicsMod.F90 | 124 ++++++++++++++++++------------ biogeochem/EDPhysiologyMod.F90 | 4 +- 2 files changed, 76 insertions(+), 52 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 3bfa11f8..ffbf8da9 100755 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -522,6 +522,14 @@ subroutine average_patch_properties( currentPatch, newPatch, patch_site_areadis 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 + + ! The fragmentation/decomposition flux from donor patches has already occured in existing patches. However + ! some of their area has been carved out for this new patches which is receiving donations. + ! Lets maintain conservation on that pre-existing mass flux in these newly disturbed patches + + newPatch%root_litter_out(p) = newPatch%root_litter_out(p) + currentPatch%root_litter_out(p) * patch_site_areadis/newPatch%area + newPatch%leaf_litter_out(p) = newPatch%leaf_litter_out(p) + currentPatch%leaf_litter_out(p) * patch_site_areadis/newPatch%area + enddo newPatch%spread = newPatch%spread + currentPatch%spread * patch_site_areadis/newPatch%area @@ -837,9 +845,10 @@ subroutine mortality_litter_fluxes(currentSite, cp_target, new_patch_target, pat new_patch%leaf_litter(p) = new_patch%leaf_litter(p) + canopy_mortality_leaf_litter(p) / litter_area * np_mult new_patch%root_litter(p) = new_patch%root_litter(p) + canopy_mortality_root_litter(p) / litter_area * np_mult + currentPatch%leaf_litter(p) = currentPatch%leaf_litter(p) + canopy_mortality_leaf_litter(p) / litter_area currentPatch%root_litter(p) = currentPatch%root_litter(p) + canopy_mortality_root_litter(p) / litter_area - + ! track as diagnostic fluxes currentSite%leaf_litter_diagnostic_input_carbonflux(p) = currentSite%leaf_litter_diagnostic_input_carbonflux(p) + & canopy_mortality_leaf_litter(p) * hlm_days_per_year / AREA @@ -929,10 +938,7 @@ subroutine create_patch(currentSite, new_patch, age, areap, spread_local,cwd_ag_ new_patch%total_tree_area = 0.0_r8 new_patch%NCL_p = 1 - new_patch%leaf_litter_in(:) = 0._r8 - new_patch%leaf_litter_out(:) = 0._r8 - - + end subroutine create_patch @@ -1008,11 +1014,17 @@ subroutine zero_patch(cp_p) ! 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 + currentPatch%root_litter(:) = 0.0_r8 ! In new disturbed patches, loops over donors to increment total, needs zero here + currentPatch%leaf_litter(:) = 0.0_r8 ! In new disturbed patches, loops over donors to increment total, needs zero here - currentPatch%leaf_litter_in(:) = 0.0_r8 - currentPatch%leaf_litter_out(:) = 0.0_r8 + ! Cold-start initialized patches should have no litter flux in/out as they have not undergone any time. + ! Litter fluxes in/out also need to be initialized to zero for newly disturbed patches, as they + ! will incorporate the fluxes from donors over a loop, and need an initialization + + currentPatch%leaf_litter_in(:) = 0.0_r8 ! As a newly created patch with no age, there is no flux in + currentPatch%leaf_litter_out(:) = 0.0_r8 ! As a newly created patch with no age, no frag or decomp has happened yet + currentPatch%root_litter_in(:) = 0.0_r8 ! As a newly created patch with no age, there is no flux in + currentPatch%root_litter_out(:) = 0.0_r8 ! As a newly created patch with no age, no frag or decomp has happened yet ! FIRE currentPatch%fuel_eff_moist = 0.0_r8 ! average fuel moisture content of the ground fuel @@ -1205,6 +1217,7 @@ subroutine fuse_patches( csite, bc_in ) end subroutine fuse_patches ! ============================================================================ + subroutine fuse_2_patches(dp, rp) ! ! !DESCRIPTION: @@ -1225,57 +1238,66 @@ subroutine fuse_2_patches(dp, rp) 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? - type(ed_patch_type), pointer :: youngerp ! pointer to the patch younger than donor - type(ed_patch_type), pointer :: olderp ! pointer to the patch older than donor - type(ed_site_type), pointer :: csite ! pointer to the donor patch's site - !--------------------------------------------------------------------- + integer :: c,p !counters for pft and litter size class. + integer :: tnull,snull ! are the tallest and shortest cohorts associated? + type(ed_patch_type), pointer :: youngerp ! pointer to the patch younger than donor + type(ed_patch_type), pointer :: olderp ! pointer to the patch older than donor + type(ed_site_type), pointer :: csite ! pointer to the donor patch's site + real(r8) :: inv_sum_area ! Inverse of the sum of the two patches areas + !----------------------------------------------------------------------------------------------- + + ! Generate a litany of area weighted averages + + inv_sum_area = 1.0_r8/(dp%area + rp%area) + + rp%age = (dp%age * dp%area + rp%age * rp%area) * inv_sum_area - !area weighted average of ages & litter - rp%age = (dp%age * dp%area + rp%age * rp%area)/(dp%area + rp%area) rp%age_class = get_age_class_index(rp%age) - do p = 1,numpft_ed - 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) + rp%cwd_ag(c) = (dp%cwd_ag(c)*dp%area + rp%cwd_ag(c)*rp%area) * inv_sum_area + rp%cwd_bg(c) = (dp%cwd_bg(c)*dp%area + rp%cwd_bg(c)*rp%area) * inv_sum_area enddo + + do p = 1,numpft_ed + rp%seeds_in(p) = (rp%seeds_in(p)*rp%area + dp%seeds_in(p)*dp%area) * inv_sum_area + rp%seed_decay(p) = (rp%seed_decay(p)*rp%area + dp%seed_decay(p)*dp%area) * inv_sum_area + rp%seed_germination(p) = (rp%seed_germination(p)*rp%area + dp%seed_germination(p)*dp%area) * inv_sum_area - 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) + rp%leaf_litter(p) = (dp%leaf_litter(p)*dp%area + rp%leaf_litter(p)*rp%area) * inv_sum_area + rp%root_litter(p) = (dp%root_litter(p)*dp%area + rp%root_litter(p)*rp%area) * inv_sum_area + + rp%root_litter_out(p) = (dp%root_litter_out(p)*dp%area + rp%root_litter_out(p)*rp%area) * inv_sum_area + rp%leaf_litter_out(p) = (dp%leaf_litter_out(p)*dp%area + rp%leaf_litter_out(p)*rp%area) * inv_sum_area + + rp%root_litter_in(p) = (dp%root_litter_in(p)*dp%area + rp%root_litter_in(p)*rp%area) * inv_sum_area + rp%leaf_litter_in(p) = (dp%leaf_litter_in(p)*dp%area + rp%leaf_litter_in(p)*rp%area) * inv_sum_area + + rp%dleaf_litter_dt(p) = (dp%dleaf_litter_dt(p)*dp%area + rp%dleaf_litter_dt(p)*rp%area) * inv_sum_area + rp%droot_litter_dt(p) = (dp%droot_litter_dt(p)*dp%area + rp%droot_litter_dt(p)*rp%area) * inv_sum_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%dleaf_litter_dt(:) = (dp%dleaf_litter_dt(:)*dp%area + rp%dleaf_litter_dt(:)*rp%area)/(dp%area+rp%area) - rp%leaf_litter_in(:) = (dp%leaf_litter_in(:)*dp%area + rp%leaf_litter_in(:)*rp%area)/(dp%area+rp%area) - rp%leaf_litter_out(:) = (dp%leaf_litter_out(:)*dp%area + rp%leaf_litter_out(:)*rp%area)/(dp%area+rp%area) - + rp%fuel_eff_moist = (dp%fuel_eff_moist*dp%area + rp%fuel_eff_moist*rp%area) * inv_sum_area + rp%livegrass = (dp%livegrass*dp%area + rp%livegrass*rp%area) * inv_sum_area + rp%sum_fuel = (dp%sum_fuel*dp%area + rp%sum_fuel*rp%area) * inv_sum_area + rp%fuel_bulkd = (dp%fuel_bulkd*dp%area + rp%fuel_bulkd*rp%area) * inv_sum_area + rp%fuel_sav = (dp%fuel_sav*dp%area + rp%fuel_sav*rp%area) * inv_sum_area + rp%fuel_mef = (dp%fuel_mef*dp%area + rp%fuel_mef*rp%area) * inv_sum_area + rp%ros_front = (dp%ros_front*dp%area + rp%ros_front*rp%area) * inv_sum_area + rp%effect_wspeed = (dp%effect_wspeed*dp%area + rp%effect_wspeed*rp%area) * inv_sum_area + rp%tau_l = (dp%tau_l*dp%area + rp%tau_l*rp%area) * inv_sum_area + rp%fuel_frac(:) = (dp%fuel_frac(:)*dp%area + rp%fuel_frac(:)*rp%area) * inv_sum_area + rp%tfc_ros = (dp%tfc_ros*dp%area + rp%tfc_ros*rp%area) * inv_sum_area + rp%fi = (dp%fi*dp%area + rp%fi*rp%area) * inv_sum_area + rp%fd = (dp%fd*dp%area + rp%fd*rp%area) * inv_sum_area + rp%ros_back = (dp%ros_back*dp%area + rp%ros_back*rp%area) * inv_sum_area + rp%ab = (dp%ab*dp%area + rp%ab*rp%area) * inv_sum_area + rp%nf = (dp%nf*dp%area + rp%nf*rp%area) * inv_sum_area + rp%sh = (dp%sh*dp%area + rp%sh*rp%area) * inv_sum_area + rp%frac_burnt = (dp%frac_burnt*dp%area + rp%frac_burnt*rp%area) * inv_sum_area + rp%burnt_frac_litter(:) = (dp%burnt_frac_litter(:)*dp%area + rp%burnt_frac_litter(:)*rp%area) * inv_sum_area + rp%btran_ft(:) = (dp%btran_ft(:)*dp%area + rp%btran_ft(:)*rp%area) * inv_sum_area rp%area = rp%area + dp%area !THIS MUST COME AT THE END! diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index e6229de8..19d08c11 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1293,6 +1293,7 @@ subroutine cwd_out( currentSite, currentPatch, bc_in ) currentPatch%fragmentation_scaler ) currentPatch%root_litter_out(ft) = max(0.0_r8,currentPatch%root_litter(ft)* SF_val_max_decomp(dl_sf) * & currentPatch%fragmentation_scaler ) + if ( currentPatch%leaf_litter_out(ft)<0.0_r8.or.currentPatch%root_litter_out(ft)<0.0_r8)then write(fates_log(),*) 'root or leaf out is negative?',SF_val_max_decomp(dl_sf),currentPatch%fragmentation_scaler endif @@ -1360,6 +1361,7 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) real(r8) mass_convert ! ED uses kg, CLM uses g integer :: begp,endp integer :: begc,endc !bounds + integer :: ipa !------------------------------------------------------------------------ real(r8) :: cinput_rootfr(1:numpft_ed, 1:hlm_numlevdecomp_full) ! column by pft root fraction used for calculating inputs real(r8) :: croot_prof_perpatch(1:hlm_numlevdecomp_full) @@ -1675,7 +1677,7 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) end do !currentPatch end do ! do sites(s) - + do s = 1, nsites do j = 1, hlm_numlevdecomp ! time unit conversion From f90a8d7f14b086f00d0f6c17667e855e07b04b50 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 7 Jun 2017 09:50:39 -0400 Subject: [PATCH 415/437] Removed some whitespace changes and a temporary variable (ipa). --- biogeochem/EDPhysiologyMod.F90 | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 19d08c11..e6229de8 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1293,7 +1293,6 @@ subroutine cwd_out( currentSite, currentPatch, bc_in ) currentPatch%fragmentation_scaler ) currentPatch%root_litter_out(ft) = max(0.0_r8,currentPatch%root_litter(ft)* SF_val_max_decomp(dl_sf) * & currentPatch%fragmentation_scaler ) - if ( currentPatch%leaf_litter_out(ft)<0.0_r8.or.currentPatch%root_litter_out(ft)<0.0_r8)then write(fates_log(),*) 'root or leaf out is negative?',SF_val_max_decomp(dl_sf),currentPatch%fragmentation_scaler endif @@ -1361,7 +1360,6 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) real(r8) mass_convert ! ED uses kg, CLM uses g integer :: begp,endp integer :: begc,endc !bounds - integer :: ipa !------------------------------------------------------------------------ real(r8) :: cinput_rootfr(1:numpft_ed, 1:hlm_numlevdecomp_full) ! column by pft root fraction used for calculating inputs real(r8) :: croot_prof_perpatch(1:hlm_numlevdecomp_full) @@ -1677,7 +1675,7 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) end do !currentPatch end do ! do sites(s) - + do s = 1, nsites do j = 1, hlm_numlevdecomp ! time unit conversion From d36a2a3eb5a9be15a7c30d42bbe83be626b0ae1b Mon Sep 17 00:00:00 2001 From: JKShuman Date: Fri, 9 Jun 2017 10:55:24 -0600 Subject: [PATCH 416/437] Update Spitfire FDI, area burnt & clean up Update d_FDI to FDI to be in line with Thonicke Update equation for number fires (Patch%NF) to include FDI to bring in line with Eq. 2 Thonicke and FireMIP. Clean up patch_area_in_m2 conditional of area burnt. Patch%frac_burnt capped at 1. Decommission Site%ab. %ab is only at patch level. Update fire_threshold to 50kW/m as in Pyne 1986. Fixes: User interface changes?:No Code review: JKShuman Test suite: Full suite ED, short for CLM45, cheyenne, intel Test baseline: fates-clm 601eb87 and clm4_5_15_r233 Test namelist changes:none Test summary: b4b non-fire answer changing for fire as expected --- fire/SFMainMod.F90 | 44 +++++++++++++++++++++++++------------------- main/EDTypesMod.F90 | 8 ++++---- 2 files changed, 29 insertions(+), 23 deletions(-) diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index bc9198e3..5210598d 100755 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -175,7 +175,7 @@ subroutine charecteristics_of_fuel ( currentSite ) ! 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 + ! NCWD =4 NFSC = 6 ! dl_sf = 1, tw_sf = 2, lb_sf = 4, tr_sf = 5, lg_sf = 6, ! zero fire arrays. @@ -638,6 +638,7 @@ 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. + !currentSite%FDI probability that an ignition will start a fire !currentPatch%ROS_front forward ROS (m/min) !currentPatch%TFC_ROS total fuel consumed by flaming front (kgC/m2) @@ -645,13 +646,12 @@ subroutine fire_intensity ( currentSite ) 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_site_type), intent(inout), 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; @@ -666,11 +666,15 @@ subroutine fire_intensity ( currentSite ) 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 7 from Venevsky et al GCB 2002 (modification of equation 8 in Thonicke et al. 2010) + ! FDI 0.1 = low, 0.3 moderate, 0.75 high, and 1 = extreme ignition potential for alpha 0.000337 + currentSite%FDI = 1.0_r8 - exp(-SF_val_fdi_alpha*currentSite%acc_NI) ! Equation 14 in Thonicke et al. 2010 ! fire duration in minutes - currentPatch%FD = (SF_val_max_durat+1) / (1.0_r8 + SF_val_max_durat * exp(SF_val_durat_slope*d_FDI)) + + currentPatch%FD = (SF_val_max_durat+1) / (1.0_r8 + SF_val_max_durat * & + exp(SF_val_durat_slope*currentSite%FDI)) + if(write_SF == itrue)then if ( hlm_masterproc == itrue ) write(fates_log(),*) 'fire duration minutes',currentPatch%fd endif @@ -748,7 +752,8 @@ subroutine area_burnt ( currentSite ) ! THIS SHOULD HAVE THE COLUMN AND LU AREA WEIGHT ALSO, NO? gridarea = km2_to_m2 ! 1M m2 in a km2 - currentPatch%NF = ED_val_nignitions * currentPatch%area/area /365 + currentPatch%NF = ED_val_nignitions * currentPatch%area/area /365 * & + currentSite%FDI ! If there are 15 lightening strickes per year, per km2. (approx from NASA product) ! then there are 15/365 s/km2 each day. @@ -763,22 +768,23 @@ subroutine area_burnt ( currentSite ) currentPatch%AB = size_of_fire * currentPatch%NF patch_area_in_m2 = gridarea*currentPatch%area/area - if (currentPatch%AB > patch_area_in_m2 ) then !all of patch burnt. - - if ( hlm_masterproc == itrue ) write(fates_log(),*) 'burnt all of patch',currentPatch%patchno, & - currentPatch%area/area,currentPatch%ab,patch_area_in_m2 - if ( hlm_masterproc == itrue ) write(fates_log(),*) 'ros',currentPatch%ROS_front,currentPatch%FD, & - currentPatch%NF,currentPatch%FI,size_of_fire - - if ( hlm_masterproc == itrue ) write(fates_log(),*) 'litter', & - currentPatch%sum_fuel,currentPatch%CWD_AG,currentPatch%leaf_litter - ! turn km2 into m2. work out total area burnt. - currentPatch%AB = patch_area_in_m2 - endif + currentPatch%frac_burnt = currentPatch%AB / patch_area_in_m2 if(write_SF == itrue)then if ( hlm_masterproc == itrue ) write(fates_log(),*) 'frac_burnt',currentPatch%frac_burnt endif + + if (currentPatch%frac_burnt > 1 ) then !all of patch burnt. + + currentPatch%frac_burnt = 1.0 ! capping at 1 same as %AB/patch_area_in_m2 + + if ( hlm_masterproc == itrue ) write(fates_log(),*) 'burnt all of patch',currentPatch%patchno + if ( hlm_masterproc == itrue ) write(fates_log(),*) 'ros',currentPatch%ROS_front,currentPatch%FD, & + currentPatch%NF,currentPatch%FI,size_of_fire + + endif + + endif endif! fire currentSite%frac_burnt = currentSite%frac_burnt + currentPatch%frac_burnt * currentPatch%area/area diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index ecb52db6..bd874869 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -76,14 +76,14 @@ module EDTypesMod ! SPITFIRE - integer, parameter :: NCWD = 4 ! number of coarse woody debris pools - integer , parameter :: NFSC = NCWD+2 ! number fuel size classes (really this is a mix of cwd size classes, leaf litter, and grass types) + integer, parameter :: NCWD = 4 ! number of coarse woody debris pools (twig,s branch,l branch, trunk) + integer , parameter :: NFSC = NCWD+2 ! number fuel size classes (4 cwd size classes, leaf litter, and grass) integer, parameter :: lg_sf = 6 ! array index of live grass pool for spitfire integer, parameter :: dl_sf = 1 ! array index of dead leaf pool for spitfire (dead grass and dead leaves) integer, parameter :: tw_sf = 2 ! array index of twig pool for spitfire integer, parameter :: tr_sf = 5 ! array index of dead trunk pool for spitfire integer, parameter :: lb_sf = 4 ! array index of large branch pool for spitfire - real(r8), parameter :: fire_threshold = 35.0_r8 ! threshold for fires that spread or go out. KWm-2 + real(r8), parameter :: fire_threshold = 50.0_r8 ! threshold for fires that spread or go out. KWm-2 (Pyne 1986) ! PATCH FUSION real(r8), parameter :: NTOL = 0.05_r8 ! min plant density for hgt bin to be used in height profile comparisons @@ -543,7 +543,7 @@ module EDTypesMod ! FIRE real(r8) :: wind ! daily wind in m/min for Spitfire units real(r8) :: acc_ni ! daily nesterov index accumulating over time. - real(r8) :: ab ! daily burnt area: m2 + real(r8) :: fdi ! daily probability an ignition event will start a fire real(r8) :: frac_burnt ! fraction of soil burnt in this day. real(r8) :: total_burn_flux_to_atm ! total carbon burnt to the atmosphere in this day. KgC/site real(r8) :: cwd_ag_burned(ncwd) From 40bbfec0da40f293295f6a51d070f5509baaafb7 Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Wed, 14 Jun 2017 14:56:47 -0700 Subject: [PATCH 417/437] added new FATES license file --- LICENSE.txt | 93 +++++++++++++++++++++++++++++++++-------------------- 1 file changed, 59 insertions(+), 34 deletions(-) diff --git a/LICENSE.txt b/LICENSE.txt index 6c74023f..12f41fb6 100644 --- a/LICENSE.txt +++ b/LICENSE.txt @@ -1,34 +1,59 @@ -Copyright (c) 2013-2015, University Corporation for Atmospheric Research (UCAR) -All rights reserved. - -Developed by: - University Corporation for Atmospheric Research - National Center for Atmospheric Research - https://www2.cesm.ucar.edu/working-groups/sewg - -Permission is hereby granted, free of charge, to any person obtaining -a copy of this software and associated documentation files (the "Software"), -to deal with the Software without restriction, including without limitation -the rights to use, copy, modify, merge, publish, distribute, sublicense, -and/or sell copies of the Software, and to permit persons to whom -the Software is furnished to do so, subject to the following conditions: - - - Redistributions of source code must retain the above copyright notice, - this list of conditions and the following disclaimers. - - Redistributions in binary form must reproduce the above copyright notice, - this list of conditions and the following disclaimers in the documentation - and/or other materials provided with the distribution. - - Neither the names of UCAR, or NCAR, - nor the names of its contributors may be used to endorse or promote - products derived from this Software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" -AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE -LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -POSSIBILITY OF SUCH DAMAGE. +Functionally Assembled Terrestrial Ecosystem Simulator (“FATES”) + +Copyright (c) 2016-2017, The Regents of the University of California, through Lawrence +Berkeley National Laboratory, University Corporation for Atmospheric Research, Los Alamos +National Security, LLC (LANS), as operator of Los Alamos National Laboratory (LANL), and +President and Fellows of Harvard College. All rights reserved. + +Copyright (c) 2013-2015, University Corporation for Atmospheric Research (UCAR). All +rights reserved. + +If you have questions about your rights to use or distribute this software, please contact +Berkeley Lab's Innovation & Partnerships Office at IPO@lbl.gov. + +NOTICE. This Software was developed under funding from the U.S. Department of Energy and +the U.S. Government consequently retains certain rights. As such, the U.S. Government has +been granted for itself and others acting on its behalf a paid-up, nonexclusive, +irrevocable, worldwide license in the Software to reproduce, distribute copies to the +public, prepare derivative works, and perform publicly and display publicly, and to permit +other to do so. + + Redistribution and use in source and binary forms, with or without modification, are + permitted provided that the following conditions are met: + + (1) Redistributions of source code must retain the above copyright notice, this list of + conditions and the following disclaimer. + + (2) Redistributions in binary form must reproduce the above copyright notice, this list + of conditions and the following disclaimer in the documentation and/or other materials + provided with the distribution. + + (3) Neither the name of the University of California, Lawrence Berkeley National + Laboratory, University Corporation for Atmospheric Research, Los Alamos National + Security, LLC (LANS), as operator of Los Alamos National Laboratory (LANL), President and + Fellows of Harvard College, or the U.S. Dept. of Energy nor the names of its contributors + may be used to endorse or promote products derived from this software without specific + prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR +TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +You are under no obligation whatsoever to provide any bug fixes, patches, or upgrades to +the features, functionality or performance of the source code ("Enhancements") to anyone; +however, if you choose to make your Enhancements available either publicly, or directly to +Lawrence Berkeley National Laboratory, without imposing a separate written license +agreement for such Enhancements, then you hereby grant the following license to Lawrence +Berkeley National Laboratory, University Corporation for Atmospheric Research, Los Alamos +National Security, LLC (LANS), as operator of Los Alamos National Laboratory (LANL), +President and Fellows of Harvard College, and the U.S. Dept. of Energy: a non-exclusive, +royalty-free perpetual license to install, use, modify, prepare derivative works, +incorporate into other computer software, distribute, and sublicense such enhancements or +derivative works thereof, in binary and source code form. + From 87680abdafc88ab14d17808deb88d99a3f9857bd Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 20 Jun 2017 15:19:30 -0700 Subject: [PATCH 418/437] Added ability to read in a list of css/pss file couplets and their coordinates. First task towards inventory initialization. --- main/EDInitMod.F90 | 152 +++++++++++++++++++++------ main/FatesInventoryInitMod.F90 | 183 +++++++++++++++++++++++++++++++++ 2 files changed, 305 insertions(+), 30 deletions(-) create mode 100644 main/FatesInventoryInitMod.F90 diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index f7ada2f3..21ff7a93 100755 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -21,12 +21,20 @@ module EDInitMod use EDTypesMod , only : numpft_ed use FatesInterfaceMod , only : bc_in_type use EDTypesMod , only : use_fates_plant_hydro - + + ! CIME GLOBALS + use shr_log_mod , only : errMsg => shr_log_errMsg + implicit none private logical :: DEBUG = .false. + logical, parameter :: do_inv_init = .true. + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + public :: zero_site public :: init_patches public :: set_site_properties @@ -186,11 +194,19 @@ end subroutine set_site_properties subroutine init_patches( nsites, sites, bc_in) ! ! !DESCRIPTION: - !initialize patches on new ground + ! initialize patches + ! This may be call a near bare ground initialization, or it may + ! load patches from an inventory. + ! ! !USES: use EDParamsMod , only : ED_val_maxspread use FatesPlantHydraulicsMod, only : updateSizeDepRhizHydProps + use FatesInventoryInitMod, only : get_inventory_file_unit + use FatesInventoryInitMod, only : inv_file_list + use FatesInventoryInitMod, only : count_inventory_sites + use FatesInventoryInitMod, only : assess_inventory_sites + ! ! !ARGUMENTS integer, intent(in) :: nsites @@ -206,43 +222,119 @@ subroutine init_patches( nsites, sites, bc_in) real(r8) :: root_litter_local(numpft_ed) real(r8) :: age !notional age of this patch type(ed_patch_type), pointer :: newp + + + ! Census Initialization variables + integer :: file_unit + integer :: nfilesites ! number of sites in the inventory file list + logical :: lod ! logical, file "O"pene"D" + logical :: lex ! logical, file "EX"ists + integer :: ios ! integer, "IO" status + character(len=512) :: iostr + logical, parameter :: do_inv_init = .true. + character(len=256), allocatable :: inv_css_list(:) + character(len=256), allocatable :: inv_pss_list(:) + real(r8), allocatable :: inv_lat_list(:) + real(r8), allocatable :: inv_lon_list(:) + !---------------------------------------------------------------------- - 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 - age = 0.0_r8 - - !FIX(SPM,032414) clean this up...inits out of this loop - do s = 1, nsites + if (do_inv_init) then - allocate(newp) + ! I. Load the inventory list file, do some file handle checks + ! ------------------------------------------------------------------------------------------ - newp%patchno = 1 - newp%younger => null() - newp%older => null() + file_unit = get_inventory_file_unit() + inquire(file=trim(inv_file_list),exist=lex,opened=lod) + if( .not.lex ) then ! The inventory file list DOE + write(fates_log(), *) 'An inventory Initialization was requested.' + write(fates_log(), *) 'However the inventory file: ',trim(inv_file_list),' DNE' + write(fates_log(), *) 'Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + if( lod ) then ! The inventory file should not be open + write(fates_log(), *) 'The inventory list file is open but should not be.' + write(fates_log(), *) 'Aborting.' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + open(unit=file_unit,file=trim(inv_file_list),status='OLD',action='READ',form='FORMATTED') + rewind(file_unit) + + ! There should be at least 1 line + read(file_unit,fmt='(A)',iostat=ios) iostr + read(file_unit,fmt='(A)',iostat=ios) iostr + if( ios /= 0 ) then + write(fates_log(), *) 'The inventory file does not contain at least two lines' + write(fates_log(), *) 'of data, ie a header and 1 site. Aborting.' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + rewind(unit=file_unit) - sites(s)%youngest_patch => newp - sites(s)%youngest_patch => newp - sites(s)%oldest_patch => newp - ! make new patch... - call create_patch(sites(s), newp, age, AREA, & - spread_local, cwd_ag_local, cwd_bg_local, leaf_litter_local, & - root_litter_local) + ! Count the number of sites that are listed in this file, and allocate storage arrays + ! ------------------------------------------------------------------------------------------ - call init_cohorts(newp, bc_in(s)) + nfilesites = count_inventory_sites(file_unit) - ! This sets the rhizosphere shells based on the plant initialization - ! The initialization of the plant-relevant hydraulics variables - ! were set from a call inside of the init_cohorts()->create_cohort() subroutine - if (use_fates_plant_hydro) then - call updateSizeDepRhizHydProps(sites(s), bc_in(s)) - end if + allocate(inv_pss_list(nfilesites)) + allocate(inv_css_list(nfilesites)) + allocate(inv_lat_list(nfilesites)) + allocate(inv_lon_list(nfilesites)) + + + ! Check through the sites that are listed and do some sanity checks + ! ------------------------------------------------------------------------------------------ + call assess_inventory_sites(file_unit,nfilesites, & + inv_pss_list,inv_css_list, & + inv_lat_list,inv_lon_list) + + ! For each site, identify the most proximal PSS/CSS couplet, read-in the data + ! allocate linked lists and assign to memory +! do s = 1, nsites +! end do + + deallocate(inv_pss_list,inv_css_list,inv_lat_list,inv_lon_list) + + else + + 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 + age = 0.0_r8 + + !FIX(SPM,032414) clean this up...inits out of this loop + do s = 1, nsites + + allocate(newp) + + newp%patchno = 1 + newp%younger => null() + newp%older => null() + + sites(s)%youngest_patch => newp + sites(s)%youngest_patch => newp + sites(s)%oldest_patch => newp + + ! make new patch... + call create_patch(sites(s), newp, age, AREA, & + spread_local, cwd_ag_local, cwd_bg_local, leaf_litter_local, & + root_litter_local) + + call init_cohorts(newp, bc_in(s)) + + ! This sets the rhizosphere shells based on the plant initialization + ! The initialization of the plant-relevant hydraulics variables + ! were set from a call inside of the init_cohorts()->create_cohort() subroutine + if (use_fates_plant_hydro) then + call updateSizeDepRhizHydProps(sites(s), bc_in(s)) + end if + + enddo - enddo + end if end subroutine init_patches diff --git a/main/FatesInventoryInitMod.F90 b/main/FatesInventoryInitMod.F90 new file mode 100644 index 00000000..7d616a35 --- /dev/null +++ b/main/FatesInventoryInitMod.F90 @@ -0,0 +1,183 @@ +module FatesInventoryInitMod + + !----------------------------------------------------------------------------------------------- + ! This module contains the majority of the code used to read forest inventory data and + ! initialize a simulation from that data. Some important points: + ! - This procedure is called through the host model's "cold-start" initialization and not a + ! restart type of simulation. + ! - This procedure, if called from a massive grid, is both probably inappropriate, and probably + ! time consuming. + ! - This procedure is assumed to be called over a small subset of sites, for instance a single + ! site, or a small collection of sparse/irregularly spaced group of sites + ! + ! Created: Ryan Knox June 2017 + ! This code borrows heavily in concept from what is done in ED2. We will also do our best to + ! maintain compatibility with the PSS/CSS file formats that were used in ED2. + ! See: https://github.com/EDmodel/ED2/blob/master/ED/src/io/ed_read_ed10_20_history.f90 + ! At the time of writing this ED2 is unlicensed, and only concepts were borrowed with no direct + ! code copied. + !----------------------------------------------------------------------------------------------- + + ! CIME GLOBALS + use shr_file_mod, only : shr_file_getUnit + use shr_log_mod , only : errMsg => shr_log_errMsg + + ! FATES GLOBALS + use FatesConstantsMod, only : r8 => fates_r8 + use FatesGlobals , only : endrun => fates_endrun + use FatesGlobals , only : fates_log + + implicit none + + character(len=*), parameter :: inv_file_list = 'inventory_file_list.txt' + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + + public :: count_inventory_sites + public :: get_inventory_file_unit + public :: inv_file_list + public :: assess_inventory_sites + +contains + + + + + + ! ============================================================================================== + + ! This is is as wrappery as wrapper get + function get_inventory_file_unit() result(file_unit) + integer :: file_unit + file_unit = shr_file_getUnit() + return + end function get_inventory_file_unit + + + ! ============================================================================================== + + + function count_inventory_sites(file_unit) result(nsites) + + integer, intent(in) :: file_unit + + character(len=512) :: header_str + character(len=512) :: site_str + integer :: ios + real(r8) :: site_lat + real(r8) :: site_lon + character(len=256) :: pss_file + character(len=256) :: css_file + + integer :: nsites + + + ! Set the file position to the top of the file + ! Read in the header line + ! Read through sites and check coordinates and file existence + rewind(unit=file_unit) + read(file_unit,fmt='(A)') header_str + nsites = 0 + do + read(file_unit,fmt='(A)',iostat=ios) site_str + if (ios/=0) exit + nsites = nsites + 1 + end do + + return + end function count_inventory_sites + + ! ============================================================================================== + + subroutine assess_inventory_sites(file_unit,nsites, & + inv_pss_list,inv_css_list, & + inv_lat_list,inv_lon_list) + + integer, intent(in) :: file_unit + integer, intent(in) :: nsites + character(len=256),intent(inout) :: inv_pss_list(nsites) + character(len=256),intent(inout) :: inv_css_list(nsites) + real(r8),intent(inout) :: inv_lat_list(nsites) + real(r8),intent(inout) :: inv_lon_list(nsites) + + character(len=512) :: header_str + character(len=512) :: site_str + integer :: isite + integer :: ios + character(len=256) :: pss_file + character(len=256) :: css_file + real(r8) :: site_lat + real(r8) :: site_lon + integer :: iblnk + logical :: lex + + rewind(unit=file_unit) + read(file_unit,fmt='(4A)') header_str + print*,trim(header_str) + do isite=1,nsites + + ! Read in the whole line + read(file_unit,fmt='(a)',iostat=ios) site_str + + ! Parse the first entry from the line (latitude) + read(site_str,*) site_lat + + ! Parse the second entry from the line (longitude) + site_str = adjustl(site_str) + iblnk = index(site_str,' ') + site_str = adjustl(site_str(iblnk:)) + read(site_str,*) site_lon + + site_str = adjustl(site_str) + iblnk = index(site_str,' ') + site_str = adjustl(site_str(iblnk:)) + iblnk = index(site_str,' ') + read(site_str(:iblnk),fmt='(1A)') pss_file + + site_str = adjustl(site_str) + iblnk = index(site_str,' ') + site_str = adjustl(site_str(iblnk:)) + read(site_str,fmt='(1A)') css_file + + + if ( site_lat < -90.0_r8 .or. site_lat > 90.0_r8 ) then + write(fates_log(), *) 'read invalid latitude: ',site_lat,' from inventory site list' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if ( site_lon < -180.0_r8 .or. site_lon > 360.0_r8 ) then + write(fates_log(), *) 'read invalid longitude: ',site_lon,' from inventory site list' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + inquire(file=trim(pss_file),exist=lex) + if( .not.lex ) then + write(fates_log(), *) 'the following pss file could not be found:' + write(fates_log(), *) trim(pss_file) + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + inquire(file=trim(css_file),exist=lex) + if( .not.lex ) then + write(fates_log(), *) 'the following css file could not be found:' + write(fates_log(), *) trim(css_file) + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + ! If we have made it to this point, then in all likelihood, the PSS/CSS + ! File has probably been correctly identified + + inv_pss_list(isite) = pss_file + inv_css_list(isite) = css_file + inv_lat_list(isite) = site_lat + inv_lon_list(isite) = site_lon + + end do + + + + end subroutine assess_inventory_sites + + +end module FatesInventoryInitMod From 25519dda1d1436bbdee63ceda3fd3880a6dae5d6 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 21 Jun 2017 13:38:21 -0700 Subject: [PATCH 419/437] Started the process of reading PSS files. Made some initial assumptions, probably poor ones about how stsc maps to CWD and litter. Introduced a file format parameter to the inventory_file_list. --- biogeochem/EDPatchDynamicsMod.F90 | 1 + main/EDInitMod.F90 | 154 ++++++++++++++++++++++++++---- main/FatesInventoryInitMod.F90 | 154 ++++++++++++++++++++++++++---- 3 files changed, 273 insertions(+), 36 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index ffbf8da9..d2f20c7a 100755 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -41,6 +41,7 @@ module EDPatchDynamicsMod public :: check_patch_area public :: set_patchno public :: set_root_fraction + public :: dealloc_patch private:: fuse_2_patches diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 21ff7a93..9abebc9a 100755 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -200,12 +200,16 @@ subroutine init_patches( nsites, sites, bc_in) ! ! !USES: - use EDParamsMod , only : ED_val_maxspread + use shr_file_mod, only : shr_file_getUnit + use shr_file_mod, only : shr_file_freeUnit + + use EDPatchDynamicsMod , only : dealloc_patch + use EDParamsMod , only : ED_val_maxspread use FatesPlantHydraulicsMod, only : updateSizeDepRhizHydProps - use FatesInventoryInitMod, only : get_inventory_file_unit use FatesInventoryInitMod, only : inv_file_list use FatesInventoryInitMod, only : count_inventory_sites use FatesInventoryInitMod, only : assess_inventory_sites + use FatesInventoryInitMod, only : set_inventory_edpatch_type1 ! ! !ARGUMENTS @@ -222,6 +226,8 @@ subroutine init_patches( nsites, sites, bc_in) real(r8) :: root_litter_local(numpft_ed) real(r8) :: age !notional age of this patch type(ed_patch_type), pointer :: newp + type(ed_patch_type), pointer :: newpatch + type(ed_patch_type), pointer :: oldpatch ! Census Initialization variables @@ -232,19 +238,36 @@ subroutine init_patches( nsites, sites, bc_in) integer :: ios ! integer, "IO" status character(len=512) :: iostr logical, parameter :: do_inv_init = .true. + integer, allocatable :: inv_format_list(:) character(len=256), allocatable :: inv_css_list(:) character(len=256), allocatable :: inv_pss_list(:) real(r8), allocatable :: inv_lat_list(:) real(r8), allocatable :: inv_lon_list(:) + integer :: invsite + integer :: ipa ! Patch index + + + ! List out some nominal patch values that are used for Near Bear Ground initializations + ! as well as initializing inventory + ! --------------------------------------------------------------------------------------------- + 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 + age = 0.0_r8 + ! --------------------------------------------------------------------------------------------- - !---------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------------- + ! Two primary options, either a Near Bear Ground (NBG) or Inventory based cold-start + ! --------------------------------------------------------------------------------------------- if (do_inv_init) then ! I. Load the inventory list file, do some file handle checks ! ------------------------------------------------------------------------------------------ - file_unit = get_inventory_file_unit() + file_unit = shr_file_getUnit() inquire(file=trim(inv_file_list),exist=lex,opened=lod) if( .not.lex ) then ! The inventory file list DOE write(fates_log(), *) 'An inventory Initialization was requested.' @@ -277,6 +300,7 @@ subroutine init_patches( nsites, sites, bc_in) nfilesites = count_inventory_sites(file_unit) + allocate(inv_format_list(nfilesites)) allocate(inv_pss_list(nfilesites)) allocate(inv_css_list(nfilesites)) allocate(inv_lat_list(nfilesites)) @@ -285,25 +309,123 @@ subroutine init_patches( nsites, sites, bc_in) ! Check through the sites that are listed and do some sanity checks ! ------------------------------------------------------------------------------------------ - call assess_inventory_sites(file_unit,nfilesites, & - inv_pss_list,inv_css_list, & - inv_lat_list,inv_lon_list) + call assess_inventory_sites(file_unit, nfilesites, inv_format_list, & + inv_pss_list, inv_css_list, & + inv_lat_list, inv_lon_list) + + ! We can close the list file now. + close(file_unit, iostat = ios) + if( ios /= 0 ) then + write(fates_log(), *) 'The inventory file needed to be closed, but was still open' + write(fates_log(), *) 'aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + call shr_file_freeUnit(file_unit) + ! For each site, identify the most proximal PSS/CSS couplet, read-in the data ! allocate linked lists and assign to memory -! do s = 1, nsites -! end do + do s = 1, nsites + invsite = & + minloc( (sites(s)%lat-inv_lat_list(:))**2.0_r8 + (sites(s)%lon-inv_lon_list(:))**2.0_r8 , dim=1) + + ! Open the PSS/CSS couplet and initialize the ED data structures. + ! Lets start withe the PSS + ! --------------------------------------------------------------------------------------- + + file_unit = shr_file_getUnit() + open(unit=file_unit,file=trim(inv_pss_list(invsite)),status='OLD',action='READ',form='FORMATTED') + rewind(file_unit) + read(file_unit,fmt=*) iostr + print*,"PATCH HEADER:" + print*,trim(iostr) + + ipa = 0 + invpatchloop: do + + allocate(newpatch) + + newpatch%patchno = ipa + newpatch%younger => null() + newpatch%older => null() + + ! This call doesn't do much asside from initializing the patch with + ! nominal values, NaNs, zero's and allocating some vectors + call create_patch(sites(s), newpatch, 0.0_r8, 0.0_r8, & + spread_local, cwd_ag_local, cwd_bg_local, leaf_litter_local, & + root_litter_local) + + + if( inv_format_list(invsite) == 1 ) then + + call set_inventory_edpatch_type1(newpatch,file_unit,ipa,ios) + + end if + + ! If a new line was found in the inventory patch file, + ! then it will return an IO status flag (ios) of 0 + ! In that case, the patch structure (newpatch) has been filled + ! with relevant information. + ! + ! Add it to the site's patch list + ! ------------------------------------------------------------------------------------ + if(ios==0) then + + if(ipa == 0) then + ! This is the first patch to be added + ! It starts off as the oldest and youngest patch in the list + sites(s)%youngest_patch => newpatch + sites(s)%oldest_patch => newpatch + oldpatch => newpatch + else + ! At least for now, we will assume that each subsequent + ! patch is a younger one. We can sort when we are done + ! but lets not worry about it immediately + newpatch%older => oldpatch + newpatch%younger => NULL() + sites(s)%youngest_patch => newpatch + oldpatch => newpatch + end if + + ! If a new line was NOT found in the inventory patch file, + ! then no patch was populated and we should just deallocate the temporary + ! and move along (tidy up site list and go to the next site) + else + + call dealloc_patch(newpatch) + deallocate(newpatch) + exit ! This should break the do loop + + end if + + + + ipa = ipa + 1 + end do invpatchloop + + stop + + + ! Sort the patch list by age + ! --------------------------------------------------------------------------------------- + + + + close(file_unit,iostat=ios) + if( ios /= 0 ) then + write(fates_log(), *) 'The pss file: ',inv_pss_list(invsite),' could not be closed' + write(fates_log(), *) 'aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + call shr_file_freeUnit(file_unit) + stop + end do - deallocate(inv_pss_list,inv_css_list,inv_lat_list,inv_lon_list) + deallocate(inv_format_list, inv_pss_list, inv_css_list, inv_lat_list, inv_lon_list) else - 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 - age = 0.0_r8 + !FIX(SPM,032414) clean this up...inits out of this loop do s = 1, nsites diff --git a/main/FatesInventoryInitMod.F90 b/main/FatesInventoryInitMod.F90 index 7d616a35..0cd37be6 100644 --- a/main/FatesInventoryInitMod.F90 +++ b/main/FatesInventoryInitMod.F90 @@ -19,13 +19,15 @@ module FatesInventoryInitMod !----------------------------------------------------------------------------------------------- ! CIME GLOBALS - use shr_file_mod, only : shr_file_getUnit + use shr_log_mod , only : errMsg => shr_log_errMsg ! FATES GLOBALS use FatesConstantsMod, only : r8 => fates_r8 use FatesGlobals , only : endrun => fates_endrun use FatesGlobals , only : fates_log + + use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type, area implicit none @@ -34,27 +36,15 @@ module FatesInventoryInitMod character(len=*), parameter, private :: sourcefile = & __FILE__ + logical, parameter :: debug_inv = .true. + public :: count_inventory_sites - public :: get_inventory_file_unit public :: inv_file_list public :: assess_inventory_sites + public :: set_inventory_edpatch_type1 contains - - - - - ! ============================================================================================== - - ! This is is as wrappery as wrapper get - function get_inventory_file_unit() result(file_unit) - integer :: file_unit - file_unit = shr_file_getUnit() - return - end function get_inventory_file_unit - - ! ============================================================================================== @@ -90,12 +80,13 @@ end function count_inventory_sites ! ============================================================================================== - subroutine assess_inventory_sites(file_unit,nsites, & + subroutine assess_inventory_sites(file_unit,nsites, inv_format_list, & inv_pss_list,inv_css_list, & inv_lat_list,inv_lon_list) integer, intent(in) :: file_unit integer, intent(in) :: nsites + integer, intent(inout) :: inv_format_list(nsites) character(len=256),intent(inout) :: inv_pss_list(nsites) character(len=256),intent(inout) :: inv_css_list(nsites) real(r8),intent(inout) :: inv_lat_list(nsites) @@ -110,31 +101,40 @@ subroutine assess_inventory_sites(file_unit,nsites, & real(r8) :: site_lat real(r8) :: site_lon integer :: iblnk + integer :: file_format logical :: lex rewind(unit=file_unit) read(file_unit,fmt='(4A)') header_str - print*,trim(header_str) + do isite=1,nsites ! Read in the whole line read(file_unit,fmt='(a)',iostat=ios) site_str - ! Parse the first entry from the line (latitude) + ! Parse the format identifier + read(site_str,*) file_format + + ! Parse the latitude + site_str = adjustl(site_str) + iblnk = index(site_str,' ') + site_str = adjustl(site_str(iblnk:)) read(site_str,*) site_lat - ! Parse the second entry from the line (longitude) + ! Parse the longitude site_str = adjustl(site_str) iblnk = index(site_str,' ') site_str = adjustl(site_str(iblnk:)) read(site_str,*) site_lon + ! Parse the pss file name site_str = adjustl(site_str) iblnk = index(site_str,' ') site_str = adjustl(site_str(iblnk:)) iblnk = index(site_str,' ') read(site_str(:iblnk),fmt='(1A)') pss_file + ! Parse the css file name site_str = adjustl(site_str) iblnk = index(site_str,' ') site_str = adjustl(site_str(iblnk:)) @@ -168,6 +168,7 @@ subroutine assess_inventory_sites(file_unit,nsites, & ! If we have made it to this point, then in all likelihood, the PSS/CSS ! File has probably been correctly identified + inv_format_list(isite) = file_format inv_pss_list(isite) = pss_file inv_css_list(isite) = css_file inv_lat_list(isite) = site_lat @@ -179,5 +180,118 @@ subroutine assess_inventory_sites(file_unit,nsites, & end subroutine assess_inventory_sites + ! ============================================================================================== + + subroutine set_inventory_edpatch_type1(newpatch,file_unit,ipa,ios) + + ! -------------------------------------------------------------------------------------------- + ! This subroutine reads in a line of an inventory patch file (pss) + ! And populates a new patch with that information. + ! This routine specifically reads PSS files that are "Type 1" formatted + ! + ! FILE FORMAT: + ! time (year) year of measurement + ! patch (string) patch id string + ! trk (integer) LU type index (0 non-forest, 1 secondary, 2 primary + ! age (years) Time since this patch was disturbed (created) + ! area (fraction) Fraction of the site occupied by this patch + ! water (NA) Water content of soil (NOT USED) + ! fsc (kg/m2) Fast Soil Carbon + ! stsc (kg/m2) Structural Soil Carbon + ! stsl (kg/m2) Structural Soil Lignan + ! ssc (kg/m2) Slow Soil Carbon + ! psc (NA) Passive Soil Carbon (NOT USED) + ! msn (kg/m2) Mineralized Soil Nitrogen + ! fsn (kg/m2) Fast Soil Nitrogen + ! -------------------------------------------------------------------------------------------- + + use EDTypesMod, only: get_age_class_index + use EDtypesMod, only: AREA + use EDTypesMod, only: numpft_ed + use EDTypesMod, only: ncwd + use SFParamsMod , only : SF_val_CWD_frac + use EDParamsMod , only : ED_val_ag_biomass + + + + ! Arguments + type(ed_patch_type),intent(inout), target :: newpatch ! Patch structure + integer,intent(in) :: file_unit ! Self explanatory + integer,intent(in) :: ipa ! Patch index (line number) + integer,intent(out) :: ios ! Return flag + + real(r8) :: p_time ! Time patch was recorded + character(len=64) :: p_name ! Unique ID string defining patch + real(r8) :: p_trk ! Land Use index + ! 0 = Agriculture, 1 = Secondary Forest + ! 2 = Primary Forest, 3 = Forest Plantation + ! 4 = Burnt Patch, 5 = Abandoned (secondary growth) + ! 6 = Logged Forest + real(r8) :: p_age ! Patch age [years] + real(r8) :: p_area ! Patch area [fraction] + real(r8) :: p_water ! Patch water (unused) + real(r8) :: p_fsc ! Patch fast soil carbon + real(r8) :: p_stsc ! Patch structural soil carbon + real(r8) :: p_stsl ! Patch structural soil lignans + real(r8) :: p_ssc ! Patch slow soil carbon + real(r8) :: p_psc ! Patch P soil carbon + real(r8) :: p_msn ! Patch mean soil nitrogen + real(r8) :: p_fsn ! Patch fast soil nitrogen + integer :: icwd ! index for counting CWD pools + integer :: ipft ! index for counting PFTs + real(r8) :: pftfrac ! the inverse of the total number of PFTs + + character(len=128),parameter :: wr_fmt = & + '(F5.2,2X,A4,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2)' + + real(r8), parameter :: cwdfrac = 0.95 ! CWD is 95% of structural biomass (GUESS, BAD ONE) + real(r8), parameter :: leaffrac = 0.5 ! leaf litter is this fraction of total + + + read(file_unit,fmt=*,iostat=ios) p_time, p_name, p_trk, p_age, p_area, & + p_water,p_fsc, p_stsc, p_stsl, p_ssc, & + p_psc, p_msn, p_fsn + + if (ios/=0) return + + if( debug_inv) then + write(*,fmt=wr_fmt) & + p_time, p_name, p_trk, p_age, p_area, & + p_water,p_fsc, p_stsc, p_stsl, p_ssc, & + p_psc, p_msn, p_fsn + end if + + ! Fill in the patch's memory structures + + newpatch%age = p_age + newpatch%age_class = get_age_class_index(newpatch%age) + newpatch%area = p_area*AREA + + ! The non-litter patch soil variables need to be sent to the HLM + ! This is not being sent as of this message (RGK 06-2017) + + ! Estimate CWD and litter pools from p_stsc (twig,s branch,l branch, trunk) + + ! Lets start out assuming that CWD is about 95% of the total structural + ! carbon pool from non-living biomass + + do icwd = 1, ncwd + newpatch%cwd_ag(icwd) = p_stsc*cwdfrac*ED_val_ag_biomass * SF_val_CWD_frac(icwd) + newpatch%cwd_bg(icwd) = p_stsc*cwdfrac*(1.0_r8 - ED_val_ag_biomass) * SF_val_CWD_frac(icwd) + end do + + pftfrac = 1.0_r8/dble(numpft_ed) + + do ipft = 1, numpft_ed + newpatch%leaf_litter(ipft) = p_stsc*(1.0_r8-cwdfrac)*leaffrac*pftfrac + newpatch%root_litter(ipft) = p_stsc*(1.0_r8-cwdfrac)*(1.0_r8-leaffrac)*pftfrac + end do + + return + + end subroutine set_inventory_edpatch_type1 + + + end module FatesInventoryInitMod From 26a87d00dd4a07ae714c44b643211b4bba6b0c3b Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 22 Jun 2017 18:52:18 -0700 Subject: [PATCH 420/437] Completed first pass at reading in cohort data from inventory, as well as fusing, sorting and associating cohorts with patches. --- main/EDInitMod.F90 | 352 +++++------------ main/FatesInventoryInitMod.F90 | 694 ++++++++++++++++++++++++++------- 2 files changed, 652 insertions(+), 394 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 9abebc9a..fb4ab011 100755 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -192,271 +192,97 @@ end subroutine set_site_properties ! ============================================================================ subroutine init_patches( nsites, sites, bc_in) - ! - ! !DESCRIPTION: - ! initialize patches - ! This may be call a near bare ground initialization, or it may - ! load patches from an inventory. - - ! - ! !USES: - use shr_file_mod, only : shr_file_getUnit - use shr_file_mod, only : shr_file_freeUnit - - use EDPatchDynamicsMod , only : dealloc_patch - use EDParamsMod , only : ED_val_maxspread - use FatesPlantHydraulicsMod, only : updateSizeDepRhizHydProps - use FatesInventoryInitMod, only : inv_file_list - use FatesInventoryInitMod, only : count_inventory_sites - use FatesInventoryInitMod, only : assess_inventory_sites - use FatesInventoryInitMod, only : set_inventory_edpatch_type1 - - ! - ! !ARGUMENTS - integer, intent(in) :: nsites - type(ed_site_type) , intent(inout), target :: sites(nsites) - type(bc_in_type), intent(in) :: bc_in(nsites) - ! - ! !LOCAL VARIABLES: - integer :: s - 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) :: age !notional age of this patch - type(ed_patch_type), pointer :: newp - type(ed_patch_type), pointer :: newpatch - type(ed_patch_type), pointer :: oldpatch - - - ! Census Initialization variables - integer :: file_unit - integer :: nfilesites ! number of sites in the inventory file list - logical :: lod ! logical, file "O"pene"D" - logical :: lex ! logical, file "EX"ists - integer :: ios ! integer, "IO" status - character(len=512) :: iostr - logical, parameter :: do_inv_init = .true. - integer, allocatable :: inv_format_list(:) - character(len=256), allocatable :: inv_css_list(:) - character(len=256), allocatable :: inv_pss_list(:) - real(r8), allocatable :: inv_lat_list(:) - real(r8), allocatable :: inv_lon_list(:) - integer :: invsite - integer :: ipa ! Patch index - - - ! List out some nominal patch values that are used for Near Bear Ground initializations - ! as well as initializing inventory - ! --------------------------------------------------------------------------------------------- - 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 - age = 0.0_r8 - ! --------------------------------------------------------------------------------------------- - - ! --------------------------------------------------------------------------------------------- - ! Two primary options, either a Near Bear Ground (NBG) or Inventory based cold-start - ! --------------------------------------------------------------------------------------------- - - if (do_inv_init) then - - ! I. Load the inventory list file, do some file handle checks - ! ------------------------------------------------------------------------------------------ - - file_unit = shr_file_getUnit() - inquire(file=trim(inv_file_list),exist=lex,opened=lod) - if( .not.lex ) then ! The inventory file list DOE - write(fates_log(), *) 'An inventory Initialization was requested.' - write(fates_log(), *) 'However the inventory file: ',trim(inv_file_list),' DNE' - write(fates_log(), *) 'Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - if( lod ) then ! The inventory file should not be open - write(fates_log(), *) 'The inventory list file is open but should not be.' - write(fates_log(), *) 'Aborting.' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - open(unit=file_unit,file=trim(inv_file_list),status='OLD',action='READ',form='FORMATTED') - rewind(file_unit) - - ! There should be at least 1 line - read(file_unit,fmt='(A)',iostat=ios) iostr - read(file_unit,fmt='(A)',iostat=ios) iostr - if( ios /= 0 ) then - write(fates_log(), *) 'The inventory file does not contain at least two lines' - write(fates_log(), *) 'of data, ie a header and 1 site. Aborting.' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - rewind(unit=file_unit) - - - ! Count the number of sites that are listed in this file, and allocate storage arrays - ! ------------------------------------------------------------------------------------------ - - nfilesites = count_inventory_sites(file_unit) - - allocate(inv_format_list(nfilesites)) - allocate(inv_pss_list(nfilesites)) - allocate(inv_css_list(nfilesites)) - allocate(inv_lat_list(nfilesites)) - allocate(inv_lon_list(nfilesites)) - - - ! Check through the sites that are listed and do some sanity checks - ! ------------------------------------------------------------------------------------------ - call assess_inventory_sites(file_unit, nfilesites, inv_format_list, & - inv_pss_list, inv_css_list, & - inv_lat_list, inv_lon_list) - - ! We can close the list file now. - close(file_unit, iostat = ios) - if( ios /= 0 ) then - write(fates_log(), *) 'The inventory file needed to be closed, but was still open' - write(fates_log(), *) 'aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - call shr_file_freeUnit(file_unit) - - - ! For each site, identify the most proximal PSS/CSS couplet, read-in the data - ! allocate linked lists and assign to memory - do s = 1, nsites - invsite = & - minloc( (sites(s)%lat-inv_lat_list(:))**2.0_r8 + (sites(s)%lon-inv_lon_list(:))**2.0_r8 , dim=1) - - ! Open the PSS/CSS couplet and initialize the ED data structures. - ! Lets start withe the PSS - ! --------------------------------------------------------------------------------------- - - file_unit = shr_file_getUnit() - open(unit=file_unit,file=trim(inv_pss_list(invsite)),status='OLD',action='READ',form='FORMATTED') - rewind(file_unit) - read(file_unit,fmt=*) iostr - print*,"PATCH HEADER:" - print*,trim(iostr) - - ipa = 0 - invpatchloop: do - - allocate(newpatch) - - newpatch%patchno = ipa - newpatch%younger => null() - newpatch%older => null() - - ! This call doesn't do much asside from initializing the patch with - ! nominal values, NaNs, zero's and allocating some vectors - call create_patch(sites(s), newpatch, 0.0_r8, 0.0_r8, & - spread_local, cwd_ag_local, cwd_bg_local, leaf_litter_local, & - root_litter_local) - - - if( inv_format_list(invsite) == 1 ) then - - call set_inventory_edpatch_type1(newpatch,file_unit,ipa,ios) - - end if - - ! If a new line was found in the inventory patch file, - ! then it will return an IO status flag (ios) of 0 - ! In that case, the patch structure (newpatch) has been filled - ! with relevant information. - ! - ! Add it to the site's patch list - ! ------------------------------------------------------------------------------------ - if(ios==0) then - - if(ipa == 0) then - ! This is the first patch to be added - ! It starts off as the oldest and youngest patch in the list - sites(s)%youngest_patch => newpatch - sites(s)%oldest_patch => newpatch - oldpatch => newpatch - else - ! At least for now, we will assume that each subsequent - ! patch is a younger one. We can sort when we are done - ! but lets not worry about it immediately - newpatch%older => oldpatch - newpatch%younger => NULL() - sites(s)%youngest_patch => newpatch - oldpatch => newpatch - end if - - ! If a new line was NOT found in the inventory patch file, - ! then no patch was populated and we should just deallocate the temporary - ! and move along (tidy up site list and go to the next site) - else - - call dealloc_patch(newpatch) - deallocate(newpatch) - exit ! This should break the do loop - - end if - - - - ipa = ipa + 1 - end do invpatchloop - - stop - - - ! Sort the patch list by age - ! --------------------------------------------------------------------------------------- - - - - close(file_unit,iostat=ios) - if( ios /= 0 ) then - write(fates_log(), *) 'The pss file: ',inv_pss_list(invsite),' could not be closed' - write(fates_log(), *) 'aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - call shr_file_freeUnit(file_unit) - stop - end do - - deallocate(inv_format_list, inv_pss_list, inv_css_list, inv_lat_list, inv_lon_list) - - else - - - - !FIX(SPM,032414) clean this up...inits out of this loop - do s = 1, nsites - - allocate(newp) - - newp%patchno = 1 - newp%younger => null() - newp%older => null() - - sites(s)%youngest_patch => newp - sites(s)%youngest_patch => newp - sites(s)%oldest_patch => newp + ! + ! !DESCRIPTION: + ! initialize patches + ! This may be call a near bare ground initialization, or it may + ! load patches from an inventory. - ! make new patch... - call create_patch(sites(s), newp, age, AREA, & - spread_local, cwd_ag_local, cwd_bg_local, leaf_litter_local, & - root_litter_local) - - call init_cohorts(newp, bc_in(s)) - - ! This sets the rhizosphere shells based on the plant initialization - ! The initialization of the plant-relevant hydraulics variables - ! were set from a call inside of the init_cohorts()->create_cohort() subroutine - if (use_fates_plant_hydro) then - call updateSizeDepRhizHydProps(sites(s), bc_in(s)) - end if - - enddo + ! + - end if + use EDPatchDynamicsMod , only : dealloc_patch + use EDParamsMod , only : ED_val_maxspread + use FatesPlantHydraulicsMod, only : updateSizeDepRhizHydProps + use FatesInventoryInitMod, only : initialize_sites_by_inventory + + ! + ! !ARGUMENTS + integer, intent(in) :: nsites + type(ed_site_type) , intent(inout), target :: sites(nsites) + type(bc_in_type), intent(in) :: bc_in(nsites) + ! + ! !LOCAL VARIABLES: + integer :: s + 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) :: age !notional age of this patch + type(ed_patch_type), pointer :: newp + logical, parameter :: do_inv_init = .true. + + ! List out some nominal patch values that are used for Near Bear Ground initializations + ! as well as initializing inventory + ! --------------------------------------------------------------------------------------------- + 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 + age = 0.0_r8 + ! --------------------------------------------------------------------------------------------- + + ! --------------------------------------------------------------------------------------------- + ! Two primary options, either a Near Bear Ground (NBG) or Inventory based cold-start + ! --------------------------------------------------------------------------------------------- + + if (do_inv_init) then + + call initialize_sites_by_inventory(nsites,sites,bc_in, & + ncwd, numpft_ed, nclmax, & + cwd_ag_local, cwd_bg_local, leaf_litter_local, & + root_litter_local, spread_local) + + do s = 1, nsites + if (use_fates_plant_hydro) then + call updateSizeDepRhizHydProps(sites(s), bc_in(s)) + end if + enddo + + else + + !FIX(SPM,032414) clean this up...inits out of this loop + do s = 1, nsites + + allocate(newp) + + newp%patchno = 1 + newp%younger => null() + newp%older => null() + + sites(s)%youngest_patch => newp + sites(s)%youngest_patch => newp + sites(s)%oldest_patch => newp + + ! make new patch... + call create_patch(sites(s), newp, age, AREA, & + spread_local, cwd_ag_local, cwd_bg_local, leaf_litter_local, & + root_litter_local) + + call init_cohorts(newp, bc_in(s)) + + ! This sets the rhizosphere shells based on the plant initialization + ! The initialization of the plant-relevant hydraulics variables + ! were set from a call inside of the init_cohorts()->create_cohort() subroutine + if (use_fates_plant_hydro) then + call updateSizeDepRhizHydProps(sites(s), bc_in(s)) + end if + + enddo + + end if end subroutine init_patches diff --git a/main/FatesInventoryInitMod.F90 b/main/FatesInventoryInitMod.F90 index 0cd37be6..e00b8a4d 100644 --- a/main/FatesInventoryInitMod.F90 +++ b/main/FatesInventoryInitMod.F90 @@ -19,46 +19,338 @@ module FatesInventoryInitMod !----------------------------------------------------------------------------------------------- ! CIME GLOBALS - + use shr_log_mod , only : errMsg => shr_log_errMsg ! FATES GLOBALS use FatesConstantsMod, only : r8 => fates_r8 use FatesGlobals , only : endrun => fates_endrun use FatesGlobals , only : fates_log - + use FatesInterfaceMod, only : bc_in_type use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type, area - + use EDPftvarcon , only : EDPftvarcon_inst + use EDEcophysConType , only : EDecophyscon + implicit none - + private + + type pp_array + type(ed_patch_type), pointer :: cpatch + end type pp_array + character(len=*), parameter :: inv_file_list = 'inventory_file_list.txt' character(len=*), parameter, private :: sourcefile = & __FILE__ - logical, parameter :: debug_inv = .true. + logical, parameter :: debug_inv = .true. + + integer, parameter :: patchname_strlen = 64 + integer, parameter :: line_strlen = 512 + integer, parameter :: path_strlen = 256 - public :: count_inventory_sites - public :: inv_file_list - public :: assess_inventory_sites - public :: set_inventory_edpatch_type1 + + public :: initialize_sites_by_inventory contains ! ============================================================================================== + subroutine initialize_sites_by_inventory(nsites,sites,bc_in, & + ncwd, npft, nclmax, cwd_ag_local, cwd_bg_local, & + leaf_litter_local, root_litter_local, spread_local) + + ! !USES: + use shr_file_mod, only : shr_file_getUnit + use shr_file_mod, only : shr_file_freeUnit + use EDPatchDynamicsMod, only : create_patch + use EDPatchDynamicsMod, only : fuse_patches + use EDCohortDynamicsMod, only : fuse_cohorts + use EDCohortDynamicsMod, only : sort_cohorts + + ! Arguments + integer, intent(in) :: nsites + type(ed_site_type) , intent(inout), target :: sites(nsites) + type(bc_in_type), intent(in) :: bc_in(nsites) + integer :: ncwd + integer :: npft + integer :: nclmax + real(r8) :: cwd_ag_local(ncwd) + real(r8) :: cwd_bg_local(ncwd) + real(r8) :: spread_local(nclmax) + real(r8) :: leaf_litter_local(npft) + real(r8) :: root_litter_local(npft) + + ! Locals + type(ed_patch_type), pointer :: currentpatch + type(ed_patch_type), pointer :: newpatch + type(ed_patch_type), pointer :: olderpatch + integer :: file_unit + integer :: nfilesites ! number of sites in the inventory file list + logical :: lod ! logical, file "O"pene"D" + logical :: lex ! logical, file "EX"ists + integer :: ios ! integer, "IO" status + character(len=line_strlen) :: header_str + + integer :: s + integer :: ipa + integer, allocatable :: inv_format_list(:) + character(len=path_strlen), allocatable :: inv_css_list(:) + character(len=path_strlen), allocatable :: inv_pss_list(:) + real(r8), allocatable :: inv_lat_list(:) + real(r8), allocatable :: inv_lon_list(:) + integer :: invsite + character(len=patchname_strlen) :: patch_name + integer :: npatches + type(pp_array), allocatable :: patch_pointer_vec(:) + character(len=patchname_strlen), allocatable :: patch_name_vec(:) + + ! I. Load the inventory list file, do some file handle checks + ! ------------------------------------------------------------------------------------------ + + file_unit = shr_file_getUnit() + inquire(file=trim(inv_file_list),exist=lex,opened=lod) + if( .not.lex ) then ! The inventory file list DOE + write(fates_log(), *) 'An inventory Initialization was requested.' + write(fates_log(), *) 'However the inventory file: ',trim(inv_file_list),' DNE' + write(fates_log(), *) 'Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + if( lod ) then ! The inventory file should not be open + write(fates_log(), *) 'The inventory list file is open but should not be.' + write(fates_log(), *) 'Aborting.' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + open(unit=file_unit,file=trim(inv_file_list),status='OLD',action='READ',form='FORMATTED') + rewind(file_unit) + + ! There should be at least 1 line + read(file_unit,fmt='(A)',iostat=ios) header_str + read(file_unit,fmt='(A)',iostat=ios) header_str + if( ios /= 0 ) then + write(fates_log(), *) 'The inventory file does not contain at least two lines' + write(fates_log(), *) 'of data, ie a header and 1 site. Aborting.' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + rewind(unit=file_unit) + + + ! Count the number of sites that are listed in this file, and allocate storage arrays + ! ------------------------------------------------------------------------------------------ + + nfilesites = count_inventory_sites(file_unit) + + allocate(inv_format_list(nfilesites)) + allocate(inv_pss_list(nfilesites)) + allocate(inv_css_list(nfilesites)) + allocate(inv_lat_list(nfilesites)) + allocate(inv_lon_list(nfilesites)) + + + ! Check through the sites that are listed and do some sanity checks + ! ------------------------------------------------------------------------------------------ + call assess_inventory_sites(file_unit, nfilesites, inv_format_list, & + inv_pss_list, inv_css_list, & + inv_lat_list, inv_lon_list) + + ! We can close the list file now. + close(file_unit, iostat = ios) + if( ios /= 0 ) then + write(fates_log(), *) 'The inventory file needed to be closed, but was still open' + write(fates_log(), *) 'aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + call shr_file_freeUnit(file_unit) + + + ! For each site, identify the most proximal PSS/CSS couplet, read-in the data + ! allocate linked lists and assign to memory + do s = 1, nsites + invsite = & + minloc( (sites(s)%lat-inv_lat_list(:))**2.0_r8 + (sites(s)%lon-inv_lon_list(:))**2.0_r8 , dim=1) + + ! Open the PSS/CSS couplet and initialize the ED data structures. + ! Lets start withe the PSS + ! --------------------------------------------------------------------------------------- + + file_unit = shr_file_getUnit() + open(unit=file_unit,file=trim(inv_pss_list(invsite)),status='OLD',action='READ',form='FORMATTED') + rewind(file_unit) + read(file_unit,fmt=*) header_str + + ! Do one quick pass through just to count lines + ipa = 0 + countpatchloop: do + read(file_unit,fmt=*,iostat=ios) header_str + if(ios/=0) exit + ipa = ipa + 1 + end do countpatchloop + rewind(file_unit) + read(file_unit,fmt=*) header_str + + npatches = ipa + allocate(patch_name_vec(npatches)) + allocate(patch_pointer_vec(npatches)) + + + do ipa=1,npatches + + allocate(newpatch) + + newpatch%patchno = ipa + newpatch%younger => null() + newpatch%older => null() + + ! This call doesn't do much asside from initializing the patch with + ! nominal values, NaNs, zero's and allocating some vectors + call create_patch(sites(s), newpatch, 0.0_r8, 0.0_r8, & + spread_local, cwd_ag_local, cwd_bg_local, leaf_litter_local, & + root_litter_local) + + if( inv_format_list(invsite) == 1 ) then + call set_inventory_edpatch_type1(newpatch,file_unit,ipa,ios,patch_name) + end if + + ! Add it to the site's patch list + ! ------------------------------------------------------------------------------------ + + patch_name_vec(ipa) = trim(patch_name) + patch_pointer_vec(ipa)%cpatch => newpatch + + if(ipa == 1) then + ! This is the first patch to be added + ! It starts off as the oldest and youngest patch in the list + sites(s)%youngest_patch => newpatch + sites(s)%oldest_patch => newpatch + else + + ! Insert this patch into the patch LL + ! First check the two end-cases + + ! Youngest Patch + if(newpatch%age<=sites(s)%youngest_patch%age)then + newpatch%older => sites(s)%youngest_patch + newpatch%younger => null() + sites(s)%youngest_patch%younger => newpatch + sites(s)%youngest_patch => newpatch + + ! Oldest Patch + else if(newpatch%age>sites(s)%oldest_patch%age)then + newpatch%older => null() + newpatch%younger => sites(s)%oldest_patch + sites(s)%oldest_patch%older => newpatch + sites(s)%oldest_patch => newpatch + + ! Somewhere in the middle + else + currentpatch => sites(s)%youngest_patch + do while(associated(currentpatch)) + + olderpatch => currentpatch%older + if(associated(currentpatch%older)) then + if(newpatch%age >= currentpatch%age .and. & + newpatch%age < olderpatch%age) then + ! Set the new patches pointers + newpatch%older => currentpatch%older + newpatch%younger => currentpatch + ! Fix the patch's older pointer + currentpatch%older => newpatch + ! Fix the older patch's younger pointer + olderpatch%younger => newpatch + end if + end if + + currentPatch => olderpatch + enddo + + end if + end if + + end do + + close(file_unit,iostat=ios) + if( ios /= 0 ) then + write(fates_log(), *) 'The pss file: ',inv_pss_list(invsite),' could not be closed' + write(fates_log(), *) 'aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + call shr_file_freeUnit(file_unit) + + currentpatch => sites(s)%youngest_patch + do while(associated(currentpatch)) + print*,"NEW INVENTORY PATCH, AGE: ",currentpatch%age," AREA: ",currentpatch%area + currentPatch => currentpatch%older + enddo + + + ! OPEN THE CSS FILE AND ASSOCIATE IT WITH THE RIGHT PATCH + ! --------------------------------------------------------------------------------------- + file_unit = shr_file_getUnit() + open(unit=file_unit,file=trim(inv_css_list(invsite)),status='OLD',action='READ',form='FORMATTED') + rewind(file_unit) + read(file_unit,fmt=*) header_str + + invcohortloop: do + if( inv_format_list(invsite) == 1 ) then + call set_inventory_edcohort_type1(sites(s),bc_in(s),file_unit, & + npatches, patch_pointer_vec,patch_name_vec, ios) + end if + if(ios/=0) then + exit + end if + end do invcohortloop + + close(file_unit,iostat=ios) + if( ios /= 0 ) then + write(fates_log(), *) 'The css file: ',inv_css_list(invsite),' could not be closed' + write(fates_log(), *) 'aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + call shr_file_freeUnit(file_unit) + + deallocate(patch_pointer_vec,patch_name_vec) + + ! Update the patch index numbers and fuse the cohorts in the patches + ! ---------------------------------------------------------------------------------------- + ipa=1 + currentpatch => sites(s)%youngest_patch + do while(associated(currentpatch)) + currentpatch%patchno = ipa + ipa=ipa+1 + + ! Perform Cohort Fusion + call fuse_cohorts(currentpatch,bc_in(s)) + call sort_cohorts(currentpatch) + + currentPatch => currentpatch%older + enddo + + ! Fuse patches + ! ---------------------------------------------------------------------------------------- + call fuse_patches(sites(s), bc_in(s) ) + + + end do + + deallocate(inv_format_list, inv_pss_list, inv_css_list, inv_lat_list, inv_lon_list) + + + end subroutine initialize_sites_by_inventory + + ! ============================================================================================== function count_inventory_sites(file_unit) result(nsites) integer, intent(in) :: file_unit - character(len=512) :: header_str - character(len=512) :: site_str + character(len=line_strlen) :: header_str + character(len=line_strlen) :: site_str integer :: ios real(r8) :: site_lat real(r8) :: site_lon - character(len=256) :: pss_file - character(len=256) :: css_file + character(len=path_strlen) :: pss_file + character(len=path_strlen) :: css_file integer :: nsites @@ -81,29 +373,29 @@ end function count_inventory_sites ! ============================================================================================== subroutine assess_inventory_sites(file_unit,nsites, inv_format_list, & - inv_pss_list,inv_css_list, & - inv_lat_list,inv_lon_list) + inv_pss_list,inv_css_list, & + inv_lat_list,inv_lon_list) integer, intent(in) :: file_unit integer, intent(in) :: nsites integer, intent(inout) :: inv_format_list(nsites) - character(len=256),intent(inout) :: inv_pss_list(nsites) - character(len=256),intent(inout) :: inv_css_list(nsites) + character(len=path_strlen),intent(inout) :: inv_pss_list(nsites) + character(len=path_strlen),intent(inout) :: inv_css_list(nsites) real(r8),intent(inout) :: inv_lat_list(nsites) real(r8),intent(inout) :: inv_lon_list(nsites) - character(len=512) :: header_str - character(len=512) :: site_str + character(len=line_strlen) :: header_str + character(len=line_strlen) :: site_str integer :: isite integer :: ios - character(len=256) :: pss_file - character(len=256) :: css_file + character(len=path_strlen) :: pss_file + character(len=path_strlen) :: css_file real(r8) :: site_lat real(r8) :: site_lon integer :: iblnk integer :: file_format logical :: lex - + rewind(unit=file_unit) read(file_unit,fmt='(4A)') header_str @@ -150,14 +442,14 @@ subroutine assess_inventory_sites(file_unit,nsites, inv_format_list, & write(fates_log(), *) 'read invalid longitude: ',site_lon,' from inventory site list' call endrun(msg=errMsg(sourcefile, __LINE__)) end if - + inquire(file=trim(pss_file),exist=lex) if( .not.lex ) then write(fates_log(), *) 'the following pss file could not be found:' write(fates_log(), *) trim(pss_file) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - + inquire(file=trim(css_file),exist=lex) if( .not.lex ) then write(fates_log(), *) 'the following css file could not be found:' @@ -175,123 +467,263 @@ subroutine assess_inventory_sites(file_unit,nsites, inv_format_list, & inv_lon_list(isite) = site_lon end do - + end subroutine assess_inventory_sites ! ============================================================================================== - subroutine set_inventory_edpatch_type1(newpatch,file_unit,ipa,ios) - - ! -------------------------------------------------------------------------------------------- - ! This subroutine reads in a line of an inventory patch file (pss) - ! And populates a new patch with that information. - ! This routine specifically reads PSS files that are "Type 1" formatted - ! - ! FILE FORMAT: - ! time (year) year of measurement - ! patch (string) patch id string - ! trk (integer) LU type index (0 non-forest, 1 secondary, 2 primary - ! age (years) Time since this patch was disturbed (created) - ! area (fraction) Fraction of the site occupied by this patch - ! water (NA) Water content of soil (NOT USED) - ! fsc (kg/m2) Fast Soil Carbon - ! stsc (kg/m2) Structural Soil Carbon - ! stsl (kg/m2) Structural Soil Lignan - ! ssc (kg/m2) Slow Soil Carbon - ! psc (NA) Passive Soil Carbon (NOT USED) - ! msn (kg/m2) Mineralized Soil Nitrogen - ! fsn (kg/m2) Fast Soil Nitrogen - ! -------------------------------------------------------------------------------------------- - - use EDTypesMod, only: get_age_class_index - use EDtypesMod, only: AREA - use EDTypesMod, only: numpft_ed - use EDTypesMod, only: ncwd - use SFParamsMod , only : SF_val_CWD_frac - use EDParamsMod , only : ED_val_ag_biomass - - - - ! Arguments - type(ed_patch_type),intent(inout), target :: newpatch ! Patch structure - integer,intent(in) :: file_unit ! Self explanatory - integer,intent(in) :: ipa ! Patch index (line number) - integer,intent(out) :: ios ! Return flag - - real(r8) :: p_time ! Time patch was recorded - character(len=64) :: p_name ! Unique ID string defining patch - real(r8) :: p_trk ! Land Use index - ! 0 = Agriculture, 1 = Secondary Forest - ! 2 = Primary Forest, 3 = Forest Plantation - ! 4 = Burnt Patch, 5 = Abandoned (secondary growth) - ! 6 = Logged Forest - real(r8) :: p_age ! Patch age [years] - real(r8) :: p_area ! Patch area [fraction] - real(r8) :: p_water ! Patch water (unused) - real(r8) :: p_fsc ! Patch fast soil carbon - real(r8) :: p_stsc ! Patch structural soil carbon - real(r8) :: p_stsl ! Patch structural soil lignans - real(r8) :: p_ssc ! Patch slow soil carbon - real(r8) :: p_psc ! Patch P soil carbon - real(r8) :: p_msn ! Patch mean soil nitrogen - real(r8) :: p_fsn ! Patch fast soil nitrogen - integer :: icwd ! index for counting CWD pools - integer :: ipft ! index for counting PFTs - real(r8) :: pftfrac ! the inverse of the total number of PFTs - - character(len=128),parameter :: wr_fmt = & - '(F5.2,2X,A4,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2)' - - real(r8), parameter :: cwdfrac = 0.95 ! CWD is 95% of structural biomass (GUESS, BAD ONE) - real(r8), parameter :: leaffrac = 0.5 ! leaf litter is this fraction of total - - - read(file_unit,fmt=*,iostat=ios) p_time, p_name, p_trk, p_age, p_area, & - p_water,p_fsc, p_stsc, p_stsl, p_ssc, & - p_psc, p_msn, p_fsn - - if (ios/=0) return - - if( debug_inv) then - write(*,fmt=wr_fmt) & - p_time, p_name, p_trk, p_age, p_area, & - p_water,p_fsc, p_stsc, p_stsl, p_ssc, & - p_psc, p_msn, p_fsn - end if - - ! Fill in the patch's memory structures - - newpatch%age = p_age - newpatch%age_class = get_age_class_index(newpatch%age) - newpatch%area = p_area*AREA - - ! The non-litter patch soil variables need to be sent to the HLM - ! This is not being sent as of this message (RGK 06-2017) - - ! Estimate CWD and litter pools from p_stsc (twig,s branch,l branch, trunk) - - ! Lets start out assuming that CWD is about 95% of the total structural - ! carbon pool from non-living biomass - - do icwd = 1, ncwd - newpatch%cwd_ag(icwd) = p_stsc*cwdfrac*ED_val_ag_biomass * SF_val_CWD_frac(icwd) - newpatch%cwd_bg(icwd) = p_stsc*cwdfrac*(1.0_r8 - ED_val_ag_biomass) * SF_val_CWD_frac(icwd) - end do - - pftfrac = 1.0_r8/dble(numpft_ed) - - do ipft = 1, numpft_ed - newpatch%leaf_litter(ipft) = p_stsc*(1.0_r8-cwdfrac)*leaffrac*pftfrac - newpatch%root_litter(ipft) = p_stsc*(1.0_r8-cwdfrac)*(1.0_r8-leaffrac)*pftfrac - end do - - return + subroutine set_inventory_edpatch_type1(newpatch,file_unit,ipa,ios,patch_name) + + ! -------------------------------------------------------------------------------------------- + ! This subroutine reads in a line of an inventory patch file (pss) + ! And populates a new patch with that information. + ! This routine specifically reads PSS files that are "Type 1" formatted + ! + ! FILE FORMAT: + ! time (year) year of measurement + ! patch (string) patch id string + ! trk (integer) LU type index (0 non-forest, 1 secondary, 2 primary + ! age (years) Time since this patch was disturbed (created) + ! area (fraction) Fraction of the site occupied by this patch + ! water (NA) Water content of soil (NOT USED) + ! fsc (kg/m2) Fast Soil Carbon + ! stsc (kg/m2) Structural Soil Carbon + ! stsl (kg/m2) Structural Soil Lignan + ! ssc (kg/m2) Slow Soil Carbon + ! psc (NA) Passive Soil Carbon (NOT USED) + ! msn (kg/m2) Mineralized Soil Nitrogen + ! fsn (kg/m2) Fast Soil Nitrogen + ! -------------------------------------------------------------------------------------------- + + use EDTypesMod, only: get_age_class_index + use EDtypesMod, only: AREA + use EDTypesMod, only: numpft_ed + use EDTypesMod, only: ncwd + use SFParamsMod , only : SF_val_CWD_frac + use EDParamsMod , only : ED_val_ag_biomass + + + + ! Arguments + type(ed_patch_type),intent(inout), target :: newpatch ! Patch structure + integer,intent(in) :: file_unit ! Self explanatory + integer,intent(in) :: ipa ! Patch index (line number) + integer,intent(out) :: ios ! Return flag + character(len=patchname_strlen),intent(out) :: patch_name ! unique string identifier of patch + + real(r8) :: p_time ! Time patch was recorded + real(r8) :: p_trk ! Land Use index + ! 0 = Agriculture, 1 = Secondary Forest + ! 2 = Primary Forest, 3 = Forest Plantation + ! 4 = Burnt Patch, 5 = Abandoned (secondary growth) + ! 6 = Logged Forest + character(len=patchname_strlen) :: p_name ! unique string identifier of patch + real(r8) :: p_age ! Patch age [years] + real(r8) :: p_area ! Patch area [fraction] + real(r8) :: p_water ! Patch water (unused) + real(r8) :: p_fsc ! Patch fast soil carbon + real(r8) :: p_stsc ! Patch structural soil carbon + real(r8) :: p_stsl ! Patch structural soil lignans + real(r8) :: p_ssc ! Patch slow soil carbon + real(r8) :: p_psc ! Patch P soil carbon + real(r8) :: p_msn ! Patch mean soil nitrogen + real(r8) :: p_fsn ! Patch fast soil nitrogen + integer :: icwd ! index for counting CWD pools + integer :: ipft ! index for counting PFTs + real(r8) :: pftfrac ! the inverse of the total number of PFTs + + character(len=128),parameter :: wr_fmt = & + '(F5.2,2X,A4,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2)' + + real(r8), parameter :: cwdfrac = 0.95 ! CWD is 95% of structural biomass (GUESS, BAD ONE) + real(r8), parameter :: leaffrac = 0.5 ! leaf litter is this fraction of total + + + read(file_unit,fmt=*,iostat=ios) p_time, p_name, p_trk, p_age, p_area, & + p_water,p_fsc, p_stsc, p_stsl, p_ssc, & + p_psc, p_msn, p_fsn + + if (ios/=0) return + + patch_name = trim(p_name) + + if( debug_inv) then + write(*,fmt=wr_fmt) & + p_time, p_name, p_trk, p_age, p_area, & + p_water,p_fsc, p_stsc, p_stsl, p_ssc, & + p_psc, p_msn, p_fsn + end if + + ! Fill in the patch's memory structures + + newpatch%age = p_age + newpatch%age_class = get_age_class_index(newpatch%age) + newpatch%area = p_area*AREA + + ! The non-litter patch soil variables need to be sent to the HLM + ! This is not being sent as of this message (RGK 06-2017) + + ! --------------------------------------------------------------------- + ! The litter and CWD could be estimated from at least two methods + ! 1) after reading in the cohort data, assuming a SS turnover rate + ! 2) again assuming SS, back out the CWD and Litter flux rates into + ! the SSC, STSC and FSC pools that balance with their decomp rates + ! and then use those flux rates, to calculate the CWD and litter + ! pool sizes based on another SS model where flux out balances with + ! mortality and litter fluxes into the non-decomposing pool + ! + ! This is significant science modeling and does not have a simple + ! first hack solution. (RGK 06-2017) + ! ---------------------------------------------------------------------- + + do icwd = 1, ncwd + newpatch%cwd_ag(icwd) = 0.0_r8 + newpatch%cwd_bg(icwd) = 0.0_r8 + end do + + do ipft = 1, numpft_ed + newpatch%leaf_litter(ipft) = 0.0_r8 + newpatch%root_litter(ipft) = 0.0_r8 + end do + + return end subroutine set_inventory_edpatch_type1 + ! ============================================================================================== + + subroutine set_inventory_edcohort_type1(csite,bc_in,file_unit,npatches, & + patch_pointer_vec,patch_name_vec,ios) + + ! -------------------------------------------------------------------------------------------- + ! This subroutine reads in a line of an inventory cohort file (css) + ! And populates a new cohort with that information. + ! This routine specifically reads CSS files that are "Type 1" formatted + ! + ! FILE FORMAT: + ! time (year) year of measurement + ! patch (string) patch id string associated with this cohort + ! index (integer) cohort index + ! dbh (cm) diameter at breast height + ! height (m) height of the tree + ! pft (integer) the plant functional type index (must be consistent with param file) + ! n (/m2) The plant number density + ! bdead (kgC/plant)The dead biomass per indiv of this cohort (NOT USED) + ! balive (kgC/plant)The live biomass per indiv of this cohort (NOT USED) + ! avgRG (cm/yr?) Average Radial Growth (NOT USED) + ! -------------------------------------------------------------------------------------------- + + use EDTypesMod , only : numpft_ed + use EDGrowthFunctionsMod, only : hite + use EDGrowthFunctionsMod, only : bleaf + use EDGrowthFunctionsMod, only : bdead + use EDCohortDynamicsMod , only : create_cohort + + ! Arguments + type(ed_site_type),intent(inout), target :: csite ! current site + type(bc_in_type),intent(in) :: bc_in ! boundary conditions + integer, intent(in) :: file_unit ! Self explanatory + integer, intent(in) :: npatches + type(pp_array), intent(in) :: patch_pointer_vec(npatches) + character(len=patchname_strlen), intent(in) :: patch_name_vec(npatches) + integer,intent(out) :: ios ! Return flag + + real(r8) :: c_time ! Time patch was recorded + character(len=patchname_strlen) :: p_name ! The patch associated with this cohort + integer :: c_index ! cohort index + real(r8) :: c_dbh ! diameter at breast height (cm) + real(r8) :: c_height ! tree height (m) + integer :: c_pft ! plant functional type index + real(r8) :: c_nplant ! plant density (/m2) + real(r8) :: c_bdead ! dead biomass (kg) + real(r8) :: c_balive ! live biomass (kg) + real(r8) :: c_avgRG ! avg radial growth (NOT USED) + integer :: cstatus + type(ed_patch_type), pointer :: cpatch + type(ed_cohort_type), pointer :: temp_cohort + integer :: ipa + character(len=128),parameter :: wr_fmt = & + '(F5.2,2X,A4,2X,I4,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2)' + + read(file_unit,fmt=*,iostat=ios) c_time, p_name, c_index, c_dbh, c_height, & + c_pft, c_nplant, c_bdead, c_balive, c_avgRG + + if (ios/=0) return + + if( debug_inv) then + write(*,fmt=wr_fmt) & + c_time, p_name, c_index, c_dbh, c_height, & + c_pft, c_nplant, c_bdead, c_balive, c_avgRG + end if + + ! Identify the patch based on the patch_name + do ipa=1,npatches + if( trim(p_name) == trim(patch_name_vec(ipa))) then + cpatch => patch_pointer_vec(ipa)%cpatch + end if + end do + + + ! =================================================================== + ! KLUGE KLUGE KLUGE KLUGE KLUGE KLUGE KLUGE KLUGE KLUGE KLUGE KLUGE + c_pft = 1 + ! =================================================================== + + if (c_pft > numpft_ed ) then + write(fates_log(), *) 'An inventory cohort file specified a pft index' + write(fates_log(), *) 'greater than the maximum specified pfts ed_numpft' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + allocate(temp_cohort) ! A temporary cohort is needed because we want to make + ! use of the allometry functions + + temp_cohort%pft = c_pft + temp_cohort%n = c_nplant * cpatch%area + temp_cohort%hite = Hite(temp_cohort) + temp_cohort%dbh = c_dbh + temp_cohort%canopy_trim = 1.0_r8 + temp_cohort%bdead = Bdead(temp_cohort) + temp_cohort%balive = Bleaf(temp_cohort)*(1.0_r8 + EDPftvarcon_inst%froot_leaf(c_pft) & + + EDecophyscon%sapwood_ratio(c_pft)*temp_cohort%hite) + temp_cohort%b = temp_cohort%balive + temp_cohort%bdead + + if( EDPftvarcon_inst%evergreen(c_pft) == 1) then + temp_cohort%bstore = Bleaf(temp_cohort) * EDecophyscon%cushion(c_pft) + temp_cohort%laimemory = 0._r8 + cstatus = 2 + endif + + if( EDPftvarcon_inst%season_decid(c_pft) == 1 ) then !for dorment places + temp_cohort%bstore = Bleaf(temp_cohort) * EDecophyscon%cushion(c_pft) !stored carbon in new seedlings. + if(csite%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 = csite%status + endif + + if ( EDPftvarcon_inst%stress_decid(c_pft) == 1 ) then + temp_cohort%bstore = Bleaf(temp_cohort) * EDecophyscon%cushion(c_pft) + temp_cohort%laimemory = Bleaf(temp_cohort) + temp_cohort%balive = temp_cohort%balive - temp_cohort%laimemory + cstatus = csite%dstatus + endif + + call create_cohort(cpatch, c_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, bc_in) + + deallocate(temp_cohort) ! get rid of temporary cohort + + return + end subroutine set_inventory_edcohort_type1 end module FatesInventoryInitMod From 380eda153478739dd73fcf7f32f94e62df5fce06 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 23 Jun 2017 14:13:24 -0700 Subject: [PATCH 421/437] Various syntatical and refactor improvemnets to inventory initialization. Module is generating expected results, have not submitted to regressino testing yet. --- main/EDInitMod.F90 | 5 +- main/FatesInventoryInitMod.F90 | 382 ++++++++++++++++++++------------- 2 files changed, 230 insertions(+), 157 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index fb4ab011..9792ca9f 100755 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -240,10 +240,7 @@ subroutine init_patches( nsites, sites, bc_in) if (do_inv_init) then - call initialize_sites_by_inventory(nsites,sites,bc_in, & - ncwd, numpft_ed, nclmax, & - cwd_ag_local, cwd_bg_local, leaf_litter_local, & - root_litter_local, spread_local) + call initialize_sites_by_inventory(nsites,sites,bc_in) do s = 1, nsites if (use_fates_plant_hydro) then diff --git a/main/FatesInventoryInitMod.F90 b/main/FatesInventoryInitMod.F90 index e00b8a4d..a8a33192 100644 --- a/main/FatesInventoryInitMod.F90 +++ b/main/FatesInventoryInitMod.F90 @@ -20,32 +20,41 @@ module FatesInventoryInitMod ! CIME GLOBALS - use shr_log_mod , only : errMsg => shr_log_errMsg + use shr_log_mod , only : errMsg => shr_log_errMsg ! FATES GLOBALS use FatesConstantsMod, only : r8 => fates_r8 use FatesGlobals , only : endrun => fates_endrun use FatesGlobals , only : fates_log use FatesInterfaceMod, only : bc_in_type - use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type, area - use EDPftvarcon , only : EDPftvarcon_inst - use EDEcophysConType , only : EDecophyscon + use EDTypesMod , only : ed_site_type + use EDTypesMod , only : ed_patch_type + use EDTypesMod , only : ed_cohort_type + use EDTypesMod , only : area + use EDPftvarcon , only : EDPftvarcon_inst + use EDEcophysConType , only : EDecophyscon implicit none private + ! This derived type is to allow an array of pointers to the LL patch structure + ! This is different than allocating a vector of patches. This is needed for + ! quickly matching cohort string identifiers, the indices that match thos identifiers + ! with a patch. BY having a vector of patch pointers that lines up with the string + ! identifier array, this can be done quickly. type pp_array type(ed_patch_type), pointer :: cpatch end type pp_array - character(len=*), parameter :: inv_file_list = 'inventory_file_list.txt' + ! For now we will use a hard-coded file name for the inventory file list + character(len=*), parameter :: inv_file_list = 'inventory_file_list.txt' - character(len=*), parameter, private :: sourcefile = & - __FILE__ + character(len=*), parameter, private :: sourcefile = __FILE__ - logical, parameter :: debug_inv = .true. + logical, parameter :: debug_inv = .true. ! Debug flag for devs - integer, parameter :: patchname_strlen = 64 + ! String length specifiers + integer, parameter :: patchname_strlen = 64 integer, parameter :: line_strlen = 512 integer, parameter :: path_strlen = 256 @@ -56,54 +65,56 @@ module FatesInventoryInitMod ! ============================================================================================== - subroutine initialize_sites_by_inventory(nsites,sites,bc_in, & - ncwd, npft, nclmax, cwd_ag_local, cwd_bg_local, & - leaf_litter_local, root_litter_local, spread_local) + subroutine initialize_sites_by_inventory(nsites,sites,bc_in) ! !USES: use shr_file_mod, only : shr_file_getUnit use shr_file_mod, only : shr_file_freeUnit + use EDTypesMod, only : nclmax + use EDTypesMod, only : numpft_ed + use EDTypesMod, only : maxpft + use EDTypesMod, only : ncwd + use EDParamsMod, only : ED_val_maxspread use EDPatchDynamicsMod, only : create_patch use EDPatchDynamicsMod, only : fuse_patches use EDCohortDynamicsMod, only : fuse_cohorts use EDCohortDynamicsMod, only : sort_cohorts ! Arguments - integer, intent(in) :: nsites - type(ed_site_type) , intent(inout), target :: sites(nsites) - type(bc_in_type), intent(in) :: bc_in(nsites) - integer :: ncwd - integer :: npft - integer :: nclmax - real(r8) :: cwd_ag_local(ncwd) - real(r8) :: cwd_bg_local(ncwd) - real(r8) :: spread_local(nclmax) - real(r8) :: leaf_litter_local(npft) - real(r8) :: root_litter_local(npft) + integer, intent(in) :: nsites + type(ed_site_type), intent(inout), target :: sites(nsites) + type(bc_in_type), intent(in) :: bc_in(nsites) ! Locals - type(ed_patch_type), pointer :: currentpatch - type(ed_patch_type), pointer :: newpatch - type(ed_patch_type), pointer :: olderpatch - integer :: file_unit - integer :: nfilesites ! number of sites in the inventory file list - logical :: lod ! logical, file "O"pene"D" - logical :: lex ! logical, file "EX"ists - integer :: ios ! integer, "IO" status - character(len=line_strlen) :: header_str - - integer :: s - integer :: ipa - integer, allocatable :: inv_format_list(:) - character(len=path_strlen), allocatable :: inv_css_list(:) - character(len=path_strlen), allocatable :: inv_pss_list(:) - real(r8), allocatable :: inv_lat_list(:) - real(r8), allocatable :: inv_lon_list(:) - integer :: invsite - character(len=patchname_strlen) :: patch_name - integer :: npatches - type(pp_array), allocatable :: patch_pointer_vec(:) - character(len=patchname_strlen), allocatable :: patch_name_vec(:) + type(ed_patch_type), pointer :: currentpatch + type(ed_patch_type), pointer :: newpatch + type(ed_patch_type), pointer :: olderpatch + integer :: file_unit + integer :: nfilesites ! number of sites in file list + logical :: lod ! logical, file "O"pene"D" + logical :: lex ! logical, file "EX"ists + integer :: ios ! integer, "IO" status + character(len=line_strlen) :: header_str ! large string for whole lines + real(r8) :: age_init ! dummy value for creating a patch + real(r8) :: area_init ! dummy value for creating a patch + real(r8) :: spread_init(nclmax) ! dummy value for creating a patch + real(r8) :: cwd_ag_init(ncwd) ! dummy value for creating a patch + real(r8) :: cwd_bg_init(ncwd) ! dummy value for creating a patch + real(r8) :: leaf_litter_init(maxpft) ! dummy value for creating a patch + real(r8) :: root_litter_init(maxpft) ! dummy value for creating a patch + integer :: s ! site index + integer :: ipa ! patch index + integer, allocatable :: inv_format_list(:) ! list of format specs + character(len=path_strlen), allocatable :: inv_css_list(:) ! list of css file names + character(len=path_strlen), allocatable :: inv_pss_list(:) ! list of pss file names + real(r8), allocatable :: inv_lat_list(:) ! list of lat coords + real(r8), allocatable :: inv_lon_list(:) ! list of lon coords + integer :: invsite ! index of inventory site + ! closest to actual site + character(len=patchname_strlen) :: patch_name ! patch ID string in the file + integer :: npatches ! number of patches found in PSS + type(pp_array), allocatable :: patch_pointer_vec(:) ! vector of pointers to patch LL + character(len=patchname_strlen), allocatable :: patch_name_vec(:) ! vector of patch ID strings ! I. Load the inventory list file, do some file handle checks ! ------------------------------------------------------------------------------------------ @@ -154,7 +165,7 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in, & inv_pss_list, inv_css_list, & inv_lat_list, inv_lon_list) - ! We can close the list file now. + ! We can close the list file now close(file_unit, iostat = ios) if( ios /= 0 ) then write(fates_log(), *) 'The inventory file needed to be closed, but was still open' @@ -168,14 +179,16 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in, & ! allocate linked lists and assign to memory do s = 1, nsites invsite = & - minloc( (sites(s)%lat-inv_lat_list(:))**2.0_r8 + (sites(s)%lon-inv_lon_list(:))**2.0_r8 , dim=1) + minloc( (sites(s)%lat-inv_lat_list(:))**2.0_r8 + & + (sites(s)%lon-inv_lon_list(:))**2.0_r8 , dim=1) ! Open the PSS/CSS couplet and initialize the ED data structures. ! Lets start withe the PSS ! --------------------------------------------------------------------------------------- file_unit = shr_file_getUnit() - open(unit=file_unit,file=trim(inv_pss_list(invsite)),status='OLD',action='READ',form='FORMATTED') + open(unit=file_unit,file=trim(inv_pss_list(invsite)), & + status='OLD',action='READ',form='FORMATTED') rewind(file_unit) read(file_unit,fmt=*) header_str @@ -203,10 +216,21 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in, & newpatch%older => null() ! This call doesn't do much asside from initializing the patch with - ! nominal values, NaNs, zero's and allocating some vectors - call create_patch(sites(s), newpatch, 0.0_r8, 0.0_r8, & - spread_local, cwd_ag_local, cwd_bg_local, leaf_litter_local, & - root_litter_local) + ! nominal values, NaNs, zero's and allocating some vectors. We should + ! be able to get the following values from the patch files. But on + ! the patch creation step, we don't have that information. + + age_init = 0.0_r8 + area_init = 0.0_r8 + spread_init(:) = ED_val_maxspread + cwd_ag_init(:) = 0.0_r8 + cwd_bg_init(:) = 0.0_r8 + leaf_litter_init(1:numpft_ed) = 0.0_r8 + root_litter_init(1:numpft_ed) = 0.0_r8 + + call create_patch(sites(s), newpatch, age_init, area_init, spread_init, & + cwd_ag_init, cwd_bg_init, & + leaf_litter_init(1:numpft_ed), root_litter_init(1:numpft_ed) ) if( inv_format_list(invsite) == 1 ) then call set_inventory_edpatch_type1(newpatch,file_unit,ipa,ios,patch_name) @@ -246,7 +270,6 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in, & else currentpatch => sites(s)%youngest_patch do while(associated(currentpatch)) - olderpatch => currentpatch%older if(associated(currentpatch%older)) then if(newpatch%age >= currentpatch%age .and. & @@ -260,13 +283,10 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in, & olderpatch%younger => newpatch end if end if - currentPatch => olderpatch enddo - end if end if - end do close(file_unit,iostat=ios) @@ -277,32 +297,39 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in, & end if call shr_file_freeUnit(file_unit) - currentpatch => sites(s)%youngest_patch - do while(associated(currentpatch)) - print*,"NEW INVENTORY PATCH, AGE: ",currentpatch%age," AREA: ",currentpatch%area - currentPatch => currentpatch%older - enddo + if(debug_inv) then + write(fates_log(),*) 'Raw List of Inventory Patches, Age Sorted:' + currentpatch => sites(s)%youngest_patch + do while(associated(currentpatch)) + write(fates_log(),*) ' AGE: ',currentpatch%age,' AREA: ',currentpatch%area + currentPatch => currentpatch%older + enddo + end if - - ! OPEN THE CSS FILE AND ASSOCIATE IT WITH THE RIGHT PATCH + ! OPEN THE CSS FILE ! --------------------------------------------------------------------------------------- file_unit = shr_file_getUnit() - open(unit=file_unit,file=trim(inv_css_list(invsite)),status='OLD',action='READ',form='FORMATTED') + open(unit=file_unit,file=trim(inv_css_list(invsite)), & + status='OLD',action='READ',form='FORMATTED') rewind(file_unit) read(file_unit,fmt=*) header_str + ! Read in each cohort line. Each line is associated with a patch from the PSS + ! file via a patch name identification string. We pass the whole site pointer + ! to this routine, because inside the routine we identify the patch by making + ! comparisons with patch_name_vec and identifying the patch pointer + ! from patch_pointer_vec + invcohortloop: do - if( inv_format_list(invsite) == 1 ) then + if ( inv_format_list(invsite) == 1 ) then call set_inventory_edcohort_type1(sites(s),bc_in(s),file_unit, & npatches, patch_pointer_vec,patch_name_vec, ios) end if - if(ios/=0) then - exit - end if + if ( ios/=0 ) exit end do invcohortloop close(file_unit,iostat=ios) - if( ios /= 0 ) then + if( ios/=0 ) then write(fates_log(), *) 'The css file: ',inv_css_list(invsite),' could not be closed' write(fates_log(), *) 'aborting' call endrun(msg=errMsg(sourcefile, __LINE__)) @@ -330,29 +357,27 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in, & ! ---------------------------------------------------------------------------------------- call fuse_patches(sites(s), bc_in(s) ) - end do deallocate(inv_format_list, inv_pss_list, inv_css_list, inv_lat_list, inv_lon_list) - + return end subroutine initialize_sites_by_inventory ! ============================================================================================== function count_inventory_sites(file_unit) result(nsites) - integer, intent(in) :: file_unit + ! Simple function that counts the number of lines in the inventory descriptor file + + ! Arguments + integer, intent(in) :: file_unit + ! Locals character(len=line_strlen) :: header_str character(len=line_strlen) :: site_str - integer :: ios - real(r8) :: site_lat - real(r8) :: site_lon - character(len=path_strlen) :: pss_file - character(len=path_strlen) :: css_file - - integer :: nsites + integer :: ios + integer :: nsites ! Set the file position to the top of the file @@ -376,25 +401,36 @@ subroutine assess_inventory_sites(file_unit,nsites, inv_format_list, & inv_pss_list,inv_css_list, & inv_lat_list,inv_lon_list) - integer, intent(in) :: file_unit - integer, intent(in) :: nsites - integer, intent(inout) :: inv_format_list(nsites) + ! ------------------------------------------------------------------------------------------- + ! This subroutine looks through the inventory descriptor file + ! and line by line reads information about the available inventory + ! sites, and saves their information (such as location and file path) + ! to arrays. This routine also does some simple checks to make + ! sure it is not reading nonsense + ! ------------------------------------------------------------------------------------------- + + + ! Arguments + integer, intent(in) :: file_unit + integer, intent(in) :: nsites + integer, intent(inout) :: inv_format_list(nsites) character(len=path_strlen),intent(inout) :: inv_pss_list(nsites) character(len=path_strlen),intent(inout) :: inv_css_list(nsites) - real(r8),intent(inout) :: inv_lat_list(nsites) - real(r8),intent(inout) :: inv_lon_list(nsites) + real(r8),intent(inout) :: inv_lat_list(nsites) + real(r8),intent(inout) :: inv_lon_list(nsites) - character(len=line_strlen) :: header_str - character(len=line_strlen) :: site_str - integer :: isite - integer :: ios - character(len=path_strlen) :: pss_file - character(len=path_strlen) :: css_file - real(r8) :: site_lat - real(r8) :: site_lon - integer :: iblnk - integer :: file_format - logical :: lex + ! Locals + character(len=line_strlen) :: header_str + character(len=line_strlen) :: site_str + integer :: isite ! site index + integer :: ios ! fortran read status flag + character(len=path_strlen) :: pss_file + character(len=path_strlen) :: css_file + real(r8) :: site_lat ! inventory site latitude + real(r8) :: site_lon ! site longitude + integer :: iblnk ! Index used for string parsing + integer :: file_format ! format type (1=legacy ED pss/css) + logical :: lex ! file existence flag rewind(unit=file_unit) read(file_unit,fmt='(4A)') header_str @@ -468,8 +504,7 @@ subroutine assess_inventory_sites(file_unit,nsites, inv_format_list, & end do - - + return end subroutine assess_inventory_sites ! ============================================================================================== @@ -504,42 +539,34 @@ subroutine set_inventory_edpatch_type1(newpatch,file_unit,ipa,ios,patch_name) use SFParamsMod , only : SF_val_CWD_frac use EDParamsMod , only : ED_val_ag_biomass - - ! Arguments - type(ed_patch_type),intent(inout), target :: newpatch ! Patch structure - integer,intent(in) :: file_unit ! Self explanatory - integer,intent(in) :: ipa ! Patch index (line number) - integer,intent(out) :: ios ! Return flag - character(len=patchname_strlen),intent(out) :: patch_name ! unique string identifier of patch - - real(r8) :: p_time ! Time patch was recorded - real(r8) :: p_trk ! Land Use index - ! 0 = Agriculture, 1 = Secondary Forest - ! 2 = Primary Forest, 3 = Forest Plantation - ! 4 = Burnt Patch, 5 = Abandoned (secondary growth) - ! 6 = Logged Forest - character(len=patchname_strlen) :: p_name ! unique string identifier of patch - real(r8) :: p_age ! Patch age [years] - real(r8) :: p_area ! Patch area [fraction] - real(r8) :: p_water ! Patch water (unused) - real(r8) :: p_fsc ! Patch fast soil carbon - real(r8) :: p_stsc ! Patch structural soil carbon - real(r8) :: p_stsl ! Patch structural soil lignans - real(r8) :: p_ssc ! Patch slow soil carbon - real(r8) :: p_psc ! Patch P soil carbon - real(r8) :: p_msn ! Patch mean soil nitrogen - real(r8) :: p_fsn ! Patch fast soil nitrogen - integer :: icwd ! index for counting CWD pools - integer :: ipft ! index for counting PFTs - real(r8) :: pftfrac ! the inverse of the total number of PFTs + type(ed_patch_type),intent(inout), target :: newpatch ! Patch structure + integer,intent(in) :: file_unit ! Self explanatory + integer,intent(in) :: ipa ! Patch index (line number) + integer,intent(out) :: ios ! Return flag + character(len=patchname_strlen),intent(out) :: patch_name ! unique string identifier of patch + + ! Locals + real(r8) :: p_time ! Time patch was recorded + real(r8) :: p_trk ! Land Use index (see above descriptions) + character(len=patchname_strlen) :: p_name ! unique string identifier of patch + real(r8) :: p_age ! Patch age [years] + real(r8) :: p_area ! Patch area [fraction] + real(r8) :: p_water ! Patch water (unused) + real(r8) :: p_fsc ! Patch fast soil carbon + real(r8) :: p_stsc ! Patch structural soil carbon + real(r8) :: p_stsl ! Patch structural soil lignans + real(r8) :: p_ssc ! Patch slow soil carbon + real(r8) :: p_psc ! Patch P soil carbon + real(r8) :: p_msn ! Patch mean soil nitrogen + real(r8) :: p_fsn ! Patch fast soil nitrogen + integer :: icwd ! index for counting CWD pools + integer :: ipft ! index for counting PFTs + real(r8) :: pftfrac ! the inverse of the total number of PFTs character(len=128),parameter :: wr_fmt = & '(F5.2,2X,A4,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2)' - real(r8), parameter :: cwdfrac = 0.95 ! CWD is 95% of structural biomass (GUESS, BAD ONE) - real(r8), parameter :: leaffrac = 0.5 ! leaf litter is this fraction of total - read(file_unit,fmt=*,iostat=ios) p_time, p_name, p_trk, p_age, p_area, & p_water,p_fsc, p_stsc, p_stsl, p_ssc, & @@ -589,7 +616,6 @@ subroutine set_inventory_edpatch_type1(newpatch,file_unit,ipa,ios,patch_name) end do return - end subroutine set_inventory_edpatch_type1 @@ -623,30 +649,36 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,file_unit,npatches, & use EDCohortDynamicsMod , only : create_cohort ! Arguments - type(ed_site_type),intent(inout), target :: csite ! current site - type(bc_in_type),intent(in) :: bc_in ! boundary conditions - integer, intent(in) :: file_unit ! Self explanatory - integer, intent(in) :: npatches - type(pp_array), intent(in) :: patch_pointer_vec(npatches) - character(len=patchname_strlen), intent(in) :: patch_name_vec(npatches) - integer,intent(out) :: ios ! Return flag - - real(r8) :: c_time ! Time patch was recorded - character(len=patchname_strlen) :: p_name ! The patch associated with this cohort - integer :: c_index ! cohort index - real(r8) :: c_dbh ! diameter at breast height (cm) - real(r8) :: c_height ! tree height (m) - integer :: c_pft ! plant functional type index - real(r8) :: c_nplant ! plant density (/m2) - real(r8) :: c_bdead ! dead biomass (kg) - real(r8) :: c_balive ! live biomass (kg) - real(r8) :: c_avgRG ! avg radial growth (NOT USED) - integer :: cstatus - type(ed_patch_type), pointer :: cpatch - type(ed_cohort_type), pointer :: temp_cohort - integer :: ipa + type(ed_site_type),intent(inout), target :: csite ! current site + type(bc_in_type),intent(in) :: bc_in ! boundary conditions + integer, intent(in) :: file_unit ! Self explanatory + integer, intent(in) :: npatches ! number of patches + type(pp_array), intent(in) :: patch_pointer_vec(npatches) + character(len=patchname_strlen), intent(in) :: patch_name_vec(npatches) + integer,intent(out) :: ios ! Return flag + + ! Locals + real(r8) :: c_time ! Time patch was recorded + character(len=patchname_strlen) :: p_name ! The patch associated with this cohort + integer :: c_index ! cohort index + real(r8) :: c_dbh ! diameter at breast height (cm) + real(r8) :: c_height ! tree height (m) + integer :: c_pft ! plant functional type index + real(r8) :: c_nplant ! plant density (/m2) + real(r8) :: c_bdead ! dead biomass (kg) + real(r8) :: c_balive ! live biomass (kg) + real(r8) :: c_avgRG ! avg radial growth (NOT USED) + integer :: cstatus ! + type(ed_patch_type), pointer :: cpatch ! current patch pointer + type(ed_cohort_type), pointer :: temp_cohort ! temporary patch (needed for allom funcs) + integer :: ipa ! patch idex + logical :: matched_patch ! check if cohort was matched w/ patch + character(len=128),parameter :: wr_fmt = & - '(F5.2,2X,A4,2X,I4,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2)' + '(F5.2,2X,A4,2X,I4,2X,F5.2,2X,F5.2,2X,I4,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2)' + + real(r8), parameter :: abnormal_large_nplant = 1000.0_r8 ! Used to catch bad values + real(r8), parameter :: abnormal_large_dbh = 500.0_r8 ! I've never heard of a tree > 3m read(file_unit,fmt=*,iostat=ios) c_time, p_name, c_index, c_dbh, c_height, & c_pft, c_nplant, c_bdead, c_balive, c_avgRG @@ -660,24 +692,69 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,file_unit,npatches, & end if ! Identify the patch based on the patch_name + matched_patch = .false. do ipa=1,npatches if( trim(p_name) == trim(patch_name_vec(ipa))) then cpatch => patch_pointer_vec(ipa)%cpatch + matched_patch = .true. end if end do + if(.not.matched_patch)then + write(fates_log(), *) 'could not match a cohort with a patch' + write(fates_log(),fmt=wr_fmt) & + c_time, p_name, c_index, c_dbh, c_height, & + c_pft, c_nplant, c_bdead, c_balive, c_avgRG + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + ! =================================================================== ! KLUGE KLUGE KLUGE KLUGE KLUGE KLUGE KLUGE KLUGE KLUGE KLUGE KLUGE c_pft = 1 ! =================================================================== + ! Run some sanity checks on the input data + ! pft, nplant and dbh are the critical ones in this format specification + ! ------------------------------------------------------------------------------------------- + if (c_pft > numpft_ed ) then + write(fates_log(), *) 'inventory pft: ',c_pft write(fates_log(), *) 'An inventory cohort file specified a pft index' write(fates_log(), *) 'greater than the maximum specified pfts ed_numpft' call endrun(msg=errMsg(sourcefile, __LINE__)) end if + if (c_pft <= 0 ) then + write(fates_log(), *) 'inventory pft: ',c_pft + write(fates_log(), *) 'The inventory produced a cohort with <=0 pft index' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if (c_dbh <=0 ) then + write(fates_log(), *) 'inventory dbh: ', c_dbh + write(fates_log(), *) 'The inventory produced a cohort with <= 0 dbh' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if (c_dbh > abnormal_large_dbh ) then + write(fates_log(), *) 'inventory dbh: ', c_nplant + write(fates_log(), *) 'The inventory produced a cohort with very large diameter [cm]' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if (c_nplant <=0 ) then + write(fates_log(), *) 'inventory nplant: ', c_nplant + write(fates_log(), *) 'The inventory produced a cohort with <= 0 density /m2' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if (c_nplant > abnormal_large_nplant ) then + write(fates_log(), *) 'inventory nplant: ', c_nplant + write(fates_log(), *) 'The inventory produced a cohort with very large density /m2' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + allocate(temp_cohort) ! A temporary cohort is needed because we want to make ! use of the allometry functions @@ -723,7 +800,6 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,file_unit,npatches, & deallocate(temp_cohort) ! get rid of temporary cohort return - end subroutine set_inventory_edcohort_type1 end module FatesInventoryInitMod From 116fc849c66e447c36c7084d7b7109f7e6a66eb3 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 23 Jun 2017 14:24:25 -0700 Subject: [PATCH 422/437] Turned off inventory init by default and set debug to false. --- main/EDInitMod.F90 | 2 +- main/FatesInventoryInitMod.F90 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 9792ca9f..8989a1ed 100755 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -221,7 +221,7 @@ subroutine init_patches( nsites, sites, bc_in) real(r8) :: root_litter_local(numpft_ed) real(r8) :: age !notional age of this patch type(ed_patch_type), pointer :: newp - logical, parameter :: do_inv_init = .true. + logical, parameter :: do_inv_init = .false. ! List out some nominal patch values that are used for Near Bear Ground initializations ! as well as initializing inventory diff --git a/main/FatesInventoryInitMod.F90 b/main/FatesInventoryInitMod.F90 index a8a33192..3de51fcb 100644 --- a/main/FatesInventoryInitMod.F90 +++ b/main/FatesInventoryInitMod.F90 @@ -51,7 +51,7 @@ module FatesInventoryInitMod character(len=*), parameter, private :: sourcefile = __FILE__ - logical, parameter :: debug_inv = .true. ! Debug flag for devs + logical, parameter :: debug_inv = .false. ! Debug flag for devs ! String length specifiers integer, parameter :: patchname_strlen = 64 From 2188931845a5a4aa35c394109d8f12f54263339d Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 26 Jun 2017 14:44:00 -0700 Subject: [PATCH 423/437] Updates to inventory initialization code per ckoven review. Includes changing the on/off flag to integer instead of logical, adding checks on model site proximity to inventory site, improved check on the inventory sites longitude designation. Removed a kluge on pft. --- biogeochem/EDPatchDynamicsMod.F90 | 1 - main/EDInitMod.F90 | 7 +++---- main/FatesInventoryInitMod.F90 | 33 +++++++++++++++++++++++-------- 3 files changed, 28 insertions(+), 13 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index d2f20c7a..ffbf8da9 100755 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -41,7 +41,6 @@ module EDPatchDynamicsMod public :: check_patch_area public :: set_patchno public :: set_root_fraction - public :: dealloc_patch private:: fuse_2_patches diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 8989a1ed..709c99c5 100755 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -6,6 +6,7 @@ module EDInitMod use FatesConstantsMod , only : r8 => fates_r8 use FatesConstantsMod , only : ifalse + use FatesConstantsMod , only : itrue use FatesGlobals , only : endrun => fates_endrun use EDTypesMod , only : nclmax use FatesGlobals , only : fates_log @@ -30,7 +31,7 @@ module EDInitMod logical :: DEBUG = .false. - logical, parameter :: do_inv_init = .true. + integer, parameter :: do_inv_init = ifalse character(len=*), parameter, private :: sourcefile = & __FILE__ @@ -201,7 +202,6 @@ subroutine init_patches( nsites, sites, bc_in) ! - use EDPatchDynamicsMod , only : dealloc_patch use EDParamsMod , only : ED_val_maxspread use FatesPlantHydraulicsMod, only : updateSizeDepRhizHydProps use FatesInventoryInitMod, only : initialize_sites_by_inventory @@ -221,7 +221,6 @@ subroutine init_patches( nsites, sites, bc_in) real(r8) :: root_litter_local(numpft_ed) real(r8) :: age !notional age of this patch type(ed_patch_type), pointer :: newp - logical, parameter :: do_inv_init = .false. ! List out some nominal patch values that are used for Near Bear Ground initializations ! as well as initializing inventory @@ -238,7 +237,7 @@ subroutine init_patches( nsites, sites, bc_in) ! Two primary options, either a Near Bear Ground (NBG) or Inventory based cold-start ! --------------------------------------------------------------------------------------------- - if (do_inv_init) then + if (do_inv_init .eq. itrue) then call initialize_sites_by_inventory(nsites,sites,bc_in) diff --git a/main/FatesInventoryInitMod.F90 b/main/FatesInventoryInitMod.F90 index 3de51fcb..1689a6c1 100644 --- a/main/FatesInventoryInitMod.F90 +++ b/main/FatesInventoryInitMod.F90 @@ -59,6 +59,11 @@ module FatesInventoryInitMod integer, parameter :: path_strlen = 256 + real(r8), parameter :: max_site_adjacency_deg = 0.05_r8 ! The maximum distance in degrees + ! allowed between a site's coordinate + ! defined in model memory and a physical + ! site listed in the file + public :: initialize_sites_by_inventory contains @@ -182,6 +187,18 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) minloc( (sites(s)%lat-inv_lat_list(:))**2.0_r8 + & (sites(s)%lon-inv_lon_list(:))**2.0_r8 , dim=1) + ! Do a sanity check on the distance separation between physical site and model site + if ( sqrt( (sites(s)%lat-inv_lat_list(invsite))**2.0_r8 + & + (sites(s)%lon-inv_lon_list(invsite))**2.0_r8 ) > max_site_adjacency_deg ) then + write(fates_log(), *) 'Model site at lat:',sites(s)%lat,' lon:',sites(s)%lon + write(fates_log(), *) 'has no reasonably proximal site in the inventory site list.' + write(fates_log(), *) 'Closest is at lat:',inv_lat_list(invsite),' lon:',inv_lon_list(invsite) + write(fates_log(), *) 'Separation must be less than ',max_site_adjacency_deg,' degrees' + write(fates_log(), *) 'Exiting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + ! Open the PSS/CSS couplet and initialize the ED data structures. ! Lets start withe the PSS ! --------------------------------------------------------------------------------------- @@ -474,7 +491,11 @@ subroutine assess_inventory_sites(file_unit,nsites, inv_format_list, & call endrun(msg=errMsg(sourcefile, __LINE__)) end if - if ( site_lon < -180.0_r8 .or. site_lon > 360.0_r8 ) then + ! Longitude should be converted to positive coordinate + + if( site_lon<0.0_r8 ) site_lon = 360.0_r8 + site_lon + + if ( site_lon < 0.0_r8 .or. site_lon > 360.0_r8 ) then write(fates_log(), *) 'read invalid longitude: ',site_lon,' from inventory site list' call endrun(msg=errMsg(sourcefile, __LINE__)) end if @@ -708,16 +729,10 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,file_unit,npatches, & call endrun(msg=errMsg(sourcefile, __LINE__)) end if - - ! =================================================================== - ! KLUGE KLUGE KLUGE KLUGE KLUGE KLUGE KLUGE KLUGE KLUGE KLUGE KLUGE - c_pft = 1 - ! =================================================================== - ! Run some sanity checks on the input data ! pft, nplant and dbh are the critical ones in this format specification ! ------------------------------------------------------------------------------------------- - + if (c_pft > numpft_ed ) then write(fates_log(), *) 'inventory pft: ',c_pft write(fates_log(), *) 'An inventory cohort file specified a pft index' @@ -758,6 +773,8 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,file_unit,npatches, & allocate(temp_cohort) ! A temporary cohort is needed because we want to make ! use of the allometry functions + + temp_cohort%pft = c_pft temp_cohort%n = c_nplant * cpatch%area temp_cohort%hite = Hite(temp_cohort) From 566f8edefcf45efad6fd2d6db39006e69e267b40 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 28 Jun 2017 11:35:12 -0700 Subject: [PATCH 424/437] Addressed various syntactical concerns brought up by Chonggang Xu for inventory intialization routine. --- main/EDInitMod.F90 | 2 +- main/FatesInventoryInitMod.F90 | 164 +++++++++++++++++++-------------- 2 files changed, 96 insertions(+), 70 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 709c99c5..7fbe4fa6 100755 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -31,7 +31,7 @@ module EDInitMod logical :: DEBUG = .false. - integer, parameter :: do_inv_init = ifalse + integer, parameter :: do_inv_init = itrue character(len=*), parameter, private :: sourcefile = & __FILE__ diff --git a/main/FatesInventoryInitMod.F90 b/main/FatesInventoryInitMod.F90 index 1689a6c1..ac81038b 100644 --- a/main/FatesInventoryInitMod.F90 +++ b/main/FatesInventoryInitMod.F90 @@ -94,10 +94,12 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) type(ed_patch_type), pointer :: currentpatch type(ed_patch_type), pointer :: newpatch type(ed_patch_type), pointer :: olderpatch - integer :: file_unit + integer :: sitelist_file_unit ! fortran file unit for site list + integer :: pss_file_unit ! fortran file unit for the pss file + integer :: css_file_unit ! fortran file unit for the css file integer :: nfilesites ! number of sites in file list - logical :: lod ! logical, file "O"pene"D" - logical :: lex ! logical, file "EX"ists + logical :: lopen ! logical, file is open + logical :: lexist ! logical, file exists integer :: ios ! integer, "IO" status character(len=line_strlen) :: header_str ! large string for whole lines real(r8) :: age_init ! dummy value for creating a patch @@ -124,38 +126,38 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) ! I. Load the inventory list file, do some file handle checks ! ------------------------------------------------------------------------------------------ - file_unit = shr_file_getUnit() - inquire(file=trim(inv_file_list),exist=lex,opened=lod) - if( .not.lex ) then ! The inventory file list DOE + sitelist_file_unit = shr_file_getUnit() + inquire(file=trim(inv_file_list),exist=lexist,opened=lopen) + if( .not.lexist ) then ! The inventory file list DNE write(fates_log(), *) 'An inventory Initialization was requested.' write(fates_log(), *) 'However the inventory file: ',trim(inv_file_list),' DNE' write(fates_log(), *) 'Aborting' call endrun(msg=errMsg(sourcefile, __LINE__)) end if - if( lod ) then ! The inventory file should not be open + if( lopen ) then ! The inventory file should not be open write(fates_log(), *) 'The inventory list file is open but should not be.' write(fates_log(), *) 'Aborting.' call endrun(msg=errMsg(sourcefile, __LINE__)) end if - open(unit=file_unit,file=trim(inv_file_list),status='OLD',action='READ',form='FORMATTED') - rewind(file_unit) + open(unit=sitelist_file_unit,file=trim(inv_file_list),status='OLD',action='READ',form='FORMATTED') + rewind(sitelist_file_unit) ! There should be at least 1 line - read(file_unit,fmt='(A)',iostat=ios) header_str - read(file_unit,fmt='(A)',iostat=ios) header_str + read(sitelist_file_unit,fmt='(A)',iostat=ios) header_str + read(sitelist_file_unit,fmt='(A)',iostat=ios) header_str if( ios /= 0 ) then write(fates_log(), *) 'The inventory file does not contain at least two lines' write(fates_log(), *) 'of data, ie a header and 1 site. Aborting.' call endrun(msg=errMsg(sourcefile, __LINE__)) end if - rewind(unit=file_unit) + rewind(unit=sitelist_file_unit) ! Count the number of sites that are listed in this file, and allocate storage arrays ! ------------------------------------------------------------------------------------------ - nfilesites = count_inventory_sites(file_unit) + nfilesites = count_inventory_sites(sitelist_file_unit) allocate(inv_format_list(nfilesites)) allocate(inv_pss_list(nfilesites)) @@ -166,18 +168,18 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) ! Check through the sites that are listed and do some sanity checks ! ------------------------------------------------------------------------------------------ - call assess_inventory_sites(file_unit, nfilesites, inv_format_list, & + call assess_inventory_sites(sitelist_file_unit, nfilesites, inv_format_list, & inv_pss_list, inv_css_list, & inv_lat_list, inv_lon_list) ! We can close the list file now - close(file_unit, iostat = ios) + close(sitelist_file_unit, iostat = ios) if( ios /= 0 ) then write(fates_log(), *) 'The inventory file needed to be closed, but was still open' write(fates_log(), *) 'aborting' call endrun(msg=errMsg(sourcefile, __LINE__)) end if - call shr_file_freeUnit(file_unit) + call shr_file_freeUnit(sitelist_file_unit) ! For each site, identify the most proximal PSS/CSS couplet, read-in the data @@ -203,21 +205,21 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) ! Lets start withe the PSS ! --------------------------------------------------------------------------------------- - file_unit = shr_file_getUnit() - open(unit=file_unit,file=trim(inv_pss_list(invsite)), & + pss_file_unit = shr_file_getUnit() + open(unit=pss_file_unit,file=trim(inv_pss_list(invsite)), & status='OLD',action='READ',form='FORMATTED') - rewind(file_unit) - read(file_unit,fmt=*) header_str + rewind(pss_file_unit) + read(pss_file_unit,fmt=*) header_str ! Do one quick pass through just to count lines ipa = 0 countpatchloop: do - read(file_unit,fmt=*,iostat=ios) header_str + read(pss_file_unit,fmt=*,iostat=ios) header_str if(ios/=0) exit ipa = ipa + 1 end do countpatchloop - rewind(file_unit) - read(file_unit,fmt=*) header_str + rewind(pss_file_unit) + read(pss_file_unit,fmt=*) header_str npatches = ipa allocate(patch_name_vec(npatches)) @@ -250,7 +252,7 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) leaf_litter_init(1:numpft_ed), root_litter_init(1:numpft_ed) ) if( inv_format_list(invsite) == 1 ) then - call set_inventory_edpatch_type1(newpatch,file_unit,ipa,ios,patch_name) + call set_inventory_edpatch_type1(newpatch,pss_file_unit,ipa,ios,patch_name) end if ! Add it to the site's patch list @@ -306,13 +308,13 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) end if end do - close(file_unit,iostat=ios) + close(pss_file_unit,iostat=ios) if( ios /= 0 ) then write(fates_log(), *) 'The pss file: ',inv_pss_list(invsite),' could not be closed' write(fates_log(), *) 'aborting' call endrun(msg=errMsg(sourcefile, __LINE__)) end if - call shr_file_freeUnit(file_unit) + call shr_file_freeUnit(pss_file_unit) if(debug_inv) then write(fates_log(),*) 'Raw List of Inventory Patches, Age Sorted:' @@ -325,11 +327,11 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) ! OPEN THE CSS FILE ! --------------------------------------------------------------------------------------- - file_unit = shr_file_getUnit() - open(unit=file_unit,file=trim(inv_css_list(invsite)), & + css_file_unit = shr_file_getUnit() + open(unit=css_file_unit,file=trim(inv_css_list(invsite)), & status='OLD',action='READ',form='FORMATTED') - rewind(file_unit) - read(file_unit,fmt=*) header_str + rewind(css_file_unit) + read(css_file_unit,fmt=*) header_str ! Read in each cohort line. Each line is associated with a patch from the PSS ! file via a patch name identification string. We pass the whole site pointer @@ -339,19 +341,19 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) invcohortloop: do if ( inv_format_list(invsite) == 1 ) then - call set_inventory_edcohort_type1(sites(s),bc_in(s),file_unit, & + call set_inventory_edcohort_type1(sites(s),bc_in(s),css_file_unit, & npatches, patch_pointer_vec,patch_name_vec, ios) end if if ( ios/=0 ) exit end do invcohortloop - close(file_unit,iostat=ios) + close(css_file_unit,iostat=ios) if( ios/=0 ) then write(fates_log(), *) 'The css file: ',inv_css_list(invsite),' could not be closed' write(fates_log(), *) 'aborting' call endrun(msg=errMsg(sourcefile, __LINE__)) end if - call shr_file_freeUnit(file_unit) + call shr_file_freeUnit(css_file_unit) deallocate(patch_pointer_vec,patch_name_vec) @@ -383,12 +385,12 @@ end subroutine initialize_sites_by_inventory ! ============================================================================================== - function count_inventory_sites(file_unit) result(nsites) + function count_inventory_sites(sitelist_file_unit) result(nsites) ! Simple function that counts the number of lines in the inventory descriptor file ! Arguments - integer, intent(in) :: file_unit + integer, intent(in) :: sitelist_file_unit ! Locals character(len=line_strlen) :: header_str @@ -400,11 +402,11 @@ function count_inventory_sites(file_unit) result(nsites) ! Set the file position to the top of the file ! Read in the header line ! Read through sites and check coordinates and file existence - rewind(unit=file_unit) - read(file_unit,fmt='(A)') header_str + rewind(unit=sitelist_file_unit) + read(sitelist_file_unit,fmt='(A)') header_str nsites = 0 do - read(file_unit,fmt='(A)',iostat=ios) site_str + read(sitelist_file_unit,fmt='(A)',iostat=ios) site_str if (ios/=0) exit nsites = nsites + 1 end do @@ -414,7 +416,7 @@ end function count_inventory_sites ! ============================================================================================== - subroutine assess_inventory_sites(file_unit,nsites, inv_format_list, & + subroutine assess_inventory_sites(sitelist_file_unit,nsites, inv_format_list, & inv_pss_list,inv_css_list, & inv_lat_list,inv_lon_list) @@ -424,21 +426,40 @@ subroutine assess_inventory_sites(file_unit,nsites, inv_format_list, & ! sites, and saves their information (such as location and file path) ! to arrays. This routine also does some simple checks to make ! sure it is not reading nonsense + ! + ! File Format for the inventory site file: + ! 1 line header + ! 1 line listing each available inventory site with the following fields: + ! type latitude longitude pss-name css-name + ! + ! The fields for each site are described as follows: + ! + ! + ! + ! type integer We will accomodate different file format with different + ! field values as the need arises. format 1 will read in + ! datasets via "set_inventory_edpatch_type1()", + ! "set_inventory_edcohort_type1()" + ! + ! latitude float The geographic latitude coordinate of the site + ! longitude float The geogarphic longitude coordinate of the site + ! pss-name string The full path to the patch descriptor file (PSS) + ! css-name string The full path to the cohort descriptor file (CSS) ! ------------------------------------------------------------------------------------------- ! Arguments - integer, intent(in) :: file_unit - integer, intent(in) :: nsites - integer, intent(inout) :: inv_format_list(nsites) - character(len=path_strlen),intent(inout) :: inv_pss_list(nsites) - character(len=path_strlen),intent(inout) :: inv_css_list(nsites) - real(r8),intent(inout) :: inv_lat_list(nsites) - real(r8),intent(inout) :: inv_lon_list(nsites) + integer, intent(in) :: sitelist_file_unit ! file unit for sitelist + integer, intent(in) :: nsites ! number of inventory sites + integer, intent(inout) :: inv_format_list(nsites) ! array of formats for each inventory site + character(len=path_strlen),intent(inout) :: inv_pss_list(nsites) ! array of pss file paths for each site + character(len=path_strlen),intent(inout) :: inv_css_list(nsites) ! array of css file paths for each site + real(r8),intent(inout) :: inv_lat_list(nsites) ! array of latitudes for each site + real(r8),intent(inout) :: inv_lon_list(nsites) ! array of longitudes for each site ! Locals - character(len=line_strlen) :: header_str - character(len=line_strlen) :: site_str + character(len=line_strlen) :: header_str ! a string to hold the header information + character(len=line_strlen) :: site_str ! a string to hold each site-line in the file integer :: isite ! site index integer :: ios ! fortran read status flag character(len=path_strlen) :: pss_file @@ -447,15 +468,15 @@ subroutine assess_inventory_sites(file_unit,nsites, inv_format_list, & real(r8) :: site_lon ! site longitude integer :: iblnk ! Index used for string parsing integer :: file_format ! format type (1=legacy ED pss/css) - logical :: lex ! file existence flag + logical :: lexist ! file existence flag - rewind(unit=file_unit) - read(file_unit,fmt='(4A)') header_str + rewind(unit=sitelist_file_unit) + read(sitelist_file_unit,fmt='(4A)') header_str do isite=1,nsites ! Read in the whole line - read(file_unit,fmt='(a)',iostat=ios) site_str + read(sitelist_file_unit,fmt='(a)',iostat=ios) site_str ! Parse the format identifier read(site_str,*) file_format @@ -500,15 +521,15 @@ subroutine assess_inventory_sites(file_unit,nsites, inv_format_list, & call endrun(msg=errMsg(sourcefile, __LINE__)) end if - inquire(file=trim(pss_file),exist=lex) - if( .not.lex ) then + inquire(file=trim(pss_file),exist=lexist) + if( .not.lexist ) then write(fates_log(), *) 'the following pss file could not be found:' write(fates_log(), *) trim(pss_file) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - inquire(file=trim(css_file),exist=lex) - if( .not.lex ) then + inquire(file=trim(css_file),exist=lexist) + if( .not.lexist ) then write(fates_log(), *) 'the following css file could not be found:' write(fates_log(), *) trim(css_file) call endrun(msg=errMsg(sourcefile, __LINE__)) @@ -530,14 +551,16 @@ end subroutine assess_inventory_sites ! ============================================================================================== - subroutine set_inventory_edpatch_type1(newpatch,file_unit,ipa,ios,patch_name) + subroutine set_inventory_edpatch_type1(newpatch,pss_file_unit,ipa,ios,patch_name) ! -------------------------------------------------------------------------------------------- ! This subroutine reads in a line of an inventory patch file (pss) ! And populates a new patch with that information. ! This routine specifically reads PSS files that are "Type 1" formatted ! - ! FILE FORMAT: + ! The file is formatted text, which contains 1 header line to label columns + ! and then 1 line for each patch containing the following fields: + ! ! time (year) year of measurement ! patch (string) patch id string ! trk (integer) LU type index (0 non-forest, 1 secondary, 2 primary @@ -550,7 +573,7 @@ subroutine set_inventory_edpatch_type1(newpatch,file_unit,ipa,ios,patch_name) ! ssc (kg/m2) Slow Soil Carbon ! psc (NA) Passive Soil Carbon (NOT USED) ! msn (kg/m2) Mineralized Soil Nitrogen - ! fsn (kg/m2) Fast Soil Nitrogen + ! fsn (kg/m2) Fast Soil Nitrogen ! -------------------------------------------------------------------------------------------- use EDTypesMod, only: get_age_class_index @@ -561,11 +584,11 @@ subroutine set_inventory_edpatch_type1(newpatch,file_unit,ipa,ios,patch_name) use EDParamsMod , only : ED_val_ag_biomass ! Arguments - type(ed_patch_type),intent(inout), target :: newpatch ! Patch structure - integer,intent(in) :: file_unit ! Self explanatory - integer,intent(in) :: ipa ! Patch index (line number) - integer,intent(out) :: ios ! Return flag - character(len=patchname_strlen),intent(out) :: patch_name ! unique string identifier of patch + type(ed_patch_type),intent(inout), target :: newpatch ! Patch structure + integer,intent(in) :: pss_file_unit ! Self explanatory + integer,intent(in) :: ipa ! Patch index (line number) + integer,intent(out) :: ios ! Return flag + character(len=patchname_strlen),intent(out) :: patch_name ! unique string identifier of patch ! Locals real(r8) :: p_time ! Time patch was recorded @@ -589,7 +612,7 @@ subroutine set_inventory_edpatch_type1(newpatch,file_unit,ipa,ios,patch_name) '(F5.2,2X,A4,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2)' - read(file_unit,fmt=*,iostat=ios) p_time, p_name, p_trk, p_age, p_area, & + read(pss_file_unit,fmt=*,iostat=ios) p_time, p_name, p_trk, p_age, p_area, & p_water,p_fsc, p_stsc, p_stsl, p_ssc, & p_psc, p_msn, p_fsn @@ -642,7 +665,7 @@ end subroutine set_inventory_edpatch_type1 ! ============================================================================================== - subroutine set_inventory_edcohort_type1(csite,bc_in,file_unit,npatches, & + subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & patch_pointer_vec,patch_name_vec,ios) ! -------------------------------------------------------------------------------------------- @@ -650,6 +673,9 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,file_unit,npatches, & ! And populates a new cohort with that information. ! This routine specifically reads CSS files that are "Type 1" formatted ! + ! The file formatted text, which contains 1 header line to label columns + ! and then 1 line for each cohort containing the following fields: + ! ! FILE FORMAT: ! time (year) year of measurement ! patch (string) patch id string associated with this cohort @@ -672,7 +698,7 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,file_unit,npatches, & ! Arguments type(ed_site_type),intent(inout), target :: csite ! current site type(bc_in_type),intent(in) :: bc_in ! boundary conditions - integer, intent(in) :: file_unit ! Self explanatory + integer, intent(in) :: css_file_unit ! Self explanatory integer, intent(in) :: npatches ! number of patches type(pp_array), intent(in) :: patch_pointer_vec(npatches) character(len=patchname_strlen), intent(in) :: patch_name_vec(npatches) @@ -701,9 +727,9 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,file_unit,npatches, & real(r8), parameter :: abnormal_large_nplant = 1000.0_r8 ! Used to catch bad values real(r8), parameter :: abnormal_large_dbh = 500.0_r8 ! I've never heard of a tree > 3m - read(file_unit,fmt=*,iostat=ios) c_time, p_name, c_index, c_dbh, c_height, & + read(css_file_unit,fmt=*,iostat=ios) c_time, p_name, c_index, c_dbh, c_height, & c_pft, c_nplant, c_bdead, c_balive, c_avgRG - + if (ios/=0) return if( debug_inv) then From 9d481fd1cb4d7bcae28dbf0b6c5393fcf4aa9a83 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 28 Jun 2017 11:37:53 -0700 Subject: [PATCH 425/437] Set do_inv_init back to false as default. --- main/EDInitMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 7fbe4fa6..709c99c5 100755 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -31,7 +31,7 @@ module EDInitMod logical :: DEBUG = .false. - integer, parameter :: do_inv_init = itrue + integer, parameter :: do_inv_init = ifalse character(len=*), parameter, private :: sourcefile = & __FILE__ From 752693663a1ba422a52b146435e8d16d84a112dc Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 5 Jul 2017 15:34:06 -0700 Subject: [PATCH 426/437] Modified unique cohort identifier to be a string. Added a cohort count function to check if inventory initialization actually generated any cohorts in model, as a check. --- main/FatesInventoryInitMod.F90 | 27 +++++++++++++++++++-------- 1 file changed, 19 insertions(+), 8 deletions(-) diff --git a/main/FatesInventoryInitMod.F90 b/main/FatesInventoryInitMod.F90 index ac81038b..cdd0e94d 100644 --- a/main/FatesInventoryInitMod.F90 +++ b/main/FatesInventoryInitMod.F90 @@ -55,6 +55,7 @@ module FatesInventoryInitMod ! String length specifiers integer, parameter :: patchname_strlen = 64 + integer, parameter :: cohortname_strlen = 64 integer, parameter :: line_strlen = 512 integer, parameter :: path_strlen = 256 @@ -84,6 +85,7 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) use EDPatchDynamicsMod, only : fuse_patches use EDCohortDynamicsMod, only : fuse_cohorts use EDCohortDynamicsMod, only : sort_cohorts + use EDcohortDynamicsMod, only : count_cohorts ! Arguments integer, intent(in) :: nsites @@ -111,6 +113,7 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) real(r8) :: root_litter_init(maxpft) ! dummy value for creating a patch integer :: s ! site index integer :: ipa ! patch index + integer :: total_cohorts ! cohort counter for error checking integer, allocatable :: inv_format_list(:) ! list of format specs character(len=path_strlen), allocatable :: inv_css_list(:) ! list of css file names character(len=path_strlen), allocatable :: inv_pss_list(:) ! list of pss file names @@ -360,6 +363,7 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) ! Update the patch index numbers and fuse the cohorts in the patches ! ---------------------------------------------------------------------------------------- ipa=1 + total_cohorts = 0 currentpatch => sites(s)%youngest_patch do while(associated(currentpatch)) currentpatch%patchno = ipa @@ -368,10 +372,17 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) ! Perform Cohort Fusion call fuse_cohorts(currentpatch,bc_in(s)) call sort_cohorts(currentpatch) + total_cohorts = total_cohorts + count_cohorts(currentpatch) currentPatch => currentpatch%older enddo + if(total_cohorts .eq. 0)then + write(fates_log(), *) 'The inventory initialization produced no cohorts.' + write(fates_log(), *) 'aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + ! Fuse patches ! ---------------------------------------------------------------------------------------- call fuse_patches(sites(s), bc_in(s) ) @@ -707,7 +718,7 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & ! Locals real(r8) :: c_time ! Time patch was recorded character(len=patchname_strlen) :: p_name ! The patch associated with this cohort - integer :: c_index ! cohort index + character(len=cohortname_strlen) :: c_name ! cohort index real(r8) :: c_dbh ! diameter at breast height (cm) real(r8) :: c_height ! tree height (m) integer :: c_pft ! plant functional type index @@ -722,22 +733,22 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & logical :: matched_patch ! check if cohort was matched w/ patch character(len=128),parameter :: wr_fmt = & - '(F5.2,2X,A4,2X,I4,2X,F5.2,2X,F5.2,2X,I4,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2)' + '(F7.1,2X,A20,2X,A20,2X,F5.2,2X,F5.2,2X,I4,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2)' real(r8), parameter :: abnormal_large_nplant = 1000.0_r8 ! Used to catch bad values real(r8), parameter :: abnormal_large_dbh = 500.0_r8 ! I've never heard of a tree > 3m - read(css_file_unit,fmt=*,iostat=ios) c_time, p_name, c_index, c_dbh, c_height, & + read(css_file_unit,fmt=*,iostat=ios) c_time, p_name, c_name, c_dbh, c_height, & c_pft, c_nplant, c_bdead, c_balive, c_avgRG - if (ios/=0) return - if( debug_inv) then write(*,fmt=wr_fmt) & - c_time, p_name, c_index, c_dbh, c_height, & - c_pft, c_nplant, c_bdead, c_balive, c_avgRG + c_time, p_name, c_name, c_dbh, c_height, & + c_pft, c_nplant, c_bdead, c_balive, c_avgRG end if + if (ios/=0) return + ! Identify the patch based on the patch_name matched_patch = .false. do ipa=1,npatches @@ -750,7 +761,7 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & if(.not.matched_patch)then write(fates_log(), *) 'could not match a cohort with a patch' write(fates_log(),fmt=wr_fmt) & - c_time, p_name, c_index, c_dbh, c_height, & + c_time, p_name, c_name, c_dbh, c_height, & c_pft, c_nplant, c_bdead, c_balive, c_avgRG call endrun(msg=errMsg(sourcefile, __LINE__)) end if From 9a7315d290a32fbc98c1352958ad0d97ac268926 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 5 Jul 2017 17:28:38 -0700 Subject: [PATCH 427/437] Added some checks on basal area to the inventory init. --- main/FatesInventoryInitMod.F90 | 57 ++++++++++++++++++++++++++++++++++ 1 file changed, 57 insertions(+) diff --git a/main/FatesInventoryInitMod.F90 b/main/FatesInventoryInitMod.F90 index cdd0e94d..28ab8dd2 100644 --- a/main/FatesInventoryInitMod.F90 +++ b/main/FatesInventoryInitMod.F90 @@ -24,6 +24,7 @@ module FatesInventoryInitMod ! FATES GLOBALS use FatesConstantsMod, only : r8 => fates_r8 + use FatesConstantsMod, only : pi_const use FatesGlobals , only : endrun => fates_endrun use FatesGlobals , only : fates_log use FatesInterfaceMod, only : bc_in_type @@ -94,6 +95,7 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) ! Locals type(ed_patch_type), pointer :: currentpatch + type(ed_cohort_type), pointer :: currentcohort type(ed_patch_type), pointer :: newpatch type(ed_patch_type), pointer :: olderpatch integer :: sitelist_file_unit ! fortran file unit for site list @@ -125,6 +127,11 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) integer :: npatches ! number of patches found in PSS type(pp_array), allocatable :: patch_pointer_vec(:) ! vector of pointers to patch LL character(len=patchname_strlen), allocatable :: patch_name_vec(:) ! vector of patch ID strings + real(r8) :: basal_area_postf ! basal area before fusion (m2/ha) + real(r8) :: basal_area_pref ! basal area after fusion (m2/ha) + + real(r8), parameter :: max_ba_diff = 1.0e-2 ! 1% is the maximum allowable + ! change in BA due to fusion ! I. Load the inventory list file, do some file handle checks ! ------------------------------------------------------------------------------------------ @@ -360,6 +367,26 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) deallocate(patch_pointer_vec,patch_name_vec) + ! Report Basal Area (as a check on if things were read in) + ! ------------------------------------------------------------------------------ + basal_area_pref = 0.0_r8 + currentpatch => sites(s)%youngest_patch + do while(associated(currentpatch)) + currentcohort => currentpatch%tallest + do while(associated(currentcohort)) + basal_area_pref = basal_area_pref + & + currentcohort%n*0.25*((currentcohort%dbh/100.0_r8)**2.0_r8)*pi_const + currentcohort => currentcohort%shorter + end do + currentPatch => currentpatch%older + enddo + + write(fates_log(),*) '-------------------------------------------------------' + write(fates_log(),*) 'Basal Area from inventory, BEFORE fusion' + write(fates_log(),*) 'Lat: ',sites(s)%lat,' Lon: ',sites(s)%lon + write(fates_log(),*) basal_area_pref,' [m2/ha]' + write(fates_log(),*) '-------------------------------------------------------' + ! Update the patch index numbers and fuse the cohorts in the patches ! ---------------------------------------------------------------------------------------- ipa=1 @@ -387,6 +414,36 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) ! ---------------------------------------------------------------------------------------- call fuse_patches(sites(s), bc_in(s) ) + ! Report Basal Area (as a check on if things were read in) + ! ---------------------------------------------------------------------------------------- + basal_area_postf = 0.0_r8 + currentpatch => sites(s)%youngest_patch + do while(associated(currentpatch)) + currentcohort => currentpatch%tallest + do while(associated(currentcohort)) + basal_area_postf = basal_area_postf + & + currentcohort%n*0.25*((currentcohort%dbh/100.0_r8)**2.0_r8)*pi_const + currentcohort => currentcohort%shorter + end do + currentPatch => currentpatch%older + enddo + + write(fates_log(),*) '-------------------------------------------------------' + write(fates_log(),*) 'Basal Area from inventory, AFTER fusion' + write(fates_log(),*) 'Lat: ',sites(s)%lat,' Lon: ',sites(s)%lon + write(fates_log(),*) basal_area_postf,' [m2/ha]' + write(fates_log(),*) '-------------------------------------------------------' + + ! Check to see if the fusion process has changed too much + ! We are sensitive to fusion in inventories because we may be asking for a massive amount + ! of fusion. For instance some init files are directly from inventory, where a cohort + ! is synomomous with a single plant. + + if( abs(basal_area_postf-basal_area_pref)/basal_area_pref > max_ba_diff ) then + write(fates_log(),*) 'Inventory Fusion Changed total biomass beyond reasonable limit' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end do deallocate(inv_format_list, inv_pss_list, inv_css_list, inv_lat_list, inv_lon_list) From f0558b64628c27dc50cb0e8e0f16d92389771421 Mon Sep 17 00:00:00 2001 From: ckoven Date: Thu, 6 Jul 2017 11:44:52 -0700 Subject: [PATCH 428/437] added 6 new vars to track growth and mortality rates conditional on size, age, and canopy position --- main/FatesHistoryInterfaceMod.F90 | 54 ++++++++++++++++++++++++++++++- 1 file changed, 53 insertions(+), 1 deletion(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 8c73b956..fcb7b51e 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -82,6 +82,12 @@ module FatesHistoryInterfaceMod ! Indices to site by size-class by pft variables integer, private :: ih_nplant_si_scag + integer, private :: ih_nplant_canopy_si_scag + integer, private :: ih_nplant_understory_si_scag + integer, private :: ih_ddbh_canopy_si_scag + integer, private :: ih_ddbh_understory_si_scag + integer, private :: ih_mortality_canopy_si_scag + integer, private :: ih_mortality_understory_si_scag ! Indices to (site) variables integer, private :: ih_nep_si @@ -1258,7 +1264,13 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_cwd_bg_out_si_cwdsc => this%hvars(ih_cwd_bg_out_si_cwdsc)%r82d, & hio_crownarea_si_cnlf => this%hvars(ih_crownarea_si_cnlf)%r82d, & hio_crownarea_si_can => this%hvars(ih_crownarea_si_can)%r82d, & - hio_nplant_si_scag => this%hvars(ih_nplant_si_scag)%r82d) + hio_nplant_si_scag => this%hvars(ih_nplant_si_scag)%r82d, & + hio_nplant_canopy_si_scag => this%hvars(ih_nplant_canopy_si_scag)%r82d, & + hio_nplant_understory_si_scag => this%hvars(ih_nplant_understory_si_scag)%r82d, & + hio_ddbh_canopy_si_scag => this%hvars(ih_ddbh_canopy_si_scag)%r82d, & + hio_ddbh_understory_si_scag => this%hvars(ih_ddbh_understory_si_scag)%r82d, & + hio_mortality_canopy_si_scag => this%hvars(ih_mortality_canopy_si_scag)%r82d, & + hio_mortality_understory_si_scag => this%hvars(ih_mortality_understory_si_scag)%r82d) ! --------------------------------------------------------------------------------- @@ -1450,6 +1462,11 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! update SCPF/SCLS- and canopy/subcanopy- partitioned quantities if (ccohort%canopy_layer .eq. 1) then + hio_nplant_canopy_si_scag(io_si,iscag) = hio_nplant_canopy_si_scag(io_si,iscag) + ccohort%n + hio_mortality_canopy_si_scag(io_si,iscag) = hio_mortality_canopy_si_scag(io_si,iscag) + & + (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%imort + ccohort%fmort) * ccohort%n + hio_ddbh_canopy_si_scag(io_si,iscag) = hio_ddbh_canopy_si_scag(io_si,iscag) + & + ccohort%ddbhdt*ccohort%n hio_bstor_canopy_si_scpf(io_si,scpf) = hio_bstor_canopy_si_scpf(io_si,scpf) + & ccohort%bstore * ccohort%n hio_bleaf_canopy_si_scpf(io_si,scpf) = hio_bleaf_canopy_si_scpf(io_si,scpf) + & @@ -1509,6 +1526,11 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_yesterdaycanopylevel_canopy_si_scls(io_si,scls) + & ccohort%canopy_layer_yesterday * ccohort%n else + hio_nplant_understory_si_scag(io_si,iscag) = hio_nplant_understory_si_scag(io_si,iscag) + ccohort%n + hio_mortality_understory_si_scag(io_si,iscag) = hio_mortality_understory_si_scag(io_si,iscag) + & + (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%imort + ccohort%fmort) * ccohort%n + hio_ddbh_understory_si_scag(io_si,iscag) = hio_ddbh_understory_si_scag(io_si,iscag) + & + ccohort%ddbhdt*ccohort%n hio_bstor_understory_si_scpf(io_si,scpf) = hio_bstor_understory_si_scpf(io_si,scpf) + & ccohort%bstore * ccohort%n hio_bleaf_understory_si_scpf(io_si,scpf) = hio_bleaf_understory_si_scpf(io_si,scpf) + & @@ -2912,6 +2934,36 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_scag_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_si_scag ) + call this%set_history_var(vname='NPLANT_CANOPY_SCAG',units = 'plants/ha', & + long='number of plants per hectare in canopy in each size x age class', use_default='inactive', & + avgflag='A', vtype=site_scag_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_canopy_si_scag ) + + call this%set_history_var(vname='NPLANT_UNDERSTORY_SCAG',units = 'plants/ha', & + long='number of plants per hectare in understory in each size x age class', use_default='inactive', & + avgflag='A', vtype=site_scag_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_understory_si_scag ) + + call this%set_history_var(vname='DDBH_CANOPY_SCAG',units = 'cm/yr/ha', & + long='growth rate of canopy plantsnumber of plants per hectare in canopy in each size x age class', use_default='inactive', & + avgflag='A', vtype=site_scag_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ddbh_canopy_si_scag ) + + call this%set_history_var(vname='DDBH_UNDERSTORY_SCAG',units = 'cm/yr/ha', & + long='growth rate of understory plants in each size x age class', use_default='inactive', & + avgflag='A', vtype=site_scag_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ddbh_understory_si_scag ) + + call this%set_history_var(vname='MORTALITY_CANOPY_SCAG',units = 'plants/ha/yr', & + long='mortality rate of canopy plants in each size x age class', use_default='inactive', & + avgflag='A', vtype=site_scag_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_mortality_canopy_si_scag ) + + call this%set_history_var(vname='MORTALITY_UNDERSTORY_SCAG',units = 'plants/ha/yr', & + long='mortality rate of understory plantsin each size x age class', use_default='inactive', & + avgflag='A', vtype=site_scag_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_mortality_understory_si_scag ) + ! Carbon Flux (grid dimension x scpf) (THESE ARE DEFAULT INACTIVE!!! ! (BECAUSE THEY TAKE UP SPACE!!! From 6bd2ffcca279fd9b15812620383b49b9e0f83c11 Mon Sep 17 00:00:00 2001 From: ckoven Date: Fri, 7 Jul 2017 09:42:30 -0700 Subject: [PATCH 429/437] adding all biomass tendency terms to cohort fusion handling --- biogeochem/EDCohortDynamicsMod.F90 | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index feade648..c9ec3b69 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -860,6 +860,12 @@ subroutine fuse_cohorts(patchptr, bc_in) currentCohort%npp_bseed = (currentCohort%n*currentCohort%npp_bseed + nextc%n*nextc%npp_bseed)/newn currentCohort%npp_store = (currentCohort%n*currentCohort%npp_store + nextc%n*nextc%npp_store)/newn + ! biomass and dbh tendencies + currentCohort%ddbhdt = (currentCohort%n*currentCohort%ddbhdt + nextc%n*nextc%ddbhdt)/newn + currentCohort%dbalivedt = (currentCohort%n*currentCohort%dbalivedt + nextc%n*nextc%dbalivedt)/newn + currentCohort%dbdeaddt = (currentCohort%n*currentCohort%dbdeaddt + nextc%n*nextc%dbdeaddt)/newn + currentCohort%dbstoredt = (currentCohort%n*currentCohort%dbstoredt + nextc%n*nextc%dbstoredt)/newn + do i=1, nlevleaf if (currentCohort%year_net_uptake(i) == 999._r8 .or. nextc%year_net_uptake(i) == 999._r8) then currentCohort%year_net_uptake(i) = & From 944315bcf8538224c6ba1d54200d658597e6480e Mon Sep 17 00:00:00 2001 From: ckoven Date: Fri, 14 Jul 2017 16:15:29 -0700 Subject: [PATCH 430/437] first attempt to add fractional disturbance term for mortality (as hard-coded param) --- biogeochem/EDPatchDynamicsMod.F90 | 7 +++++-- biogeochem/EDPhysiologyMod.F90 | 7 ++++--- main/EDParamsMod.F90 | 2 ++ 3 files changed, 11 insertions(+), 5 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index ffbf8da9..501ffba6 100755 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -23,6 +23,7 @@ module EDPatchDynamicsMod use FatesConstantsMod , only : r8 => fates_r8 use FatesPlantHydraulicsMod, only : InitHydrCohort use FatesPlantHydraulicsMod, only : DeallocateHydrCohort + use EDParamsMod , only : fates_mortality_disturbance_fraction ! CIME globals use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) @@ -86,7 +87,7 @@ subroutine disturbance_rates( site_in) currentCohort%patchptr => currentPatch call mortality_rates(currentCohort,cmort,hmort,bmort) - currentCohort%dmort = cmort+hmort+bmort + currentCohort%dmort = cmort+hmort+bmort currentCohort%c_area = c_area(currentCohort) ! Initialize diagnostic mortality rates @@ -99,6 +100,7 @@ subroutine disturbance_rates( site_in) if(currentCohort%canopy_layer == 1)then currentPatch%disturbance_rates(1) = currentPatch%disturbance_rates(1) + & + fates_mortality_disturbance_fraction * & min(1.0_r8,currentCohort%dmort)*hlm_freq_day*currentCohort%c_area/currentPatch%area endif @@ -289,7 +291,8 @@ subroutine spawn_patches( currentSite, bc_in) ! because this is the part of the original patch where no trees have actually fallen ! The diagnostic cmort,bmort and hmort rates have already been saved - currentCohort%n = currentCohort%n * (1.0_r8 - min(1.0_r8,currentCohort%dmort * hlm_freq_day)) + currentCohort%n = currentCohort%n * (1.0_r8 - fates_mortality_disturbance_fraction * & + min(1.0_r8,currentCohort%dmort * hlm_freq_day)) nc%n = 0.0_r8 ! kill all of the trees who caused the disturbance. nc%cmort = nan ! The mortality diagnostics are set to nan because the cohort should dissappear diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index e6229de8..78c16a85 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -31,7 +31,7 @@ module EDPhysiologyMod use shr_log_mod , only : errMsg => shr_log_errMsg use FatesGlobals , only : fates_log use FatesGlobals , only : endrun => fates_endrun - + use EDParamsMod , only : fates_mortality_disturbance_fraction implicit none private @@ -788,11 +788,12 @@ subroutine Growth_Derivatives( currentSite, currentCohort, bc_in) ! Mortality for trees in the understorey. !if trees are in the canopy, then their death is 'disturbance'. This probably needs a different terminology + call mortality_rates(currentCohort,cmort,hmort,bmort) if (currentCohort%canopy_layer > 1)then - call mortality_rates(currentCohort,cmort,hmort,bmort) currentCohort%dndt = -1.0_r8 * (cmort+hmort+bmort) * currentCohort%n else - currentCohort%dndt = 0._r8 + currentCohort%dndt = -(1.0_r8 - fates_mortality_disturbance_fraction) & + * (cmort+hmort+bmort) * currentCohort%n endif ! Height diff --git a/main/EDParamsMod.F90 b/main/EDParamsMod.F90 index 8bc4e9f9..f9c5661a 100644 --- a/main/EDParamsMod.F90 +++ b/main/EDParamsMod.F90 @@ -72,6 +72,8 @@ module EDParamsMod public :: FatesParamsInit public :: FatesRegisterParams public :: FatesReceiveParams + + real(r8), protected :: fates_mortality_disturbance_fraction = 0.5_r8 ! the fraction of canopy mortality that results in disturbance (i.e. transfer of area from new to old patch) contains From 7b00fd51905794a81c27c06f22a7224b2ee79d07 Mon Sep 17 00:00:00 2001 From: ckoven Date: Mon, 17 Jul 2017 17:32:19 -0700 Subject: [PATCH 431/437] changing disturbance fraction to be equal to default fates_understorey_death value --- main/EDParamsMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/EDParamsMod.F90 b/main/EDParamsMod.F90 index f9c5661a..4d46b605 100644 --- a/main/EDParamsMod.F90 +++ b/main/EDParamsMod.F90 @@ -73,7 +73,7 @@ module EDParamsMod public :: FatesRegisterParams public :: FatesReceiveParams - real(r8), protected :: fates_mortality_disturbance_fraction = 0.5_r8 ! the fraction of canopy mortality that results in disturbance (i.e. transfer of area from new to old patch) + real(r8), protected :: fates_mortality_disturbance_fraction = 0.55983_r8 ! the fraction of canopy mortality that results in disturbance (i.e. transfer of area from new to old patch) contains From a39d6587233d6f383ceaf08d3ecaa5aab6557b68 Mon Sep 17 00:00:00 2001 From: ckoven Date: Wed, 19 Jul 2017 11:26:32 -0700 Subject: [PATCH 432/437] reset value of fates_mortality_disturbance_fraction to one to revert to prior behavior --- main/EDParamsMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/EDParamsMod.F90 b/main/EDParamsMod.F90 index 4d46b605..eb994766 100644 --- a/main/EDParamsMod.F90 +++ b/main/EDParamsMod.F90 @@ -73,7 +73,7 @@ module EDParamsMod public :: FatesRegisterParams public :: FatesReceiveParams - real(r8), protected :: fates_mortality_disturbance_fraction = 0.55983_r8 ! the fraction of canopy mortality that results in disturbance (i.e. transfer of area from new to old patch) + real(r8), protected :: fates_mortality_disturbance_fraction = 1.0_r8 ! the fraction of canopy mortality that results in disturbance (i.e. transfer of area from new to old patch) contains From 94bd85aaca51741278336fa935f3ba935de08025 Mon Sep 17 00:00:00 2001 From: JKShuman Date: Wed, 19 Jul 2017 13:59:36 -0600 Subject: [PATCH 433/437] Update AreaBurnt,add DEBUG, fix indexing Update calculation for area burnt to be in line with Thonicke etal 2010 Eq 2 for readability. Add "if (DEBUG)" to write statement for "SH currentCohort%c_area" in fire/SFMainMod to reduce log output. Add "if (DEBUG)" to write statement for "using high bl cap" in biobgeochem/EDPhysio to reduce log output. Fixes: User interface changes?: No Code review: JKShuman Test suite: Test baseline: Test namelist changes: Test answer changes: expect non-answer changing Test summary: compiles, --- biogeochem/EDCanopyStructureMod.F90 | 2 +- biogeochem/EDPhysiologyMod.F90 | 2 +- biogeophys/EDSurfaceAlbedoMod.F90 | 31 +++++++++++++++-------------- fire/SFMainMod.F90 | 20 ++++++++++--------- main/EDTypesMod.F90 | 2 +- 5 files changed, 30 insertions(+), 27 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index d042fa78..4b8cbd95 100755 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1233,7 +1233,7 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) write(fates_log(), *) 'ED: canopy-area-profile wrong', & sum(currentPatch%canopy_area_profile(L,1:numpft_ed,1)), & currentPatch%patchno, L - write(fates_log(), *) 'ED: areas',currentPatch%canopy_area_profile(L,1:2,1),currentPatch%patchno + write(fates_log(), *) 'ED: areas',currentPatch%canopy_area_profile(L,1:numpft_ed,1),currentPatch%patchno currentCohort => currentPatch%shortest diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index e6229de8..a8aab761 100755 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -960,7 +960,7 @@ subroutine Growth_Derivatives( currentSite, currentCohort, bc_in) !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(fates_log(),*) 'using high bl cap',target_balive,currentCohort%balive + if (DEBUG) write(fates_log(),*) 'using high bl cap',target_balive,currentCohort%balive endif else diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index 9ab4392c..6da2a280 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -830,11 +830,12 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) endif enddo enddo + if (lai_change(1,2,1).gt.0.0.and.lai_change(1,2,2).gt.0.0)then - ! write(fates_log(),*) 'lai_change(1,2,12)',lai_change(1,2,1:4) + ! write(fates_log(),*) '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(fates_log(),*) ' lai_change (1,2,23)',lai_change(1,2,1:4) + ! write(fates_log(),*) ' 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 ! NO-OP @@ -846,7 +847,7 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) endif if (lai_change(1,1,4).gt.0.0.and.lai_change(1,1,5).gt.0.0)then ! NO-OP - ! write(fates_log(),*) 'first layer of lai_change 4 5',lai_change(1,1,1:5) + ! write(fates_log(),*) 'first layer of lai_change 4 5',lai_change(1,1,1:5) endif if (radtype == 1)then @@ -865,10 +866,10 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) write(fates_log(),*) 'Large Dir Radn consvn error',error ,ifp,ib write(fates_log(),*) 'diags', bc_out(s)%albd_parb(ifp,ib), bc_out(s)%ftdd_parb(ifp,ib), & bc_out(s)%ftid_parb(ifp,ib), bc_out(s)%fabd_parb(ifp,ib) - write(fates_log(),*) 'lai_change',lai_change(currentpatch%ncl_p,1:2,1:4) - write(fates_log(),*) 'elai',currentpatch%elai_profile(currentpatch%ncl_p,1:2,1:4) - write(fates_log(),*) 'esai',currentpatch%esai_profile(currentpatch%ncl_p,1:2,1:4) - write(fates_log(),*) 'ftweight',ftweight(1,1:2,1:4) + write(fates_log(),*) 'lai_change',lai_change(currentpatch%ncl_p,1:numpft_ed,1:4) + write(fates_log(),*) 'elai',currentpatch%elai_profile(currentpatch%ncl_p,1:numpft_ed,1:4) + write(fates_log(),*) 'esai',currentpatch%esai_profile(currentpatch%ncl_p,1:numpft_ed,1:4) + write(fates_log(),*) 'ftweight',ftweight(1,1:numpft_ed,1:4) write(fates_log(),*) 'cp',currentPatch%area, currentPatch%patchno write(fates_log(),*) 'bc_in(s)%albgr_dir_rb(ib)',bc_in(s)%albgr_dir_rb(ib) @@ -884,16 +885,16 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) write(fates_log(),*) '>5% Dif Radn consvn error',error ,ifp,ib write(fates_log(),*) 'diags', bc_out(s)%albi_parb(ifp,ib), bc_out(s)%ftii_parb(ifp,ib), & bc_out(s)%fabi_parb(ifp,ib) - write(fates_log(),*) 'lai_change',lai_change(currentpatch%ncl_p,1:2,1:4) - write(fates_log(),*) 'elai',currentpatch%elai_profile(currentpatch%ncl_p,1:2,1:4) - write(fates_log(),*) 'esai',currentpatch%esai_profile(currentpatch%ncl_p,1:2,1:4) - write(fates_log(),*) 'ftweight',ftweight(currentpatch%ncl_p,1:2,1:4) + write(fates_log(),*) 'lai_change',lai_change(currentpatch%ncl_p,1:numpft_ed,1:4) + write(fates_log(),*) 'elai',currentpatch%elai_profile(currentpatch%ncl_p,1:numpft_ed,1:4) + write(fates_log(),*) 'esai',currentpatch%esai_profile(currentpatch%ncl_p,1:numpft_ed,1:4) + write(fates_log(),*) 'ftweight',ftweight(currentpatch%ncl_p,1:numpft_ed,1:4) write(fates_log(),*) 'cp',currentPatch%area, currentPatch%patchno write(fates_log(),*) 'bc_in(s)%albgr_dif_rb(ib)',bc_in(s)%albgr_dif_rb(ib) - write(fates_log(),*) 'rhol',rhol(1:2,:) - write(fates_log(),*) 'ftw',sum(ftweight(1,:,1)),ftweight(1,1:2,1) - write(fates_log(),*) 'present',currentPatch%present(1,1:2) - write(fates_log(),*) 'CAP',currentPatch%canopy_area_profile(1,1:2,1) + write(fates_log(),*) 'rhol',rhol(1:numpft_ed,:) + write(fates_log(),*) 'ftw',sum(ftweight(1,:,1)),ftweight(1,1:numpft_ed,1) + write(fates_log(),*) 'present',currentPatch%present(1,1:numpft_ed) + write(fates_log(),*) 'CAP',currentPatch%canopy_area_profile(1,1:numpft_ed,1) bc_out(s)%albi_parb(ifp,ib) = bc_out(s)%albi_parb(ifp,ib) + error end if diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index 5210598d..8a5ab941 100755 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -344,7 +344,7 @@ subroutine wind_effect ( currentSite, bc_in) currentCohort => currentPatch%tallest do while(associated(currentCohort)) - write(fates_log(),*) 'SF currentCohort%c_area ',currentCohort%c_area + if (DEBUG) write(fates_log(),*) 'SF currentCohort%c_area ',currentCohort%c_area if(EDPftvarcon_inst%woody(currentCohort%pft) == 1)then currentPatch%total_tree_area = currentPatch%total_tree_area + currentCohort%c_area else @@ -477,7 +477,7 @@ subroutine rate_of_spread ( currentSite ) ! Equation A5 in Thonicke et al. 2010 ! phi_wind (unitless) ! convert wind_elev_fire from m/min to ft/min for Rothermel ROS eqn - ! wind max per Lasslop et al 2014 to lenearly reduce ROS for high wind speeds + ! wind max per Lasslop et al 2014 to linearly reduce ROS for high wind speeds !OLD! phi_wind = c * ((3.281_r8*currentPatch%effect_wspeed)**b)*(beta_ratio**(-e)) if (currentPatch%effect_wspeed .le. wind_max) then wind_elev_fire = currentPatch%effect_wspeed @@ -485,7 +485,7 @@ subroutine rate_of_spread ( currentSite ) if (debug_windspeed) write(fates_log(),*) 'SF wind LESS max ', currentPatch%effect_wspeed if (debug_windspeed) write(fates_log(),*) 'month and day', hlm_current_month, hlm_current_day else - ! max conditional 225 ft/min from Lasslop 2014 converted to 68.577 m/min + !max condition 225 ft/min (FIREMIP Rabin table A10 JSBACH-Spitfire) convert to 68.577 m/min wind_elev_fire = max(0.0_r8,(68.577-0.5*currentPatch%effect_wspeed)) phi_wind = c * ((3.281_r8*wind_elev_fire)**b)*(beta_ratio**(-e)) if (debug_windspeed) write(fates_log(),*) 'SF wind GREATER max ', currentPatch%effect_wspeed @@ -493,7 +493,7 @@ subroutine rate_of_spread ( currentSite ) endif ! ---propagating flux---- - ! Equation A2 in Thonicke et al.2010 + ! Equation A2 in Thonicke et al.2010 and Eq. 42 Rothermal 1972 ! xi (unitless) 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) @@ -752,20 +752,22 @@ subroutine area_burnt ( currentSite ) ! THIS SHOULD HAVE THE COLUMN AND LU AREA WEIGHT ALSO, NO? gridarea = km2_to_m2 ! 1M m2 in a km2 - currentPatch%NF = ED_val_nignitions * currentPatch%area/area /365 * & - currentSite%FDI + !NF = number of lighting strikes per day per km2 + currentPatch%NF = ED_val_nignitions * 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. + ! Equation 16 in arora and boer model JGR 2005 !currentPatch%AB = currentPatch%AB *3.0_r8 + + !size of fire = equation 14 Arora and Boer JGR 2005 size_of_fire = ((3.1416_r8/(4.0_r8*lb))*((df+db)**2.0_r8)) - !AB is daily area burnt = size of fires in m2 * number of ignitions - currentPatch%AB = size_of_fire * currentPatch%NF + !AB = daily area burnt = size fires in m2 * num ignitions * prob ignition starts fire + currentPatch%AB = size_of_fire * currentPatch%NF * currentSite%FDI patch_area_in_m2 = gridarea*currentPatch%area/area diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index bd874869..f468aa87 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -22,7 +22,7 @@ module EDTypesMod ! are used, but this helps allocate scratch ! space and output arrays. - integer, parameter :: numpft_ed = 2 ! number of PFTs used in ED. + integer, parameter :: numpft_ed = 1 ! number of PFTs used in ED. ! TODO: we use this cp_maxSWb only because we have a static array q(size=2) of ! land-ice abledo for vis and nir. This should be a parameter, which would From 6c0ee5fc141ed9885e91c96710bf16cdc19e7f45 Mon Sep 17 00:00:00 2001 From: ckoven Date: Wed, 19 Jul 2017 16:48:17 -0700 Subject: [PATCH 434/437] pulled in impact mortality bugfix and some other diagnostic variables form presecribed_physiology branch --- biogeochem/EDCohortDynamicsMod.F90 | 4 +++ main/EDTypesMod.F90 | 2 ++ main/FatesHistoryInterfaceMod.F90 | 39 +++++++++++++++++++++++++----- 3 files changed, 39 insertions(+), 6 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index feade648..b5c6e7b5 100755 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -1242,6 +1242,10 @@ subroutine copy_cohort( currentCohort,copyc ) if( use_fates_plant_hydro ) call CopyCohortHydraulics(n,o) + ! indices for binning + n%size_class = o%size_class + n%size_by_pft_class = o%size_by_pft_class + !Pointers n%taller => NULL() ! pointer to next tallest cohort n%shorter => NULL() ! pointer to next shorter cohort diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index bd874869..89eb6c58 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -24,6 +24,8 @@ module EDTypesMod integer, parameter :: numpft_ed = 2 ! number of PFTs used in ED. + integer, parameter :: maxCohortsPerPatch = nclmax * numpft_ed * nlevleaf ! maximum number of cohorts to live on a patch + ! TODO: we use this cp_maxSWb only because we have a static array q(size=2) of ! land-ice abledo for vis and nir. This should be a parameter, which would ! get us on track to start using multi-spectral or hyper-spectral (RGK 02-2017) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 8c73b956..e6c56bf3 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -169,6 +169,8 @@ module FatesHistoryInterfaceMod integer, private :: ih_trimming_understory_si_scls integer, private :: ih_crown_area_canopy_si_scls integer, private :: ih_crown_area_understory_si_scls + integer, private :: ih_ddbh_canopy_si_scls + integer, private :: ih_ddbh_understory_si_scls ! lots of non-default diagnostics for understanding canopy versus understory carbon balances integer, private :: ih_rdark_canopy_si_scls @@ -1186,6 +1188,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_nplant_understory_si_scpf => this%hvars(ih_nplant_understory_si_scpf)%r82d, & hio_ddbh_canopy_si_scpf => this%hvars(ih_ddbh_canopy_si_scpf)%r82d, & hio_ddbh_understory_si_scpf => this%hvars(ih_ddbh_understory_si_scpf)%r82d, & + hio_ddbh_canopy_si_scls => this%hvars(ih_ddbh_canopy_si_scls)%r82d, & + hio_ddbh_understory_si_scls => this%hvars(ih_ddbh_understory_si_scls)%r82d, & hio_gpp_canopy_si_scpf => this%hvars(ih_gpp_canopy_si_scpf)%r82d, & hio_gpp_understory_si_scpf => this%hvars(ih_gpp_understory_si_scpf)%r82d, & hio_ar_canopy_si_scpf => this%hvars(ih_ar_canopy_si_scpf)%r82d, & @@ -1456,7 +1460,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) ccohort%bl * ccohort%n hio_canopy_biomass_pa(io_pa) = hio_canopy_biomass_pa(io_pa) + n_density * ccohort%b * g_per_kg hio_mortality_canopy_si_scpf(io_si,scpf) = hio_mortality_canopy_si_scpf(io_si,scpf)+ & - (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%imort + ccohort%fmort) * ccohort%n + (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%fmort) * ccohort%n hio_nplant_canopy_si_scpf(io_si,scpf) = hio_nplant_canopy_si_scpf(io_si,scpf) + ccohort%n hio_nplant_canopy_si_scls(io_si,scls) = hio_nplant_canopy_si_scls(io_si,scls) + ccohort%n hio_trimming_canopy_si_scls(io_si,scls) = hio_trimming_canopy_si_scls(io_si,scls) + & @@ -1470,11 +1474,13 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! growth increment hio_ddbh_canopy_si_scpf(io_si,scpf) = hio_ddbh_canopy_si_scpf(io_si,scpf) + & ccohort%ddbhdt*ccohort%n + hio_ddbh_canopy_si_scls(io_si,scls) = hio_ddbh_canopy_si_scls(io_si,scls) + & + ccohort%ddbhdt*ccohort%n ! sum of all mortality hio_mortality_canopy_si_scls(io_si,scls) = hio_mortality_canopy_si_scls(io_si,scls) + & - (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%imort + ccohort%fmort) * ccohort%n + (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%fmort) * ccohort%n hio_canopy_mortality_carbonflux_si(io_si) = hio_canopy_mortality_carbonflux_si(io_si) + & - (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%imort + ccohort%fmort) * & + (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%fmort) * & ccohort%b * ccohort%n * g_per_kg * days_per_sec * years_per_day * ha_per_m2 ! hio_leaf_md_canopy_si_scls(io_si,scls) = hio_leaf_md_canopy_si_scls(io_si,scls) + & @@ -1515,7 +1521,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) ccohort%bl * ccohort%n hio_understory_biomass_pa(io_pa) = hio_understory_biomass_pa(io_pa) + n_density * ccohort%b * g_per_kg hio_mortality_understory_si_scpf(io_si,scpf) = hio_mortality_understory_si_scpf(io_si,scpf)+ & - (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%imort + ccohort%fmort) * ccohort%n + (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%fmort) * ccohort%n hio_nplant_understory_si_scpf(io_si,scpf) = hio_nplant_understory_si_scpf(io_si,scpf) + ccohort%n hio_nplant_understory_si_scls(io_si,scls) = hio_nplant_understory_si_scls(io_si,scls) + ccohort%n hio_trimming_understory_si_scls(io_si,scls) = hio_trimming_understory_si_scls(io_si,scls) + & @@ -1529,11 +1535,13 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! growth increment hio_ddbh_understory_si_scpf(io_si,scpf) = hio_ddbh_understory_si_scpf(io_si,scpf) + & ccohort%ddbhdt*ccohort%n + hio_ddbh_understory_si_scls(io_si,scls) = hio_ddbh_understory_si_scls(io_si,scls) + & + ccohort%ddbhdt*ccohort%n ! sum of all mortality hio_mortality_understory_si_scls(io_si,scls) = hio_mortality_understory_si_scls(io_si,scls) + & - (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%imort + ccohort%fmort) * ccohort%n + (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%fmort) * ccohort%n hio_understory_mortality_carbonflux_si(io_si) = hio_understory_mortality_carbonflux_si(io_si) + & - (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%imort + ccohort%fmort) * & + (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%fmort) * & ccohort%b * ccohort%n * g_per_kg * days_per_sec * years_per_day * ha_per_m2 ! hio_leaf_md_understory_si_scls(io_si,scls) = hio_leaf_md_understory_si_scls(io_si,scls) + & @@ -1569,6 +1577,15 @@ subroutine update_history_dyn(this,nc,nsites,sites) ccohort%canopy_layer_yesterday * ccohort%n endif ! + ! consider imort as understory mortality even if it happens in cohorts that may have been promoted as part of the patch creation... + hio_mortality_understory_si_scpf(io_si,scpf) = hio_mortality_understory_si_scpf(io_si,scpf)+ & + (ccohort%imort) * ccohort%n + hio_mortality_understory_si_scls(io_si,scls) = hio_mortality_understory_si_scls(io_si,scls) + & + (ccohort%imort) * ccohort%n + hio_understory_mortality_carbonflux_si(io_si) = hio_understory_mortality_carbonflux_si(io_si) + & + (ccohort%imort) * & + ccohort%b * ccohort%n * g_per_kg * days_per_sec * years_per_day * ha_per_m2 + ! ccohort%canopy_layer_yesterday = real(ccohort%canopy_layer, r8) end associate @@ -3152,6 +3169,16 @@ subroutine define_history_vars(this, initialize_variables) ! size-class only variables + call this%set_history_var(vname='DDBH_CANOPY_SCLS', units = 'cm/yr/ha', & + long='diameter growth increment by pft/size',use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ddbh_canopy_si_scls ) + + call this%set_history_var(vname='DDBH_UNDERSTORY_SCLS', units = 'cm/yr/ha', & + long='diameter growth increment by pft/size',use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ddbh_understory_si_scls ) + call this%set_history_var(vname='YESTERDAYCANLEV_CANOPY_SCLS', units = 'indiv/ha', & long='Yesterdays canopy level for canopy plants by size class', use_default='inactive', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & From d30002f20f8904251061d230a35673f15900c98a Mon Sep 17 00:00:00 2001 From: ckoven Date: Wed, 19 Jul 2017 16:51:54 -0700 Subject: [PATCH 435/437] fixed impact mortaaity reporting for scag-dimensioned flux output too --- main/FatesHistoryInterfaceMod.F90 | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 48a3d737..740955d7 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -1468,7 +1468,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) if (ccohort%canopy_layer .eq. 1) then hio_nplant_canopy_si_scag(io_si,iscag) = hio_nplant_canopy_si_scag(io_si,iscag) + ccohort%n hio_mortality_canopy_si_scag(io_si,iscag) = hio_mortality_canopy_si_scag(io_si,iscag) + & - (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%imort + ccohort%fmort) * ccohort%n + (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%fmort) * ccohort%n hio_ddbh_canopy_si_scag(io_si,iscag) = hio_ddbh_canopy_si_scag(io_si,iscag) + & ccohort%ddbhdt*ccohort%n hio_bstor_canopy_si_scpf(io_si,scpf) = hio_bstor_canopy_si_scpf(io_si,scpf) + & @@ -1534,7 +1534,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) else hio_nplant_understory_si_scag(io_si,iscag) = hio_nplant_understory_si_scag(io_si,iscag) + ccohort%n hio_mortality_understory_si_scag(io_si,iscag) = hio_mortality_understory_si_scag(io_si,iscag) + & - (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%imort + ccohort%fmort) * ccohort%n + (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%fmort) * ccohort%n hio_ddbh_understory_si_scag(io_si,iscag) = hio_ddbh_understory_si_scag(io_si,iscag) + & ccohort%ddbhdt*ccohort%n hio_bstor_understory_si_scpf(io_si,scpf) = hio_bstor_understory_si_scpf(io_si,scpf) + & @@ -1607,6 +1607,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_understory_mortality_carbonflux_si(io_si) = hio_understory_mortality_carbonflux_si(io_si) + & (ccohort%imort) * & ccohort%b * ccohort%n * g_per_kg * days_per_sec * years_per_day * ha_per_m2 + hio_mortality_understory_si_scag(io_si,iscag) = hio_mortality_understory_si_scag(io_si,iscag) + & + (ccohort%imort) * ccohort%n ! ccohort%canopy_layer_yesterday = real(ccohort%canopy_layer, r8) From 7301abf9f298ec2398c196f7c30449c5255450a1 Mon Sep 17 00:00:00 2001 From: ckoven Date: Wed, 19 Jul 2017 17:07:49 -0700 Subject: [PATCH 436/437] bugfix on prior --- main/EDTypesMod.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 89eb6c58..349ffc3a 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -11,7 +11,6 @@ module EDTypesMod save integer, parameter :: maxPatchesPerSite = 10 ! maximum number of patches to live on a site - integer, parameter :: maxCohortsPerPatch = 160 ! maximum number of cohorts to live on a patch integer, parameter :: nclmax = 2 ! Maximum number of canopy layers integer, parameter :: ican_upper = 1 ! Nominal index for the upper canopy integer, parameter :: ican_ustory = 2 ! Nominal index for understory in two-canopy system From 4cf5aa93a80f95f5432e998d9ca33c2c89b7652d Mon Sep 17 00:00:00 2001 From: JKShuman Date: Mon, 24 Jul 2017 14:49:10 -0600 Subject: [PATCH 437/437] Return numpft_ed to originial value Put EDTypesMod.f90 back to original value of 2 as part of previous commit. User interface changes?: No Code review: JKShuman No testing --- main/EDTypesMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index f468aa87..bd874869 100755 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -22,7 +22,7 @@ module EDTypesMod ! are used, but this helps allocate scratch ! space and output arrays. - integer, parameter :: numpft_ed = 1 ! number of PFTs used in ED. + integer, parameter :: numpft_ed = 2 ! number of PFTs used in ED. ! TODO: we use this cp_maxSWb only because we have a static array q(size=2) of ! land-ice abledo for vis and nir. This should be a parameter, which would